Simple Parser

parser.hs

{-# LANGUAGE InstanceSigs        #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RebindableSyntax    #-}
{-# LANGUAGE ScopedTypeVariables #-}

type Input = String


data ParseResult a =
    UnexpectedEof
  | ExpectedEof      Input
  | UnexpectedChar   Char
  | UnexpectedString String
  | Result           Input   a
  deriving Eq


instance Show a => Show (ParseResult a) where
  show UnexpectedEof =
    "Unexpected end of stream"
  show (ExpectedEof i) =
    stringconcat ["Expected end of stream, but got >", show i, "<"]
  show (UnexpectedChar c) =
    stringconcat ["Unexpected character: ", show [c]]
  show (UnexpectedString s) =
    stringconcat ["Unexpected string: ", show s]
  show (Result i a) =
    stringconcat ["Result >", hlist i, "< ", show a]


instance Functor ParseResult where
  _ <$> UnexpectedEof =
    UnexpectedEof
  _ <$> ExpectedEof i =
    ExpectedEof i
  _ <$> UnexpectedChar c =
    UnexpectedChar c
  _ <$> UnexpectedString s =
    UnexpectedString s
  f <$> Result i a =
    Result i (f a)


isErrorResult ::
  ParseResult a
  -> Bool
isErrorResult (Result _ _) =
  False
isErrorResult UnexpectedEof =
  True
isErrorResult (ExpectedEof _) =
  True
isErrorResult (UnexpectedChar _) =
  True
isErrorResult (UnexpectedString _) =
  True


onResult ::
  ParseResult a
  -> (Input -> a -> ParseResult b)
  -> ParseResult b
onResult UnexpectedEof _ =
  UnexpectedEof
onResult (ExpectedEof i) _ =
  ExpectedEof i
onResult (UnexpectedChar c) _ =
  UnexpectedChar c
onResult (UnexpectedString s)  _ =
  UnexpectedString s
onResult (Result i a) k =
  k i a

-------------------

newtype Parser a = P (Input -> ParseResult a)


parse ::
  Parser a
  -> Input
  -> ParseResult a
parse (P p) =
  p


unexpectedCharParser ::
  Char
  -> Parser a
unexpectedCharParser c =
  P (\_ -> UnexpectedChar c)


constantParser ::
  ParseResult a
  -> Parser a
constantParser =
  P . const


character ::
  Parser Char
character =
  P (\case
      Nil      -> UnexpectedEof
      (h :. t) -> Result t h)


instance Functor Parser where
  (<$>) ::
    (a -> b)
    -> Parser a
    -> Parser b
  f <$> (P p) =
    P $ (f <$>) . p


valueParser ::
  a
  -> Parser a
valueParser a =
  P (`Result` a)


(|||) ::
  Parser a
  -> Parser a
  -> Parser a
(|||) l r =
  P (\i -> let p = parse l i
            in bool p (parse r i) $ isErrorResult p)
infixl 3 |||


instance Alternative Parser where
  empty :: Parser a
  empty = constantParser UnexpectedEof

  (<|>) :: Parser a -> Parser a -> Parser a
  (<|>) = (|||)


instance Monad Parser where
  (=<<) ::
    (a -> Parser b)
    -> Parser a
    -> Parser b
  f =<< (P p) =
    let g j x = parse (f x) j
        h i = onResult (p i) g
    in P h


instance Applicative Parser where
  pure ::
    a
    -> Parser a
  pure =
    valueParser
  (<*>) ::
    Parser (a -> b)
    -> Parser a
    -> Parser b
  (<*>) f p =
    let g a = ($ a) <$> f
    in g =<< p


satisfy ::
  (Char -> Bool)
  -> Parser Char
satisfy p =
  let f a = bool (unexpectedCharParser a) (pure a) (p a)
  in f =<< character


is ::
  Char -> Parser Char
is c =
  satisfy (== c)


digit ::
  Parser Char
digit =
  satisfy isDigit


space ::
  Parser Char
space =
  satisfy isSpace


list ::
  Parser a
  -> Parser (List a)
list p =
  list1 p ||| pure Nil


list1 ::
  Parser a
  -> Parser (List a)
list1 p = do
      a <- p
      b <- list p
      return (a :. b)


spaces1 ::
  Parser String
spaces1 =
  list1 space


lower ::
  Parser Char
lower =
  satisfy isLower


upper ::
  Parser Char
upper =
  satisfy isUpper


alpha ::
  Parser Char
alpha =
  satisfy isAlpha


sequenceParser ::
  List (Parser a)
  -> Parser (List a)
sequenceParser =
  let f p acc = do a <- p
                   b <- acc
                   return (a :. b)
   in foldRight f (pure Nil)

thisMany ::
  Int
  -> Parser a
  -> Parser (List a)
thisMany =
  (sequenceParser .) . replicate


------------------------
-- Example: Parsing a Person


ageParser ::
  Parser Int
ageParser =
  (\k -> case read k of Empty  -> constantParser (UnexpectedString k)
                        Full h -> pure h) =<< (list1 digit)


firstNameParser ::
  Parser String
firstNameParser =
  do h <- upper
     t <- list lower
     return (h :. t)


surnameParser ::
  Parser String
surnameParser =
  do h <- upper
     t <- thisMany 5 lower
     l <- list lower
     return $ (h :. t) ++ l


smokerParser ::
  Parser Bool
smokerParser =
  let f = const . pure
  in (f True =<< is 'y') ||| (f False =<< is 'n')


phoneBodyParser ::
  Parser String
phoneBodyParser =
  list (digit ||| is '-' ||| is '.')


phoneParser ::
  Parser String
phoneParser =
  do start <- digit
     body  <- phoneBodyParser
     _ <- is '#'
     return (start :. body)


personParser ::
  Parser Person
personParser =
  do age      <- ageParser
     _        <- spaces1
     name     <- firstNameParser
     _        <- spaces1
     surname  <- surnameParser
     _        <- spaces1
     isSmoker <- smokerParser
     _        <- spaces1
     phone    <- phoneParser
     pure $ Person age name surname isSmoker phone