Parser combinators (BFPG 2025-02-11)

Parser.hs

{-# LANGUAGE NoOverloadedStrings #-}

{-

Parser combinator library and parser implementation for a simple JSON-ish
format.

- Strings, bool, ints (positive only), objects
- No whitespace
- No string escapes (delimited by double quotes)

-}

module Parser where

import Control.Applicative

data Parser a
  = Parser { runParser :: String -> Maybe (String, a) }

instance Functor Parser where
  fmap f p = Parser $ \s -> fmap (fmap f) (runParser p s)

instance Applicative Parser where
  pure a = Parser $ \s -> Just (s, a)

  pf <*> pa = Parser $ \s ->
    case runParser pf s of
      Nothing -> Nothing
      Just (s', f) -> runParser (fmap f pa) s'

instance Alternative Parser where
  empty = Parser $ const Nothing
  p1 <|> p2 = Parser $ \s -> runParser p1 s <|> runParser p2 s

parse :: Parser a -> String -> Maybe a
parse p = fmap snd . runParser (p <* endOfInput)

endOfInput :: Parser ()
endOfInput = Parser $ \s -> case s of
  ""  -> Just ("", ())
  _   -> Nothing

satisfy :: (Char -> Bool) -> Parser Char
satisfy test = Parser $ \s -> case s of
  (h:t) | test h -> Just (t, h)
  _              -> Nothing

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

digit :: Parser Char
digit = satisfy (`elem` "0123456789" )

int :: Parser Int
int = fmap read (some digit)

-- match the exact string
literal :: [Char] -> Parser String
literal = traverse char

bool :: Parser Bool
bool =
  fmap (const True) (literal "true")
  <|> fmap (const False) (literal "false")

betwixt :: Parser l -> Parser r -> Parser a -> Parser a
betwixt pl pr pa = pl *> pa <* pr

quotedString :: Parser String
quotedString = betwixt (char '"') (char '"') (many (satisfy (/= '"')))

sepBy :: Parser sep -> Parser a -> Parser [a]
sepBy sep a =
  pure (:) <*> a <*> many (sep *> a)
  <|> pure []

type KV = (String, Value)
type Object = [KV]

data Value =
  VBool Bool
  | VString String
  | VInt Int  
  | VObject Object
  deriving (Show)

value :: Parser Value
value =
  VBool <$> bool
  <|> VInt <$> int
  <|> VString <$> quotedString
  <|> VObject <$> object

kv :: Parser KV
kv = (,) <$> quotedString <* char ':' <*> value

object :: Parser Object
object =
  betwixt (char '{') (char '}') (sepBy (char ',') kv)