FP101x monadic parser example

fp101x-chapter7-part2.hs

import Data.Char (isDigit)

data Parser a = Parser (String -> [(a, String)])

instance Functor Parser where
  fmap f (Parser pa) = Parser $ \inp ->
    flip fmap (pa inp) $ \(a, out) -> (f a, out)

instance Applicative Parser where
  pure a = Parser $ \inp -> [(a, inp)]
  (Parser pf) <*> (Parser pa) = Parser $ \inp ->
    concat . flip fmap (pf inp) $ \(f, out) ->
      flip fmap (pa out) $ \(a, out') ->
        (f a, out')

instance Monad Parser where
  (Parser pa) >>= f = Parser $ \inp ->
    concat . flip fmap (pa inp) $ \(a, out) ->
      let (Parser pb) = f a
       in pb out

item :: Parser Char
item = Parser $ \inp -> case inp of
  [] -> []
  (x:xs) -> [(x,xs)]

failure :: Parser a
failure = Parser $ \inp -> []

(+++) :: Parser a -> Parser a -> Parser a
p +++ q = Parser $ \inp ->
  case parse p inp of
    [] -> parse q inp
    [(v, out)] -> [(v, out)]

parse :: Parser a -> String -> [(a, String)]
parse (Parser p) inp = p inp

sat :: (Char -> Bool) -> Parser Char
sat p = do
  x <- item
  if p x
    then return x
    else failure

digit :: Parser Char
digit = sat isDigit

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

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

many1 :: Parser a -> Parser [a]
many1 p = do
  v <- p
  vs <- many p
  return (v:vs)

string :: String -> Parser String
string [] = return []
string (x:xs) = do
  char x
  string xs
  return (x:xs)

p :: Parser String
p = do
  char '['
  d <- digit
  ds <- many (do char ','
                 digit)
  char ']'
  return (d:ds)

main = do
  print $ parse item ""       -- should output: []
  print $ parse item "abc"    -- [('a', "bc")]
  print $ parse p "[1,2,3,4]" -- [("1234","")]
  print $ parse p "[1,2,3,4"  -- []