Earley 0.6.0 → 0.7.0

raw patch · 4 files changed

+147/−68 lines, 4 filesdep −kan-extensionsPVP ok

version bump matches the API change (PVP)

Dependencies removed: kan-extensions

API changes (from Hackage documentation)

Files

• Earley.cabal +2/−2
• Text/Earley.hs +2/−0
• Text/Earley/Grammar.hs +4/−3
• Text/Earley/Parser.hs +139/−63

@@ -1,5 +1,5 @@ name:                Earley-version:             0.6.0+version:             0.7.0 synopsis:            Parsing all context-free grammars using Earley's algorithm. description:         See <https://www.github.com/ollef/Earley> for more                      information and@@ -21,7 +21,7 @@ library   exposed-modules:     Text.Earley.Derived, Text.Earley.Grammar, Text.Earley.Parser Text.Earley   -- other-modules:-  build-depends:       base ==4.8.*, containers >=0.5, kan-extensions >=4.2, ListLike >=4.1+  build-depends:       base ==4.8.*, containers >=0.5, ListLike >=4.1   -- hs-source-dirs:   default-language:    Haskell2010   ghc-options:         -Wall -funbox-strict-fields

@@ -6,6 +6,8 @@     symbol, namedSymbol, word   , -- * Parsing     Report(..), Result(..), parser, allParses, fullParses+    -- * Recognition+  , report   )   where import Text.Earley.Grammar

@@ -88,8 +88,9 @@   Named p m <|> q         = Named (p <|> q) m   p         <|> Named q n = Named (p <|> q) n   p         <|> q         = Plus p q-  many p       = Many p $ Pure id-  some p       = (:) <$> p <*> many p+  many Empty = pure []+  many p     = Many p $ Pure id+  some p     = (:) <$> p <*> many p  -- | A context-free grammar. --@@ -131,6 +132,6 @@ instance MonadFix (Grammar r e) where   mfix f = FixBind f return --- | Create a new non-terminal by listing its production rule.+-- | Create a new non-terminal by giving its production. rule :: Prod r e t a -> Grammar r e (Prod r e t a) rule p = RuleBind p return

@@ -6,12 +6,13 @@   , parser   , allParses   , fullParses+  , report   ) where import Control.Applicative import Control.Arrow+import Control.Monad import Control.Monad.Fix import Control.Monad.ST.Lazy-import Data.Functor.Yoneda import Data.ListLike(ListLike) import qualified Data.ListLike as ListLike import Data.STRef.Lazy@@ -24,7 +25,7 @@ data Rule s r e t a = Rule   { ruleProd     :: ProdR s r e t a   , ruleNullable :: {-# UNPACK #-} !(STRef s (Maybe [a]))-  , ruleConts    :: {-# UNPACK #-} !(STRef s (Conts s r e t a r))+  , ruleConts    :: {-# UNPACK #-} !(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@@ -53,6 +54,25 @@ nullableProd Empty             = return mempty nullableProd (Named p _)       = nullableProd p +-- | 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++pureArg :: x -> Args s f a -> Args s (x -> f) a+pureArg x args = args . ($ x)++impureArgs :: ST s [x] -> Args s f a -> Args s (x -> f) a+impureArgs mxs args f = fmap concat . mapM (args . f) =<< mxs++mapArgs :: (a -> b) -> Args s f a -> Args s f b+mapArgs = fmap . fmap . fmap++composeArgs :: Args s a b -> Args s b c -> Args s a c+composeArgs ab bc a = fmap concat . mapM bc =<< ab a+ ------------------------------------------------------------------------------- -- * States and continuations -------------------------------------------------------------------------------@@ -61,37 +81,45 @@ -- | An Earley state with result type @a@. data State s r e t a where   State :: {-# UNPACK #-} !Pos-        -> !(ProdR s r e t b)+        -> !(ProdR s r e t f)+        -> {-# UNPACK #-} !(Args s f b)         -> {-# UNPACK #-} !(Conts s r e t b a)         -> State s r e t a-  Final :: a -> State s r e t a+  Final :: f -> Args s f 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      :: {-# UNPACK #-} !Pos-            -> !(ProdR s r e t (a -> b))-            -> {-# UNPACK #-} !(Conts s r e t b c)-            -> Cont s r e t a c-  FinalCont :: (a -> c) -> Cont s r e t a c+            -> {-# UNPACK #-} !(Args s a b)+            -> !(ProdR s r e t (b -> c))+            -> {-# UNPACK #-} !(Args s c d)+            -> {-# UNPACK #-} !(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 -type Conts s r e t a c = STRef s [Cont s r e t a c]+data Conts s r e t a c = Conts+  { conts     :: {-# UNPACK #-} !(STRef s [Cont s r e t a c])+  , contsArgs :: {-# UNPACK #-} !(STRef s (Maybe (STRef s (ST s [a]))))+  } -contraMapCont :: (b -> a) -> Cont s r e t a c -> Cont s r e t b c-contraMapCont f (Cont pos p cs) = (Cont pos $! ((. f) <$> p)) cs-contraMapCont f (FinalCont g)   = FinalCont (g . f)+contraMapCont :: Args s b a -> Cont s r e t a c -> Cont s r e t b c+contraMapCont f (Cont pos g p args cs) = Cont pos (composeArgs f g) p args cs+contraMapCont f (FinalCont args)       = FinalCont (composeArgs f args) -contToState :: a -> Cont s r e t a c -> State s r e t c-contToState a (Cont pos p cs) = State pos (($ a) <$> p) cs-contToState a (FinalCont f)   = Final (f a)+contToState :: ST s [a] -> Cont s r e t a c -> State s r e t c+contToState r (Cont pos g p args cs) = +  let mb = fmap concat . mapM g =<< r in+  State pos p (impureArgs mb args) cs+contToState r (FinalCont args)       = Final id (impureArgs 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 cont = readSTRef cont >>= go False+simplifyCont Conts {conts = cont} = readSTRef cont >>= go False   where-    go !_ [Cont _ (Pure f) cont'] = do+    go !_ [Cont _ g (Pure f) args cont'] = do       ks' <- simplifyCont cont'-      go True $ map (contraMapCont f) ks'+      go True $ map (contraMapCont $ mapArgs f g `composeArgs` args) ks'     go True ks = do       writeSTRef cont ks       return ks@@ -114,10 +142,10 @@  -- | Given a grammar, construct an initial state. initialState :: ProdR s a e t a -> ST s (State s a e t a)-initialState r = do-  rs <- newSTRef [FinalCont id]-  return $ State (-1) r rs+initialState p = State (-1) p noArgs+              <$> (Conts <$> newSTRef [FinalCont noArgs] <*> newSTRef Nothing) + ------------------------------------------------------------------------------- -- * Parsing -------------------------------------------------------------------------------@@ -137,11 +165,13 @@ data Result s e i a   = Ended (Report e i)     -- ^ The parser ended.-  | Parsed a Int i (i -> ST s (Result s e i a))-    -- ^ The parser parsed something, namely an 'a'. The 'Int' is the position-    -- in the input where it did so, the 'i' is the rest of the input, and the-    -- function is the parser continuation. This allows incrementally feeding-    -- the parser more input (e.g. when the 'i' is empty).+  | 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 uncons #-}@@ -156,60 +186,90 @@   | ListLike.null ts' = ts'   | otherwise         = ListLike.tail ts' -{-# SPECIALISE parse :: [State s a e t a] -> [State s a e t a] -> ST s () -> [e] -> Pos -> [t] -> ST s (Result s e [t] a) #-}+{-# SPECIALISE parse :: [State s a e t a]+                     -> [ST s [a]]+                     -> [State s a e t a]+                     -> ST s ()+                     -> [e]+                     -> Pos+                     -> [t]+                     -> 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+      -> [ST s [a]]        -- ^ Results ready to be reported (when this position has been processed)       -> [State s a e t a] -- ^ States to process at the next position       -> ST s ()           -- ^ Computation that resets the continuation refs of productions       -> [e]               -- ^ Named productions encountered at this position       -> Pos               -- ^ The current position in the input string       -> i                 -- ^ The input string       -> ST s (Result s e i a)-parse []      []    !reset names !pos   !ts = do+parse [] [] [] !reset names !pos !ts = do   reset   return $ Ended Report {position = pos, expected = names, unconsumed = ts}-parse []      !next !reset _names !pos !ts = do+parse [] [] !next !reset _ !pos !ts = do   reset-  parse next [] (return ()) [] (pos + 1) (safeTail ts)-parse (st:ss) !next !reset names !pos !ts = case st of-  Final a -> return $ Parsed a pos ts $ parse ss next reset names pos-  State spos pr scont -> case pr of+  parse next [] [] (return ()) [] (pos + 1) $ safeTail ts+parse [] !results !next !reset names !pos !ts = do+  reset+  return $ Parsed (concat <$> sequence results) pos ts+         $ parse [] [] next (return ()) names pos ts+parse (st:ss) !results !next !reset names !pos !ts = case st of+  Final f args -> parse ss (args f : results) next reset names pos ts+  State spos pr args scont -> case pr of     Terminal f p -> case uncons ts of-      Just (t, _) | f t -> parse ss (State spos (($ t) <$> p) scont : next) reset names pos ts-      _                 -> parse ss next reset names pos ts+      Just (t, _) | f t ->+        parse ss results (State spos p (pureArg t args) scont : next) reset names pos ts+      _                 -> parse ss results next reset names pos ts     NonTerminal r p -> do       rkref <- readSTRef $ ruleConts r       ks    <- readSTRef rkref-      writeSTRef rkref (Cont spos p scont : ks)-      nulls' <- nullable r-      let notExpanded = null ks-          p'          = liftYoneda p-          nulls       = fmap (\a -> State spos (lowerYoneda $ ($ a) <$> p') scont) nulls'-      if notExpanded then do-        let st' = State pos (ruleProd r) rkref-        parse (st' : nulls ++ ss)+      writeSTRef rkref (Cont spos noArgs p args scont : ks)+      nulls <- nullable r+      let nullStates = [State spos p (pureArg a args) scont | a <- nulls]+      if null ks then do -- The rule has not been expanded at this position.+        asref <- newSTRef Nothing+        let st' = State pos (ruleProd r) noArgs (Conts rkref asref)+        parse (st' : nullStates ++ ss)+              results               next               ((writeSTRef (ruleConts r) =<< newSTRef mempty) >> reset)               names               pos               ts-      else-        parse (nulls ++ ss) next reset names pos ts+      else -- The rule has already been expanded at this position.+        parse (nullStates ++ ss) results next reset names pos ts     Pure a | spos /= pos -> do-      conts <- simplifyCont scont-      parse (map (contToState a) conts ++ ss) next reset names pos ts-           | otherwise -> parse ss next reset names pos ts+      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) <*>)+          parse ss results next reset names pos ts+        Nothing    -> do -- It hasn't.+          asref <- newSTRef (return mempty)+          modifySTRef asref (((++) <$> args a) <*>)+          writeSTRef argsRef $ Just asref+          ks  <- simplifyCont scont+          let kstates = map (contToState $ join $ readSTRef asref) ks+          parse (kstates ++ ss)+                results+                next+                (writeSTRef argsRef Nothing >> reset)+                names+                pos+                ts+           | otherwise -> parse ss results next reset names pos ts -    Plus p q    -> parse (State spos p scont : State spos q scont : ss) next reset names pos ts+    Plus p q    -> parse (State spos p args scont : State spos q args scont : ss) results next reset names pos ts     Many p q    -> do-      rkref <- newSTRef [Cont spos (Many p ((\f as a -> f (a : as)) <$> q)) scont]-      let st' = State pos p rkref-          nst = State spos (($ []) <$> q) scont-      parse (st' : nst : ss) next reset names pos ts-    Empty       -> parse ss next reset names pos ts--    Named pr' n -> parse (State spos pr' scont : ss) next reset (n : names) pos ts+      scont' <- Conts <$> newSTRef [Cont spos noArgs (Many p ((\f as a -> f (a : as)) <$> q)) args scont]+                      <*> newSTRef Nothing+      let st' = State pos p noArgs scont'+          nst = State spos q (pureArg [] args) scont+      parse (st' : nst : ss) results next reset names pos ts+    Empty       -> parse ss results next reset names pos ts+    Named pr' n -> parse (State spos pr' args scont : ss) results next reset (n : names) pos ts  {-# INLINE parser #-} -- | Create a parser from the given grammar.@@ -219,7 +279,7 @@        -> ST s (Result s e i a) parser g xs = do   s <- initialState =<< grammar g-  parse [s] [] (return ()) [] 0 xs+  parse [s] [] [] (return ()) [] 0 xs  -- | 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@@ -229,8 +289,10 @@   where     go :: Result s e i a -> ST s ([(a, Int)], Report e i)     go r = case r of-      Ended report     -> return ([], report)-      Parsed a pos i k -> fmap (first ((a, pos) :)) $ go =<< k i+      Ended rep         -> return ([], rep)+      Parsed mas pos _ k -> do+        as <- mas+        fmap (first (zip as (repeat pos) ++)) $ go =<< k  {-# INLINE fullParses #-} -- | Return all parses that reached the end of the input from the result of a@@ -240,7 +302,21 @@   where     go :: ListLike i t => Result s e i a -> ST s ([a], Report e i)     go r = case r of-      Ended report -> return ([], report)-      Parsed a _ i k-        | ListLike.null i -> fmap (first (a :)) $ go =<< k i-        | otherwise       -> go =<< k i+      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 (Result s e i a)) -> Report e i+report p = runST $ p >>= 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