Monadic Parsers as Anamorphisms Co-Algebras

ParserAnamorphisms.hs

{-#LANGUAGE DeriveFunctor#-}

module Main where

fix :: ((a -> b) -> a -> b) -> a -> b
fix f = f (fix f)

newtype Fix f = In { out :: f (Fix f) }

ana :: Functor f => (a -> f a) -> (a -> Fix f) -> a -> Fix f
ana psi f = In . fmap f . psi

anaRec :: Functor f => (a -> f a) -> a -> Fix f
anaRec psi = fix (ana psi)

cata :: Functor f => (f a -> a) -> (Fix f -> a) -> Fix f -> a
cata psi f = psi . fmap f . out

cataRec :: Functor f => (f a -> a) -> Fix f -> a
cataRec psi = fix (cata psi)

data ListF a b = Empty | Cons a b deriving Functor

type ListR a = Fix (ListF a)

type Parser a = String -> ListF a String

-- unit parser
unit :: a -> Parser a
unit = Cons

-- zero parser
zero :: Parser a
zero _ = Empty

-- item parser
item :: Parser Char
item (x:xs) = Cons x xs
item [] = Empty

bind :: Parser a -> (a -> Parser b) -> Parser b
bind m f s = case m s of
              Empty -> Empty
              Cons x s' -> f x s'

-- sat parser
sat :: (Char -> Bool) -> Parser Char
sat p = bind item (\ch -> if p ch then unit ch else zero)

-- char parser
char :: Char -> Parser Char
char x = sat (\y -> x == y)

-- letter parser
letter :: Parser Char
letter = sat (\x -> ('a' <= x && x <= 'z') || 'A' <= x && x <= 'Z')

space :: Parser Char
space = sat (== ' ')

mplus :: Parser a -> Parser a -> Parser a
p `mplus` q = \s -> case p s of
                Empty -> q s
                r -> r

-- many parser
many :: Parser a -> Parser [a]
many p = bind p (\x ->
         bind (many p) (\xs -> unit (x:xs))) `mplus` unit []

-- sepBy parser
sepBy :: Parser a -> Parser b -> Parser [a]
p `sepBy` sep = bind p (\x ->
                bind (many (bind sep (\_ ->
                            bind p unit))) (\xs -> unit (x:xs))) `mplus` unit []
-- string parser
string :: String -> Parser String
string "" = unit ""
string (x:xs) = bind (char x) (\ch ->
                bind (string xs) (\rest -> unit(ch : rest)))

-- word parser
word :: Parser String
word "" = Empty
word s = many letter s

sampleParser :: Parser [String]
sampleParser = bind (word `sepBy` space) (\w ->
               bind (string "...") (\_ -> unit w))

parse :: String -> ListR [String]
parse = anaRec sampleParser

printResult :: Show a => ListR a -> String
printResult = cataRec psi
  where psi Empty = ""
        psi (Cons n ret) = show n ++ ret

main :: IO ()
main = putStrLn (printResult (parse "Welcome to the Real World..."))