Monadic parsing_in_Haskell

monadic_parsing_in_Haskell.hs

-- ========================================================================== --
--
--  FUNCTIONAL PEARLS
--  Monadic Parsing in Haskell
--  Graham Hutton University of Nottingham
--  Erik Meijer University of Utrecht
--
-- ========================================================================== --
{-# LANGUAGE DeriveFunctor #-}

-- import Control.Applicative (Applicative(..))
import Data.Char           (isDigit, isSpace, ord)
import Control.Monad       (ap)
import Control.Applicative (Alternative, empty, (<|>))

-- ========================================================================== --
-- 2. A type of parsers
-- ========================================================================== --

newtype Parser a = Parser { parser :: String -> [(a, String)]} deriving Functor

-- ========================================================================== --
-- 3. A monad of parsers
-- ========================================================================== --

item :: Parser Char
item = Parser (\cs -> case cs of 
                           ""     -> []
                           (c:cs) -> [(c, cs)])

-- > parser item "abc"
-- [('a',"bc")]
-- > parser item ""
-- []
-- >

instance Applicative Parser  where  -- for GHC 7.10
  pure = return
  (<*>) = ap  

instance Monad Parser where
  return a = Parser (\cs -> [(a, cs)])
  p >>= f  = Parser (\cs -> concat [parser (f a) cs' | (a, cs') <- parser p cs])


-- item >>= \x -> item
-- <=>
-- Parser(
-- \cs -> concate[
--  parser (f a) cs'          ~~~ parser ((\x -> item) c1) cs1, parser ((\x -> item) c2) cs2, ... , parser ((\x -> item) cn csn
--                            ~~~ parser item cs1, parser c2 cs2, ... , parser cn csn
--  |
--  (a, cs') <- parser p cs   ~~~ (c1, cs1), (c2, cs2), ... , (cn, csn)
-- ])
-- 
-- > let item2 = item >>= \x -> item
-- > parser item2 "abc"
-- [('b',"c")]
-- 
-- > let item3 = item >>= \x -> item >>= \y -> item
-- > parser item3 "abcd"
-- [('c',"d")]
-- > parser item3 "abc"
-- [('c',"")]
-- > parser item3 "ab"
-- []
-- 
-- > let item3_tuple = item >>= \x -> item >>= \y -> item >>= \z -> return (x,y)
-- > parser item3_tuple "abcd"
-- [(('a','b'),"d")]
-- > parser item3_tuple "abc"
-- [(('a','b'),"")]
-- > parser item3_tuple "ab"
-- []
-- > parser item3_tuple "a"
-- []
-- 

-- ========================================================================== --
-- 5. Choice combinators
-- ========================================================================== --

instance Alternative Parser where
  empty   = Parser (\cs -> [])
  p <|> q = Parser (\cs -> parser p cs ++ parser q cs)
--  (<|>) p q = Parser (\cs -> parser p cs ++ parser q cs)

-- > :t parser (item <|> item) "abc"
-- parser (item <|> item) "abc" :: [(Char, String)]
-- > parser (item <|> item) "abc"
-- [('a',"bc"),('a',"bc")]
-- > parser (item <|> empty) "abc"
-- [('a',"bc")]
-- > parser (empty <|> item) "abc"
-- [('a',"bc")]
-- > 

(+++) :: Parser a -> Parser a -> Parser a
p +++ q = Parser (\cs -> case parser (p <|> q) cs of
                              []     -> []
                              (x:xs) -> [x])

-- > parser (item +++ item) "abc"
-- [('a',"bc")]
-- > parser (item +++ empty) "abc"
-- [('a',"bc")]
-- > parser (empty +++ item) "abc"
-- [('a',"bc")]
-- > 
-- 

sat :: (Char -> Bool) -> Parser Char
sat p = do {c <- item ; if p c then return c else empty}

-- > :t sat ('a' ==) 
-- sat ('a' ==) :: Parser Char
-- > :t sat
-- sat :: (Char -> Bool) -> Parser Char
-- > :t sat ('a' ==) 
-- sat ('a' ==) :: Parser Char
-- > :t parser $ sat ('a' ==) 
-- parser $ sat ('a' ==) :: String -> [(Char, String)]
-- > parser (sat ('a' ==)) "abc"
-- [('a',"bc")]
-- > parser (sat ('a' ==)) "cba"
-- []
--

char :: Char -> Parser Char
char c = sat (c ==) 

-- ========================================================================== --
-- 6. Recursion combinators
-- ========================================================================== --

string :: String -> Parser String
string ""     = return ""
string (c:cs) = do {char c; string cs; return (c:cs)}

-- > parser (string "abc") "abc"
-- [("abc","")]
-- > parser (string "abc") "abcdef"
-- [("abc","def")]
-- > parser (string "abc") "xabcdef"
-- []
-- > parser (string "abc") "ab"
-- []
-- > 

many  :: Parser a -> Parser [a]
many p = many1 p +++ return []

many1 :: Parser a -> Parser [a]
many1 p = do {a <-p; as <- many p; return (a:as)}

-- > :t Main.many item 
-- Main.many item :: Parser [Char]
-- > parser (Main.many item) "aaa" 
-- [("aaa",""),("aa","a"),("a","aa"),("","aaa")]
-- > parser (Main.many (char 'a')) "aaa" 
-- [("aaa",""),("aa","a"),("a","aa"),("","aaa")]
-- > parser (Main.many (char 'a')) "aba" 
-- [("a","ba"),("","aba")]
-- > parser (Main.many1 (char 'a')) "aaa" 
-- [("aaa",""),("aa","a"),("a","aa")]
-- > parser (Main.many1 (char 'a')) "aba" 
-- 

-- > parser (Main.many item) "aaa" 
-- [("aaa","")]
-- > parser (Main.many (char 'a')) "aaa" 
-- [("aaa","")]
-- > parser (Main.many (char 'a')) "aba" 
-- [("a","ba")]
-- 
-- > :t Main.many1 item 
-- Main.many1 item :: Parser [Char]
-- > parser (Main.many1 (char 'a')) "aaa" 
-- [("aaa","")]
-- > parser (Main.many1 (char 'a')) "aba" 
-- [("a","ba")]
-- 
-- > parser (Main.many1 (char 'a')) "bbb" 
-- []
-- > parser (Main.many (char 'a')) "bbb" 
-- [("","bbb")]
-- > 
-- 

sepby  :: Parser a -> Parser b -> Parser [a]
p `sepby` sep = (p `sepby1` sep) +++ return []

sepby1  :: Parser a -> Parser b -> Parser [a]
p `sepby1` sep = do a  <- p
                    as <- many (do {sep; p})
                    return (a:as)

-- > :t sepby item 
-- sepby item :: Parser b -> Parser [Char]
-- > :t sepby item item
-- sepby item item :: Parser [Char]
-- > parser (sepby item item) "aaaa"
-- [("aa","a")]
-- > parser (sepby item item) "abaa"
-- [("aa","a")]
-- > parser (sepby item item) "abcd"
-- [("ac","d")]
-- > parser (sepby item (char ',')) "a,b,c"
-- [("abc","")]
-- > parser (sepby item (char ',')) "a;b;c"
-- [("a",";b;c")]
-- > parser (sepby item (char ',')) "a,b;c"
-- [("ab",";c")]
-- > parser (sepby1 item item) "abcd"
-- [("ac","d")]
-- > parser (sepby1 item item) "a,cd"
-- [("ac","d")]
-- > parser (sepby1 item item) "a,c,d"
-- [("acd","")]
-- > parser (sepby1 item item) "a,b,c"
-- [("abc","")]
-- > parser (sepby1 item (char ',')) "a,b,c"
-- [("abc","")]
-- > parser (sepby1 item (char ',')) "a;b;c"
-- [("a",";b;c")]
-- 

-- ========================================================================== --
-- 7. Lexical combinators
-- ========================================================================== --

space :: Parser String
space = many (sat isSpace)

-- > parser space "  abc"
-- [("  ","abc")]
-- > parser space "x  abc"
-- [("","x  abc")]
-- 

token :: Parser a -> Parser a
token p = do {a <- p; space; return a}

-- > parser (token (char 'a'))"  abc"
-- []
-- > parser (token (char 'a')) "  abc"
-- []
-- > parser (token (char 'a')) "abc "
-- [('a',"bc ")]
-- > parser (token (char 'a')) "a   bc "
-- [('a',"bc ")]
-- 

symb :: String -> Parser String
symb cs = token (string cs)

-- > parser (symb "abc") "  abc  "
-- []
-- > parser (symb "abc") "abc  "
-- [("abc","")]
-- > parser (symb "abc") "abc  efg"
-- [("abc","efg")]
-- > parser (symb "abc") "xyz  abc"
-- []
-- > 

apply :: Parser a -> String -> [(a, String)]
apply p = parser (do {space; p})

-- > :t apply (Main.many (char 'a'))
-- apply (Main.many (char 'a')) :: String -> [([Char], String)]
-- > apply (Main.many (char 'a')) "aaabbb"
-- [("aaa","bbb")]
-- > apply (Main.many (char 'a')) "dbbaaa"
-- [("","dbbaaa")]
-- > 
-- 

chainl :: Parser a -> Parser (a -> a-> a) -> a -> Parser a
chainl p op a = (p `chainl1` op) +++ return a

chainl1 :: Parser a -> Parser (a -> a-> a) -> Parser a
chainl1 p op = do {a <- p; rest a}                      -- p -> (\a1 -> rest a1) 
                  where rest a = (do f <- op            -- Parser a
                                     b <- p
                                     rest (f a b))
                                 +++ return a           -- Parser a

-- > :t Parser 
-- Parser :: (String -> [(a, String)]) -> Parser a
-- 
-- Parser (a->a->a) :: (String -> [(a->a->a, String)]) -> Parser (a->a->a)
--
-- a <- p    ...  a :: String -> [(x,       String)]
--                                 |
--                                 V
-- f <- op   ...  f :: String -> [(x->x->x, String)]
--                                       ^
--                                       |
-- b <- p    ...  b :: String -> [      (x, String)]
--
-- 

-- ========================================================================== --
-- 8.  Example
-- ========================================================================== --

expr   :: Parser Int
expr    = term `chainl1` addop
addop  :: Parser (Int -> Int -> Int) 
addop   = do {symb "+"; return (+)} +++ do {symb "-"; return (-)}
mulop  :: Parser (Int -> Int -> Int) 
mulop   = do {symb "*"; return (*)} +++ do {symb "/"; return (div)}

term   :: Parser Int
term    = factor `chainl1` mulop

factor :: Parser Int
factor  = digit +++ do {symb "("; n <- expr; symb ")"; return n}

digit  :: Parser Int
digit   = do {x <- token (sat isDigit); return (ord x - ord '0')} -- ord '0' --> 48

-- > parser expr "1 - (2 * 3) + 4"
-- [(-1,"")]
-- > parser expr "1 - (2 / 3) + 4"
-- [(5,"")]
-- > parser expr "1 - (2 / 3) / 4"
-- [(1,"")]
-- > parser expr "1 - (2 / 3) * 4"
-- [(1,"")]
-- > parser expr "1 - (3 / 2) * 4"
-- [(-3,"")]
--