Regular.hs

module Regular where

import Data.Char (isAlpha)
import Data.List (intersperse)
import Control.Monad (liftM)
import Test.SmallCheck

-- A data type of regular expressions.

data RE = Emp
        | Lam
        | Sym Char
	| Alt [RE]
        | Cat [RE]
	| Rep RE
	deriving Eq

isEmp, isLam, isSym, isCat, isAlt, isRep :: RE -> Bool
isEmp Emp     = True
isEmp _       = False
isLam Lam     = True
isLam _       = False
isSym (Sym _) = True
isSym _       = False
isAlt (Alt _) = True
isAlt _       = False
isCat (Cat _) = True
isCat _       = False
isRep (Rep _) = True
isRep _       = False

-- Syms may be used to represent terminals or variables.
-- Using cat and alt instead of Cat and Alt ensures that:
-- (1) Cat and Alt arguments are multi-item lists;
-- (2) items in Cat arguments are not Cats;
-- (3) items in Alt arguments are not Alts.

cat :: [RE] -> RE
cat []  = Lam
cat [x] = x
cat xs  = Cat (concatMap catList xs)
  where
  catList (Cat ys) = ys
  catList z        = [z]

alt :: [RE] -> RE
alt []  = Emp
alt [x] = x
alt xs  = Alt (concatMap altList xs)
  where
  altList (Alt ys) = ys
  altList z        = [z]

instance Read RE where
  readsPrec _ s  = [rest s [[[]]]]

rest :: String -> [[[RE]]] -> (RE,String)
rest ""      (    a:as) = if null as then (a2re a,"")
                          else wrong
rest ('+':s) ((c:a):as) = if null c then wrong
			  else rest s (([]:c:a):as)
rest ('*':s) ((c:a):as) = case c of
                          []     -> wrong
                          (x:xs) -> rest s (((Rep x:xs):a):as)
rest ('0':s) ((c:a):as) = rest s (((Emp:c):a):as)
rest ('1':s) ((c:a):as) = rest s (((Lam:c):a):as)
rest ('(':s) as         = rest s ([[]]:as)
rest (')':s) (a:as)     = case as of
                          [] -> wrong
			  ((c:a'):as') -> rest s (((a2re a:c):a'):as')
rest (' ':s) as         = rest s as
rest (v  :s) ((c:a):as) = if isAlpha v then rest s (((Sym v:c):a):as)
                          else if null as then (a2re (c:a),v:s)
			  else wrong

a2re :: [[RE]] -> RE
a2re = alt . reverse . map (cat . reverse)

wrong = error "unreadable RE"

instance Show RE where
  show Emp      = "0"
  show Lam      = "1"
  show (Sym c)  = [c]
  show (Alt xs) = concat (intersperse "+" (map show xs))
  show (Cat xs) = concatMap (showBrackIf isAlt) xs
  show (Rep x)  = showBrackIf (\x -> isCat x || isAlt x) x ++ "*"

showBrackIf p x = ['(' | q] ++ show x ++ [')' | q] where q = p x

instance Serial RE where
  series = cons0 Emp
        \/ cons0 Lam
        \/ cons1 Sym . depth 0
        \/ cons1 alt
        \/ cons1 cat
        \/ cons1 Rep

prop_readShow :: RE -> IO Bool
prop_readShow re = do
  writeFile "tmp" (show re)
  re' <- liftM read (readFile "tmp")
  return (re'==re)

main = do
  rule
  putStrLn "Testing property involving IO.  Always returns True?"
  putStrLn "do\n\
           \  writeFile \"tmp\" (show re)\n\
           \  re' <- liftM read (readFile \"tmp\")\n\
           \  return (re'==re)"
  rule
  smallCheck 4 prop_readShow
  where
  rule = putStrLn
           "----------------------------------------------------"