-----------------------------------------------------------------------
--
--  Haskell: The Craft of Functional Programming
--  Simon Thompson
--  (c) Addison-Wesley, 1996-2011.
--
--      RegExp.hs
-- 
--  Regular Expressions
--
-----------------------------------------------------------------------

module RegExp where

type RegExp = String -> Bool

char :: Char -> RegExp

epsilon :: String -> Bool
epsilon = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
"")

char :: Char -> String -> Bool
char Char
ch = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==[Char
ch])

(|||) :: RegExp -> RegExp ->  RegExp

String -> Bool
e1 ||| :: (String -> Bool) -> (String -> Bool) -> String -> Bool
||| String -> Bool
e2 = 
    \String
x -> String -> Bool
e1 String
x Bool -> Bool -> Bool
|| String -> Bool
e2 String
x

(<*>) :: RegExp -> RegExp ->  RegExp

String -> Bool
e1 <*> :: (String -> Bool) -> (String -> Bool) -> String -> Bool
<*> String -> Bool
e2 =
    \String
x -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ String -> Bool
e1 String
y Bool -> Bool -> Bool
&& String -> Bool
e2 String
z | (String
y,String
z) <- String -> [(String, String)]
forall {a}. [a] -> [([a], [a])]
splits String
x ]

(<**>) :: RegExp -> RegExp ->  RegExp

String -> Bool
e1 <**> :: (String -> Bool) -> (String -> Bool) -> String -> Bool
<**> String -> Bool
e2 =
    \String
x -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [ String -> Bool
e1 String
y Bool -> Bool -> Bool
&& String -> Bool
e2 String
z | (String
y,String
z) <- String -> [(String, String)]
forall {a}. [a] -> [([a], [a])]
fsplits String
x ]

splits :: [a] -> [([a], [a])]
splits [a]
xs = [Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
n [a]
xs | Int
n<-[Int
0..Int
len]]
    where
      len :: Int
len = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs

star :: RegExp -> RegExp

star :: (String -> Bool) -> String -> Bool
star String -> Bool
p = String -> Bool
epsilon (String -> Bool) -> (String -> Bool) -> String -> Bool
||| (String -> Bool
p (String -> Bool) -> (String -> Bool) -> String -> Bool
<**> (String -> Bool) -> String -> Bool
star String -> Bool
p)
--           epsilon ||| (p <*> star p)
-- is OK as long as p can't have epsilon match

fsplits :: [a] -> [([a], [a])]
fsplits [a]
xs = [([a], [a])] -> [([a], [a])]
forall a. HasCallStack => [a] -> [a]
tail ([a] -> [([a], [a])]
forall {a}. [a] -> [([a], [a])]
splits [a]
xs)

-- a = char 'a'

-- b = char 'b'

infixr 7 :*:
infixr 5 :|:

data RE = Eps |
          Ch Char |
          RE :|: RE |
          RE :*: RE |
          St RE |
          Plus RE
          deriving(RE -> RE -> Bool
(RE -> RE -> Bool) -> (RE -> RE -> Bool) -> Eq RE
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RE -> RE -> Bool
== :: RE -> RE -> Bool
$c/= :: RE -> RE -> Bool
/= :: RE -> RE -> Bool
Eq,Int -> RE -> ShowS
[RE] -> ShowS
RE -> String
(Int -> RE -> ShowS)
-> (RE -> String) -> ([RE] -> ShowS) -> Show RE
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RE -> ShowS
showsPrec :: Int -> RE -> ShowS
$cshow :: RE -> String
show :: RE -> String
$cshowList :: [RE] -> ShowS
showList :: [RE] -> ShowS
Show)

evens :: RE
evens = RE -> RE
St RE
two
two :: RE
two = (RE
a RE -> RE -> RE
:|: RE
b) RE -> RE -> RE
:*: (RE
a RE -> RE -> RE
:|: RE
b)
          
a :: RE
a = Char -> RE
Ch Char
'a'
b :: RE
b = Char -> RE
Ch Char
'b'

-- interp: RE -> RegExp: exercise.

-- Value recursion
--  Eunmerating strings matching a regexp

enumerate :: RE -> [String]

enumerate :: RE -> [String]
enumerate RE
Eps = [String
""]
enumerate (Ch Char
ch) = [[Char
ch]]
enumerate (RE
re1 :|: RE
re2)
    = RE -> [String]
enumerate RE
re1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
`interleave` RE -> [String]
enumerate RE
re2
enumerate  (RE
re1 :*: RE
re2)
    = RE -> [String]
enumerate RE
re1 [String] -> [String] -> [String]
forall a. [[a]] -> [[a]] -> [[a]]
`cartesian` RE -> [String]
enumerate RE
re2
enumerate (St RE
re)
    = [String]
result 
      where
        result :: [String]
result =
            [String
""] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (RE -> [String]
enumerate RE
re [String] -> [String] -> [String]
forall a. [[a]] -> [[a]] -> [[a]]
`cartesian` [String]
result)

-- Auxiliary functions
-- interleave and product for potentially infinite lists

interleave :: [a] -> [a] -> [a]

interleave :: forall a. [a] -> [a] -> [a]
interleave [] [a]
ys = [a]
ys
interleave (a
x:[a]
xs) [a]
ys = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
interleave [a]
ys [a]
xs
        
cartesian :: [[a]] -> [[a]] -> [[a]]

cartesian :: forall a. [[a]] -> [[a]] -> [[a]]
cartesian [] [[a]]
ys = []
cartesian ([a]
x:[[a]]
xs) [[a]]
ys 
    = [ [a]
x[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++[a]
y | [a]
y<-[[a]]
ys ] [[a]] -> [[a]] -> [[a]]
forall a. [a] -> [a] -> [a]
`interleave` [[a]] -> [[a]] -> [[a]]
forall a. [[a]] -> [[a]] -> [[a]]
cartesian [[a]]
xs [[a]]
ys
    
-- Recursive regular expressions

anbn :: RE

anbn :: RE
anbn = RE
Eps RE -> RE -> RE
:|: (RE
a RE -> RE -> RE
:*: (RE
anbn RE -> RE -> RE
:*: RE
b))

-- Extending the implementation

plus :: RE -> RE
plus :: RE -> RE
plus RE
re = RE
re RE -> RE -> RE
:*: RE -> RE
St RE
re

-- Simplification

simplify :: RE -> RE

simplify :: RE -> RE
simplify (St (St RE
re)) = RE -> RE
simplify (RE -> RE
St RE
re)
simplify (Plus (St RE
re)) = RE -> RE
simplify (RE -> RE
St RE
re)
simplify (St (Plus RE
re)) = RE -> RE
simplify (RE -> RE
St RE
re)
simplify (RE
re1 :|: RE
re2) =
    if RE
sre1RE -> RE -> Bool
forall a. Eq a => a -> a -> Bool
==RE
sre2 then RE
sre1 else RE
sre1 RE -> RE -> RE
:|: RE
sre2 
          where
            sre1 :: RE
sre1 = RE -> RE
simplify RE
re1; sre2 :: RE
sre2 = RE -> RE
simplify RE
re2
simplify RE
re = RE
re

-- smart constructors

starC :: RE -> RE
starC :: RE -> RE
starC (St RE
re) = RE
re
starC (Plus RE
re) = RE
re
starC RE
re = RE -> RE
St RE
re