Earley 0.9.0 → 0.10.0

raw patch · 13 files changed

+238/−218 lines, 13 filesdep ~basenew-component:exe:earley-infinitePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Earley.cabal +17/−1
• Text/Earley/Grammar.hs +21/−21
• Text/Earley/Internal.hs +92/−130
• Text/Earley/Mixfix.hs +29/−6
• bench/BenchAll.hs +5/−5
• examples/English.hs +7/−7
• examples/Expr.hs +2/−2
• examples/Expr2.hs +2/−2
• examples/Infinite.hs +19/−0
• examples/Mixfix.hs +2/−2
• examples/VeryAmbiguous.hs +2/−2
• examples/Words.hs +2/−2
• tests/Tests.hs +38/−38

@@ -1,5 +1,5 @@ name:                Earley-version:             0.9.0+version:             0.10.0 synopsis:            Parsing all context-free grammars using Earley's algorithm. description:         See <https://www.github.com/ollef/Earley> for more                      information and@@ -13,6 +13,13 @@ category:            Parsing build-type:          Simple cabal-version:       >=1.10+tested-with:+                     GHC == 7.8.1,+                     GHC == 7.8.2,+                     GHC == 7.8.3,+                     GHC == 7.8.4,+                     GHC == 7.10.1,+                     GHC == 7.10.2  Flag Examples   Description: "Build examples"@@ -86,6 +93,15 @@   if !flag(examples)     buildable:         False   main-is:             Words.hs+  ghc-options:         -Wall+  hs-source-dirs:      examples+  default-language:    Haskell2010+  build-depends:       base, Earley++executable earley-infinite+  if !flag(examples)+    buildable:         False+  main-is:             Infinite.hs   ghc-options:         -Wall   hs-source-dirs:      examples   default-language:    Haskell2010

@@ -6,6 +6,7 @@   , (<?>)   , Grammar(..)   , rule+  , alts   ) where import Control.Applicative import Control.Monad@@ -71,32 +72,33 @@   fmap f (Many p q)        = Many p $ fmap (f .) q   fmap f (Named p n)       = Named (fmap f p) n -alts :: [Prod r e t a] -> Prod r e t a-alts as = Alts (as >>= go) $ pure id+-- | Smart constructor for alternatives.+alts :: [Prod r e t a] -> Prod r e t (a -> b) -> Prod r e t b+alts as p = case as >>= go of+  []  -> empty+  [a] -> a <**> p+  as' -> Alts as' p   where+    go (Alts [] _)         = []     go (Alts as' (Pure f)) = fmap f <$> as'+    go (Named p' n)        = map (<?> n) $ go p'     go a                   = [a] -alts' :: [Prod r e t a] -> Prod r e t (a -> b) -> Prod r e t b-alts' [] _        = Alts [] $ pure id-alts' as (Pure f) = alts $ fmap f <$> as-alts' as p        = Alts as p- instance Applicative (Prod r e t) where   pure = Pure   {-# INLINE (<*>) #-}   Terminal b p    <*> q = Terminal b $ flip <$> p <*> q   NonTerminal r p <*> q = NonTerminal r $ flip <$> p <*> q   Pure f          <*> q = fmap f q-  Alts as p       <*> q = alts' as $ flip <$> p <*> q+  Alts as p       <*> q = alts as $ flip <$> p <*> q   Many a p        <*> q = Many a $ flip <$> p <*> q   Named p n       <*> q = Named (p <*> q) n  instance Alternative (Prod r e t) where-  empty = alts []+  empty = Alts [] $ pure id   Named p m <|> q         = Named (p <|> q) m   p         <|> Named q n = Named (p <|> q) n-  p         <|> q         = alts [p, q]+  p         <|> q         = alts [p, q] $ pure id   many (Alts [] _) = pure []   many p           = Many p $ Pure id   some p           = (:) <$> p <*> many p@@ -107,8 +109,6 @@ -- -- @a@: The return type of the grammar (often a 'Prod'). ----- @e@: The type of names, used for example to report expected tokens.--- -- @r@: The type of a non-terminal. This plays a role similar to the @s@ in the --      type @ST s a@.  Since the 'parser' function expects the @r@ to be --      universally quantified, there is not much to do with this parameter@@ -118,29 +118,29 @@ -- e.g.  'Monad' and 'MonadFix'. Note that GHC has syntactic sugar for -- 'MonadFix': use @{-\# LANGUAGE RecursiveDo \#-}@ and @mdo@ instead of -- @do@.-data Grammar r e a where-  RuleBind :: Prod r e t a -> (Prod r e t a -> Grammar r e b) -> Grammar r e b-  FixBind  :: (a -> Grammar r e a) -> (a -> Grammar r e b) -> Grammar r e b-  Return   :: a -> Grammar r e a+data Grammar r a where+  RuleBind :: Prod r e t a -> (Prod r e t a -> Grammar r b) -> Grammar r b+  FixBind  :: (a -> Grammar r a) -> (a -> Grammar r b) -> Grammar r b+  Return   :: a -> Grammar r a -instance Functor (Grammar r e) where+instance Functor (Grammar r) where   fmap f (RuleBind ps h) = RuleBind ps (fmap f . h)   fmap f (FixBind g h)   = FixBind g (fmap f . h)   fmap f (Return x)      = Return $ f x -instance Applicative (Grammar r e) where+instance Applicative (Grammar r) where   pure  = return   (<*>) = ap -instance Monad (Grammar r e) where+instance Monad (Grammar r) where   return = Return   RuleBind ps f >>= k = RuleBind ps (f >=> k)   FixBind f g   >>= k = FixBind f (g >=> k)   Return x      >>= k = k x -instance MonadFix (Grammar r e) where+instance MonadFix (Grammar r) where   mfix f = FixBind f return  -- | Create a new non-terminal by giving its production.-rule :: Prod r e t a -> Grammar r e (Prod r e t a)+rule :: Prod r e t a -> Grammar r (Prod r e t a) rule p = RuleBind p return

@@ -1,10 +1,11 @@-{-# LANGUAGE CPP, BangPatterns, DeriveFunctor, GADTs, Rank2Types #-}--- | This module exposes the internals of the package: its API may change independently of the PVP-compliant version number.+{-# 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.Fix+import Control.Monad import Control.Monad.ST import Data.ListLike(ListLike) import qualified Data.ListLike as ListLike@@ -19,115 +20,79 @@ ------------------------------------------------------------------------------- -- | The concrete rule type that the parser uses data Rule s r e t a = Rule-  { ruleProd     :: ProdR s r e t a-  , ruleNullable :: !(STRef s (Maybe [a]))-  , ruleConts    :: !(STRef s (STRef s [Cont s r e t a r]))+  { ruleProd  :: ProdR s r e t a+  , ruleConts :: !(STRef s (STRef s [Cont s r e t a r]))   }  type ProdR s r e t a = Prod (Rule s r) e t a -nullable :: Rule s r e t a -> ST s [a]-nullable r = do-  mn <- readSTRef $ ruleNullable r-  case mn of-    Just xs -> return xs-    Nothing -> do-      writeSTRef (ruleNullable r) $ Just mempty-      res <- nullableProd $ ruleProd r-      writeSTRef (ruleNullable r) $ Just res-      return res--nullableProd :: ProdR s r e t a -> ST s [a]-nullableProd (Terminal _ _)    = return mempty-nullableProd (NonTerminal r p) = do-  as <- nullable r-  concat <$> mapM (\a -> nullableProd $ fmap ($ a) p) as-nullableProd (Pure a)          = return [a]-nullableProd (Alts as p)       = (\ass fs -> fs <*> concat ass)-                              <$> mapM nullableProd as <*> nullableProd p-nullableProd (Many p q)        = do-  as <- nullableProd $ (:[]) <$> p <|> pure []-  concat <$> mapM (\a -> nullableProd $ fmap ($ a) q) as-nullableProd (Named p _)       = nullableProd p- resetConts :: Rule s r e t a -> ST s ()-resetConts r = writeSTRef (ruleConts r) =<< newSTRef []---- | If we have something of type @f@, @'Args' s f a@ is what we need to do to--- @f@ to produce @a@s.-type Args s f a = f -> ST s [a]--noArgs :: Args s a a-noArgs = return . pure--funArg :: (f -> a) -> Args s f a-funArg f = mapArgs f noArgs--pureArg :: x -> Args s f a -> Args s (x -> f) a-pureArg x args = args . ($ x)+resetConts r = writeSTRef (ruleConts r) =<< newSTRef mempty -pureArgs :: [x] -> Args s f a -> Args s (x -> f) a-pureArgs xs args f = concat <$> mapM (args . f) xs+-------------------------------------------------------------------------------+-- * Delayed results+-------------------------------------------------------------------------------+newtype Results s a = Results { unResults :: ST s [a] }+  deriving Functor -impureArgs :: ST s [x] -> Args s f a -> Args s (x -> f) a-impureArgs mxs args f = fmap concat . mapM (args . f) =<< mxs+instance Applicative (Results s) where+  pure  = return+  (<*>) = ap -mapArgs :: (a -> b) -> Args s f a -> Args s f b-mapArgs = fmap . fmap . fmap+instance Monad (Results s) where+  return = Results . pure . pure+  Results stxs >>= f = Results $ do+    xs <- stxs+    concat <$> mapM (unResults . f) xs -composeArgs :: Args s a b -> Args s b c -> Args s a c-composeArgs ab bc a = fmap concat . mapM bc =<< ab a+instance Monoid (Results s a) where+  mempty = Results $ pure []+  mappend (Results sxs) (Results sys) = Results $ (++) <$> sxs <*> sys  ------------------------------------------------------------------------------- -- * States and continuations --------------------------------------------------------------------------------type Pos = Int- -- | An Earley state with result type @a@. data State s r e t a where-  State :: !Pos-        -> !(ProdR s r e t f)-        -> !(Args s f b)-        -> !(Conts s r e t b a)-        -> State s r e t a-  Final :: f -> Args s f a -> State s r e t a+  State :: !(ProdR s r e t a)+        -> !(a -> Results s b)+        -> !(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      :: !Pos-            -> !(Args s a b)+  Cont      :: !(a -> Results s b)             -> !(ProdR s r e t (b -> c))-            -> !(Args s c d)+            -> !(c -> Results s d)             -> !(Conts s r e t d e')             -> Cont s r e t a e'-  FinalCont :: Args s a c -> Cont s r e t a c+  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 (ST s [a]))))+  , 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 :: Args s b a -> Cont s r e t a c -> Cont s r e t b c-contraMapCont f (Cont cpos g p args cs) = Cont cpos (composeArgs f g) p args cs-contraMapCont f (FinalCont args)       = FinalCont (composeArgs f args)+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 :: ST s [a] -> Cont s r e t a c -> State s r e t c-contToState r (Cont cpos g p args cs) = -  let mb = fmap concat . mapM g =<< r in-  State cpos p (impureArgs mb args) cs-contToState r (FinalCont args)       = Final id (impureArgs r args)+contToState :: Results s a -> Cont s r e t a c -> State s r e t c+contToState r (Cont g p args cs) = State p (\f -> fmap f (r >>= g) >>= args) cs+contToState r (FinalCont args)   = Final $ r >>= args  -- | Strings of non-ambiguous continuations can be optimised by removing---   indirections.+-- 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+    go !_ [Cont g (Pure f) args cont'] = do       ks' <- simplifyCont cont'-      go True $ map (contraMapCont $ mapArgs f g `composeArgs` args) ks'+      go True $ map (contraMapCont $ \b -> fmap f (g b) >>= args) ks'     go True ks = do       writeSTRef cont ks       return ks@@ -136,13 +101,17 @@ ------------------------------------------------------------------------------- -- * Grammars -------------------------------------------------------------------------------+mkRule :: ProdR s r e t a -> ST s (Rule s r e t a)+mkRule p = do+  c  <- newSTRef =<< newSTRef mempty+  return $ Rule p c+ -- | Interpret an abstract 'Grammar'.-grammar :: Grammar (Rule s r) e a -> ST s a+grammar :: Grammar (Rule s r) a -> ST s a grammar g = case g of   RuleBind p k -> do-    c  <- newSTRef =<< newSTRef mempty-    nr <- newSTRef Nothing-    grammar $ k $ NonTerminal (Rule p nr c) $ Pure id+    r <- mkRule p+    grammar $ k $ NonTerminal r $ Pure id   FixBind f k   -> do     a <- mfix $ fmap grammar f     grammar $ k a@@ -150,7 +119,7 @@  -- | 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 (-1) p noArgs <$> (newConts =<< newSTRef [FinalCont noArgs])+initialState p = State p pure <$> (newConts =<< newSTRef [FinalCont pure])  ------------------------------------------------------------------------------- -- * Parsing@@ -186,12 +155,6 @@   | ListLike.null ts = Nothing   | otherwise        = Just $ ListLike.head ts -{-# INLINE safeTail #-}-safeTail :: ListLike i t => i -> i-safeTail ts-  | ListLike.null ts = ts-  | otherwise        = ListLike.tail ts- data ParseEnv s e i t a = ParseEnv   { results :: ![ST s [a]]     -- ^ Results ready to be reported (when this position has been processed)@@ -201,7 +164,7 @@     -- ^ Computation that resets the continuation refs of productions   , names :: ![e]     -- ^ Named productions encountered at this position-  , pos   :: !Pos+  , pos   :: !Int     -- ^ The current position in the input string   , input :: !i     -- ^ The input string@@ -235,83 +198,76 @@     } parse [] env@ParseEnv {results = []} = do   reset env-  parse (next env) (emptyParseEnv $ safeTail $ input env) {pos = pos env + 1}+  parse (next env) (emptyParseEnv $ ListLike.tail $ input env) {pos = pos env + 1} parse [] env = do   reset env   return $ Parsed (concat <$> sequence (results env)) (pos env) (input env)          $ parse [] env {results = [], reset = return ()} parse (st:ss) env = case st of-  Final f args -> parse ss env {results = args f : results env}-  State spos pr args scont -> case pr of+  Final res -> parse ss env {results = unResults res : results env}+  State pr args scont -> case pr of     Terminal f p -> case safeHead $ input env of-      Just t | f t -> parse ss env {next = State spos p (pureArg t args) scont+      Just t | f t -> parse ss env {next = State p (args . ($ t)) scont                                          : next env}       _            -> parse ss env     NonTerminal r p -> do       rkref <- readSTRef $ ruleConts r       ks    <- readSTRef rkref-      writeSTRef rkref (Cont spos noArgs p args scont : ks)-      nulls <- nullable r-      let nullStates | null nulls = mempty-                     | otherwise  = pure $ State spos p (pureArgs nulls args) scont+      writeSTRef rkref (Cont pure p args scont : ks)       if null ks then do -- The rule has not been expanded at this position.-        st' <- State (pos env) (ruleProd r) noArgs <$> newConts rkref-        parse (st' : nullStates ++ ss)+        st' <- State (ruleProd r) pure <$> newConts rkref+        parse (st' : ss)               env {reset = resetConts r >> reset env}       else -- The rule has already been expanded at this position.-        parse (nullStates ++ ss) env-    Pure a | spos /= pos env -> do+        parse ss env+    Pure a -> 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 (((++) <$> args a) <*>)+          modifySTRef asref $ mappend $ args a           parse ss env         Nothing    -> do -- It hasn't.           asref <- newSTRef $ args a           writeSTRef argsRef $ Just asref           ks  <- simplifyCont scont-          let kstates = map (contToState $ join $ readSTRef asref) ks+          let kstates = map (contToState $ Results $ join $ unResults <$> readSTRef asref) ks           parse (kstates ++ ss)                 env {reset = writeSTRef argsRef Nothing >> reset env}-           | otherwise -> parse ss env     Alts as (Pure f) -> do-      let args' = funArg f `composeArgs` args-          sts   = [State spos a args' scont | a <- as]+      let args' = args . f+          sts   = [State a args' scont | a <- as]       parse (sts ++ ss) env     Alts as p -> do-      scont' <- newConts =<< newSTRef [Cont spos noArgs p args scont]-      -- State is (-1) so that nullable alts are expanded correctly-      let sts = [State (-1) a noArgs scont' | a <- as]+      scont' <- newConts =<< newSTRef [Cont pure p args scont]+      let sts = [State a pure scont' | a <- as]       parse (sts ++ ss) env-    Many p q    -> do-      c  <- newSTRef =<< newSTRef mempty-      nr <- newSTRef Nothing-      let r   = Rule (pure [] <|> (:) <$> p <*> NonTerminal r (Pure id)) nr c-          st' = State spos (NonTerminal r q) args scont-      parse (st' : ss) env-    Named pr' n -> parse (State spos pr' args scont : ss)+    Many p q -> mdo+      r <- mkRule $ pure [] <|> (:) <$> p <*> NonTerminal r (Pure id)+      parse (State (NonTerminal r q) args scont : ss) env+    Named pr' n -> parse (State pr' args scont : ss)                          env {names = n : names env}  {-# INLINE parser #-} -- | Create a parser from the given grammar. parser :: ListLike i t-       => (forall r. Grammar r e (Prod r e t a))-       -> i-       -> ST s (Result s e i a)-parser g xs = do+       => (forall r. Grammar r (Prod r e t a))+       -> ST s (i -> ST s (Result s e i a))+parser g = do   s <- initialState =<< grammar g-  parse [s] $ emptyParseEnv xs+  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 (Result s e i a)) -> ([(a, Int)], Report e i)-allParses p = runST $ p >>= go+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)+      Ended rep           -> return ([], rep)       Parsed mas cpos _ k -> do         as <- mas         fmap (first (zip as (repeat cpos) ++)) $ go =<< k@@ -319,24 +275,30 @@ {-# 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 (Result s e i a)) -> ([a], Report e i)-fullParses p = runST $ p >>= go+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+      Parsed mas _ i' k+        | ListLike.null i' -> do           as <- mas           fmap (first (as ++)) $ go =<< k-        | otherwise       -> 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 (Result s e i a)) -> Report e i-report p = runST $ p >>= go+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

@@ -3,14 +3,15 @@   ( Associativity(..)   , Holey   , mixfixExpression+  , mixfixExpressionSeparate   ) where  #if !MIN_VERSION_base(4,8,0) import Control.Applicative+import Data.Traversable(sequenceA) #endif import Data.Either import Data.Foldable(asum, foldrM)-import Data.Traversable(sequenceA) import Text.Earley  replicateA :: Applicative f => Int -> f a -> f [a]@@ -51,13 +52,33 @@   -> (Holey ident -> [expr] -> expr)   -- ^ How to combine the successful application of a holey identifier to its   -- arguments into an expression.-  -> Grammar r e (Prod r e t expr)-mixfixExpression table atom app = mdo+  -> Grammar r (Prod r e t expr)+mixfixExpression table atom app = mixfixExpressionSeparate table' atom+  where+    table' = [[(holey, assoc, app) | (holey, assoc) <- row] | row <- table]++-- | A version of 'mixfixExpression' with a separate semantic action for each+-- individual 'Holey' identifier.+mixfixExpressionSeparate+  :: [[(Holey (Prod r e t ident), Associativity, Holey ident -> [expr] -> expr)]]+  -- ^ A table of holey identifier parsers, with associativity information and+  -- semantic actions.  The identifiers should be in groups of precedence+  -- levels listed from binding the least to the most tightly.+  --+  -- The associativity is taken into account when an identifier starts or ends+  -- with holes, or both. Internal holes (e.g. after "if" in "if_then_else_")+  -- start from the beginning of the table.+  --+  -- Note that this rule also applies to identifiers with multiple consecutive+  -- holes, e.g. "if__" --- the associativity then applies to both holes.+  -> Prod r e t expr+  -- ^ An atom, i.e. what is parsed at the lowest level. This will+  -- commonly be a (non-mixfix) identifier or a parenthesised expression.+  -> Grammar r (Prod r e t expr)+mixfixExpressionSeparate table atom = mdo   expr <- foldrM ($) atom $ map (level expr) table   return expr   where-    app' xs = app (concatMap (either (map $ const Nothing) $ map Just) xs)-            $ concat $ lefts xs     level expr idents next = mdo       same <- rule $ asum $ next : map (mixfixIdent same) idents       return same@@ -71,8 +92,10 @@           Right ps':rest -> Right (consA p ps')       : rest           rest           -> Right (consA p $ pure []) : rest -        mixfixIdent same (ps, a) = app' <$> go (grp ps)+        mixfixIdent same (ps, a, f) = f' <$> go (grp ps)           where+            f' xs = f (concatMap (either (map $ const Nothing) $ map Just) xs)+                   $ concat $ lefts xs             go ps' = case ps' of               [] -> pure []               [Right p] -> pure . Right <$> p

@@ -45,7 +45,7 @@  -- Earley parser -expr :: Grammar r String (Prod r String Token Expr)+expr :: Grammar r (Prod r String Token Expr) expr = mdo   x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2             <|> x2@@ -61,12 +61,12 @@ isIdent (x:_) = isAlpha x isIdent _     = False -sepBy1 :: Prod r e t a -> Prod r e t op -> Grammar r e (Prod r e t [a])+sepBy1 :: Prod r e t a -> Prod r e t op -> Grammar r (Prod r e t [a]) sepBy1 p op = mdo   ops <- rule $ pure [] <|> (:) <$ op <*> p <*> ops   rule $ (:) <$> p <*> ops -expr' :: Grammar r String (Prod r String Token Expr)+expr' :: Grammar r (Prod r String Token Expr) expr' = mdo   let var = Var <$> satisfy isIdent <|> symbol "(" *> mul <* symbol ")"   mul <- fmap (foldl1 Mul) <$> add `sepBy1` symbol "*"@@ -74,10 +74,10 @@   return mul  parseEarley :: [Token] -> Maybe Expr-parseEarley input = listToMaybe (fst (fullParses (parser expr input)))+parseEarley input = listToMaybe (fst (fullParses (parser expr) input))  parseEarley' :: [Token] -> Maybe Expr-parseEarley' input = listToMaybe (fst (fullParses (parser expr' input)))+parseEarley' input = listToMaybe (fst (fullParses (parser expr') input))  -- Parsec parsec 

@@ -22,7 +22,7 @@                 | Verb Verb   deriving Show -sentence :: Grammar r String (Prod r String String Sentence)+sentence :: Grammar r (Prod r String String Sentence) sentence = mdo   noun       <- rule $ satisfy (`HS.member` nouns)      <?> "noun"   verb       <- rule $ satisfy (`HS.member` verbs)      <?> "verb"@@ -37,9 +37,9 @@  main :: IO () main = do-  let p = parser sentence . words-  print $ fullParses $ p "parsers use grammars"-  print $ fullParses $ p "parsers munch long sentences"-  print $ fullParses $ p "many great sentences confuse parsers"-  print $ fullParses $ p "parsers use use"-  print $ fullParses $ p "grammars many great confusing"+  let p = fullParses (parser sentence) . words+  print $ p "parsers use grammars"+  print $ p "parsers munch long sentences"+  print $ p "many great sentences confuse parsers"+  print $ p "parsers use use"+  print $ p "grammars many great confusing"

@@ -10,7 +10,7 @@   | Var String   deriving (Eq, Ord, Show) -expr :: Grammar r String (Prod r String String Expr)+expr :: Grammar r (Prod r String String Expr) expr = mdo   x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2             <|> x2@@ -28,4 +28,4 @@ main :: IO () main = do   x:_ <- getArgs-  print $ fullParses $ parser expr $ words x+  print $ fullParses (parser expr) $ words x

@@ -11,7 +11,7 @@   | Lit Int   deriving (Show) -grammar :: forall r. Grammar r String (Prod r String Char Expr)+grammar :: forall r. Grammar r (Prod r String Char Expr) grammar = mdo    whitespace <- rule $ many $ satisfy isSpace@@ -42,4 +42,4 @@ main :: IO () main = do   x:_ <- getArgs-  print $ fullParses $ parser grammar x+  print $ fullParses (parser grammar) x

@@ -0,0 +1,19 @@+{-# LANGUAGE RecursiveDo #-}+module Testa where+import Control.Applicative+import Text.Earley++grammar :: Grammar r (Prod r () Char [Maybe Char])+grammar = mdo+  as <- rule $ pure []+            <|> (:) <$> optional (symbol 'a') <*> as+  return as++-- This grammar has an infinite number of results. We can still recognise the+-- language, i.e. get a report, but we can't get the results, because in doing+-- so the library will try to force a circular value.+main :: IO ()+main = do+  let input = "aaa"+  print $ report (parser grammar) input -- Works+  print $ fullParses (parser grammar) input -- Hangs

@@ -29,7 +29,7 @@   , [("_*_",           LeftAssoc)]   ] -grammar :: Grammar r String (Prod r String String Expr)+grammar :: Grammar r (Prod r String String Expr) grammar = mdo   ident     <- rule $ (V . pure . Just) <$> satisfy (not . (`HS.member` mixfixParts))                    <?> "identifier"@@ -63,4 +63,4 @@ main :: IO () main = do   x:_ <- getArgs-  print $ first (map pretty) $ fullParses $ parser grammar $ tokenize x+  print $ first (map pretty) $ fullParses (parser grammar) $ tokenize x

@@ -3,7 +3,7 @@ import System.Environment import Text.Earley -g :: Grammar r Char (Prod r Char Char ())+g :: Grammar r (Prod r Char Char ()) g = mdo   s <- rule $ () <$ symbol 'b'            <|> () <$ s <* s@@ -14,4 +14,4 @@ main :: IO () main = do   xs:_ <- getArgs-  print $ report $ parser g xs+  print $ report (parser g) xs

@@ -5,7 +5,7 @@  import Text.Earley -grammar :: Grammar r String (Prod r String Char [String])+grammar :: Grammar r (Prod r String Char [String]) grammar = mdo   whitespace  <- rule $ () <$ many (satisfy isSpace)   whitespace1 <- rule $ () <$ satisfy isSpace <* whitespace <?> "whitespace"@@ -23,4 +23,4 @@ main :: IO () main = do   x:_ <- getArgs-  print $ fullParses $ parser grammar x+  print $ fullParses (parser grammar) x

@@ -22,14 +22,14 @@     \e -> e `elem` parseAmbiguousExpr (prettyExpr 0 e)   , QC.testProperty "The empty parser doesn't parse anything" $     \(input :: String) ->-      allParses (parser (return empty :: forall r. Grammar r () (Prod r () Char ())) input)+      allParses (parser (return empty :: forall r. Grammar r (Prod r () Char ()))) input       == (,) [] Report { position   = 0                        , expected   = []                        , unconsumed = input                        }   , QC.testProperty "Many empty parsers parse very little" $     \(input :: String) ->-      allParses (parser (return $ many empty <* pure "blah" :: forall r. Grammar r () (Prod r () Char [()])) input)+      allParses (parser (return $ many empty <* pure "blah" :: forall r. Grammar r (Prod r () Char [()]))) input       == (,) [([], 0)] Report { position   = 0                               , expected   = []                               , unconsumed = input@@ -39,104 +39,104 @@ unitTests :: TestTree unitTests = testGroup "Unit Tests"   [ HU.testCase "VeryAmbiguous gives the right number of results" $-      length (fst $ fullParses $ parser veryAmbiguous $ replicate 8 'b') @?= 2871+      length (fst $ fullParses (parser veryAmbiguous) $ replicate 8 'b') @?= 2871   , HU.testCase "VeryAmbiguous gives the correct report" $-      report (parser veryAmbiguous $ replicate 3 'b') @?=+      report (parser veryAmbiguous) (replicate 3 'b') @?=       Report {position = 3, expected = "s", unconsumed = ""}   , HU.testCase "Inline alternatives work" $       let input = "ababbbaaabaa" in-      allParses (parser inlineAlts input) @?= allParses (parser nonInlineAlts input)+      allParses (parser inlineAlts) input @?= allParses (parser nonInlineAlts) input   , HU.testCase "Some reversed words" $       let input = "wordwordstop"           l     = length input in-      allParses (parser someWords input)+      allParses (parser someWords) input       @?= (,) [(["stop", "drow", "drow"], l)] Report { position   = l                                                      , expected   = []                                                      , unconsumed = []                                                      }   , HU.testCase "Optional Nothing" $-      fullParses (parser (return optional_) "b")+      fullParses (parser $ return optional_) "b"       @?= (,) [(Nothing, 'b')] Report {position = 1, expected = "", unconsumed = ""}   , HU.testCase "Optional Just" $-      fullParses (parser (return optional_) "ab")+      fullParses (parser $ return optional_) "ab"       @?= (,) [(Just 'a', 'b')] Report {position = 2, expected = "", unconsumed = ""}   , HU.testCase "Optional using rules Nothing" $-      fullParses (parser optionalRule "b")+      fullParses (parser $ optionalRule) "b"       @?= (,) [(Nothing, 'b')] Report {position = 1, expected = "", unconsumed = ""}   , HU.testCase "Optional using rules Just" $-      fullParses (parser optionalRule "ab")+      fullParses (parser $ optionalRule) "ab"       @?= (,) [(Just 'a', 'b')] Report {position = 2, expected = "", unconsumed = ""}   , HU.testCase "Optional without continuation Nothing" $-      fullParses (parser (return $ optional $ namedSymbol 'a') "")+      fullParses (parser $ return $ optional $ namedSymbol 'a') ""       @?= (,) [Nothing] Report {position = 0, expected = "a", unconsumed = ""}   , HU.testCase "Optional without continuation Just" $-      fullParses (parser (return $ optional $ namedSymbol 'a') "a")+      fullParses (parser $ return $ optional $ namedSymbol 'a') "a"       @?= (,) [Just 'a'] Report {position = 1, expected = "", unconsumed = ""}   , HU.testCase "Optional using rules without continuation Nothing" $-      fullParses (parser (rule $ optional $ namedSymbol 'a') "")+      fullParses (parser $ rule $ optional $ namedSymbol 'a') ""       @?= (,) [Nothing] Report {position = 0, expected = "a", unconsumed = ""}   , HU.testCase "Optional using rules without continuation Just" $-      fullParses (parser (rule $ optional $ namedSymbol 'a') "a")+      fullParses (parser $ rule $ optional $ namedSymbol 'a') "a"       @?= (,) [Just 'a'] Report {position = 1, expected = "", unconsumed = ""}    , HU.testCase "Mixfix 1" $       let x = Ident [Just "x"] in-      fullParses (parser mixfixGrammar $ words "if x then x else x")+      fullParses (parser mixfixGrammar) (words "if x then x else x")       @?= (,) [App ifthenelse [x, x, x]] Report {position = 6, expected = [], unconsumed = []}   , HU.testCase "Mixfix 2" $       let x = Ident [Just "x"] in-      fullParses (parser mixfixGrammar $ words "prefix x postfix")+      fullParses (parser mixfixGrammar) (words "prefix x postfix")       @?= (,) [App prefix [App postfix [x]]] Report {position = 3, expected = [], unconsumed = []}   , HU.testCase "Mixfix 3" $       let x = Ident [Just "x"] in-      fullParses (parser mixfixGrammar $ words "x infix1 x infix2 x")+      fullParses (parser mixfixGrammar) (words "x infix1 x infix2 x")       @?= (,) [App infix1 [x, App infix2 [x, x]]] Report {position = 5, expected = [], unconsumed = []}   , HU.testCase "Mixfix 4" $       let x = Ident [Just "x"] in-      fullParses (parser mixfixGrammar $ words "[ x ]")+      fullParses (parser mixfixGrammar) (words "[ x ]")       @?= (,) [App closed [x]] Report {position = 3, expected = [], unconsumed = []}    , let x = words "+ + 5 6 7" in     HU.testCase "Mixfix issue #11 1" $-    fullParses (parser (issue11 LeftAssoc) x)+    fullParses (parser $ issue11 LeftAssoc) x     @?= (,) [] Report {position = 1, expected = [], unconsumed = drop 1 x}   , let x = words "+ 5 + 6 7" in     HU.testCase "Mixfix issue #11 2" $-    fullParses (parser (issue11 LeftAssoc) x)+    fullParses (parser $ issue11 LeftAssoc) x     @?= (,) [] Report {position = 2, expected = [], unconsumed = drop 2 x}   , let x = words "+ 5 6" in     HU.testCase "Mixfix issue #11 3" $-    fullParses (parser (issue11 LeftAssoc) x)+    fullParses (parser $ issue11 LeftAssoc) x     @?= (,) [Plus11 (Var11 "5") (Var11 "6")]             Report {position = 3, expected = [], unconsumed = []}   , let x = words "+ + 5 6 7" in     HU.testCase "Mixfix issue #11 4" $-    fullParses (parser (issue11 RightAssoc) x)+    fullParses (parser $ issue11 RightAssoc) x     @?= (,) [Plus11 (Plus11 (Var11 "5") (Var11 "6")) (Var11 "7")]             Report {position = 5, expected = [], unconsumed = []}   , let x = words "+ 5 + 6 7" in     HU.testCase "Mixfix issue #11 5" $-    fullParses (parser (issue11 RightAssoc) x)+    fullParses (parser $ issue11 RightAssoc) x     @?= (,) [Plus11 (Var11 "5") (Plus11 (Var11 "6") (Var11 "7"))]             Report {position = 5, expected = [], unconsumed = []}   , let x = words "+ 5 6" in     HU.testCase "Mixfix issue #11 6" $-    fullParses (parser (issue11 RightAssoc) x)+    fullParses (parser $ issue11 RightAssoc) x     @?= (,) [Plus11 (Var11 "5") (Var11 "6")]             Report {position = 3, expected = [], unconsumed = []}   , let x = words "+ + 5 6 7" in     HU.testCase "Mixfix issue #11 7" $-    fullParses (parser (issue11 NonAssoc) x)+    fullParses (parser $ issue11 NonAssoc) x     @?= (,) [Plus11 (Plus11 (Var11 "5") (Var11 "6")) (Var11 "7")]             Report {position = 5, expected = [], unconsumed = []}   , let x = words "+ 5 + 6 7" in     HU.testCase "Mixfix issue #11 8" $-    fullParses (parser (issue11 NonAssoc) x)+    fullParses (parser $ issue11 NonAssoc) x     @?= (,) [Plus11 (Var11 "5") (Plus11 (Var11 "6") (Var11 "7"))]             Report {position = 5, expected = [], unconsumed = []}   , let x = words "+ 5 6" in     HU.testCase "Mixfix issue #11 9" $-    fullParses (parser (issue11 NonAssoc) x)+    fullParses (parser $ issue11 NonAssoc) x     @?= (,) [Plus11 (Var11 "5") (Var11 "6")]             Report {position = 3, expected = [], unconsumed = []}   ]@@ -144,27 +144,27 @@ optional_ :: Prod r Char Char (Maybe Char, Char) optional_ = (,) <$> optional (namedSymbol 'a') <*> namedSymbol 'b' -optionalRule :: Grammar r Char (Prod r Char Char (Maybe Char, Char))+optionalRule :: Grammar r (Prod r Char Char (Maybe Char, Char)) optionalRule = mdo   test <- rule $ (,) <$> optional (namedSymbol 'a') <*> namedSymbol 'b'   return test -inlineAlts :: Grammar r Char (Prod r Char Char String)+inlineAlts :: Grammar r (Prod r Char Char String) inlineAlts = mdo   p <- rule $ pure []            <|> (:) <$> (namedSymbol 'a' <|> namedSymbol 'b') <*> p   return p -nonInlineAlts :: Grammar r Char (Prod r Char Char String)+nonInlineAlts :: Grammar r (Prod r Char Char String) nonInlineAlts = mdo   ab <- rule $ namedSymbol 'a' <|> namedSymbol 'b'   p  <- rule $ pure [] <|> (:) <$> ab <*> p   return p -someWords :: Grammar r () (Prod r () Char [String])+someWords :: Grammar r (Prod r () Char [String]) someWords = return $ flip (:) <$> (map reverse <$> some (word "word")) <*> word "stop" -veryAmbiguous :: Grammar r Char (Prod r Char Char ())+veryAmbiguous :: Grammar r (Prod r Char Char ()) veryAmbiguous = mdo   s <- rule $ () <$ symbol 'b'            <|> () <$ s <* s@@ -173,10 +173,10 @@   return s  parseExpr :: String -> [Expr]-parseExpr input = fst (fullParses (parser expr (lexExpr input))) -- We need to annotate types for point-free version+parseExpr input = fst (fullParses (parser expr) (lexExpr input)) -- We need to annotate types for point-free version  parseAmbiguousExpr :: String -> [Expr]-parseAmbiguousExpr input = fst (fullParses (parser ambiguousExpr (lexExpr input)))+parseAmbiguousExpr input = fst (fullParses (parser ambiguousExpr) (lexExpr input))  data Expr   = Add Expr Expr@@ -198,7 +198,7 @@   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 String (Prod r String String Expr)+expr :: Grammar r (Prod r String String Expr) expr = mdo   x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x2             <|> x2@@ -213,7 +213,7 @@     ident (x:_) = isAlpha x     ident _     = False -ambiguousExpr :: Grammar r String (Prod r String String Expr)+ambiguousExpr :: Grammar r (Prod r String String Expr) ambiguousExpr = mdo   x1 <- rule $ Add <$> x1 <* namedSymbol "+" <*> x1             <|> x2@@ -251,7 +251,7 @@ data MixfixExpr = Ident (Holey String) | App (Holey String) [MixfixExpr]   deriving (Eq, Show) -mixfixGrammar :: Grammar r String (Prod r String String MixfixExpr)+mixfixGrammar :: Grammar r (Prod r String String MixfixExpr) mixfixGrammar = mixfixExpression table                                  (Ident . pure . Just <$> namedSymbol "x")                                  App@@ -280,7 +280,7 @@   | Plus11 Mixfix11 Mixfix11   deriving (Eq, Ord, Show) -issue11 :: Associativity -> Grammar r String (Prod r String String Mixfix11)+issue11 :: Associativity -> Grammar r (Prod r String String Mixfix11) issue11 a = mdo     atomicExpr <- rule $ Var11 <$> satisfy (/= "+")