Earley 0.11.0.1 → 0.12.0.0

raw patch · 23 files changed

+1144/−438 lines, 23 filesdep +QuickCheckdep ~basenew-component:exe:earley-roman-numeralsPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−1
• Earley.cabal +24/−8
• README.md +67/−48
• Text/Earley.hs +8/−5
• Text/Earley/Generator.hs +10/−0
• Text/Earley/Generator/Internal.hs +334/−0
• Text/Earley/Internal.hs +0/−350
• Text/Earley/Parser.hs +2/−1
• Text/Earley/Parser/Internal.hs +361/−0
• examples/Expr2.hs +5/−5
• examples/Infinite.hs +0/−1
• examples/RomanNumerals.hs +64/−0
• tests/Arbitrary.hs +13/−0
• tests/Empty.hs +13/−2
• tests/Expr.hs +66/−13
• tests/Generator.hs +18/−0
• tests/InlineAlts.hs +4/−1
• tests/Issue14.hs +3/−1
• tests/Lambda.hs +111/−0
• tests/Main.hs +4/−0
• tests/Optional.hs +12/−0
• tests/ReversedWords.hs +9/−2
• tests/VeryAmbiguous.hs +7/−0

@@ -1,3 +1,11 @@+# Unreleased++# 0.12.0.0++- Add the `Generator` module for generating grammar members+- Change (simplify) the type returned by `parser`, introducing  a `Parser` type synonym for it, and change the signature of `allParses`, `fullParses`, and `report` to accept a `Parser`+- The `Text.Earley.Internal` module is now `Text.Earley.Parser.Internal`+ # 0.11.0.1  - Add missing modules to Cabal file@@ -24,7 +32,7 @@  - Remove `Args`, and use `Results` instead - Make `parser` function not take input directly-- Remove redundant type parameter to `Grammar`.+- Remove redundant type parameter to `Grammar`  # 0.9 

@@ -1,5 +1,5 @@ name:                Earley-version:             0.11.0.1+version:             0.12.0.0 synopsis:            Parsing all context-free grammars using Earley's algorithm. description:         See <https://www.github.com/ollef/Earley> for more                      information and@@ -32,10 +32,12 @@   exposed-modules:                        Text.Earley,                        Text.Earley.Derived,+                       Text.Earley.Generator,+                       Text.Earley.Generator.Internal,                        Text.Earley.Grammar,-                       Text.Earley.Internal,                        Text.Earley.Mixfix,-                       Text.Earley.Parser+                       Text.Earley.Parser,+                       Text.Earley.Parser.Internal   build-depends:       base >=4.6 && <4.10, ListLike >=4.1   default-language:    Haskell2010   ghc-options:         -Wall@@ -77,6 +79,15 @@   default-language:    Haskell2010   build-depends:       base, Earley, unordered-containers +executable earley-roman-numerals+  if !flag(examples)+    buildable:         False+  main-is:             RomanNumerals.hs+  ghc-options:         -Wall+  hs-source-dirs:      examples+  default-language:    Haskell2010+  build-depends:       base, Earley+ executable earley-very-ambiguous   if !flag(examples)     buildable:         False@@ -111,11 +122,12 @@   build-depends:       base, deepseq, criterion >=1.1, parsec >=3.1, ListLike   default-language:    Haskell2010   ghc-options:         -Wall-  other-modules:       Text.Earley,+  other-modules:+                       Text.Earley,                        Text.Earley.Derived,                        Text.Earley.Grammar,-                       Text.Earley.Internal,-                       Text.Earley.Parser+                       Text.Earley.Parser,+                       Text.Earley.Parser.Internal  test-suite tests   type:                exitcode-stdio-1.0@@ -123,12 +135,16 @@   ghc-options:         -Wall   hs-source-dirs:      tests   default-language:    Haskell2010-  build-depends:       base, Earley, tasty >=0.10, tasty-quickcheck >=0.8, tasty-hunit >= 0.9-  other-modules:       Empty,+  build-depends:       base, Earley, tasty >=0.10, tasty-quickcheck >=0.8, tasty-hunit >= 0.9, QuickCheck >= 2.8+  other-modules:+                       Arbitrary,+                       Empty,                        Expr,+                       Generator,                        InlineAlts,                        Issue11,                        Issue14,+                       Lambda,                        Mixfix,                        Optional,                        ReversedWords,

@@ -3,64 +3,83 @@  [Go to the API documentation on Hackage.](https://hackage.haskell.org/package/Earley) -This (Text.Earley) is a library consisting of two main parts:+This ([Text.Earley](https://hackage.haskell.org/package/Earley/docs/Text-Earley.html)) is a library consisting of a few main parts: -1. Text.Earley.Grammar:-   An embedded context-free grammar (CFG) domain-specific language (DSL) with-   semantic action specification in applicative style.+### [Text.Earley.Grammar](https://hackage.haskell.org/package/Earley/docs/Text-Earley-Grammar.html) -   An example of a typical expression grammar working on an input tokenised-   into strings is the following:+An embedded context-free grammar (CFG) domain-specific language (DSL) with+semantic action specification in applicative style. -   ```haskell-      expr :: Grammar r (Prod r String String Expr)-      expr = mdo-        x1 <- rule $ Add <$> x1 <* namedToken "+" <*> x2-                  <|> x2-                  <?> "sum"-        x2 <- rule $ Mul <$> x2 <* namedToken "*" <*> x3-                  <|> x3-                  <?> "product"-        x3 <- rule $ Var <$> (satisfy ident <?> "identifier")-                  <|> namedToken "(" *> x1 <* namedToken ")"-        return x1-        where-          ident (x:_) = isAlpha x-          ident _     = False-   ```+An example of a typical expression grammar working on an input tokenised+into strings is the following: -2. Text.Earley.Parser:-   An implementation of (a modification of) the Earley parsing algorithm.+```haskell+   expr :: Grammar r (Prod r String String Expr)+   expr = mdo+     x1 <- rule $ Add <$> x1 <* namedToken "+" <*> x2+               <|> x2+               <?> "sum"+     x2 <- rule $ Mul <$> x2 <* namedToken "*" <*> x3+               <|> x3+               <?> "product"+     x3 <- rule $ Var <$> (satisfy ident <?> "identifier")+               <|> namedToken "(" *> x1 <* namedToken ")"+     return x1+     where+       ident (x:_) = isAlpha x+       ident _     = False+``` -   To invoke the parser on the above grammar, run e.g. (here using `words` as a-   stupid tokeniser):+### [Text.Earley.Parser](https://hackage.haskell.org/package/Earley/docs/Text-Earley-Parser.html) -   ```haskell-      fullParses (parser expr) $ words "a + b * ( c + d )"-      = ( [Add (Var "a") (Mul (Var "b") (Add (Var "c") (Var "d")))]-        , Report {...}-        )-   ```+An implementation of (a modification of) the Earley parsing algorithm. -   Note that we get a list of all the possible parses (though in this case-   there is only one).+To invoke the parser on the above grammar, run e.g. (here using `words` as a+stupid tokeniser): -   Another invocation, which shows the error reporting capabilities (giving the-   last position that the parser reached and what it expected at that point),-   is the following:+```haskell+   fullParses (parser expr) $ words "a + b * ( c + d )"+   = ( [Add (Var "a") (Mul (Var "b") (Add (Var "c") (Var "d")))]+     , Report {...}+     )+``` -   ```haskell-      fullParses (parser expr) $ words "a +"-      = ( []-        , Report { position   = 2-                 , expected   = ["(","identifier","product"]-                 , unconsumed = []-                 }-        )-   ```+Note that we get a list of all the possible parses (though in this case+there is only one). -Text.Earley.Mixfix additionally includes helper functionality for creating-parsers for expressions with mixfix identifiers in the style of Agda.+Another invocation, which shows the error reporting capabilities (giving the+last position that the parser reached and what it expected at that point),+is the following:++```haskell+   fullParses (parser expr) $ words "a +"+   = ( []+     , Report { position   = 2+              , expected   = ["(","identifier","product"]+              , unconsumed = []+              }+     )+```++### [Text.Earley.Generator](https://hackage.haskell.org/package/Earley/docs/Text-Earley-Generator.html)++Functionality to generate the members of the language that a grammar generates.++To get the language of a grammar given a list of allowed tokens, run e.g.:++```haskell+   language (generator romanNumeralsGrammar "VIX")+   = [(0,""),(1,"I"),(5,"V"),(10,"X"),(20,"XX"),(11,"XI"),(15,"XV"),(6,"VI"),(9,"IX"),(4,"IV"),(2,"II"),(3,"III"),(19,"XIX"),(16,"XVI"),(14,"XIV"),(12,"XII"),(7,"VII"),(21,"XXI"),(25,"XXV"),(30,"XXX"),(31,"XXXI"),(35,"XXXV"),(8,"VIII"),(13,"XIII"),(17,"XVII"),(26,"XXVI"),(29,"XXIX"),(24,"XXIV"),(22,"XXII"),(18,"XVIII"),(36,"XXXVI"),(39,"XXXIX"),(34,"XXXIV"),(32,"XXXII"),(23,"XXIII"),(27,"XXVII"),(33,"XXXIII"),(28,"XXVIII"),(37,"XXXVII"),(38,"XXXVIII")]+```++The above example shows the language generated by a [Roman numerals+grammar](examples/RomanNumerals.hs) limited to the tokens `'V'`, `'I'`, and+`'X'`.++### [Text.Earley.Mixfix](https://hackage.haskell.org/package/Earley/docs/Text-Earley-Mixfix.html)++Helper functionality for creating parsers for expressions with mixfix+identifiers in the style of Agda.  How do I write grammars? ------------------------

@@ -7,11 +7,14 @@   , -- * Deprecated operators     symbol, namedSymbol, word   , -- * Parsing-    Report(..), Result(..), parser, allParses, fullParses-    -- * Recognition-  , report+    Report(..), Parser.Result(..), Parser, parser, allParses, fullParses+  , -- * Recognition+    report+  , -- * Language generation+    Generator, generator, language, upTo, exactly   )   where-import Text.Earley.Grammar import Text.Earley.Derived-import Text.Earley.Parser+import Text.Earley.Generator+import Text.Earley.Grammar+import Text.Earley.Parser as Parser

@@ -0,0 +1,10 @@+module Text.Earley.Generator+  ( Result(..)+  , Generator+  , generator+  , language+  , upTo+  , exactly+  ) where+import Text.Earley.Generator.Internal+

@@ -0,0 +1,334 @@+{-# LANGUAGE CPP, BangPatterns, DeriveFunctor, GADTs, Rank2Types, RecursiveDo #-}+-- | This module exposes the internals of the package: its API may change+-- independently of the PVP-compliant version number.+module Text.Earley.Generator.Internal where+import Control.Applicative+import Control.Monad+import Control.Monad.ST.Lazy+import Data.ListLike(ListLike)+import qualified Data.ListLike as ListLike+import Data.Maybe(mapMaybe)+import Data.STRef.Lazy+import Text.Earley.Grammar+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif++-------------------------------------------------------------------------------+-- * Concrete rules and productions+-------------------------------------------------------------------------------+-- | The concrete rule type that the generator uses+data Rule s r e t a = Rule+  { ruleProd  :: ProdR s r e t a+  , ruleConts :: !(STRef s (STRef s [Cont s r e t a r]))+  , ruleNulls :: !(Results s t a)+  }++mkRule :: ProdR s r e t a -> ST s (Rule s r e t a)+mkRule p = mdo+  c <- newSTRef =<< newSTRef mempty+  computeNullsRef <- newSTRef $ do+    writeSTRef computeNullsRef $ return []+    ns <- unResults $ prodNulls p+    writeSTRef computeNullsRef $ return ns+    return ns+  return $ Rule (removeNulls p) c (Results $ join $ readSTRef computeNullsRef)++prodNulls :: ProdR s r e t a -> Results s t a+prodNulls prod = case prod of+  Terminal {}     -> empty+  NonTerminal r p -> ruleNulls r <**> prodNulls p+  Pure a          -> pure a+  Alts as p       -> mconcat (map prodNulls as) <**> prodNulls p+  Many a p        -> prodNulls (pure [] <|> pure <$> a) <**> prodNulls p+  Named p _       -> prodNulls p++-- | Remove (some) nulls from a production+removeNulls :: ProdR s r e t a -> ProdR s r e t a+removeNulls prod = case prod of+  Terminal {}      -> prod+  NonTerminal {}   -> prod+  Pure _           -> empty+  Alts as (Pure f) -> alts (map removeNulls as) $ Pure f+  Alts {}          -> prod+  Many {}          -> prod+  Named p n        -> Named (removeNulls p) n++type ProdR s r e t a = Prod (Rule s r) e t a++resetConts :: Rule s r e t a -> ST s ()+resetConts r = writeSTRef (ruleConts r) =<< newSTRef mempty++-------------------------------------------------------------------------------+-- * Delayed results+-------------------------------------------------------------------------------+newtype Results s t a = Results { unResults :: ST s [(a, [t])] }+  deriving Functor++lazyResults :: ST s [(a, [t])] -> ST s (Results s t a)+lazyResults stas = mdo+  resultsRef <- newSTRef $ do+    as <- stas+    writeSTRef resultsRef $ return as+    return as+  return $ Results $ join $ readSTRef resultsRef++instance Applicative (Results s t) where+  pure  = return+  (<*>) = ap++instance Alternative (Results t s) where+  empty = Results $ pure []+  Results sxs <|> Results sys = Results $ (<|>) <$> sxs <*> sys++instance Monad (Results t s) where+  return x = Results $ pure [(x, mempty)]+  Results stxs >>= f = Results $ do+    xs <- stxs+    concat <$> mapM (\(x, ts) -> fmap (\(y, ts') -> (y, ts' ++ ts)) <$> unResults (f x)) xs++instance Monoid (Results s t a) where+  mempty = empty+  mappend = (<|>)++-------------------------------------------------------------------------------+-- * States and continuations+-------------------------------------------------------------------------------+data BirthPos+  = Previous+  | Current+  deriving Eq++-- | An Earley state with result type @a@.+data State s r e t a where+  State :: !(ProdR s r e t a)+        -> !(a -> Results s t b)+        -> !BirthPos+        -> !(Conts s r e t b c)+        -> State s r e t c+  Final :: !(Results s t a) -> State s r e t a++-- | A continuation accepting an @a@ and producing a @b@.+data Cont s r e t a b where+  Cont      :: !(a -> Results s t b)+            -> !(ProdR s r e t (b -> c))+            -> !(c -> Results s t d)+            -> !(Conts s r e t d e')+            -> Cont s r e t a e'+  FinalCont :: (a -> Results s t c) -> Cont s r e t a c++data Conts s r e t a c = Conts+  { conts     :: !(STRef s [Cont s r e t a c])+  , contsArgs :: !(STRef s (Maybe (STRef s (Results s t a))))+  }++newConts :: STRef s [Cont s r e t a c] -> ST s (Conts s r e t a c)+newConts r = Conts r <$> newSTRef Nothing++contraMapCont :: (b -> Results s t a) -> Cont s r e t a c -> Cont s r e t b c+contraMapCont f (Cont g p args cs) = Cont (f >=> g) p args cs+contraMapCont f (FinalCont args)   = FinalCont (f >=> args)++contToState :: BirthPos -> Results s t a -> Cont s r e t a c -> State s r e t c+contToState pos r (Cont g p args cs) = State p (\f -> fmap f (r >>= g) >>= args) pos cs+contToState _   r (FinalCont args)   = Final $ r >>= args++-- | Strings of non-ambiguous continuations can be optimised by removing+-- indirections.+simplifyCont :: Conts s r e t b a -> ST s [Cont s r e t b a]+simplifyCont Conts {conts = cont} = readSTRef cont >>= go False+  where+    go !_ [Cont g (Pure f) args cont'] = do+      ks' <- simplifyCont cont'+      go True $ map (contraMapCont $ \b -> fmap f (g b) >>= args) ks'+    go True ks = do+      writeSTRef cont ks+      return ks+    go False ks = return ks++-------------------------------------------------------------------------------+-- * Grammars+-------------------------------------------------------------------------------+-- | Given a grammar, construct an initial state.+initialState :: ProdR s a e t a -> ST s (State s a e t a)+initialState p = State p pure Previous <$> (newConts =<< newSTRef [FinalCont pure])++-------------------------------------------------------------------------------+-- * Generation+-------------------------------------------------------------------------------+-- | The result of a generator.+data Result s t a+  = Ended (ST s [(a, [t])])+    -- ^ The generator ended.+  | Generated (ST s [(a, [t])]) (ST s (Result s t a))+    -- ^ The generator produced a number of @a@s.  These are given as a+    -- computation, @'ST' s [a]@ that constructs the 'a's when run.  The 'Int' is+    -- the position in the input where these results were obtained, and the last+    -- component is the continuation.+  deriving Functor++{-# INLINE safeHead #-}+safeHead :: ListLike i t => i -> Maybe t+safeHead ts+  | ListLike.null ts = Nothing+  | otherwise        = Just $ ListLike.head ts++data GenerationEnv s e t a = GenerationEnv+  { results :: ![ST s [(a, [t])]]+    -- ^ Results ready to be reported (when this position has been processed)+  , next    :: ![State s a e t a]+    -- ^ States to process at the next position+  , reset   :: !(ST s ())+    -- ^ Computation that resets the continuation refs of productions+  , tokens  :: ![t]+    -- ^ The possible tokens+  }++{-# INLINE emptyGenerationEnv #-}+emptyGenerationEnv :: [t] -> GenerationEnv s e t a+emptyGenerationEnv ts = GenerationEnv+  { results = mempty+  , next    = mempty+  , reset   = return ()+  , tokens  = ts+  }++-- | The internal generation routine+generate :: [State s a e t a] -- ^ States to process at this position+         -> GenerationEnv s e t a+         -> ST s (Result s t a)+generate [] env@GenerationEnv {next = []} = do+  reset env+  return $ Ended $ concat <$> sequence (results env)+generate [] env = do+  reset env+  return $ Generated (concat <$> sequence (results env))+         $ generate (next env) $ emptyGenerationEnv $ tokens env+generate (st:ss) env = case st of+  Final res -> generate ss env {results = unResults res : results env}+  State pr args pos scont -> case pr of+    Terminal f p -> generate ss env+      { next = [State p (\g -> Results (pure $ map (\(t, a) -> (g a, [t])) xs) >>= args) Previous scont | xs <- [mapMaybe (\t -> (,) t <$> f t) $ tokens env], not $ null xs]+            ++ next env+      }+    NonTerminal r p -> do+      rkref <- readSTRef $ ruleConts r+      ks    <- readSTRef rkref+      writeSTRef rkref (Cont pure p args scont : ks)+      ns    <- unResults $ ruleNulls r+      let addNullState+            | null ns = id+            | otherwise = (:)+                        $ State p (\f -> f <$> Results (pure ns) >>= args) pos scont+      if null ks then do -- The rule has not been expanded at this position.+        st' <- State (ruleProd r) pure Current <$> newConts rkref+        generate (addNullState $ st' : ss)+              env {reset = resetConts r >> reset env}+      else -- The rule has already been expanded at this position.+        generate (addNullState ss) env+    Pure a+      -- Skip following continuations that stem from the current position; such+      -- continuations are handled separately.+      | pos == Current -> generate ss env+      | otherwise -> do+        let argsRef = contsArgs scont+        masref  <- readSTRef argsRef+        case masref of+          Just asref -> do -- The continuation has already been followed at this position.+            modifySTRef asref $ mappend $ args a+            generate ss env+          Nothing    -> do -- It hasn't.+            asref <- newSTRef $ args a+            writeSTRef argsRef $ Just asref+            ks  <- simplifyCont scont+            res <- lazyResults $ join $ unResults <$> readSTRef asref+            let kstates = map (contToState pos res) ks+            generate (kstates ++ ss)+                  env {reset = writeSTRef argsRef Nothing >> reset env}+    Alts as (Pure f) -> do+      let args' = args . f+          sts   = [State a args' pos scont | a <- as]+      generate (sts ++ ss) env+    Alts as p -> do+      scont' <- newConts =<< newSTRef [Cont pure p args scont]+      let sts = [State a pure Previous scont' | a <- as]+      generate (sts ++ ss) env+    Many p q -> mdo+      r <- mkRule $ pure [] <|> (:) <$> p <*> NonTerminal r (Pure id)+      generate (State (NonTerminal r q) args pos scont : ss) env+    Named pr' _ -> generate (State pr' args pos scont : ss) env++type Generator t a = forall s. ST s (Result s t a)++-- | Create a language generator for given grammar and list of allowed tokens.+generator+  :: (forall r. Grammar r (Prod r e t a))+  -> [t]+  -> Generator t a+generator g ts = do+  let nt x = NonTerminal x $ pure id+  s <- initialState =<< runGrammar (fmap nt . mkRule) g+  generate [s] $ emptyGenerationEnv ts++-- | Run a generator, returning all members of the language.+--+-- The members are returned as parse results paired with the list of tokens+-- used to produce the result.+-- The elements of the returned list of results are sorted by their length in+-- ascending order.  If there are multiple results of the same length they are+-- returned in an unspecified order.+language+  :: Generator t a+  -> [(a, [t])]+language gen = runST $ gen >>= go+  where+    go :: Result s t a -> ST s [(a, [t])]+    go r = case r of+      Ended mas -> mas+      Generated mas k -> do+        as <- mas+        (as ++) <$> (go =<< k)++-- | @upTo n gen@ runs the generator @gen@, returning all members of the+-- language that are of length less than or equal to @n@.+--+-- The members are returned as parse results paired with the list of tokens+-- used to produce the result.+-- The elements of the returned list of results are sorted by their length in+-- ascending order.  If there are multiple results of the same length they are+-- returned in an unspecified order.+upTo+  :: Int+  -> Generator t a+  -> [(a, [t])]+upTo len gen = runST $ gen >>= go 0+  where+    go :: Int -> Result s t a -> ST s [(a, [t])]+    go curLen r | curLen <= len = case r of+      Ended mas -> mas+      Generated mas k -> do+        as <- mas+        (as ++) <$> (go (curLen + 1) =<< k)+    go _ _ = return []++-- | @exactly n gen@ runs the generator @gen@, returning all members of the+-- language that are of length equal to @n@.+--+-- The members are returned as parse results paired with the list of tokens+-- used to produce the result.+-- If there are multiple results they are returned in an unspecified order.+exactly+  :: Int+  -> Generator t a+  -> [(a, [t])]+exactly len _ | len < 0 = []+exactly len gen = runST $ gen >>= go 0+  where+    go :: Int -> Result s t a -> ST s [(a, [t])]+    go !curLen r = case r of+      Ended mas+        | curLen == len -> mas+        | otherwise -> return []+      Generated mas k+        | curLen == len -> mas+        | otherwise -> go (curLen + 1) =<< k

@@ -1,350 +0,0 @@-{-# LANGUAGE CPP, BangPatterns, DeriveFunctor, GADTs, Rank2Types, RecursiveDo #-}--- | This module exposes the internals of the package: its API may change--- independently of the PVP-compliant version number.-module Text.Earley.Internal where-import Control.Applicative-import Control.Arrow-import Control.Monad-import Control.Monad.ST-import Data.ListLike(ListLike)-import qualified Data.ListLike as ListLike-import Data.STRef-import Text.Earley.Grammar-#if !MIN_VERSION_base(4,8,0)-import Data.Monoid-#endif------------------------------------------------------------------------------------ * Concrete rules and productions----------------------------------------------------------------------------------- | The concrete rule type that the parser uses-data Rule s r e t a = Rule-  { ruleProd  :: ProdR s r e t a-  , ruleConts :: !(STRef s (STRef s [Cont s r e t a r]))-  , ruleNulls :: !(Results s a)-  }--mkRule :: ProdR s r e t a -> ST s (Rule s r e t a)-mkRule p = mdo-  c <- newSTRef =<< newSTRef mempty-  computeNullsRef <- newSTRef $ do-    writeSTRef computeNullsRef $ return []-    ns <- unResults $ prodNulls p-    writeSTRef computeNullsRef $ return ns-    return ns-  return $ Rule (removeNulls p) c (Results $ join $ readSTRef computeNullsRef)--prodNulls :: ProdR s r e t a -> Results s a-prodNulls prod = case prod of-  Terminal {}     -> empty-  NonTerminal r p -> ruleNulls r <**> prodNulls p-  Pure a          -> pure a-  Alts as p       -> mconcat (map prodNulls as) <**> prodNulls p-  Many a p        -> prodNulls (pure [] <|> pure <$> a) <**> prodNulls p-  Named p _       -> prodNulls p---- | Remove (some) nulls from a production-removeNulls :: ProdR s r e t a -> ProdR s r e t a-removeNulls prod = case prod of-  Terminal {}      -> prod-  NonTerminal {}   -> prod-  Pure _           -> empty-  Alts as (Pure f) -> alts (map removeNulls as) $ Pure f-  Alts {}          -> prod-  Many {}          -> prod-  Named p n        -> Named (removeNulls p) n--type ProdR s r e t a = Prod (Rule s r) e t a--resetConts :: Rule s r e t a -> ST s ()-resetConts r = writeSTRef (ruleConts r) =<< newSTRef mempty------------------------------------------------------------------------------------ * Delayed results---------------------------------------------------------------------------------newtype Results s a = Results { unResults :: ST s [a] }-  deriving Functor--lazyResults :: ST s [a] -> ST s (Results s a)-lazyResults stas = mdo-  resultsRef <- newSTRef $ do-    as <- stas-    writeSTRef resultsRef $ return as-    return as-  return $ Results $ join $ readSTRef resultsRef--instance Applicative (Results s) where-  pure  = return-  (<*>) = ap--instance Alternative (Results s) where-  empty = Results $ pure []-  Results sxs <|> Results sys = Results $ (<|>) <$> sxs <*> sys--instance Monad (Results s) where-  return = Results . pure . pure-  Results stxs >>= f = Results $ do-    xs <- stxs-    concat <$> mapM (unResults . f) xs--instance Monoid (Results s a) where-  mempty = empty-  mappend = (<|>)------------------------------------------------------------------------------------ * States and continuations---------------------------------------------------------------------------------data BirthPos-  = Previous-  | Current-  deriving Eq---- | An Earley state with result type @a@.-data State s r e t a where-  State :: !(ProdR s r e t a)-        -> !(a -> Results s b)-        -> !BirthPos-        -> !(Conts s r e t b c)-        -> State s r e t c-  Final :: !(Results s a) -> State s r e t a---- | A continuation accepting an @a@ and producing a @b@.-data Cont s r e t a b where-  Cont      :: !(a -> Results s b)-            -> !(ProdR s r e t (b -> c))-            -> !(c -> Results s d)-            -> !(Conts s r e t d e')-            -> Cont s r e t a e'-  FinalCont :: (a -> Results s c) -> Cont s r e t a c--data Conts s r e t a c = Conts-  { conts     :: !(STRef s [Cont s r e t a c])-  , contsArgs :: !(STRef s (Maybe (STRef s (Results s a))))-  }--newConts :: STRef s [Cont s r e t a c] -> ST s (Conts s r e t a c)-newConts r = Conts r <$> newSTRef Nothing--contraMapCont :: (b -> Results s a) -> Cont s r e t a c -> Cont s r e t b c-contraMapCont f (Cont g p args cs) = Cont (f >=> g) p args cs-contraMapCont f (FinalCont args)   = FinalCont (f >=> args)--contToState :: BirthPos -> Results s a -> Cont s r e t a c -> State s r e t c-contToState pos r (Cont g p args cs) = State p (\f -> fmap f (r >>= g) >>= args) pos cs-contToState _   r (FinalCont args)   = Final $ r >>= args---- | Strings of non-ambiguous continuations can be optimised by removing--- indirections.-simplifyCont :: Conts s r e t b a -> ST s [Cont s r e t b a]-simplifyCont Conts {conts = cont} = readSTRef cont >>= go False-  where-    go !_ [Cont g (Pure f) args cont'] = do-      ks' <- simplifyCont cont'-      go True $ map (contraMapCont $ \b -> fmap f (g b) >>= args) ks'-    go True ks = do-      writeSTRef cont ks-      return ks-    go False ks = return ks------------------------------------------------------------------------------------ * Grammars----------------------------------------------------------------------------------- | Given a grammar, construct an initial state.-initialState :: ProdR s a e t a -> ST s (State s a e t a)-initialState p = State p pure Previous <$> (newConts =<< newSTRef [FinalCont pure])------------------------------------------------------------------------------------ * Parsing----------------------------------------------------------------------------------- | A parsing report, which contains fields that are useful for presenting--- errors to the user if a parse is deemed a failure.  Note however that we get--- a report even when we successfully parse something.-data Report e i = Report-  { position   :: Int -- ^ The final position in the input (0-based) that the-                      -- parser reached.-  , expected   :: [e] -- ^ The named productions processed at the final-                      -- position.-  , unconsumed :: i   -- ^ The part of the input string that was not consumed,-                      -- which may be empty.-  } deriving (Eq, Ord, Read, Show)---- | The result of a parse.-data Result s e i a-  = Ended (Report e i)-    -- ^ The parser ended.-  | Parsed (ST s [a]) Int i (ST s (Result s e i a))-    -- ^ The parser parsed a number of @a@s.  These are given as a computation,-    -- @'ST' s [a]@ that constructs the 'a's when run.  We can thus save some-    -- work by ignoring this computation if we do not care about the results.-    -- The 'Int' is the position in the input where these results were-    -- obtained, the @i@ the rest of the input, and the last component is the-    -- continuation.-  deriving Functor--{-# INLINE safeHead #-}-safeHead :: ListLike i t => i -> Maybe t-safeHead ts-  | ListLike.null ts = Nothing-  | otherwise        = Just $ ListLike.head ts--data ParseEnv s e i t a = ParseEnv-  { results :: ![ST s [a]]-    -- ^ Results ready to be reported (when this position has been processed)-  , next    :: ![State s a e t a]-    -- ^ States to process at the next position-  , reset   :: !(ST s ())-    -- ^ Computation that resets the continuation refs of productions-  , names   :: ![e]-    -- ^ Named productions encountered at this position-  , curPos  :: !Int-    -- ^ The current position in the input string-  , input   :: !i-    -- ^ The input string-  }--{-# INLINE emptyParseEnv #-}-emptyParseEnv :: i -> ParseEnv s e i t a-emptyParseEnv i = ParseEnv-  { results = mempty-  , next    = mempty-  , reset   = return ()-  , names   = mempty-  , curPos  = 0-  , input   = i-  }--{-# SPECIALISE parse :: [State s a e t a]-                     -> ParseEnv s e [t] t a-                     -> ST s (Result s e [t] a) #-}--- | The internal parsing routine-parse :: ListLike i t-      => [State s a e t a] -- ^ States to process at this position-      -> ParseEnv s e i t a-      -> ST s (Result s e i a)-parse [] env@ParseEnv {results = [], next = []} = do-  reset env-  return $ Ended Report-    { position   = curPos env-    , expected   = names env-    , unconsumed = input env-    }-parse [] env@ParseEnv {results = []} = do-  reset env-  parse (next env)-        (emptyParseEnv $ ListLike.tail $ input env) {curPos = curPos env + 1}-parse [] env = do-  reset env-  return $ Parsed (concat <$> sequence (results env)) (curPos env) (input env)-         $ parse [] env {results = [], reset = return ()}-parse (st:ss) env = case st of-  Final res -> parse ss env {results = unResults res : results env}-  State pr args pos scont -> case pr of-    Terminal f p -> case safeHead (input env) >>= f of-      Just a -> parse ss env {next = State p (args . ($ a)) Previous scont-                                   : next env}-      Nothing -> parse ss env-    NonTerminal r p -> do-      rkref <- readSTRef $ ruleConts r-      ks    <- readSTRef rkref-      writeSTRef rkref (Cont pure p args scont : ks)-      ns    <- unResults $ ruleNulls r-      let addNullState-            | null ns = id-            | otherwise = (:)-                        $ State p (\f -> Results (pure $ map f ns) >>= args) pos scont-      if null ks then do -- The rule has not been expanded at this position.-        st' <- State (ruleProd r) pure Current <$> newConts rkref-        parse (addNullState $ st' : ss)-              env {reset = resetConts r >> reset env}-      else -- The rule has already been expanded at this position.-        parse (addNullState ss) env-    Pure a-      -- Skip following continuations that stem from the current position; such-      -- continuations are handled separately.-      | pos == Current -> parse ss env-      | otherwise -> do-        let argsRef = contsArgs scont-        masref  <- readSTRef argsRef-        case masref of-          Just asref -> do -- The continuation has already been followed at this position.-            modifySTRef asref $ mappend $ args a-            parse ss env-          Nothing    -> do -- It hasn't.-            asref <- newSTRef $ args a-            writeSTRef argsRef $ Just asref-            ks  <- simplifyCont scont-            res <- lazyResults $ join $ unResults <$> readSTRef asref-            let kstates = map (contToState pos res) ks-            parse (kstates ++ ss)-                  env {reset = writeSTRef argsRef Nothing >> reset env}-    Alts as (Pure f) -> do-      let args' = args . f-          sts   = [State a args' pos scont | a <- as]-      parse (sts ++ ss) env-    Alts as p -> do-      scont' <- newConts =<< newSTRef [Cont pure p args scont]-      let sts = [State a pure Previous scont' | a <- as]-      parse (sts ++ ss) env-    Many p q -> mdo-      r <- mkRule $ pure [] <|> (:) <$> p <*> NonTerminal r (Pure id)-      parse (State (NonTerminal r q) args pos scont : ss) env-    Named pr' n -> parse (State pr' args pos scont : ss)-                         env {names = n : names env}--{-# INLINE parser #-}--- | Create a parser from the given grammar.-parser :: ListLike i t-       => (forall r. Grammar r (Prod r e t a))-       -> ST s (i -> ST s (Result s e i a))-parser g = do-  let nt x = NonTerminal x $ pure id-  s <- initialState =<< runGrammar (fmap nt . mkRule) g-  return $ parse [s] . emptyParseEnv---- | Return all parses from the result of a given parser. The result may--- contain partial parses. The 'Int's are the position at which a result was--- produced.-allParses :: (forall s. ST s (i -> ST s (Result s e i a)))-          -> i-          -> ([(a, Int)], Report e i)-allParses p i = runST $ p >>= ($ i) >>= go-  where-    go :: Result s e i a -> ST s ([(a, Int)], Report e i)-    go r = case r of-      Ended rep           -> return ([], rep)-      Parsed mas cpos _ k -> do-        as <- mas-        fmap (first (zip as (repeat cpos) ++)) $ go =<< k--{-# INLINE fullParses #-}--- | Return all parses that reached the end of the input from the result of a---   given parser.-fullParses :: ListLike i t-           => (forall s. ST s (i -> ST s (Result s e i a)))-           -> i-           -> ([a], Report e i)-fullParses p i = runST $ p >>= ($ i) >>= go-  where-    go :: ListLike i t => Result s e i a -> ST s ([a], Report e i)-    go r = case r of-      Ended rep -> return ([], rep)-      Parsed mas _ i' k-        | ListLike.null i' -> do-          as <- mas-          fmap (first (as ++)) $ go =<< k-        | otherwise -> go =<< k--{-# INLINE report #-}--- | See e.g. how far the parser is able to parse the input string before it--- fails.  This can be much faster than getting the parse results for highly--- ambiguous grammars.-report :: ListLike i t-       => (forall s. ST s (i -> ST s (Result s e i a)))-       -> i-       -> Report e i-report p i = runST $ p >>= ($ i) >>= go-  where-    go :: ListLike i t => Result s e i a -> ST s (Report e i)-    go r = case r of-      Ended rep      -> return rep-      Parsed _ _ _ k -> go =<< k

@@ -2,9 +2,10 @@ module Text.Earley.Parser   ( Report(..)   , Result(..)+  , Parser   , parser   , allParses   , fullParses   , report   ) where-import Text.Earley.Internal+import Text.Earley.Parser.Internal

@@ -0,0 +1,361 @@+{-# LANGUAGE CPP, BangPatterns, DeriveFunctor, GADTs, Rank2Types, RecursiveDo #-}+-- | This module exposes the internals of the package: its API may change+-- independently of the PVP-compliant version number.+module Text.Earley.Parser.Internal where+import Control.Applicative+import Control.Arrow+import Control.Monad+import Control.Monad.ST+import Data.ListLike(ListLike)+import qualified Data.ListLike as ListLike+import Data.STRef+import Text.Earley.Grammar+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif++-------------------------------------------------------------------------------+-- * Concrete rules and productions+-------------------------------------------------------------------------------+-- | The concrete rule type that the parser uses+data Rule s r e t a = Rule+  { ruleProd  :: ProdR s r e t a+  , ruleConts :: !(STRef s (STRef s [Cont s r e t a r]))+  , ruleNulls :: !(Results s a)+  }++mkRule :: ProdR s r e t a -> ST s (Rule s r e t a)+mkRule p = mdo+  c <- newSTRef =<< newSTRef mempty+  computeNullsRef <- newSTRef $ do+    writeSTRef computeNullsRef $ return []+    ns <- unResults $ prodNulls p+    writeSTRef computeNullsRef $ return ns+    return ns+  return $ Rule (removeNulls p) c (Results $ join $ readSTRef computeNullsRef)++prodNulls :: ProdR s r e t a -> Results s a+prodNulls prod = case prod of+  Terminal {}     -> empty+  NonTerminal r p -> ruleNulls r <**> prodNulls p+  Pure a          -> pure a+  Alts as p       -> mconcat (map prodNulls as) <**> prodNulls p+  Many a p        -> prodNulls (pure [] <|> pure <$> a) <**> prodNulls p+  Named p _       -> prodNulls p++-- | Remove (some) nulls from a production+removeNulls :: ProdR s r e t a -> ProdR s r e t a+removeNulls prod = case prod of+  Terminal {}      -> prod+  NonTerminal {}   -> prod+  Pure _           -> empty+  Alts as (Pure f) -> alts (map removeNulls as) $ Pure f+  Alts {}          -> prod+  Many {}          -> prod+  Named p n        -> Named (removeNulls p) n++type ProdR s r e t a = Prod (Rule s r) e t a++resetConts :: Rule s r e t a -> ST s ()+resetConts r = writeSTRef (ruleConts r) =<< newSTRef mempty++-------------------------------------------------------------------------------+-- * Delayed results+-------------------------------------------------------------------------------+newtype Results s a = Results { unResults :: ST s [a] }+  deriving Functor++lazyResults :: ST s [a] -> ST s (Results s a)+lazyResults stas = mdo+  resultsRef <- newSTRef $ do+    as <- stas+    writeSTRef resultsRef $ return as+    return as+  return $ Results $ join $ readSTRef resultsRef++instance Applicative (Results s) where+  pure  = return+  (<*>) = ap++instance Alternative (Results s) where+  empty = Results $ pure []+  Results sxs <|> Results sys = Results $ (<|>) <$> sxs <*> sys++instance Monad (Results s) where+  return = Results . pure . pure+  Results stxs >>= f = Results $ do+    xs <- stxs+    concat <$> mapM (unResults . f) xs++instance Monoid (Results s a) where+  mempty = empty+  mappend = (<|>)++-------------------------------------------------------------------------------+-- * States and continuations+-------------------------------------------------------------------------------+data BirthPos+  = Previous+  | Current+  deriving Eq++-- | An Earley state with result type @a@.+data State s r e t a where+  State :: !(ProdR s r e t a)+        -> !(a -> Results s b)+        -> !BirthPos+        -> !(Conts s r e t b c)+        -> State s r e t c+  Final :: !(Results s a) -> State s r e t a++-- | A continuation accepting an @a@ and producing a @b@.+data Cont s r e t a b where+  Cont      :: !(a -> Results s b)+            -> !(ProdR s r e t (b -> c))+            -> !(c -> Results s d)+            -> !(Conts s r e t d e')+            -> Cont s r e t a e'+  FinalCont :: (a -> Results s c) -> Cont s r e t a c++data Conts s r e t a c = Conts+  { conts     :: !(STRef s [Cont s r e t a c])+  , contsArgs :: !(STRef s (Maybe (STRef s (Results s a))))+  }++newConts :: STRef s [Cont s r e t a c] -> ST s (Conts s r e t a c)+newConts r = Conts r <$> newSTRef Nothing++contraMapCont :: (b -> Results s a) -> Cont s r e t a c -> Cont s r e t b c+contraMapCont f (Cont g p args cs) = Cont (f >=> g) p args cs+contraMapCont f (FinalCont args)   = FinalCont (f >=> args)++contToState :: BirthPos -> Results s a -> Cont s r e t a c -> State s r e t c+contToState pos r (Cont g p args cs) = State p (\f -> fmap f (r >>= g) >>= args) pos cs+contToState _   r (FinalCont args)   = Final $ r >>= args++-- | Strings of non-ambiguous continuations can be optimised by removing+-- indirections.+simplifyCont :: Conts s r e t b a -> ST s [Cont s r e t b a]+simplifyCont Conts {conts = cont} = readSTRef cont >>= go False+  where+    go !_ [Cont g (Pure f) args cont'] = do+      ks' <- simplifyCont cont'+      go True $ map (contraMapCont $ \b -> fmap f (g b) >>= args) ks'+    go True ks = do+      writeSTRef cont ks+      return ks+    go False ks = return ks++-------------------------------------------------------------------------------+-- * Grammars+-------------------------------------------------------------------------------+-- | Given a grammar, construct an initial state.+initialState :: ProdR s a e t a -> ST s (State s a e t a)+initialState p = State p pure Previous <$> (newConts =<< newSTRef [FinalCont pure])++-------------------------------------------------------------------------------+-- * Parsing+-------------------------------------------------------------------------------+-- | A parsing report, which contains fields that are useful for presenting+-- errors to the user if a parse is deemed a failure.  Note however that we get+-- a report even when we successfully parse something.+data Report e i = Report+  { position   :: Int -- ^ The final position in the input (0-based) that the+                      -- parser reached.+  , expected   :: [e] -- ^ The named productions processed at the final+                      -- position.+  , unconsumed :: i   -- ^ The part of the input string that was not consumed,+                      -- which may be empty.+  } deriving (Eq, Ord, Read, Show)++-- | The result of a parse.+data Result s e i a+  = Ended (Report e i)+    -- ^ The parser ended.+  | Parsed (ST s [a]) Int i (ST s (Result s e i a))+    -- ^ The parser parsed a number of @a@s.  These are given as a computation,+    -- @'ST' s [a]@ that constructs the 'a's when run.  We can thus save some+    -- work by ignoring this computation if we do not care about the results.+    -- The 'Int' is the position in the input where these results were+    -- obtained, the @i@ the rest of the input, and the last component is the+    -- continuation.+  deriving Functor++{-# INLINE safeHead #-}+safeHead :: ListLike i t => i -> Maybe t+safeHead ts+  | ListLike.null ts = Nothing+  | otherwise        = Just $ ListLike.head ts++data ParseEnv s e i t a = ParseEnv+  { results :: ![ST s [a]]+    -- ^ Results ready to be reported (when this position has been processed)+  , next    :: ![State s a e t a]+    -- ^ States to process at the next position+  , reset   :: !(ST s ())+    -- ^ Computation that resets the continuation refs of productions+  , names   :: ![e]+    -- ^ Named productions encountered at this position+  , curPos  :: !Int+    -- ^ The current position in the input string+  , input   :: !i+    -- ^ The input string+  }++{-# INLINE emptyParseEnv #-}+emptyParseEnv :: i -> ParseEnv s e i t a+emptyParseEnv i = ParseEnv+  { results = mempty+  , next    = mempty+  , reset   = return ()+  , names   = mempty+  , curPos  = 0+  , input   = i+  }++{-# SPECIALISE parse :: [State s a e t a]+                     -> ParseEnv s e [t] t a+                     -> ST s (Result s e [t] a) #-}+-- | The internal parsing routine+parse :: ListLike i t+      => [State s a e t a] -- ^ States to process at this position+      -> ParseEnv s e i t a+      -> ST s (Result s e i a)+parse [] env@ParseEnv {results = [], next = []} = do+  reset env+  return $ Ended Report+    { position   = curPos env+    , expected   = names env+    , unconsumed = input env+    }+parse [] env@ParseEnv {results = []} = do+  reset env+  parse (next env)+        (emptyParseEnv $ ListLike.tail $ input env) {curPos = curPos env + 1}+parse [] env = do+  reset env+  return $ Parsed (concat <$> sequence (results env)) (curPos env) (input env)+         $ parse [] env {results = [], reset = return ()}+parse (st:ss) env = case st of+  Final res -> parse ss env {results = unResults res : results env}+  State pr args pos scont -> case pr of+    Terminal f p -> case safeHead (input env) >>= f of+      Just a -> parse ss env {next = State p (args . ($ a)) Previous scont+                                   : next env}+      Nothing -> parse ss env+    NonTerminal r p -> do+      rkref <- readSTRef $ ruleConts r+      ks    <- readSTRef rkref+      writeSTRef rkref (Cont pure p args scont : ks)+      ns    <- unResults $ ruleNulls r+      let addNullState+            | null ns = id+            | otherwise = (:)+                        $ State p (\f -> Results (pure $ map f ns) >>= args) pos scont+      if null ks then do -- The rule has not been expanded at this position.+        st' <- State (ruleProd r) pure Current <$> newConts rkref+        parse (addNullState $ st' : ss)+              env {reset = resetConts r >> reset env}+      else -- The rule has already been expanded at this position.+        parse (addNullState ss) env+    Pure a+      -- Skip following continuations that stem from the current position; such+      -- continuations are handled separately.+      | pos == Current -> parse ss env+      | otherwise -> do+        let argsRef = contsArgs scont+        masref  <- readSTRef argsRef+        case masref of+          Just asref -> do -- The continuation has already been followed at this position.+            modifySTRef asref $ mappend $ args a+            parse ss env+          Nothing    -> do -- It hasn't.+            asref <- newSTRef $ args a+            writeSTRef argsRef $ Just asref+            ks  <- simplifyCont scont+            res <- lazyResults $ join $ unResults <$> readSTRef asref+            let kstates = map (contToState pos res) ks+            parse (kstates ++ ss)+                  env {reset = writeSTRef argsRef Nothing >> reset env}+    Alts as (Pure f) -> do+      let args' = args . f+          sts   = [State a args' pos scont | a <- as]+      parse (sts ++ ss) env+    Alts as p -> do+      scont' <- newConts =<< newSTRef [Cont pure p args scont]+      let sts = [State a pure Previous scont' | a <- as]+      parse (sts ++ ss) env+    Many p q -> mdo+      r <- mkRule $ pure [] <|> (:) <$> p <*> NonTerminal r (Pure id)+      parse (State (NonTerminal r q) args pos scont : ss) env+    Named pr' n -> parse (State pr' args pos scont : ss)+                         env {names = n : names env}++type Parser e i a = forall s. i -> ST s (Result s e i a)++{-# INLINE parser #-}+-- | Create a parser from the given grammar.+parser+  :: ListLike i t+  => (forall r. Grammar r (Prod r e t a))+  -> Parser e i a+parser g i = do+  let nt x = NonTerminal x $ pure id+  s <- initialState =<< runGrammar (fmap nt . mkRule) g+  parse [s] $ emptyParseEnv i++-- | Return all parses from the result of a given parser. The result may+-- contain partial parses. The 'Int's are the position at which a result was+-- produced.+--+-- The elements of the returned list of results are sorted by their position in+-- ascending order.  If there are multiple results at the same position they+-- are returned in an unspecified order.+allParses+  :: Parser e i a+  -> i+  -> ([(a, Int)], Report e i)+allParses p i = runST $ p i >>= go+  where+    go :: Result s e i a -> ST s ([(a, Int)], Report e i)+    go r = case r of+      Ended rep           -> return ([], rep)+      Parsed mas cpos _ k -> do+        as <- mas+        fmap (first (zip as (repeat cpos) ++)) $ go =<< k++{-# INLINE fullParses #-}+-- | Return all parses that reached the end of the input from the result of a+-- given parser.+--+-- If there are multiple results they are returned in an unspecified order.+fullParses+  :: ListLike i t+  => Parser e i a+  -> i+  -> ([a], Report e i)+fullParses p i = runST $ p i >>= go+  where+    go :: ListLike i t => Result s e i a -> ST s ([a], Report e i)+    go r = case r of+      Ended rep -> return ([], rep)+      Parsed mas _ i' k+        | ListLike.null i' -> do+          as <- mas+          fmap (first (as ++)) $ go =<< k+        | otherwise -> go =<< k++{-# INLINE report #-}+-- | See e.g. how far the parser is able to parse the input string before it+-- fails.  This can be much faster than getting the parse results for highly+-- ambiguous grammars.+report+  :: Parser e i a+  -> i+  -> Report e i+report p i = runST $ p i >>= go+  where+    go :: Result s e i a -> ST s (Report e i)+    go r = case r of+      Ended rep      -> return rep+      Parsed _ _ _ k -> go =<< k

@@ -16,13 +16,13 @@    whitespace <- rule $ many $ satisfy isSpace -  let token :: Prod r String Char a -> Prod r String Char a-      token p = whitespace *> p+  let tok :: Prod r String Char a -> Prod r String Char a+      tok p   = whitespace *> p -      sym x   = token $ token x <?> [x]+      sym x   = tok $ token x <?> [x] -      ident   = token $ (:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum) <?> "identifier"-      num     = token $ some (satisfy isDigit) <?> "number"+      ident   = tok $ (:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum) <?> "identifier"+      num     = tok $ some (satisfy isDigit) <?> "number"    expr0 <- rule      $ (Lit . read)  <$> num

@@ -1,5 +1,4 @@ {-# LANGUAGE RecursiveDo #-}-module Testa where import Control.Applicative import Text.Earley 

@@ -0,0 +1,64 @@+{-# LANGUAGE RecursiveDo #-}+module Main where++import Control.Applicative ((<|>), (<**>))+import System.Environment (getArgs)+import Text.Earley++numeral :: String -> Int -> Prod r String Char Int+numeral str n = n <$ list str++romanNumeralsGrammar :: Grammar r (Prod r String Char Int)+romanNumeralsGrammar = mdo++  thousands <- rule+    $ pure 0+    <|> numeral "M" 1000 <**> fmap (+) thousands++  le300 <- rule+    $ pure 0+    <|> numeral "C" 100+    <|> numeral "CC" 200+    <|> numeral "CCC" 300++  hundreds <- rule+    $ le300+    <|> numeral "CD" 400+    <|> numeral "D" 500 <**> fmap (+) le300+    <|> numeral "CM" 900++  le30 <- rule+    $ pure 0+    <|> numeral "X" 10+    <|> numeral "XX" 20+    <|> numeral "XXX" 30++  tens <- rule +    $ le30+    <|> numeral "XL" 40+    <|> numeral "L" 50 <**> fmap (+) le30+    <|> numeral "XC" 90++  le3 <- rule+    $ pure 0+    <|> numeral "I" 1+    <|> numeral "II" 2+    <|> numeral "III" 3++  units <- rule+    $ le3+    <|> numeral "IV" 4+    <|> numeral "V" 5 <**> fmap (+) le3+    <|> numeral "IX" 9++  return+    $ thousands+    <**> fmap (+) hundreds+    <**> fmap (+) tens+    <**> fmap (+) units+++main :: IO ()+main = do+  x:_ <- getArgs+  print $ fullParses (parser romanNumeralsGrammar) x

@@ -0,0 +1,13 @@+{-# LANGUAGE RankNTypes #-}+module Arbitrary where++import qualified Test.QuickCheck as QC++import Text.Earley.Generator++-- | Generate an arbitrary member generated by a 'Generator'.+arbitrary :: Generator t a -> QC.Gen (a, [t])+arbitrary gen = QC.sized $ \n -> QC.elements (take (1 `max` n) xs)+  where+    xs = language gen+

@@ -2,6 +2,7 @@ module Empty where import Control.Applicative import Test.Tasty+import Test.Tasty.HUnit as HU import Test.Tasty.QuickCheck as QC  import Text.Earley@@ -10,16 +11,26 @@ tests = testGroup "Empty productions"   [ QC.testProperty "The empty production doesn't parse anything" $     \(input :: String) ->-      allParses (parser (return empty :: forall r. Grammar r (Prod r () Char ()))) input+      allParses (parser emptyGrammar) input       == (,) [] Report { position   = 0                        , expected   = []                        , unconsumed = input                        }+  , HU.testCase "The empty production doesn't generate anything" $+      language (generator emptyGrammar "abc") @?= []   , QC.testProperty "Many empty productions parse very little" $     \(input :: String) ->-      allParses (parser (return $ many empty <* pure "blah" :: forall r. Grammar r (Prod r () Char [()]))) input+      allParses (parser manyEmpty) input       == (,) [([], 0)] Report { position   = 0                               , expected   = []                               , unconsumed = input                               }+  , HU.testCase "Many empty productions generate very little" $+      language (generator manyEmpty "blahc") @?= [([], "")]   ]++emptyGrammar :: Grammar r (Prod r () Char ())+emptyGrammar = return empty++manyEmpty :: Grammar r (Prod r () Char [()])+manyEmpty = return $ many empty <* pure "blah"

@@ -7,17 +7,45 @@  import Text.Earley +import qualified Arbitrary+ tests :: TestTree tests = testGroup "Expr"-  [ QC.testProperty "Expr: parse . pretty = id" $-    \e -> [e] === parseExpr (prettyExpr 0 e)-  , QC.testProperty "Ambiguous Expr: parse . pretty ≈ id" $-    \e -> e `elem` parseAmbiguousExpr (prettyExpr 0 e)+  [ QC.testProperty "Left-recursive: parse . pretty = id" $+    \e -> [e] === parseLeftExpr (prettyLeftExpr 0 e)+  , QC.testProperty "Left-recursive: parse . pretty = id (generator)" $ do+    (e, s) <- Arbitrary.arbitrary $ generator leftExpr tokens+    return+      $ [e] === parseLeftExpr (prettyLeftExpr 0 e)+      .&&. [e] === parseLeftExpr (unwords s)+  , QC.testProperty "Right-recursive: parse . pretty = id" $+    \e -> [e] === parseRightExpr (prettyRightExpr 0 e)+  , QC.testProperty "Right-recursive: parse . pretty = id (generator)" $ do+    (e, s) <- Arbitrary.arbitrary $ generator rightExpr tokens+    return+      $ [e] === parseRightExpr (prettyRightExpr 0 e)+      .&&. [e] === parseRightExpr (unwords s)+  , QC.testProperty "Ambiguous: parse . pretty ≈ id" $+    \e -> e `elem` parseAmbiguousExpr (prettyLeftExpr 0 e)+      .&&. e `elem` parseAmbiguousExpr (prettyRightExpr 0 e)+      .&&. [e] == parseAmbiguousExpr (prettyAmbiguousExpr e)+  , QC.testProperty "Ambiguous: parse . pretty ≈ id (generator)" $ do+    (e, s) <- Arbitrary.arbitrary $ generator ambiguousExpr tokens+    return $ e `elem` parseAmbiguousExpr (prettyLeftExpr 0 e)+      .&&. e `elem` parseAmbiguousExpr (prettyRightExpr 0 e)+      .&&. [e] == parseAmbiguousExpr (prettyAmbiguousExpr e)+      .&&. e `elem` parseAmbiguousExpr (unwords s)   ] -parseExpr :: String -> [Expr]-parseExpr input = fst (fullParses (parser expr) (lexExpr input)) -- We need to annotate types for point-free version+tokens :: [String]+tokens = pure <$> "abcxyz+*()" +parseLeftExpr :: String -> [Expr]+parseLeftExpr input = fst (fullParses (parser leftExpr) (lexExpr input))++parseRightExpr :: String -> [Expr]+parseRightExpr input = fst (fullParses (parser rightExpr) (lexExpr input))+ parseAmbiguousExpr :: String -> [Expr] parseAmbiguousExpr input = fst (fullParses (parser ambiguousExpr) (lexExpr input)) @@ -34,15 +62,15 @@                                      , Add <$> arbExpr1 <*> arbExpr1                                      , Mul <$> arbExpr1 <*> arbExpr1                                      ]-                                     where arbExpr1 = arbExpr (n `div` 2)+                                     where arbExpr1 = arbExpr (n `div` 3)           arbExpr _          = arbIdent    shrink (Var _)    = []   shrink (Add a b)  = a : b : [ Add a' b | a' <- shrink a ] ++ [ Add a b' | b' <- shrink b ]   shrink (Mul a b)  = a : b : [ Mul a' b | a' <- shrink a ] ++ [ Mul a b' | b' <- shrink b ] -expr :: Grammar r (Prod r String String Expr)-expr = mdo+leftExpr :: Grammar r (Prod r String String Expr)+leftExpr = mdo   x1 <- rule $ Add <$> x1 <* namedToken "+" <*> x2             <|> x2             <?> "sum"@@ -56,6 +84,21 @@     ident (x:_) = isAlpha x     ident _     = False +rightExpr :: Grammar r (Prod r String String Expr)+rightExpr = mdo+  x1 <- rule $ Add <$> x2 <* namedToken "+" <*> x1+            <|> x2+            <?> "sum"+  x2 <- rule $ Mul <$> x3 <* namedToken "*" <*> x2+            <|> x3+            <?> "product"+  x3 <- rule $ Var <$> (satisfy ident <?> "identifier")+            <|> namedToken "(" *> x1 <* namedToken ")"+  return x1+  where+    ident (x:_) = isAlpha x+    ident _     = False+ ambiguousExpr :: Grammar r (Prod r String String Expr) ambiguousExpr = mdo   x1 <- rule $ Add <$> x1 <* namedToken "+" <*> x1@@ -75,10 +118,20 @@ prettyParens True s  = "(" ++ s ++ ")" prettyParens False s = s -prettyExpr :: Int -> Expr -> String-prettyExpr _ (Var s) = s-prettyExpr d (Add a b) = prettyParens (d > 0) $ prettyExpr 0 a ++ " + " ++ prettyExpr 1 b-prettyExpr d (Mul a b) = prettyParens (d > 1) $ prettyExpr 1 a ++ " * " ++ prettyExpr 2 b+prettyLeftExpr :: Int -> Expr -> String+prettyLeftExpr _ (Var s) = s+prettyLeftExpr d (Add a b) = prettyParens (d > 0) $ prettyLeftExpr 0 a ++ " + " ++ prettyLeftExpr 1 b+prettyLeftExpr d (Mul a b) = prettyParens (d > 1) $ prettyLeftExpr 1 a ++ " * " ++ prettyLeftExpr 2 b++prettyRightExpr :: Int -> Expr -> String+prettyRightExpr _ (Var s) = s+prettyRightExpr d (Add a b) = prettyParens (d > 0) $ prettyRightExpr 1 a ++ " + " ++ prettyRightExpr 0 b+prettyRightExpr d (Mul a b) = prettyParens (d > 1) $ prettyRightExpr 2 a ++ " * " ++ prettyRightExpr 1 b++prettyAmbiguousExpr :: Expr -> String+prettyAmbiguousExpr (Var s) = s+prettyAmbiguousExpr (Add a b) = prettyParens True $ prettyAmbiguousExpr a ++ " + " ++ prettyAmbiguousExpr b+prettyAmbiguousExpr (Mul a b) = prettyParens True $ prettyAmbiguousExpr a ++ " * " ++ prettyAmbiguousExpr b  -- @words@ like lexer, but consider parentheses as separate tokens lexExpr :: String -> [String]

@@ -0,0 +1,18 @@+module Generator where+import Control.Applicative+import Test.Tasty+import Test.Tasty.HUnit as HU++import Text.Earley++tests :: TestTree+tests = testGroup "Lambda"+  [ HU.testCase "Generate exactly 0" $+      exactly 0 (generator (pure $ pure ()) "") @?= [((), [])]+  , HU.testCase "Generate upTo 0" $+      upTo 0 (generator (pure $ pure ()) "") @?= [((), [])]+  , HU.testCase "Generate exactly 1" $+      exactly 1 (generator (pure $ pure ()) "") @?= []+  , HU.testCase "Generate upTo 1" $+      upTo 1 (generator (pure $ pure ()) "") @?= [((), [])]+  ]

@@ -8,9 +8,12 @@  tests :: TestTree tests = testGroup "Inline alternatives"-  [ HU.testCase "They work" $+  [ HU.testCase "They work when parsed" $       let input = "ababbbaaabaa" in       allParses (parser inlineAlts) input @?= allParses (parser nonInlineAlts) input+  , HU.testCase "They work when generated" $+      take 1000 (language $ generator inlineAlts "ab") @?=+      take 1000 (language $ generator nonInlineAlts "ab")   ]  inlineAlts :: Grammar r (Prod r Char Char String)

@@ -11,6 +11,9 @@     \x -> fullParses (parser (issue14 x)) ""     == (,) (replicate (issue14Length x) ())            Report { position = 0, expected = [], unconsumed = [] }+  , QC.testProperty "The same rule in alternatives generates many results" $+    \x -> language (generator (issue14 x) "")+    == replicate (issue14Length x) ((), "")   ]  data Issue14 a@@ -46,4 +49,3 @@     go x (Pure ())   = x     go x (Alt b1 b2) = go x b1 <|> go x b2     go x (Ap b1 b2)  = go x b1 <* go x b2-

@@ -0,0 +1,111 @@+{-# LANGUAGE RecursiveDo #-}+module Lambda where+import Control.Applicative+import Data.List as List+import Data.Foldable+import Test.Tasty+import Test.Tasty.HUnit as HU+import Test.Tasty.QuickCheck as QC++import Text.Earley++import qualified Arbitrary++tests :: TestTree+tests = testGroup "Lambda"+  [ HU.testCase "Generate exactly 0" $+      exactly 0 gen @?= []+  , HU.testCase "Generate upTo 0" $+      upTo 0 gen @?= []+  , HU.testCase "Generate exactly 4" $+      sort (snd <$> exactly 4 gen)+      @?=+      ["(a)a","(a)b","(aa)","(ab)","(b)a","(b)b","(ba)","(bb)"+      ,"\\a.a","\\a.b","\\b.a","\\b.b","a(a)","a(b)","a+aa","a+ab"+      ,"a+ba","a+bb","aa+a","aa+b","aaaa","aaab","aaba","aabb"+      ,"ab+a","ab+b","abaa","abab","abba","abbb","b(a)","b(b)"+      ,"b+aa","b+ab","b+ba","b+bb","ba+a","ba+b","baaa","baab"+      ,"baba","babb","bb+a","bb+b","bbaa","bbab","bbba","bbbb"+      ]+  , HU.testCase "upTo contains exactly" $ List.and (do+      m <- [0..5]+      let ys = snd <$> upTo m gen+      n <- [0..m]+      (_, x) <- upTo n gen+      return $ x `List.elem` ys)+    @? "exactly contains upTo"+  , HU.testCase "language contains upTo" $ do+    let ys = snd <$> language gen+    List.and (do+      n <- [0..5]+      (_, x) <- upTo n gen+      return $ x `List.elem` ys)+    @? "exactly contains upTo"+  , QC.testProperty "Arbitrary" $ do+    let p = parser grammar+    (e, s) <- Arbitrary.arbitrary $ generator grammar tokens+    return+      $ [e] === fst (fullParses p $ prettyExpr 0 e)+      .&&. [e] === fst (fullParses p s)+  ]+  where+    gen = generator grammar tokens++data Expr+  = Var Char+  | Lam String Expr+  | App Expr Expr+  | Add Expr Expr+  deriving (Eq, Ord, Show)++prettyExpr :: Int -> Expr -> String+prettyExpr _ (Var c) = [c]+prettyExpr d (Lam xs e) = prettyParens (d > 0) $ "\\" ++ xs ++ "." ++ prettyExpr d e+prettyExpr d (Add a b) = prettyParens (d > 1) $ prettyExpr 2 a ++ "+" ++ prettyExpr 1 b+prettyExpr d (App a b) = prettyParens (d > 3) $ prettyExpr 3 a ++ prettyExpr 4 b++prettyParens :: Bool -> String -> String+prettyParens True s  = "(" ++ s ++ ")"+prettyParens False s = s++tokens :: String+tokens = "(\\ab.+*)"++instance Arbitrary Expr where+  arbitrary = sized go+    where+      var = elements "ab"+      go 0 = Var <$> var+      go n = oneof+        [ Var <$> var+        , Lam <$> (take 2 <$> listOf1 var) <*> go'+        , App <$> go' <*> go'+        , Add <$> go' <*> go'+        ]+        where+          go' = go (n `div` 10)++  shrink (Var _) = []+  shrink (Lam xs e) = e : [Lam xs' e' | xs' <- shrink xs, not (null xs), e' <- shrink e]+  shrink (App a b) = a : b : [App a' b' | a' <- shrink a, b' <- shrink b]+  shrink (Add a b) = a : b : [Add a' b' | a' <- shrink a, b' <- shrink b]++grammar :: Grammar r (Prod r String Char Expr)+grammar = mdo+  let v = asum (token <$> "ab")+        <?> "variable"+  x1 <- rule+    $ Lam <$ token '\\' <*> some v <* token '.' <*> x1+    <|> x2+    <?> "lambda"+  x2 <- rule+    $ Add <$> x3 <* token '+' <*> x2+    <|> x3+    <?> "sum"+  x3 <- rule+    $ App <$> x3 <*> x4+    <|> x4+    <?> "application"+  let x4 = Var <$> v+        <|> token '(' *> x1 <* token ')'+  return x1

@@ -3,9 +3,11 @@  import qualified Empty import qualified Expr+import qualified Generator import qualified InlineAlts import qualified Issue11 import qualified Issue14+import qualified Lambda import qualified Mixfix import qualified Optional import qualified ReversedWords@@ -15,9 +17,11 @@ main = defaultMain $ testGroup "Tests"   [ Empty.tests   , Expr.tests+  , Generator.tests   , InlineAlts.tests   , Issue11.tests   , Issue14.tests+  , Lambda.tests   , Mixfix.tests   , Optional.tests   , ReversedWords.tests

@@ -32,6 +32,18 @@   , HU.testCase "Using rules without continuation Just" $       fullParses (parser $ rule $ optional $ namedToken 'a') "a"       @?= (,) [Just 'a'] Report {position = 1, expected = "", unconsumed = ""}+  , HU.testCase "Generate optional" $+      language (generator (return optional_) "ab")+      @?= [((Nothing, 'b'), "b"), ((Just 'a', 'b'), "ab")]+  , HU.testCase "Generate optional using rules" $+      language (generator optionalRule "ab")+      @?= [((Nothing, 'b'), "b"), ((Just 'a', 'b'), "ab")]+  , HU.testCase "Generate optional without continuation" $+      language (generator (return $ optional $ namedToken 'a') "ab")+      @?= [(Nothing, ""), (Just 'a', "a")]+  , HU.testCase "Generate optional using rules without continuation" $+      language (generator (rule $ optional $ namedToken 'a') "ab")+      @?= [(Nothing, ""), (Just 'a', "a")]   ]  optional_ :: Prod r Char Char (Maybe Char, Char)

@@ -9,8 +9,8 @@ someWords = return $ flip (:) <$> (map reverse <$> some (list "word")) <*> list "stop"  tests :: TestTree-tests = testGroup "Unit Tests"-  [ HU.testCase "Some reversed words" $+tests = testGroup "Reversed words"+  [ HU.testCase "Parse" $       let input = "wordwordstop"           l     = length input in       allParses (parser someWords) input@@ -18,4 +18,11 @@                                                      , expected   = []                                                      , unconsumed = []                                                      }+  , HU.testCase "Generate" $+    upTo 16 (generator someWords "stopwrd")+    @?=+    [ (["stop", "drow"], "wordstop")+    , (["stop", "drow", "drow"], "wordwordstop")+    , (["stop","drow","drow","drow"],"wordwordwordstop")+    ]   ]

@@ -13,6 +13,13 @@   , HU.testCase "Gives the correct report" $       report (parser veryAmbiguous) (replicate 3 'b') @?=       Report {position = 3, expected = "s", unconsumed = ""}+  , HU.testCase "Parser agrees with generator" $ and (do+      n <- [0..8]+      let str = replicate n 'b'+          numParses = length (fst $ fullParses (parser veryAmbiguous) str)+          numGens = length $ exactly n $ generator veryAmbiguous "b"+      return $ numParses == numGens)+    @? "Parser agrees with generator"   ]  veryAmbiguous :: Grammar r (Prod r Char Char ())