Test code for Earley parser

earleytest.hs

#!/usr/bin/env stack
-- stack --resolver=nightly-2015-11-04 --install-ghc runghc --package Earley

{-# LANGUAGE RecursiveDo, RankNTypes #-}
module Main where

import Control.Applicative
import Text.Earley
import System.Environment

data Zero = Zero deriving (Eq, Show)
data Comma = Comma deriving (Eq, Show)

list :: Prod r e t a -> Grammar r (Prod r e t ([a]))
list p = mdo
  r <- rule $ pure [] <|> (:) <$> p <*> r
  return r

comma :: Prod r String Char Comma
comma = Comma <$ symbol ',' <?> ","

zero :: Prod r String Char Zero
zero = Zero <$ symbol '0' <?> "0"

data Grouped = Grouped Zero [Zero] Comma Zero [(Comma, Zero, [Zero])]
  deriving (Eq, Show)

data Ungrouped = Ungrouped Zero [Zero] deriving (Eq, Show)

groupedOrUngrouped :: Grammar r (Prod r String Char (Either Grouped Ungrouped))
groupedOrUngrouped = mdo
  seqZero <- list zero
  seqGroups <- list $ (,,) <$> comma <*> zero <*> seqZero
  let l = Grouped <$> zero <*> seqZero <*> comma <*> zero <*> seqGroups
      r = Ungrouped <$> zero <*> seqZero
  rule $ Left <$> l <|> Right <$> r

grouped :: Grammar r (Prod r String Char Grouped)
grouped = mdo
  seqZero <- list zero
  seqGroups <- list $ (,,) <$> comma <*> zero <*> seqZero
  rule $ Grouped <$> zero <*> seqZero <*> comma <*> zero <*> seqGroups

main :: IO ()
main = do
  arg:[] <- getArgs
  print (allParses (parser groupedOrUngrouped) arg)
  putStrLn ""
  print (allParses (parser grouped) arg)