Earley 0.8.3 → 0.9.0

raw patch · 4 files changed

+179/−78 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Earley.cabal +3/−6
• Text/Earley/Internal.hs +71/−56
• Text/Earley/Mixfix.hs +43/−16
• tests/Tests.hs +62/−0

@@ -1,5 +1,5 @@ name:                Earley-version:             0.8.3+version:             0.9.0 synopsis:            Parsing all context-free grammars using Earley's algorithm. description:         See <https://www.github.com/ollef/Earley> for more                      information and@@ -34,7 +34,8 @@   build-depends:       base >=4.7 && <4.9, ListLike >=4.1   -- hs-source-dirs:   default-language:    Haskell2010-  ghc-options:         -Wall -funbox-strict-fields+  ghc-options:         -Wall+                       -funbox-strict-fields  executable earley-english   if !flag(examples)@@ -97,10 +98,6 @@   build-depends:       base, deepseq, criterion >=1.1, parsec >=3.1, ListLike   default-language:    Haskell2010   ghc-options:         -Wall-                       -O2-                       -fmax-simplifier-iterations=10-                       -fdicts-cheap-                       -fspec-constr-count=6  test-suite tests   type:                exitcode-stdio-1.0

@@ -66,6 +66,9 @@ pureArg :: x -> Args s f a -> Args s (x -> f) a pureArg x args = args . ($ x) +pureArgs :: [x] -> Args s f a -> Args s (x -> f) a+pureArgs xs args f = concat <$> mapM (args . f) xs+ impureArgs :: ST s [x] -> Args s f a -> Args s (x -> f) a impureArgs mxs args f = fmap concat . mapM (args . f) =<< mxs @@ -108,13 +111,13 @@ 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 (Cont cpos g p args cs) = Cont cpos (composeArgs f g) p args cs contraMapCont f (FinalCont args)       = FinalCont (composeArgs f args)  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) = +contToState r (Cont cpos g p args cs) =    let mb = fmap concat . mapM g =<< r in-  State pos p (impureArgs mb args) cs+  State cpos p (impureArgs mb args) cs contToState r (FinalCont args)       = Final id (impureArgs r args)  -- | Strings of non-ambiguous continuations can be optimised by removing@@ -189,94 +192,106 @@   | 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)+  , 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+  , pos   :: !Pos+    -- ^ 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+  , pos     = 0+  , input   = i+  }+ {-# SPECIALISE parse :: [State s a e t a]-                     -> [ST s [a]]-                     -> [State s a e t a]-                     -> ST s ()-                     -> [e]-                     -> Pos-                     -> [t]+                     -> 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-      -> [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+      -> ParseEnv s e i t a       -> ST s (Result s e i a)-parse [] [] [] reset names !pos ts = do-  reset-  return $ Ended Report {position = pos, expected = names, unconsumed = ts}-parse [] [] next reset _ !pos ts = do-  reset-  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+parse [] env@ParseEnv {results = [], next = []} = do+  reset env+  return $ Ended Report+    { position   = pos env+    , expected   = names env+    , unconsumed = input env+    }+parse [] env@ParseEnv {results = []} = do+  reset env+  parse (next env) (emptyParseEnv $ safeTail $ 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-    Terminal f p -> case safeHead ts of-      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+    Terminal f p -> case safeHead $ input env of+      Just t | f t -> parse ss env {next = State spos p (pureArg t args) 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 = [State spos p (pureArg a args) scont | a <- nulls]+      let nullStates | null nulls = mempty+                     | otherwise  = pure $ State spos p (pureArgs nulls args) scont       if null ks then do -- The rule has not been expanded at this position.-        st' <- State pos (ruleProd r) noArgs <$> newConts rkref+        st' <- State (pos env) (ruleProd r) noArgs <$> newConts rkref         parse (st' : nullStates ++ ss)-              results-              next-              (resetConts r >> reset)-              names-              pos-              ts+              env {reset = resetConts r >> reset env}       else -- The rule has already been expanded at this position.-        parse (nullStates ++ ss) results next reset names pos ts-    Pure a | spos /= pos -> do+        parse (nullStates ++ ss) env+    Pure a | spos /= pos env -> 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) <*>)-          parse ss results next reset names pos ts+          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           parse (kstates ++ ss)-                results-                next-                (writeSTRef argsRef Nothing >> reset)-                names-                pos-                ts-           | otherwise -> parse ss results next reset names pos ts+                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]-      parse (sts ++ ss) results next reset names pos ts+      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]-      parse (sts ++ ss) results next reset names pos ts+      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) results next reset names pos ts-    Named pr' n -> parse (State spos pr' args scont : ss) results next reset (n : names) pos ts+      parse (st' : ss) env+    Named pr' n -> parse (State spos pr' args scont : ss)+                         env {names = n : names env}  {-# INLINE parser #-} -- | Create a parser from the given grammar.@@ -286,7 +301,7 @@        -> ST s (Result s e i a) parser g xs = do   s <- initialState =<< grammar g-  parse [s] [] [] (return ()) [] 0 xs+  parse [s] $ emptyParseEnv 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@@ -297,9 +312,9 @@     go :: Result s e i a -> ST s ([(a, Int)], Report e i)     go r = case r of       Ended rep          -> return ([], rep)-      Parsed mas pos _ k -> do+      Parsed mas cpos _ k -> do         as <- mas-        fmap (first (zip as (repeat pos) ++)) $ go =<< k+        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

@@ -1,13 +1,24 @@ {-# LANGUAGE CPP, RecursiveDo #-}-module Text.Earley.Mixfix where+module Text.Earley.Mixfix+  ( Associativity(..)+  , Holey+  , mixfixExpression+  ) where  #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Data.Either import Data.Foldable(asum, foldrM)+import Data.Traversable(sequenceA) import Text.Earley +replicateA :: Applicative f => Int -> f a -> f [a]+replicateA n = sequenceA . replicate n++consA :: Applicative f => f a -> f [a] -> f [a]+consA p q = (:) <$> p <*> q+ data Associativity   = LeftAssoc   | NonAssoc@@ -28,9 +39,12 @@   -- 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 a hole, or both. Internal holes (e.g. after "if" in-  -- "if_then_else_") start from the beginning of the table.+  -- 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.@@ -42,24 +56,37 @@   expr <- foldrM ($) atom $ map (level expr) table   return expr   where-    app' xs = app (either (const Nothing) Just <$> xs) $ lefts xs+    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       where-        cons p q = (:) <$> p <*> q-        mixfixIdent same (ps, a) = app' <$> go ps+        -- Group consecutive holes and ident parts.+        grp [] = []+        grp (Nothing:ps) = case grp ps of+          Left n:rest -> (Left $! (n + 1)) : rest+          rest        -> Left 1            : rest+        grp (Just p:ps) = case grp ps of+          Right ps':rest -> Right (consA p ps')       : rest+          rest           -> Right (consA p $ pure []) : rest++        mixfixIdent same (ps, a) = app' <$> go (grp ps)           where             go ps' = case ps' of               [] -> pure []-              [Just p] -> pure . Right <$> p-              Nothing:rest -> cons (Left <$> if a == RightAssoc then next-                                                                else same)+              [Right p] -> pure . Right <$> p+              Left n:rest -> consA+                (Left <$> replicateA n (if a == RightAssoc then next+                                                           else same))                 $ go rest-              [Just p, Nothing] -> cons (Right <$> p)-                $ pure . Left <$> if a == LeftAssoc then next else same-              Just p:Nothing:rest -> cons (Right <$> p)-                $ cons (Left <$> expr)+              [Right p, Left n] -> consA+                (Right <$> p)+                $ pure . Left <$> replicateA n (if a == LeftAssoc then next+                                                                  else same)+              Right p:Left n:rest -> consA (Right <$> p)+                $ consA (Left <$> replicateA n expr)                 $ go rest-              Just p:rest@(Just _:_) -> cons (Right <$> p) $ go rest-+              Right _:Right _:_ -> error+                $  "Earley.mixfixExpression: The impossible happened. "+                ++ "Please report this as a bug."

@@ -95,6 +95,50 @@       let x = Ident [Just "x"] in       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)+    @?= (,) [] 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)+    @?= (,) [] 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)+    @?= (,) [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)+    @?= (,) [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)+    @?= (,) [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)+    @?= (,) [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)+    @?= (,) [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)+    @?= (,) [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)+    @?= (,) [Plus11 (Var11 "5") (Var11 "6")]+            Report {position = 3, expected = [], unconsumed = []}   ]  optional_ :: Prod r Char Char (Maybe Char, Char)@@ -230,3 +274,21 @@ infix2 = [Nothing, Just "infix2", Nothing] closed = [Just "[", Nothing, Just "]"] +-- Adapted from issue #11+data Mixfix11+  = Var11 String+  | Plus11 Mixfix11 Mixfix11+  deriving (Eq, Ord, Show)++issue11 :: Associativity -> Grammar r String (Prod r String String Mixfix11)+issue11 a = mdo+    atomicExpr <- rule $ Var11 <$> satisfy (/= "+")++    expr <- mixfixExpression+               [[([Just (symbol "+"), Nothing, Nothing], a)]]+               atomicExpr+               (\x y -> case (x,y) of+                  ([Just "+", Nothing, Nothing], [e1,e2]) -> Plus11 e1 e2+                  _ -> undefined)++    return expr