Authored by Jeremy Gibbons.

parser.hs

{-# LINE 30 "parser.ltx" #-}
{-#  LANGUAGE KindSignatures, GADTs  #-}
import Data.List (inits, tails)
import Data.Char (ord)
import Control.Monad (mplus)
{-# LINE 56 "parser.ltx" #-}
data Grammar :: *   where
  Empty   :: Grammar
  Unit    :: Grammar
  Single  :: Char -> Grammar
  Conc    :: Grammar -> Grammar -> Grammar
  Union   :: Grammar -> Grammar -> Grammar
{-# LINE 98 "parser.ltx" #-}
{-  Exercise 1: a grammar for UK registration plates  -}

choices :: [Char] -> Grammar
choices = foldr1 Union . map Single

letter :: Grammar
letter = choices ['A'..'Z']

digit :: Grammar
digit = choices ['0'..'9']

concs :: [Grammar] -> Grammar
concs = foldr Conc Unit

ukRegPlate :: Grammar
ukRegPlate =  concs [letter,letter,digit,digit,letter,letter,letter] `Union`
              concs [letter,digit,digit,digit,letter,letter,letter]
{-# LINE 130 "parser.ltx" #-}
recog :: Grammar -> String -> Bool
{-# LINE 141 "parser.ltx" #-}
{-  Exercise 2: recognition, naively  -}

recog Empty s         = False
recog Unit s          = null s
recog (Single c) s    = (s == [c])
recog (Conc x y) s    = or  [ recog x s1 && recog y s2 
                            | (s1,s2) <- zip (inits s) (tails s) ]
recog (Union x y) s   = recog x s || recog y s
{-# LINE 160 "parser.ltx" #-}
{-  Exercise 3: checking recognition works  -}

testYes, testNo :: Bool
testYes  = recog ukRegPlate "AB34EFG"
testNo   = recog ukRegPlate "1234567"
{-# LINE 185 "parser.ltx" #-}
type GrammarS = String->Bool

empty   :: GrammarS
unit    :: GrammarS
single  :: Char -> GrammarS
conc    :: GrammarS -> GrammarS -> GrammarS
union   :: GrammarS -> GrammarS -> GrammarS
{-# LINE 197 "parser.ltx" #-}
{-  Exercise 4: recognition as a shallow embedding  -}

empty s       = False
unit s        = null s
single c s    = (s == [c])
conc x y s    = or  [ x s1 && y s2 
                    | (s1,s2) <- zip (inits s) (tails s) ]
union x y s   = x s || y s
{-# LINE 219 "parser.ltx" #-}
match :: Grammar -> String -> Maybe (String, String)
{-# LINE 243 "parser.ltx" #-}
{-  Exercise 5: matching, as an interpretation of the deep embedding...  -}

match Empty s        = Nothing
match Unit s         = Just ("",s)
match (Single c) ""  = Nothing
match (Single c) (c':s)
  | c==c'            = Just ([c],s)
  | otherwise        = Nothing
match (Conc x y) s   = do { (s1,s2) <- match x s; (s3,s4) <- match y s2; return (s1++s3,s4) }
match (Union x y) s  = match x s `mplus` match y s

{-  ...and as another shallow embedding  -}

type GrammarM = String -> Maybe (String, String)

emptyM   :: GrammarM
unitM    :: GrammarM
singleM  :: Char -> GrammarM
concM    :: GrammarM -> GrammarM -> GrammarM
unionM   :: GrammarM -> GrammarM -> GrammarM

emptyM s        = Nothing
unitM s         = Just ("",s)
singleM c ""    = Nothing
singleM c (c':s)
  | c==c'       = Just ([c],s)
  | otherwise   = Nothing
concM x y s     = do { (s1,s2) <- x s; (s3,s4) <- y s2; return (s1++s3,s4) }
unionM x y s    = x s `mplus` y s
{-# LINE 298 "parser.ltx" #-}
{-  Exercise 6: generation for the deep embedding  -}

generate Empty        = []
generate Unit         = [""]
generate (Single c)   = [[c]]
generate (Conc x y)   = [ s1++s2 | s1 <- generate x, s2 <- generate y ]
generate (Union x y)  = generate x ++ generate y
{-# LINE 315 "parser.ltx" #-}
{-  Exercise 7: generation as a shallow embedding  -}

type GrammarG = [String]

emptyG   :: GrammarG
unitG    :: GrammarG
singleG  :: Char -> GrammarG
concG    :: GrammarG -> GrammarG -> GrammarG
unionG   :: GrammarG -> GrammarG -> GrammarG

emptyG      = []
unitG       = [""]
singleG c   = [[c]]
concG x y   = [ s1++s2 | s1 <- x, s2 <- y ]
unionG x y  = x ++ y
{-# LINE 356 "parser.ltx" #-}
{-  Exercise 8: interleaving and diagonalisation  -}

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

diag :: [[a]] -> [a]
diag xss = diag' ([], xss) where
  diag' ([], [])    = []
  diag' (yss, xss)  = map head yss ++ diag' (massage (map tail yss, xss))
  massage (yss, [])      = (yss, [])
  massage (yss, xs:xss)  = (filter (not . null) (xs:yss), xss)

generate' Empty        = []
generate' Unit         = [""]
generate' (Single c)   = [[c]]
generate' (Conc x y)   = diag [ [ s1++s2 | s2 <- generate' y ] | s1 <- generate' x ]
generate' (Union x y)  = generate' x `interleave` generate' y
{-# LINE 401 "parser.ltx" #-}
data Parser :: * -> *   where
  Fail     :: Parser a
  Succeed  :: a -> Parser a
  Char     :: Char -> Parser Char
  Sequ     :: Parser a -> Parser b -> Parser (a,b)
  Choice   :: Parser a -> Parser a -> Parser a
  Using    :: Parser a -> (a->b) -> Parser b
{-# LINE 427 "parser.ltx" #-}
{-  Exercise 9: parsing, on the deep embedding  -}

parse :: Parser a -> String -> Maybe (a, String)
parse Fail s           = Nothing
parse (Succeed a) s    = Just (a, s)
parse (Char c) ""      = Nothing
parse (Char c) (c':s)  = if c==c' then Just (c, s) else Nothing
parse (Sequ x y) s     = do { (a,s1) <- parse  x s ; (b,s2) <- parse y s1 ; return ((a,b),s2) }
parse (Choice x y) s   = parse x s `mplus` parse y s
parse (Using x f) s    = do { (a,s') <- parse x s ; return (f a, s') }

{-  an example parser, for fixed-point numbers  -}

fixedpoint :: Parser Double
fixedpoint =  (integer `Sequ` optional decimal 0.0) `Using` combine

integer :: Parser Integer
integer = some digitP `Using` foldl (\ n d -> 10*n+d) 0

digitP :: Parser Integer
digitP = foldr1 Choice (map Char ['0'..'9']) `Using` (toInteger . \ c -> ord c - ord '0')

some, many :: Parser a -> Parser [a]
some p = (p `Sequ` many p) `Using` (uncurry (:))
many p = optional (some p) []

decimal :: Parser Double
decimal = (Char '.' `Sequ` some digitP) `Using` (foldr (\ d x -> (x + fromInteger d) / 10.0) 0 . snd)

optional :: Parser a -> a -> Parser a
optional p a = p `Choice` Succeed a

combine :: (Integer,Double) -> Double
combine (n,x) = fromInteger n + x
{-# LINE 468 "parser.ltx" #-}
type ParserS a = String -> Maybe (a, String)
{-# LINE 477 "parser.ltx" #-}
{-  Exercise 10: parsing as a shallow embedding  -}

fail s         = Nothing
succeed a s    = Just (a, s)
char c ""      = Nothing
char c (c':s)  = if c==c' then Just (c, s) else Nothing
sequ x y s     = do { (a,s1) <- x s ; (b,s2) <- y s1 ; return ((a,b),s2) }
choice x y s   = x s `mplus` y s
using x f s    = do { (a,s') <- x s ; return (f a, s') }

find a bug - line 132

without filter (not . null) cause exception empty list

ref: http://web.it.nctu.edu.tw/~apua/diag_.html