Johachim Breitner's Applicative showcase, free applicative version

Freegram.hs

{-# LANGUAGE GADTs      #-}
{-# LANGUAGE LambdaCase #-}

module Freegram where

import           Bnf
import           Parser

import           Control.Applicative.Free.Final
import           Data.Maybe                     (catMaybes)

data DescrF a where
  CharD        :: Char    -> DescrF ()
  ManyD        :: Descr a -> DescrF [a]
  OrElseD      :: Descr a -> Descr  a -> DescrF a
  PrimitiveD   :: String  -> Parser a -> DescrF a
  NonTerminalD :: String  -> Descr  a -> DescrF a

type Descr = Ap DescrF

-- We need interpreters to replace the type classes instances.

toParser :: Descr a -> Parser a
toParser = runAp
  (\case
      CharD c          -> charP c
      ManyD d          -> manyP (toParser d)
      OrElseD a b      -> orElseP (toParser a) (toParser b)
      PrimitiveD _ p   -> p
      NonTerminalD _ d -> toParser d
  )

toGrammar :: Descr a -> Grammar a
toGrammar = runAp
  (\case
      CharD c             -> charG c
      ManyD d             -> manyG (toGrammar d)
      OrElseD a b         -> orElseG (toGrammar a) (toGrammar b)
      PrimitiveD name _   -> primitiveG name
      NonTerminalD name d -> nonTerminalG name (toGrammar d)
  )

-- Some utilities derived from that

parseD :: Descr a -> String -> Maybe a
parseD d = parse (toParser d)

ppD :: String -> Descr a -> String
ppD main descr = ppGrammar main (toGrammar descr)

-- And wrappers for our DescrF values.

char :: Char -> Descr ()
char = liftAp . CharD

many :: Descr a -> Descr [a]
many = liftAp . ManyD

orElse :: Descr a -> Descr a -> Descr a
a `orElse` b = liftAp $ a `OrElseD` b

primitive :: String -> Parser a -> Descr a
primitive name parser = liftAp $ PrimitiveD name parser

nonTerminal :: String -> Descr a -> Descr a
nonTerminal name d = liftAp $ NonTerminalD name d

-- The remaining is simple copy paste from the original article,
-- updating type signatures to line up.

many1 :: Descr a -> Descr [a]
many1 p = pure (:) <*> p <*> many p

anyChar :: Descr Char
anyChar = primitive "char" anyCharP

dottedWords :: Descr [String]
dottedWords = many1 (many anyChar <* char '.')

sepBy :: Descr a -> Descr () -> Descr [a]
sepBy p1 p2 = ((:) <$> p1 <*> (many (p2 *> p1))) `orElse` pure []

newline :: Descr ()
newline = primitive "newline" (charP '\n')

-- And then examples. The only thing that changed are the types.

parseCSV :: Descr [[String]]
parseCSV = many parseLine
  where
    parseLine = nonTerminal "line" $
        parseCell `sepBy` char ',' <* newline
    parseCell = nonTerminal "cell" $
        char '"' *> many (primitive "not-quote" (anyCharButP '"')) <* char '"'

type INIFile = [(String, [(String, String)])]

descrINI :: Descr INIFile
descrINI = many1 parseSection
  where
    parseSection = nonTerminal "section" $
        (,) <$  char '['
            <*> parseIdent
            <*  char ']'
            <*  newline
            <*> (catMaybes <$> many parseLine)
    parseIdent = nonTerminal "identifier" $
        many1 (primitive "alphanum" letterOrDigitP)
    parseLine = nonTerminal "line" $
        parseDecl `orElse` parseComment `orElse` parseEmpty

    parseDecl = nonTerminal "declaration" $ Just <$> (
        (,) <$> parseIdent
            <*  spaces
            <*  char '='
            <*  spaces
            <*> remainder)

    parseComment = nonTerminal "comment" $
        Nothing <$ char '#' <* remainder

    remainder = nonTerminal "line-remainder" $
        many1 (primitive "non-newline" (anyCharButP '\n')) <* newline

    parseEmpty = Nothing <$ newline

    spaces = nonTerminal "spaces" $ many (char ' ')