Earley 0.7.1 → 0.8.0

raw patch · 3 files changed

+55/−34 lines, 3 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Earley.cabal +3/−3
• Text/Earley/Grammar.hs +23/−14
• Text/Earley/Parser.hs +29/−17

@@ -1,5 +1,5 @@ name:                Earley-version:             0.7.1+version:             0.8.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, ListLike >=4.1+  build-depends:       base >=4.7 && <4.9, containers >=0.5, ListLike >=4.1   -- hs-source-dirs:   default-language:    Haskell2010-  ghc-options:         -Wall -funbox-strict-fields -O2+  ghc-options:         -Wall -funbox-strict-fields

@@ -1,5 +1,5 @@ -- | Context-free grammars.-{-# LANGUAGE GADTs, RankNTypes #-}+{-# LANGUAGE CPP, GADTs, RankNTypes #-} module Text.Earley.Grammar   ( Prod(..)   , satisfy@@ -10,6 +10,9 @@ import Control.Applicative import Control.Monad import Control.Monad.Fix+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif  infixr 0 <?> @@ -41,9 +44,8 @@   Pure        :: a -> Prod r e t a   -- Monoid/Alternative. We have to special-case 'many' (though it can be done   -- with rules) to be able to satisfy the Alternative interface.-  Plus        :: !(Prod r e t a) -> !(Prod r e t a) -> Prod r e t a+  Alts        :: ![Prod r e t a] -> !(Prod r e t (a -> b)) -> Prod r e t b   Many        :: !(Prod r e t a) -> !(Prod r e t ([a] -> b)) -> Prod r e t b-  Empty       :: Prod r e t a   -- Error reporting.   Named       :: !(Prod r e t a) -> e -> Prod r e t a @@ -65,32 +67,39 @@   fmap f (Terminal b p)    = Terminal b $ fmap (f .) p   fmap f (NonTerminal r p) = NonTerminal r $ fmap (f .) p   fmap f (Pure x)          = Pure $ f x-  fmap f (Plus p q)        = Plus (fmap f p) (fmap f q)+  fmap f (Alts as p)       = Alts as $ fmap (f .) p   fmap f (Many p q)        = Many p $ fmap (f .) q-  fmap _ Empty             = Empty   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+  where+    go (Alts as' (Pure f)) = fmap f <$> as'+    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-  Plus a b        <*> q = a <*> q <|> b <*> q+  Alts as p       <*> q = alts' as $ flip <$> p <*> q   Many a p        <*> q = Many a $ flip <$> p <*> q-  Empty           <*> _ = Empty   Named p n       <*> q = Named (p <*> q) n  instance Alternative (Prod r e t) where-  empty = Empty-  Empty     <|> q         = q-  p         <|> Empty     = p+  empty = alts []   Named p m <|> q         = Named (p <|> q) m   p         <|> Named q n = Named (p <|> q) n-  p         <|> q         = Plus p q-  many Empty = pure []-  many p     = Many p $ Pure id-  some p     = (:) <$> p <*> many p+  p         <|> q         = alts [p, q]+  many (Alts [] _) = pure []+  many p           = Many p $ Pure id+  some p           = (:) <$> p <*> many p  -- | A context-free grammar. --

@@ -1,5 +1,5 @@ -- | Parsing.-{-# LANGUAGE BangPatterns, DeriveFunctor, GADTs, Rank2Types #-}+{-# LANGUAGE CPP, BangPatterns, DeriveFunctor, GADTs, Rank2Types #-} module Text.Earley.Parser   ( Report(..)   , Result(..)@@ -17,6 +17,9 @@ import qualified Data.ListLike as ListLike import Data.STRef.Lazy import Text.Earley.Grammar+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid+#endif  ------------------------------------------------------------------------------- -- * Concrete rules and productions@@ -47,13 +50,16 @@   as <- nullable r   concat <$> mapM (\a -> nullableProd $ fmap ($ a) p) as nullableProd (Pure a)          = return [a]-nullableProd (Plus a b)        = mappend <$> nullableProd a <*> nullableProd b+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 Empty             = return mempty 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]@@ -61,6 +67,9 @@ 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) @@ -102,6 +111,9 @@   , contsArgs :: !(STRef s (Maybe (STRef s (ST 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 pos g p args cs) = Cont pos (composeArgs f g) p args cs contraMapCont f (FinalCont args)       = FinalCont (composeArgs f args)@@ -142,9 +154,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-              <$> (Conts <$> newSTRef [FinalCont noArgs] <*> newSTRef Nothing)-+initialState p = State (-1) p noArgs <$> (newConts =<< newSTRef [FinalCont noArgs])  ------------------------------------------------------------------------------- -- * Parsing@@ -172,7 +182,7 @@     -- 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)+  deriving Functor  {-# INLINE uncons #-} uncons :: ListLike i t => i -> Maybe (t, i)@@ -228,12 +238,11 @@       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)+        st' <- State pos (ruleProd r) noArgs <$> newConts rkref         parse (st' : nullStates ++ ss)               results               next-              ((writeSTRef (ruleConts r) =<< newSTRef mempty) >> reset)+              (resetConts r >> reset)               names               pos               ts@@ -247,8 +256,7 @@           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) <*>)+          asref <- newSTRef $ args a           writeSTRef argsRef $ Just asref           ks  <- simplifyCont scont           let kstates = map (contToState $ join $ readSTRef asref) ks@@ -260,15 +268,19 @@                 pos                 ts            | otherwise -> parse ss results 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+    Alts as (Pure f) -> do+      let args' = funArg f `composeArgs` args+          sts   = [State pos a args' scont | a <- as]+      parse (sts ++ ss) results next reset names pos ts+    Alts as p -> do+      scont' <- newConts =<< newSTRef [Cont spos noArgs p args scont]+      let sts = [State pos a noArgs scont' | a <- as]+      parse (sts ++ ss) results next reset names pos ts     Many p q    -> do-      scont' <- Conts <$> newSTRef [Cont spos noArgs (Many p ((\f as a -> f (a : as)) <$> q)) args scont]-                      <*> newSTRef Nothing+      scont' <- newConts =<< newSTRef [Cont spos noArgs (Many p ((\f as a -> f (a : as)) <$> q)) args scont]       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 #-}