diff --git a/Earley.cabal b/Earley.cabal --- a/Earley.cabal +++ b/Earley.cabal @@ -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 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 diff --git a/Text/Earley/Internal.hs b/Text/Earley/Internal.hs --- a/Text/Earley/Internal.hs +++ b/Text/Earley/Internal.hs @@ -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 diff --git a/Text/Earley/Mixfix.hs b/Text/Earley/Mixfix.hs --- a/Text/Earley/Mixfix.hs +++ b/Text/Earley/Mixfix.hs @@ -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." diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -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