diff --git a/core/src/Streamly/Internal/Data/Parser/ParserD.hs b/core/src/Streamly/Internal/Data/Parser/ParserD.hs index a004624ae6..ef4c9f0769 100644 --- a/core/src/Streamly/Internal/Data/Parser/ParserD.hs +++ b/core/src/Streamly/Internal/Data/Parser/ParserD.hs @@ -235,6 +235,9 @@ import Streamly.Internal.Data.Parser.ParserD.Type -- Downgrade a parser to a Fold ------------------------------------------------------------------------------- +-- XXX Statically detect that these constructors are not present in a toFold +-- argument. + -- | See 'Streamly.Internal.Data.Parser.toFold'. -- -- /Internal/ diff --git a/core/src/Streamly/Internal/Data/Parser/ParserD/Type.hs b/core/src/Streamly/Internal/Data/Parser/ParserD/Type.hs index 45bbda0f43..07a18f4e45 100644 --- a/core/src/Streamly/Internal/Data/Parser/ParserD/Type.hs +++ b/core/src/Streamly/Internal/Data/Parser/ParserD/Type.hs @@ -166,6 +166,7 @@ module Streamly.Internal.Data.Parser.ParserD.Type ( + {- -- * Types Initial (..) , Step (..) @@ -202,6 +203,7 @@ module Streamly.Internal.Data.Parser.ParserD.Type , noErrorUnsafeSplitWith , noErrorUnsafeSplit_ , noErrorUnsafeConcatMap + -} ) where @@ -234,60 +236,8 @@ import Prelude hiding (concatMap, filter) -- >>> import qualified Streamly.Internal.Data.Parser as Parser -- >>> import qualified Streamly.Internal.Data.Parser.ParserD as ParserD --- XXX The only differences between Initial and Step types are: --- --- * There are no backtracking counts in Initial --- * Continue and Partial are the same. Ideally Partial should mean that an --- empty result is valid and can be extracted; and Continue should mean that --- empty would result in an error on extraction. We can possibly distinguish --- the two cases. --- --- If we ignore the backtracking counts we can represent the Initial type using --- Step itself. That will also simplify the implementation of various parsers --- where the processing in intiial is just a sepcial case of step, see --- takeBetween for example. --- --- | The type of a 'Parser''s initial action. --- --- /Internal/ --- -{-# ANN type Initial Fuse #-} -data Initial s b - = IPartial !s -- ^ Wait for step function to be called with state @s@. - | IDone !b -- ^ Return a result right away without an input. - | IError !String -- ^ Return an error right away without an input. - --- | @first@ maps on 'IPartial' and @second@ maps on 'IDone'. --- --- /Internal/ --- -instance Bifunctor Initial where - {-# INLINE bimap #-} - bimap f _ (IPartial a) = IPartial (f a) - bimap _ g (IDone b) = IDone (g b) - bimap _ _ (IError err) = IError err - --- | Maps a function over the result held by 'IDone'. --- --- >>> fmap = second --- --- /Internal/ --- -instance Functor (Initial s) where - {-# INLINE fmap #-} - fmap = second - --- We can simplify the Step type as follows: --- --- Partial Int (Either s (s, b)) -- Left continue, right partial result --- Done Int (Either String b) --- --- In this case Error may also have a "leftover" return. This means that after --- several successful partial results the last segment parsing failed and we --- are returning the leftover of that. The driver may choose to restart from --- the last segment where this parser failed or from the beginning. --- --- Folds can only return the right values. Parsers can also return lefts. +-- XXX Need a way to statically detect that no "initial" function has +-- backtracking and no extract function has Partial or Continue 0. -- | The return type of a 'Parser' step. -- @@ -360,6 +310,18 @@ instance Bifunctor Step where Done n b -> Done n (g b) Error err -> Error err +-- XXX It should be bimapAddCount, we should not be discarding the counts from +-- initial. There could be cases where backtracking from initial may be useful. +-- +-- However, it may not make sense at all to backtrack in initial because the +-- previous parser would have called Done which would have dropped the buffer. +-- But in applicatives we keep the buffer. +-- +-- If we have special drivers where we do not drop the buffer even on Partial +-- or Done i.e. fully backtracking parsers, then we can use backtracking in +-- initial as well. This could be another class of parsers that works on +-- buffered data. + -- | Bimap discarding the count, and using the supplied count instead. bimapOverrideCount :: Int -> (s -> s1) -> (b -> b1) -> Step s b -> Step s1 b1 bimapOverrideCount n f g step = @@ -423,7 +385,7 @@ data Parser m a b = (s -> a -> m (Step s b)) -- Initial cannot return "Partial/Done n" or "Continue". Continue 0 is -- same as Partial 0. In other words it cannot backtrack. - (m (Initial s b)) + (m (Step s b)) -- Extract can only return Partial or Continue n. In other words it can -- only backtrack or return partial result/error. But we do not return -- result in Partial, therefore, we have to use Done instead of Partial. @@ -469,7 +431,7 @@ instance Functor m => Functor (Parser m a) where parseDToK :: Monad m => (s -> a -> m (Step s b)) - -> m (Initial s b) + -> m (Step s b) -> (s -> m (Step s b)) -> Int -> (Int, Int) @@ -479,10 +441,15 @@ parseDToK -- Non 'Alternative' case. parseDToK pstep initial extract leftover (0, _) cont = do res <- initial + -- XXX Handling of initial/step/extract can be deduplicated case res of - IPartial r -> return $ K.Continue leftover (parseCont (return r)) - IDone b -> cont state (K.Success 0 b) - IError err -> cont state (K.Failure err) + Done n b -> cont state (K.Success (leftover + n) b) + Error err -> cont state (K.Failure err) + -- XXX K.Partial or K.Continue? + Partial n pst1 -> + return $ K.Continue (leftover + n) (parseCont (return pst1)) + Continue n pst1 -> + return $ K.Continue (leftover + n) (parseCont (return pst1)) where @@ -508,17 +475,27 @@ parseDToK pstep initial extract leftover (0, _) cont = do case r of Done n b -> cont state (K.Success n b) Error err -> cont state (K.Failure err) + -- XXX We can use Partial to indicate that the parser did not + -- terminate but the input ended. And Done to indicate that the + -- parser terminated. Partial _ _ -> error "Bug: parseDToK Partial unreachable" Continue n pst1 -> return $ K.Continue n (parseCont (return pst1)) +-- XXX For noFailure parsers we do not need this case. + -- 'Alternative' case. Used count needs to be maintained when inside an -- Alternative. -parseDToK pstep initial extract leftover (level, count) cont = do +parseDToK pstep initial extract leftover st@(level, count) cont = do res <- initial case res of - IPartial r -> return $ K.Continue leftover (parseCont count (return r)) - IDone b -> cont (level,count) (K.Success 0 b) - IError err -> cont (level,count) (K.Failure err) + Partial n r -> + return $ K.Continue (leftover + n) (parseCont count (return r)) + Continue n r -> + return $ K.Continue (leftover + n) (parseCont count (return r)) + Done n b -> + -- XXX do we need to add leftover here? + cont st (K.Success (leftover + n) b) + Error err -> cont st (K.Failure err) where @@ -538,6 +515,7 @@ parseDToK pstep initial extract leftover (level, count) cont = do Continue n pst1 -> do assertM(n <= cnt1) return $ K.Continue n (parseCont (cnt1 - n) (return pst1)) + parseCont cnt acc Nothing = do pst <- acc r <- extract pst @@ -574,21 +552,6 @@ parserDone st (K.Success _ _) = error $ "Bug: fromParserK: inside alternative: " ++ show st parserDone _ (K.Failure e) = return $ K.Error e --- | When there is no more input to feed, extract the result from the Parser. --- --- /Pre-release/ --- -extractParse :: Monad m => (Maybe a -> m (K.Step m a b)) -> m (Step s b) -extractParse cont = do - r <- cont Nothing - case r of - K.Done n b -> return (Done n b) - K.Partial _ _ -> error "Bug: extractParse got Partial" - K.Continue _ cont1 -> extractParse cont1 - K.Error e -> return $ Error e - -data FromParserK b c = FPKDone !Int !b | FPKCont c - -- | Convert a CPS style 'K.Parser' to a direct style 'Parser'. -- -- "initial" returns a continuation which can be called one input at a time @@ -604,29 +567,28 @@ fromParserK parser = Parser step initial extract initial = do r <- K.runParser parser 0 (0,0) parserDone + -- XXX Just use a fromStepK to dedup this in initial/step/extract return $ case r of - K.Done n b -> IPartial $ FPKDone n b - K.Error e -> IError e - K.Partial _ cont -> IPartial $ FPKCont cont -- XXX can we get this? - K.Continue _ cont -> IPartial $ FPKCont cont - - -- Note, we can only reach FPKDone and FPKError from "initial". FPKCont - -- always transitions to only FPKCont. The input remains unconsumed in - -- this case so we use "n + 1". - step (FPKDone n b) _ = do - assertM(n == 0) - return $ Done (n + 1) b - step (FPKCont cont) a = do + K.Done n b -> Done n b + K.Error e -> Error e + K.Partial n cont -> Partial n cont -- XXX can we get this? + K.Continue n cont -> Continue n cont + + step cont a = do r <- cont (Just a) return $ case r of K.Done n b -> Done n b K.Error e -> Error e - K.Partial n cont1 -> Partial n (FPKCont cont1) - K.Continue n cont1 -> Continue n (FPKCont cont1) + K.Partial n cont1 -> Partial n cont1 + K.Continue n cont1 -> Continue n cont1 - -- Note, we can only reach FPKDone and FPKError from "initial". - extract (FPKDone n b) = return (Done n b) - extract (FPKCont cont) = extractParse cont + extract cont = do + r <- cont Nothing + return $ case r of + K.Done n b -> Done n b + K.Error e -> Error e + K.Partial _ _ -> error "Bug: extract got Partial" + K.Continue n cont1 -> Continue n cont1 #ifndef DISABLE_FUSION {-# RULES "fromParserK/toParserK fusion" [2] @@ -644,27 +606,23 @@ fromParserK parser = Parser step initial extract -- /Pre-release/ {-# INLINE rmapM #-} rmapM :: Monad m => (b -> m c) -> Parser m a b -> Parser m a c -rmapM f (Parser step initial extract) = - Parser step1 initial1 (extract >=> mapMStep f) +rmapM f (Parser step initial extract) = Parser step1 initial1 extract1 where - initial1 = do - res <- initial - -- this is mapM f over result - case res of - IPartial x -> return $ IPartial x - IDone a -> IDone <$> f a - IError err -> return $ IError err + initial1 = initial >>= mapMStep f + step1 s a = step s a >>= mapMStep f + extract1 = extract >=> mapMStep f + -- | See 'Streamly.Internal.Data.Parser.fromPure'. -- -- /Pre-release/ -- {-# INLINE_NORMAL fromPure #-} fromPure :: Monad m => b -> Parser m a b -fromPure b = Parser undefined (pure $ IDone b) undefined +fromPure b = Parser undefined (pure $ Done 0 b) undefined -- | See 'Streamly.Internal.Data.Parser.fromEffect'. -- @@ -672,7 +630,7 @@ fromPure b = Parser undefined (pure $ IDone b) undefined -- {-# INLINE fromEffect #-} fromEffect :: Monad m => m b -> Parser m a b -fromEffect b = Parser undefined (IDone <$> b) undefined +fromEffect b = Parser undefined (Done 0 <$> b) undefined ------------------------------------------------------------------------------- -- Sequential applicative @@ -702,18 +660,14 @@ serialWith func (Parser stepL initialL extractL) where initial = do - -- XXX We can use bimap here if we make this a Step type resL <- initialL case resL of - IPartial sl -> return $ IPartial $ SeqParseL sl - IDone bl -> do - resR <- initialR - -- XXX We can use bimap here if we make this a Step type - return $ case resR of - IPartial sr -> IPartial $ SeqParseR (func bl) sr - IDone br -> IDone (func bl br) - IError err -> IError err - IError err -> return $ IError err + Partial n sl -> return $ Partial n $ SeqParseL sl + Continue n sl -> return $ Continue n $ SeqParseL sl + Done n bl -> + let f = bimapOverrideCount n (SeqParseR (func bl)) (func bl) + in f <$> initialR + Error err -> return $ Error err -- Note: For the composed parse to terminate, the left parser has to be -- a terminating parser returning a Done at some point. @@ -721,7 +675,6 @@ serialWith func (Parser stepL initialL extractL) -- Important: Please do not use Applicative here. See -- https://github.com/composewell/streamly/issues/1033 and the problem -- defined in split_ for more info. - -- XXX Use bimap resL <- stepL st a case resL of -- Note: We need to buffer the input for a possible Alternative @@ -730,37 +683,33 @@ serialWith func (Parser stepL initialL extractL) -- buffered until we know that the applicative cannot fail. Partial n s -> return $ Continue n (SeqParseL s) Continue n s -> return $ Continue n (SeqParseL s) - Done n b -> do - -- XXX Use bimap if we make this a Step type - -- fmap (bimap (SeqParseR (func b)) (func b)) initialR - initR <- initialR - return $ case initR of - IPartial sr -> Continue n $ SeqParseR (func b) sr - IDone br -> Done n (func b br) - IError err -> Error err + Done n bl -> + let f = bimapOverrideCount n (SeqParseR (func bl)) (func bl) + in f <$> initialR Error err -> return $ Error err - step (SeqParseR f st) a = fmap (bimap (SeqParseR f) f) (stepR st a) + step (SeqParseR f st) a = bimap (SeqParseR f) f <$> stepR st a - extract (SeqParseR f sR) = fmap (bimap (SeqParseR f) f) (extractR sR) + extract (SeqParseR f sR) = bimap (SeqParseR f) f <$> extractR sR extract (SeqParseL sL) = do - -- XXX Use bimap here rL <- extractL sL case rL of + Partial _ _ -> error "Bug: serialWith extract 'Partial'" + Continue n s -> return $ Continue n (SeqParseL s) Done n bL -> do - -- XXX Use bimap here if we use Step type in Initial iR <- initialR case iR of - IPartial sR -> do - fmap - (bimap (SeqParseR (func bL)) (func bL)) - (extractR sR) - IDone bR -> return $ Done n $ func bL bR - IError err -> return $ Error err + Partial _ sR -> + -- XXX Need to add the previous n + bimap (SeqParseR (func bL)) (func bL) <$> extractR sR + Continue _ sR -> + -- XXX Need to add the previous n + bimap (SeqParseR (func bL)) (func bL) <$> extractR sR + Done _ bR -> return $ Done n $ func bL bR + Error err -> return $ Error err Error err -> return $ Error err - Partial _ _ -> error "Bug: serialWith extract 'Partial'" - Continue n s -> return $ Continue n (SeqParseL s) +{- ------------------------------------------------------------------------------- -- Sequential applicative for backtracking folds ------------------------------------------------------------------------------- @@ -1539,3 +1488,4 @@ filter f (Parser step initial extract) = Parser step1 initial extract where step1 x a = if f a then step x a else return $ Partial 0 x + -} diff --git a/default.nix b/default.nix index f50a575ca3..a7405188bc 100644 --- a/default.nix +++ b/default.nix @@ -5,9 +5,10 @@ { nixpkgs ? - import (builtins.fetchTarball https://github.com/NixOS/nixpkgs/archive/refs/tags/21.11.tar.gz) + import (builtins.fetchTarball + https://github.com/NixOS/nixpkgs/archive/refs/tags/22.05.tar.gz) {} -, compiler ? "default" +, compiler ? "ghc922" , c2nix ? "" # cabal2nix CLI options # TODO #, sources ? [] # e.g. [./. ./benchmark] @@ -63,14 +64,14 @@ let haskellPackages = # sha256 = "073wbhdxj1sh5160blaihbzkkhabs8s71pqhag16lvmgbb7a3hla"; # } {}; - unicode-data = - super.callHackageDirect - { pkg = "unicode-data"; - ver = "0.2.0"; - sha256 = "14crb68g79yyw87fgh49z2fn4glqx0zr53v6mapihaxzkikhkkc3"; - } {}; + #unicode-data = + # super.callHackageDirect + # { pkg = "unicode-data"; + # ver = "0.2.0"; + # sha256 = "14crb68g79yyw87fgh49z2fn4glqx0zr53v6mapihaxzkikhkkc3"; + # } {}; - tasty-bench = super.tasty-bench_0_3_1; + #tasty-bench = super.tasty-bench_0_3_1; #tasty-bench = # super.callHackageDirect