Earley 0.10.0.1 → 0.10.1.0

raw patch · 5 files changed

+156/−62 lines, 5 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• Earley.cabal +2/−1
• Text/Earley/Grammar.hs +16/−1
• Text/Earley/Internal.hs +92/−57
• tests/Tests.hs +42/−3

@@ -1,3 +1,7 @@+# 0.10.0.1++- Add changelog+ # 0.10  - Remove `Args`, and use `Results` instead

@@ -1,5 +1,5 @@ name:                Earley-version:             0.10.0.1+version:             0.10.1.0 synopsis:            Parsing all context-free grammars using Earley's algorithm. description:         See <https://www.github.com/ollef/Earley> for more                      information and@@ -28,6 +28,7 @@ Flag Examples   Description: "Build examples"   Default:     False+  Manual:      True  source-repository    head   type:     git

@@ -4,9 +4,10 @@   ( Prod(..)   , satisfy   , (<?>)+  , alts   , Grammar(..)   , rule-  , alts+  , runGrammar   ) where import Control.Applicative import Control.Monad@@ -146,3 +147,17 @@ -- | Create a new non-terminal by giving its production. rule :: Prod r e t a -> Grammar r (Prod r e t a) rule p = RuleBind p return++-- | Run a grammar, given an action to perform on productions to be turned into+-- non-terminals.+runGrammar :: MonadFix m+           => (forall e t a. Prod r e t a -> m (Prod r e t a))+           -> Grammar r b -> m b+runGrammar r grammar = case grammar of+  RuleBind p k -> do+    nt <- r p+    runGrammar r $ k nt+  Return a -> return a+  FixBind f k -> do+    a <- mfix $ runGrammar r <$> f+    runGrammar r $ k a

@@ -4,7 +4,6 @@ module Text.Earley.Internal where import Control.Applicative import Control.Arrow-import Control.Monad.Fix import Control.Monad import Control.Monad.ST import Data.ListLike(ListLike)@@ -22,8 +21,39 @@ 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 ()@@ -47,6 +77,10 @@   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@@ -54,16 +88,22 @@     concat <$> mapM (unResults . f) xs  instance Monoid (Results s a) where-  mempty = Results $ pure []-  mappend (Results sxs) (Results sys) = Results $ (++) <$> sxs <*> sys+  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@@ -89,9 +129,9 @@ contraMapCont f (Cont g p args cs) = Cont (f >=> g) p args cs contraMapCont f (FinalCont args)   = FinalCont (f >=> 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+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.@@ -109,25 +149,9 @@ ------------------------------------------------------------------------------- -- * 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) a -> ST s a-grammar g = case g of-  RuleBind p k -> do-    r <- mkRule p-    grammar $ k $ NonTerminal r $ Pure id-  FixBind f k   -> do-    a <- mfix $ fmap grammar f-    grammar $ k a-  Return x      -> return x- -- | 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 <$> (newConts =<< newSTRef [FinalCont pure])+initialState p = State p pure Previous <$> (newConts =<< newSTRef [FinalCont pure])  ------------------------------------------------------------------------------- -- * Parsing@@ -166,15 +190,15 @@ 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]+  , next    :: ![State s a e t a]     -- ^ States to process at the next position-  , reset :: !(ST s ())+  , reset   :: !(ST s ())     -- ^ Computation that resets the continuation refs of productions-  , names :: ![e]+  , names   :: ![e]     -- ^ Named productions encountered at this position-  , pos   :: !Int+  , curPos  :: !Int     -- ^ The current position in the input string-  , input :: !i+  , input   :: !i     -- ^ The input string   } @@ -185,7 +209,7 @@   , next    = mempty   , reset   = return ()   , names   = mempty-  , pos     = 0+  , curPos  = 0   , input   = i   } @@ -200,61 +224,71 @@ parse [] env@ParseEnv {results = [], next = []} = do   reset env   return $ Ended Report-    { position   = pos env+    { position   = curPos env     , expected   = names env     , unconsumed = input env     } parse [] env@ParseEnv {results = []} = do   reset env-  parse (next env) (emptyParseEnv $ ListLike.tail $ input env) {pos = pos env + 1}+  parse (next env)+        (emptyParseEnv $ ListLike.tail $ input env) {curPos = curPos env + 1} parse [] env = do   reset env-  return $ Parsed (concat <$> sequence (results env)) (pos env) (input 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 scont -> case pr of+  State pr args pos scont -> case pr of     Terminal f p -> case safeHead $ input env of-      Just t | f t -> parse ss env {next = State p (args . ($ t)) scont+      Just t | f t -> parse ss env {next = State p (args . ($ t)) Previous scont                                          : next env}       _            -> 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 <$> newConts rkref-        parse (st' : ss)+        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 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 $ 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 res) ks-          parse (kstates ++ ss)-                env {reset = writeSTRef argsRef Nothing >> reset env}+        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' scont | a <- as]+          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 scont' | a <- as]+      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 scont : ss) env-    Named pr' n -> parse (State pr' args scont : ss)+      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 #-}@@ -263,7 +297,8 @@        => (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+  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

@@ -1,10 +1,10 @@ {-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}+import Control.Applicative+import Data.Char import Test.Tasty-import Test.Tasty.QuickCheck as QC import Test.Tasty.HUnit      as HU+import Test.Tasty.QuickCheck as QC -import Data.Char-import Control.Applicative import Text.Earley import Text.Earley.Mixfix @@ -34,6 +34,10 @@                               , expected   = []                               , unconsumed = input                               }+  , QC.testProperty "The same rule in alternatives gives many results (issue #14)" $+    \x -> fullParses (parser (issue14 x)) ""+    == (,) (replicate (issue14Length x) ())+           Report { position = 0, expected = [], unconsumed = [] }   ]  unitTests :: TestTree@@ -292,3 +296,38 @@                   _ -> undefined)      return expr++data Issue14 a+  = Pure a+  | Alt (Issue14 a) (Issue14 a)+  | Ap (Issue14 a) (Issue14 a)+  deriving (Eq, Ord, Show)++instance Arbitrary a => Arbitrary (Issue14 a) where+  arbitrary = sized arbTree+    where arbTree n | n > 0  = oneof [ Pure <$> arbitrary+                                     , Alt <$> arbTree1 <*> arbTree1+                                     , Ap <$> arbTree1 <*> arbTree1+                                     ]+                                     where arbTree1 = arbTree (n `div` 2)+          arbTree _          = Pure <$> arbitrary++  shrink (Pure a)  = Pure <$> shrink a+  shrink (Alt a b) = a : b : [Alt a' b | a' <- shrink a] ++ [Alt a b' | b' <- shrink b]+  shrink (Ap a b)  = a : b : [Ap a' b | a' <- shrink a] ++ [Ap a b' | b' <- shrink b]++issue14Length :: Issue14 () -> Int+issue14Length (Pure ()) = 1+issue14Length (Alt a b) = ((+) $! issue14Length a) $! issue14Length b+issue14Length (Ap a b)  = ((*) $! issue14Length a) $! issue14Length b++issue14 :: Issue14 () -> Grammar r (Prod r () Char ())+issue14 tree = do+  emptyRule <- rule $ pure ()+  let x = go emptyRule tree+  return x+  where+    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+