@@ -119,9 +119,10 @@ module Streamly.Internal.Data.Parser.ParserD
119119 , takeWhile1
120120 , dropWhile
121121
122− -- ** Single Element Separators
122+ -- ** Separated by elements
123123 -- | Separator could be in prefix postion ('takeStartBy'), or suffix
124− -- position ('takeEndBy').
124+ -- position ('takeEndBy'). See 'deintercalate', 'sepBy' etc for infix
125+ -- separator parsing, also see 'intersperseQuotedBy' fold.
125126
126127 -- These can be implemented modularly with refolds, using takeWhile and
127128 -- satisfy.
@@ -134,18 +135,29 @@ module Streamly.Internal.Data.Parser.ParserD
134135 , takeEitherSepBy
135136 , wordBy
136137
137− -- ** By comparing
138+ -- ** Grouped by element comparison
138139 , groupBy
139140 , groupByRolling
140141 , groupByRollingEither
141142
142− -- ** Framing
143+ -- ** Framed by elements
144+ -- | Also see 'intersperseQuotedBy' fold.
145+ -- Framed by a one or more ocurrences of a separator around a word like
146+ -- spaces or quotes. No nesting.
147+ , wordFramedBy -- XXX Remove this? Covered by wordWithQuotes?
148+ , wordWithQuotes
149+ , wordKeepQuotes
150+ , wordProcessQuotes
151+
152+ -- Framed by separate start and end characters, potentially nested.
153+ -- blockWithQuotes allows quotes inside a block. However,
154+ -- takeFramedByGeneric can be used to express takeStartBy, takeEndBy and
155+ -- block with escaping.
143156 -- , takeFramedBy
144157 , takeFramedBy_
145158 , takeFramedByEsc_
146159 , takeFramedByGeneric
147− , wordFramedBy
148− , wordQuotedBy
160+ , blockWithQuotes
149161
150162 -- Matching strings
151163 -- , prefixOf -- match any prefix of a given string
@@ -172,10 +184,35 @@ module Streamly.Internal.Data.Parser.ParserD
172184 -- , teeTill -- like manyTill but parallel
173185 -}
174186
175− -- ** Sequential Interleaving
187+ -- ** Sequential Alternative
188+ , alt
189+
190+ {-
191+ -- ** Parallel Alternatives
192+ , shortest
193+ , longest
194+ -- , fastest
195+ -}
196+
197+ -- * N-ary Combinators
198+ -- ** Sequential Collection
199+ , sequence
200+ , concatMap
201+
202+ -- ** Sequential Repetition
203+ , count
204+ , countBetween
205+ -- , countBetweenTill
206+ , manyP
207+ , many
208+ , some
209+
210+ -- ** Interleaved Repetition
176211 -- Use two folds, run a primary parser, its rejected values go to the
177212 -- secondary parser.
178213 , deintercalate
214+ , deintercalate1
215+ , deintercalateAll
179216 -- , deintercalatePrefix
180217 -- , deintercalateSuffix
181218
@@ -196,30 +233,8 @@ module Streamly.Internal.Data.Parser.ParserD
196233 -- @
197234 , sepBy1
198235 , sepBy
236+ , sepByAll
199237
200− -- ** Sequential Alternative
201− , alt
202−
203− {-
204− -- ** Parallel Alternatives
205− , shortest
206− , longest
207− -- , fastest
208− -}
209−
210− -- * N-ary Combinators
211− -- ** Sequential Collection
212− , sequence
213− , concatMap
214−
215− -- ** Sequential Repetition
216− , count
217− , countBetween
218− -- , countBetweenTill
219−
220− , manyP
221− , many
222− , some
223238 , manyTillP
224239 , manyTill
225240 , manyThen
@@ -1024,9 +1039,9 @@ data FramedEscState s =
10241039-- XXX We can remove Maybe from esc
10251040{-# INLINE takeFramedByGeneric #-}
10261041takeFramedByGeneric :: Monad m =>
1027− Maybe (a -> Bool)
1028− -> Maybe (a -> Bool)
1029− -> Maybe (a -> Bool)
1042+ Maybe (a -> Bool) -- is escape char?
1043+ -> Maybe (a -> Bool) -- is frame begin?
1044+ -> Maybe (a -> Bool) -- is frame end?
10301045 -> Fold m a b
10311046 -> Parser a m b
10321047takeFramedByGeneric esc begin end (Fold fstep finitial fextract) =
@@ -1119,6 +1134,94 @@ takeFramedByGeneric esc begin end (Fold fstep finitial fextract) =
11191134 Nothing -> err "takeFramedByGeneric: missing closing frame"
11201135 extract (FrameEscEsc _ _) = err "takeFramedByGeneric: trailing escape"
11211136
1137+data BlockParseState s =
1138+ BlockInit !s
1139+ | BlockUnquoted !Int !s
1140+ | BlockQuoted !Int !s
1141+ | BlockQuotedEsc !Int !s
1142+
1143+-- Blocks can be of different types e.g. {} or (). We only parse from the
1144+-- perspective of the outermost block type. The nesting of that block are
1145+-- checked. Any other block types nested inside it are opaque to us and can be
1146+-- parsed when the contents of the block are parsed.
1147+
1148+-- XXX Put a limit on nest level to keep the API safe.
1149+
1150+-- | Parse a block enclosed within open, close brackets. Block contents may be
1151+-- quoted, brackets inside quotes are ignored. Quoting characters can be used
1152+-- within quotes if escaped. A block can have a nested block inside it.
1153+--
1154+-- Quote begin and end chars are the same. Block brackets and quote chars must
1155+-- not overlap. Block start and end brackets must be different for nesting
1156+-- blocks within blocks.
1157+--
1158+-- >>> p = Parser.blockWithQuotes (== '\\') (== '"') '{' '}' Fold.toList
1159+-- >>> Stream.parse p $ Stream.fromList "{msg: \"hello world\"}"
1160+-- Right "msg: \"hello world\""
1161+--
1162+{-# INLINE blockWithQuotes #-}
1163+blockWithQuotes :: (Monad m, Eq a) =>
1164+ (a -> Bool) -- ^ escape char
1165+ -> (a -> Bool) -- ^ quote char, to quote inside brackets
1166+ -> a -- ^ Block opening bracket
1167+ -> a -- ^ Block closing bracket
1168+ -> Fold m a b
1169+ -> Parser a m b
1170+blockWithQuotes isEsc isQuote bopen bclose
1171+ (Fold fstep finitial fextract) =
1172+ Parser step initial extract
1173+
1174+ where
1175+
1176+ initial = do
1177+ res <- finitial
1178+ return $
1179+ case res of
1180+ FL.Partial s -> IPartial (BlockInit s)
1181+ FL.Done _ ->
1182+ error "blockWithQuotes: fold finished without input"
1183+
1184+ {-# INLINE process #-}
1185+ process s a nextState = do
1186+ res <- fstep s a
1187+ return
1188+ $ case res of
1189+ FL.Partial s1 -> Continue 0 (nextState s1)
1190+ FL.Done b -> Done 0 b
1191+
1192+ step (BlockInit s) a =
1193+ return
1194+ $ if a == bopen
1195+ then Continue 0 $ BlockUnquoted 1 s
1196+ else Error "blockWithQuotes: missing block start"
1197+ step (BlockUnquoted level s) a
1198+ | a == bopen = process s a (BlockUnquoted (level + 1))
1199+ | a == bclose =
1200+ if level == 1
1201+ then fmap (Done 0) (fextract s)
1202+ else process s a (BlockUnquoted (level - 1))
1203+ | isQuote a = process s a (BlockQuoted level)
1204+ | otherwise = process s a (BlockUnquoted level)
1205+ step (BlockQuoted level s) a
1206+ | isEsc a = process s a (BlockQuotedEsc level)
1207+ | otherwise =
1208+ if isQuote a
1209+ then process s a (BlockUnquoted level)
1210+ else process s a (BlockQuoted level)
1211+ step (BlockQuotedEsc level s) a = process s a (BlockQuoted level)
1212+
1213+ err = return . Error
1214+
1215+ extract (BlockInit s) = fmap (Done 0) $ fextract s
1216+ extract (BlockUnquoted level _) =
1217+ err $ "blockWithQuotes: finished at block nest level " ++ show level
1218+ extract (BlockQuoted level _) =
1219+ err $ "blockWithQuotes: finished, inside an unfinished quote, "
1220+ ++ "at block nest level " ++ show level
1221+ extract (BlockQuotedEsc level _) =
1222+ err $ "blockWithQuotes: finished, inside an unfinished quote, "
1223+ ++ "after an escape char, at block nest level " ++ show level
1224+
11221225-- | @takeEndBy cond parser@ parses a token that ends by a separator chosen by
11231226-- the supplied predicate. The separator is also taken with the token.
11241227--
@@ -1500,10 +1603,10 @@ data WordFramedState s b =
15001603--
15011604{-# INLINE wordFramedBy #-}
15021605wordFramedBy :: Monad m =>
1503− (a -> Bool) -- ^ Escape
1504− -> (a -> Bool) -- ^ left quote
1505− -> (a -> Bool) -- ^ right quote
1506− -> (a -> Bool) -- ^ word seperator
1606+ (a -> Bool) -- ^ Matches escape elem?
1607+ -> (a -> Bool) -- ^ Matches left quote?
1608+ -> (a -> Bool) -- ^ matches right quote?
1609+ -> (a -> Bool) -- ^ matches word separator?
15071610 -> Fold m a b
15081611 -> Parser a m b
15091612wordFramedBy isEsc isBegin isEnd isSep
@@ -1583,61 +1686,109 @@ wordFramedBy isEsc isBegin isEnd isSep
15831686data WordQuotedState s b a =
15841687 WordQuotedSkipPre !s
15851688 | WordUnquotedWord !s
1586− | WordQuotedWord !s !Int a
1689+ | WordQuotedWord !s !Int !a !a
15871690 | WordUnquotedEsc !s
1588− | WordQuotedEsc !s !Int a
1691+ | WordQuotedEsc !s !Int !a !a
15891692 | WordQuotedSkipPost !b
15901693
1591−-- | Like 'wordFramedBy' but the closing quote is determined by the opening
1592−-- quote. The first quote begin starts a quote that is closed by its
1593−-- corresponding closing quote.
1694+-- | Quote and bracket aware word splitting with escaping. Like 'wordBy' but
1695+-- word separators within specified quotes or brackets are ignored. Quotes and
1696+-- escape characters can be processed. If the end quote is different from the
1697+-- start quote it is called a bracket. The following quoting rules apply:
1698+--
1699+-- * In an unquoted string a character may be preceded by an escape character.
1700+-- The escape character is removed and the character following it is treated
1701+-- literally with no special meaning e.g. e.g. h\ e\ l\ l\ o is a single word,
1702+-- \n is same as n.
1703+-- * Any part of the word can be placed within quotes. Inside quotes all
1704+-- characters are treated literally with no special meaning. Quoting character
1705+-- itself cannot be used within quotes unless escape processing within quotes
1706+-- is applied to allow it.
1707+-- * Optionally escape processing for quoted part can be specified. Escape
1708+-- character has no special meaning inside quotes unless it is followed by a
1709+-- character that has a escape translation specified, in that case the escape
1710+-- character is removed, and the specified translation is applied to the
1711+-- character following it. This can be used to escape the quoting character
1712+-- itself within quotes.
1713+-- * There can be multiple quoting characters, when a quote starts, all other
1714+-- quoting characters within that quote lose any special meaning until the
1715+-- quote is closed.
1716+-- * A starting quote char without an ending char generates a parse error. An
1717+-- ending bracket char without a corresponding bracket begin is ignored.
1718+-- * Brackets can be nested.
1719+--
1720+-- We should note that unquoted and quoted escape processing are different. In
1721+-- unquoted part escape character is always removed. In quoted part it is
1722+-- removed only if followed by a special meaning character. This is consistent
1723+-- with how shell performs escape processing.
1724+
1725+-- Examples of quotes - "double quotes", 'single quotes', (parens), {braces},
1726+-- ((nested) brackets).
1727+--
1728+-- Example:
15941729--
1595−-- 'wordFramedBy' and 'wordQuotedBy' both allow multiple quote characters based
1596−-- on the predicates but 'wordQuotedBy' always fixes the quote at the first
1597−-- occurrence and then it is closed only by the corresponding closing quote.
1598−-- Therefore, other quoting characters can be embedded inside it as normal
1599−-- characters. On the other hand, 'wordFramedBy' would close the quote as soon
1600−-- as it encounters any of the closing quotes.
1730+-- >>> :{
1731+-- >>> q x =
1732+-- >>> case x of
1733+-- >>> '"' -> Just x
1734+-- >>> '\'' -> Just x
1735+-- >>> _ -> Nothing
1736+-- >>> :}
1737+--
1738+-- >>> p = Parser.wordKeepQuotes (== '\\') q isSpace Fold.toList
1739+-- >>> Stream.parse p $ Stream.fromList "a\"b'c\";'d\"e'f ghi"
1740+-- Right "a\"b'c\";'d\"e'f"
16011741--
1602−-- >>> q = (`elem` ['"', '\''])
1603−-- >>> p kQ = Parser.wordQuotedBy kQ (== '\\') q q id isSpace Fold.toList
1742+-- Note that outer quotes and backslashes from the input string are consumed by
1743+-- Haskell, therefore, the actual input string passed to the parser is:
1744+-- a"b'c";'d"e'f ghi
16041745--
1605−-- >>> Stream.parse (p False) $ Stream.fromList "a\"b'c\";'d\"e'f ghi"
1606−-- Right "ab'c;d\"ef"
1746+-- Similarly, when printing, double quotes are escaped by Haskell.
16071747--
1608−-- >>> Stream.parse (p True) $ Stream.fromList "a\"b'c\";'d\"e'f ghi"
1609−-- Right "a\"b'c\";'d\"e'f"
1748+-- Limitations:
16101749--
1611−{-# INLINE wordQuotedBy #-}
1612−wordQuotedBy :: (Monad m, Eq a) =>
1613− Bool -- ^ keep the quotes in the output
1614− -> (a -> Bool) -- ^ Escape
1615− -> (a -> Bool) -- ^ left quote
1616− -> (a -> Bool) -- ^ right quote
1617− -> (a -> a) -- ^ get right quote from the left quote
1618− -> (a -> Bool) -- ^ word seperator
1750+-- Shell like quote processing can be performed by using quote char specific
1751+-- escape processing, single quotes with no escapes, and double quotes with
1752+-- escapes.
1753+--
1754+-- JSON string processing can also be achieved except the "\uXXXX" style
1755+-- escaping for Unicode characters.
1756+--
1757+{-# INLINE wordWithQuotes #-}
1758+wordWithQuotes :: (Monad m, Eq a) =>
1759+ Bool -- ^ Retain the quotes and escape chars in the output
1760+ -> (a -> a -> Maybe a) -- ^ quote char -> escaped char -> translated char
1761+ -> a -- ^ Matches an escape elem?
1762+ -> (a -> Maybe a) -- ^ If left quote, return right quote, else Nothing.
1763+ -> (a -> Bool) -- ^ Matches a word separator?
16191764 -> Fold m a b
16201765 -> Parser a m b
1621−wordQuotedBy keepQuotes isEsc isBegin isEnd toRight isSep
1766+wordWithQuotes keepQuotes tr escChar toRight isSep
16221767 (Fold fstep finitial fextract) =
16231768 Parser step initial extract
16241769
16251770 where
16261771
1772+ -- Can be used to generate parse error for a bracket end without a bracket
1773+ -- begin.
1774+ isInvalid = const False
1775+
1776+ isEsc = (== escChar)
1777+
16271778 initial = do
16281779 res <- finitial
16291780 return $
16301781 case res of
16311782 FL.Partial s -> IPartial (WordQuotedSkipPre s)
16321783 FL.Done _ ->
1633− error "wordQuotedBy: fold done without input"
1784+ error "wordKeepQuotes: fold done without input"
16341785
1635− {-# INLINE process #-}
1636− process s a n q = do
1786+ {-# INLINE processQuoted #-}
1787+ processQuoted s a n ql qr = do
16371788 res <- fstep s a
16381789 return
16391790 $ case res of
1640− FL.Partial s1 -> Continue 0 (WordQuotedWord s1 n q)
1791+ FL.Partial s1 -> Continue 0 (WordQuotedWord s1 n ql qr)
16411792 FL.Done b -> Done 0 b
16421793
16431794 {-# INLINE processUnquoted #-}
@@ -1651,45 +1802,59 @@ wordQuotedBy keepQuotes isEsc isBegin isEnd toRight isSep
16511802 step (WordQuotedSkipPre s) a
16521803 | isEsc a = return $ Continue 0 $ WordUnquotedEsc s
16531804 | isSep a = return $ Partial 0 $ WordQuotedSkipPre s
1654− | isBegin a =
1655− if keepQuotes
1656− then process s a 1 a
1657− else return $ Continue 0 $ WordQuotedWord s 1 a
1658− | isEnd a =
1659− return $ Error "wordQuotedBy: missing frame start"
1660− | otherwise = processUnquoted s a
1805+ | otherwise =
1806+ case toRight a of
1807+ Just qr ->
1808+ if keepQuotes
1809+ then processQuoted s a 1 a qr
1810+ else return $ Continue 0 $ WordQuotedWord s 1 a qr
1811+ Nothing
1812+ | isInvalid a ->
1813+ return $ Error "wordKeepQuotes: invalid unquoted char"
1814+ | otherwise -> processUnquoted s a
16611815 step (WordUnquotedWord s) a
16621816 | isEsc a = return $ Continue 0 $ WordUnquotedEsc s
16631817 | isSep a = do
16641818 b <- fextract s
16651819 return $ Partial 0 $ WordQuotedSkipPost b
16661820 | otherwise = do
1667− if isBegin a
1668− then if keepQuotes
1669− then process s a 1 a
1670− else return $ Continue 0 $ WordQuotedWord s 1 a
1671− else if isEnd a
1672− then return $ Error "wordQuotedBy: missing frame start"
1821+ case toRight a of
1822+ Just qr ->
1823+ if keepQuotes
1824+ then processQuoted s a 1 a qr
1825+ else return $ Continue 0 $ WordQuotedWord s 1 a qr
1826+ Nothing ->
1827+ if isInvalid a
1828+ then return $ Error "wordKeepQuotes: invalid unquoted char"
16731829 else processUnquoted s a
1674− step (WordQuotedWord s n q) a
1675− | isEsc a = return $ Continue 0 $ WordQuotedEsc s n q
1830+ step (WordQuotedWord s n ql qr) a
1831+ | isEsc a = return $ Continue 0 $ WordQuotedEsc s n ql qr
1832+ {-
16761833 -- XXX Will this ever occur? Will n ever be 0?
16771834 | n == 0 && isSep a = do
16781835 b <- fextract s
16791836 return $ Partial 0 $ WordQuotedSkipPost b
1837+ -}
16801838 | otherwise = do
1681− if a == toRight q
1839+ if a == qr
16821840 then
16831841 if n == 1
16841842 then if keepQuotes
16851843 then processUnquoted s a
16861844 else return $ Continue 0 $ WordUnquotedWord s
1687− else process s a (n - 1) q
1688− else if a == q
1689− then process s a (n + 1) q
1690− else process s a n q
1845+ else processQuoted s a (n - 1) ql qr
1846+ else if a == ql
1847+ then processQuoted s a (n + 1) ql qr
1848+ else processQuoted s a n ql qr
16911849 step (WordUnquotedEsc s) a = processUnquoted s a
1692− step (WordQuotedEsc s n q) a = process s a n q
1850+ step (WordQuotedEsc s n ql qr) a =
1851+ case tr ql a of
1852+ Nothing -> do
1853+ res <- fstep s escChar
1854+ case res of
1855+ FL.Partial s1 -> processQuoted s1 a n ql qr
1856+ FL.Done b -> return $ Done 0 b
1857+ Just x -> processQuoted s x n ql qr
16931858 step (WordQuotedSkipPost b) a =
16941859 return
16951860 $ if not (isSep a)
@@ -1700,16 +1865,53 @@ wordQuotedBy keepQuotes isEsc isBegin isEnd toRight isSep
17001865
17011866 extract (WordQuotedSkipPre s) = fmap (Done 0) $ fextract s
17021867 extract (WordUnquotedWord s) = fmap (Done 0) $ fextract s
1703− extract (WordQuotedWord s n _) =
1868+ extract (WordQuotedWord s n _ _) =
17041869 if n == 0
17051870 then fmap (Done 0) $ fextract s
1706− else err "wordQuotedBy: missing frame end"
1871+ else err "wordWithQuotes: missing frame end"
17071872 extract WordQuotedEsc {} =
1708− err "wordQuotedBy: trailing escape"
1873+ err "wordWithQuotes: trailing escape"
17091874 extract (WordUnquotedEsc _) =
1710− err "wordQuotedBy: trailing escape"
1875+ err "wordWithQuotes: trailing escape"
17111876 extract (WordQuotedSkipPost b) = return (Done 0 b)
17121877
1878+-- | 'wordWithQuotes' without processing the quotes and escape function
1879+-- supplied to escape the quote char within a quote. Can be used to parse words
1880+-- keeping the quotes and escapes intact.
1881+--
1882+-- >>> wordKeepQuotes = Parser.wordWithQuotes True (\_ _ -> Nothing)
1883+--
1884+{-# INLINE wordKeepQuotes #-}
1885+wordKeepQuotes :: (Monad m, Eq a) =>
1886+ a -- ^ Escape char
1887+ -> (a -> Maybe a) -- ^ If left quote, return right quote, else Nothing.
1888+ -> (a -> Bool) -- ^ Matches a word separator?
1889+ -> Fold m a b
1890+ -> Parser a m b
1891+wordKeepQuotes =
1892+ -- Escape the quote char itself
1893+ wordWithQuotes True (\q x -> if q == x then Just x else Nothing)
1894+
1895+-- See the "Quoting Rules" section in the "bash" manual page for a primer on
1896+-- how quotes are used by shells.
1897+
1898+-- | 'wordWithQuotes' with quote processing applied and escape function
1899+-- supplied to escape the quote char within a quote. Can be ysed to parse words
1900+-- and processing the quoting and escaping at the same time.
1901+--
1902+-- >>> wordProcessQuotes = Parser.wordWithQuotes False (\_ _ -> Nothing)
1903+--
1904+{-# INLINE wordProcessQuotes #-}
1905+wordProcessQuotes :: (Monad m, Eq a) =>
1906+ a -- ^ Escape char
1907+ -> (a -> Maybe a) -- ^ If left quote, return right quote, else Nothing.
1908+ -> (a -> Bool) -- ^ Matches a word separator?
1909+ -> Fold m a b
1910+ -> Parser a m b
1911+wordProcessQuotes =
1912+ -- Escape the quote char itself
1913+ wordWithQuotes False (\q x -> if q == x then Just x else Nothing)
1914+
17131915{-# ANN type GroupByState Fuse #-}
17141916data GroupByState a s
17151917 = GroupByInit !s
@@ -2361,15 +2563,162 @@ lookAhead (Parser step1 initial1 _) = Parser step initial extract
23612563-- all the three parsers. One parser can count the line numbers to provide the
23622564-- line number info.
23632565
2364−data DeintercalateState fs sp ss =
2365− DeintercalateL !fs !sp
2366− | DeintercalateR !fs !ss !Bool
2566+{-# ANN type DeintercalateAllState Fuse #-}
2567+data DeintercalateAllState fs sp ss =
2568+ DeintercalateAllInitL !fs
2569+ | DeintercalateAllL !fs !sp
2570+ | DeintercalateAllInitR !fs
2571+ | DeintercalateAllR !fs !ss
23672572
23682573-- XXX rename this to intercalate
23692574
2575+-- Having deintercalateAll for accepting or rejecting entire input could be
2576+-- useful. For example, in case of JSON parsing we get an entire block of
2577+-- key-value pairs which we need to verify. This version may be simpler, more
2578+-- efficient. We could implement this as a stream operation like parseMany.
2579+--
2580+-- XXX Also, it may be a good idea to provide a parse driver for a fold. For
2581+-- example, in case of csv parsing as we are feeding a line to a fold we can
2582+-- parse it.
2583+
2584+-- | Like 'deintercalate' but the entire input must satisfy the pattern
2585+-- otherwise the parser fails. This is many times faster than deintercalate.
2586+--
2587+-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList
2588+-- >>> p2 = Parser.satisfy (== '+')
2589+-- >>> p = Parser.deintercalateAll p1 p2 Fold.toList
2590+-- >>> Stream.parse p $ Stream.fromList ""
2591+-- Right []
2592+-- >>> Stream.parse p $ Stream.fromList "1"
2593+-- Right [Left "1"]
2594+-- >>> Stream.parse p $ Stream.fromList "1+"
2595+-- Left (ParseError "takeWhile1: end of input")
2596+-- >>> Stream.parse p $ Stream.fromList "1+2+3"
2597+-- Right [Left "1",Right '+',Left "2",Right '+',Left "3"]
2598+--
2599+{-# INLINE deintercalateAll #-}
2600+deintercalateAll :: Monad m =>
2601+ Parser a m x
2602+ -> Parser a m y
2603+ -> Fold m (Either x y) z
2604+ -> Parser a m z
2605+deintercalateAll
2606+ (Parser stepL initialL extractL)
2607+ (Parser stepR initialR _)
2608+ (Fold fstep finitial fextract) = Parser step initial extract
2609+
2610+ where
2611+
2612+ errMsg p status =
2613+ error $ "deintercalate: " ++ p ++ " parser cannot "
2614+ ++ status ++ " without input"
2615+
2616+ initial = do
2617+ res <- finitial
2618+ case res of
2619+ FL.Partial fs -> return $ IPartial $ DeintercalateAllInitL fs
2620+ FL.Done c -> return $ IDone c
2621+
2622+ {-# INLINE processL #-}
2623+ processL foldAction n nextState = do
2624+ fres <- foldAction
2625+ case fres of
2626+ FL.Partial fs1 -> return $ Partial n (nextState fs1)
2627+ FL.Done c -> return $ Done n c
2628+
2629+ {-# INLINE runStepL #-}
2630+ runStepL fs sL a = do
2631+ r <- stepL sL a
2632+ case r of
2633+ Partial n s -> return $ Partial n (DeintercalateAllL fs s)
2634+ Continue n s -> return $ Continue n (DeintercalateAllL fs s)
2635+ Done n b ->
2636+ processL (fstep fs (Left b)) n DeintercalateAllInitR
2637+ Error err -> return $ Error err
2638+
2639+ {-# INLINE processR #-}
2640+ processR foldAction n = do
2641+ fres <- foldAction
2642+ case fres of
2643+ FL.Partial fs1 -> do
2644+ res <- initialL
2645+ case res of
2646+ IPartial ps -> return $ Partial n (DeintercalateAllL fs1 ps)
2647+ IDone _ -> errMsg "left" "succeed"
2648+ IError _ -> errMsg "left" "fail"
2649+ FL.Done c -> return $ Done n c
2650+
2651+ {-# INLINE runStepR #-}
2652+ runStepR fs sR a = do
2653+ r <- stepR sR a
2654+ case r of
2655+ Partial n s -> return $ Partial n (DeintercalateAllR fs s)
2656+ Continue n s -> return $ Continue n (DeintercalateAllR fs s)
2657+ Done n b -> processR (fstep fs (Right b)) n
2658+ Error err -> return $ Error err
2659+
2660+ step (DeintercalateAllInitL fs) a = do
2661+ res <- initialL
2662+ case res of
2663+ IPartial s -> runStepL fs s a
2664+ IDone _ -> errMsg "left" "succeed"
2665+ IError _ -> errMsg "left" "fail"
2666+ step (DeintercalateAllL fs sL) a = runStepL fs sL a
2667+ step (DeintercalateAllInitR fs) a = do
2668+ res <- initialR
2669+ case res of
2670+ IPartial s -> runStepR fs s a
2671+ IDone _ -> errMsg "right" "succeed"
2672+ IError _ -> errMsg "right" "fail"
2673+ step (DeintercalateAllR fs sR) a = runStepR fs sR a
2674+
2675+ {-# INLINE extractResult #-}
2676+ extractResult n fs r = do
2677+ res <- fstep fs r
2678+ case res of
2679+ FL.Partial fs1 -> fmap (Done n) $ fextract fs1
2680+ FL.Done c -> return (Done n c)
2681+ extract (DeintercalateAllInitL fs) = fmap (Done 0) $ fextract fs
2682+ extract (DeintercalateAllL fs sL) = do
2683+ r <- extractL sL
2684+ case r of
2685+ Done n b -> extractResult n fs (Left b)
2686+ Error err -> return $ Error err
2687+ Continue n s -> return $ Continue n (DeintercalateAllL fs s)
2688+ Partial _ _ -> error "Partial in extract"
2689+ extract (DeintercalateAllInitR fs) = fmap (Done 0) $ fextract fs
2690+ extract (DeintercalateAllR _ _) =
2691+ return $ Error "deintercalateAll: input ended at 'Right' value"
2692+
2693+{-# ANN type DeintercalateState Fuse #-}
2694+data DeintercalateState b fs sp ss =
2695+ DeintercalateInitL !fs
2696+ | DeintercalateL !Int !fs !sp
2697+ | DeintercalateInitR !fs
2698+ | DeintercalateR !Int !fs !ss
2699+ | DeintercalateRL !Int !b !fs !sp
2700+
2701+-- XXX Add tests that the next character that we take after running a parser is
2702+-- correct. Especially for the parsers that maintain a count. In the stream
2703+-- finished case (extract) as well as not finished case.
2704+
23702705-- | Apply two parsers alternately to an input stream. The input stream is
23712706-- considered an interleaving of two patterns. The two parsers represent the
2372−-- two patterns.
2707+-- two patterns. Parsing starts at the first parser and stops at the first
2708+-- parser. It can be used to parse a infix style pattern e.g. p1 p2 p1 . Empty
2709+-- input or single parse of the first parser is accepted.
2710+--
2711+-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList
2712+-- >>> p2 = Parser.satisfy (== '+')
2713+-- >>> p = Parser.deintercalate p1 p2 Fold.toList
2714+-- >>> Stream.parse p $ Stream.fromList ""
2715+-- Right []
2716+-- >>> Stream.parse p $ Stream.fromList "1"
2717+-- Right [Left "1"]
2718+-- >>> Stream.parse p $ Stream.fromList "1+"
2719+-- Right [Left "1"]
2720+-- >>> Stream.parse p $ Stream.fromList "1+2+3"
2721+-- Right [Left "1",Right '+',Left "2",Right '+',Left "3"]
23732722--
23742723{-# INLINE deintercalate #-}
23752724deintercalate :: Monad m =>
@@ -2379,7 +2728,163 @@ deintercalate :: Monad m =>
23792728 -> Parser a m z
23802729deintercalate
23812730 (Parser stepL initialL extractL)
2382− (Parser stepR initialR extractR)
2731+ (Parser stepR initialR _)
2732+ (Fold fstep finitial fextract) = Parser step initial extract
2733+
2734+ where
2735+
2736+ errMsg p status =
2737+ error $ "deintercalate: " ++ p ++ " parser cannot "
2738+ ++ status ++ " without input"
2739+
2740+ initial = do
2741+ res <- finitial
2742+ case res of
2743+ FL.Partial fs -> return $ IPartial $ DeintercalateInitL fs
2744+ FL.Done c -> return $ IDone c
2745+
2746+ {-# INLINE processL #-}
2747+ processL foldAction n nextState = do
2748+ fres <- foldAction
2749+ case fres of
2750+ FL.Partial fs1 -> return $ Partial n (nextState fs1)
2751+ FL.Done c -> return $ Done n c
2752+
2753+ {-# INLINE runStepL #-}
2754+ runStepL cnt fs sL a = do
2755+ let cnt1 = cnt + 1
2756+ r <- stepL sL a
2757+ case r of
2758+ Partial n s -> return $ Continue n (DeintercalateL (cnt1 - n) fs s)
2759+ Continue n s -> return $ Continue n (DeintercalateL (cnt1 - n) fs s)
2760+ Done n b ->
2761+ processL (fstep fs (Left b)) n DeintercalateInitR
2762+ Error _ -> do
2763+ xs <- fextract fs
2764+ return $ Done cnt1 xs
2765+
2766+ {-# INLINE processR #-}
2767+ processR cnt b fs n = do
2768+ res <- initialL
2769+ case res of
2770+ IPartial ps -> return $ Continue n (DeintercalateRL cnt b fs ps)
2771+ IDone _ -> errMsg "left" "succeed"
2772+ IError _ -> errMsg "left" "fail"
2773+
2774+ {-# INLINE runStepR #-}
2775+ runStepR cnt fs sR a = do
2776+ let cnt1 = cnt + 1
2777+ r <- stepR sR a
2778+ case r of
2779+ Partial n s -> return $ Continue n (DeintercalateR (cnt1 - n) fs s)
2780+ Continue n s -> return $ Continue n (DeintercalateR (cnt1 - n) fs s)
2781+ Done n b -> processR (cnt1 - n) b fs n
2782+ Error _ -> do
2783+ xs <- fextract fs
2784+ return $ Done cnt1 xs
2785+
2786+ step (DeintercalateInitL fs) a = do
2787+ res <- initialL
2788+ case res of
2789+ IPartial s -> runStepL 0 fs s a
2790+ IDone _ -> errMsg "left" "succeed"
2791+ IError _ -> errMsg "left" "fail"
2792+ step (DeintercalateL cnt fs sL) a = runStepL cnt fs sL a
2793+ step (DeintercalateInitR fs) a = do
2794+ res <- initialR
2795+ case res of
2796+ IPartial s -> runStepR 0 fs s a
2797+ IDone _ -> errMsg "right" "succeed"
2798+ IError _ -> errMsg "right" "fail"
2799+ step (DeintercalateR cnt fs sR) a = runStepR cnt fs sR a
2800+ step (DeintercalateRL cnt bR fs sL) a = do
2801+ let cnt1 = cnt + 1
2802+ r <- stepL sL a
2803+ case r of
2804+ Partial n s -> return $ Continue n (DeintercalateRL (cnt1 - n) bR fs s)
2805+ Continue n s -> return $ Continue n (DeintercalateRL (cnt1 - n) bR fs s)
2806+ Done n bL -> do
2807+ res <- fstep fs (Right bR)
2808+ case res of
2809+ FL.Partial fs1 -> do
2810+ fres <- fstep fs1 (Left bL)
2811+ case fres of
2812+ FL.Partial fs2 ->
2813+ return $ Partial n (DeintercalateInitR fs2)
2814+ FL.Done c -> return $ Done n c
2815+ -- XXX We could have the fold accept pairs of (bR, bL)
2816+ FL.Done _ -> error "Fold terminated consuming partial input"
2817+ Error _ -> do
2818+ xs <- fextract fs
2819+ return $ Done cnt1 xs
2820+
2821+ {-# INLINE extractResult #-}
2822+ extractResult n fs r = do
2823+ res <- fstep fs r
2824+ case res of
2825+ FL.Partial fs1 -> fmap (Done n) $ fextract fs1
2826+ FL.Done c -> return (Done n c)
2827+
2828+ extract (DeintercalateInitL fs) = fmap (Done 0) $ fextract fs
2829+ extract (DeintercalateL cnt fs sL) = do
2830+ r <- extractL sL
2831+ case r of
2832+ Done n b -> extractResult n fs (Left b)
2833+ Continue n s -> return $ Continue n (DeintercalateL (cnt - n) fs s)
2834+ Partial _ _ -> error "Partial in extract"
2835+ Error _ -> do
2836+ xs <- fextract fs
2837+ return $ Done cnt xs
2838+ extract (DeintercalateInitR fs) = fmap (Done 0) $ fextract fs
2839+ extract (DeintercalateR cnt fs _) = fmap (Done cnt) $ fextract fs
2840+ extract (DeintercalateRL cnt bR fs sL) = do
2841+ r <- extractL sL
2842+ case r of
2843+ Done n bL -> do
2844+ res <- fstep fs (Right bR)
2845+ case res of
2846+ FL.Partial fs1 -> extractResult n fs1 (Left bL)
2847+ FL.Done _ -> error "Fold terminated consuming partial input"
2848+ Continue n s -> return $ Continue n (DeintercalateRL (cnt - n) bR fs s)
2849+ Partial _ _ -> error "Partial in extract"
2850+ Error _ -> do
2851+ xs <- fextract fs
2852+ return $ Done cnt xs
2853+
2854+{-# ANN type Deintercalate1State Fuse #-}
2855+data Deintercalate1State b fs sp ss =
2856+ Deintercalate1InitL !Int !fs !sp
2857+ | Deintercalate1InitR !fs
2858+ | Deintercalate1R !Int !fs !ss
2859+ | Deintercalate1RL !Int !b !fs !sp
2860+
2861+-- | Apply two parsers alternately to an input stream. The input stream is
2862+-- considered an interleaving of two patterns. The two parsers represent the
2863+-- two patterns. Parsing starts at the first parser and stops at the first
2864+-- parser. It can be used to parse a infix style pattern e.g. p1 p2 p1 . Empty
2865+-- input or single parse of the first parser is accepted.
2866+--
2867+-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList
2868+-- >>> p2 = Parser.satisfy (== '+')
2869+-- >>> p = Parser.deintercalate1 p1 p2 Fold.toList
2870+-- >>> Stream.parse p $ Stream.fromList ""
2871+-- Left (ParseError "takeWhile1: end of input")
2872+-- >>> Stream.parse p $ Stream.fromList "1"
2873+-- Right [Left "1"]
2874+-- >>> Stream.parse p $ Stream.fromList "1+"
2875+-- Right [Left "1"]
2876+-- >>> Stream.parse p $ Stream.fromList "1+2+3"
2877+-- Right [Left "1",Right '+',Left "2",Right '+',Left "3"]
2878+--
2879+{-# INLINE deintercalate1 #-}
2880+deintercalate1 :: Monad m =>
2881+ Parser a m x
2882+ -> Parser a m y
2883+ -> Fold m (Either x y) z
2884+ -> Parser a m z
2885+deintercalate1
2886+ (Parser stepL initialL extractL)
2887+ (Parser stepR initialR _)
23832888 (Fold fstep finitial fextract) = Parser step initial extract
23842889
23852890 where
@@ -2392,93 +2897,150 @@ deintercalate
23922897 res <- finitial
23932898 case res of
23942899 FL.Partial fs -> do
2395− resL <- initialL
2396− case resL of
2397− IPartial sL -> return $ IPartial $ DeintercalateL fs sL
2900+ pres <- initialL
2901+ case pres of
2902+ IPartial s -> return $ IPartial $ Deintercalate1InitL 0 fs s
23982903 IDone _ -> errMsg "left" "succeed"
23992904 IError _ -> errMsg "left" "fail"
24002905 FL.Done c -> return $ IDone c
24012906
2402− step (DeintercalateL fs sL) a = do
2907+ {-# INLINE processL #-}
2908+ processL foldAction n nextState = do
2909+ fres <- foldAction
2910+ case fres of
2911+ FL.Partial fs1 -> return $ Partial n (nextState fs1)
2912+ FL.Done c -> return $ Done n c
2913+
2914+ {-# INLINE runStepInitL #-}
2915+ runStepInitL cnt fs sL a = do
2916+ let cnt1 = cnt + 1
24032917 r <- stepL sL a
24042918 case r of
2405− Partial n s -> return $ Partial n (DeintercalateL fs s)
2406− Continue n s -> return $ Continue n (DeintercalateL fs s)
2407− Done n b -> do
2408− fres <- fstep fs (Left b)
2409− case fres of
2410− FL.Partial fs1 -> do
2411− resR <- initialR
2412− case resR of
2413− IPartial sR ->
2414− return
2415− $ Partial n (DeintercalateR fs1 sR False)
2416− IDone _ -> errMsg "right" "succeed"
2417− IError _ -> errMsg "right" "fail"
2418− FL.Done c -> return $ Done n c
2919+ Partial n s -> return $ Continue n (Deintercalate1InitL (cnt1 - n) fs s)
2920+ Continue n s -> return $ Continue n (Deintercalate1InitL (cnt1 - n) fs s)
2921+ Done n b ->
2922+ processL (fstep fs (Left b)) n Deintercalate1InitR
24192923 Error err -> return $ Error err
2420− step (DeintercalateR fs sR consumed) a = do
2924+
2925+ {-# INLINE processR #-}
2926+ processR cnt b fs n = do
2927+ res <- initialL
2928+ case res of
2929+ IPartial ps -> return $ Continue n (Deintercalate1RL cnt b fs ps)
2930+ IDone _ -> errMsg "left" "succeed"
2931+ IError _ -> errMsg "left" "fail"
2932+
2933+ {-# INLINE runStepR #-}
2934+ runStepR cnt fs sR a = do
2935+ let cnt1 = cnt + 1
24212936 r <- stepR sR a
24222937 case r of
2423− Partial n s -> return $ Partial n (DeintercalateR fs s True)
2424− Continue n s -> return $ Continue n (DeintercalateR fs s True)
2425− Done n b ->
2426− if consumed
2427− then do
2428− fres <- fstep fs (Right b)
2429− case fres of
2430− FL.Partial fs1 -> do
2431− resL <- initialL
2432− case resL of
2433− IPartial sL ->
2434− return $ Partial n $ DeintercalateL fs1 sL
2435− IDone _ -> errMsg "left" "succeed"
2436− IError _ -> errMsg "left" "fail"
2437− FL.Done c -> return $ Done n c
2438− else error "deintercalate: infinite loop"
2439− Error err -> return $ Error err
2938+ Partial n s -> return $ Continue n (Deintercalate1R (cnt1 - n) fs s)
2939+ Continue n s -> return $ Continue n (Deintercalate1R (cnt1 - n) fs s)
2940+ Done n b -> processR (cnt1 - n) b fs n
2941+ Error _ -> do
2942+ xs <- fextract fs
2943+ return $ Done cnt1 xs
24402944
2441− {-# INLINE processResult #-}
2442− processResult n fs r = do
2945+ step (Deintercalate1InitL cnt fs sL) a = runStepInitL cnt fs sL a
2946+ step (Deintercalate1InitR fs) a = do
2947+ res <- initialR
2948+ case res of
2949+ IPartial s -> runStepR 0 fs s a
2950+ IDone _ -> errMsg "right" "succeed"
2951+ IError _ -> errMsg "right" "fail"
2952+ step (Deintercalate1R cnt fs sR) a = runStepR cnt fs sR a
2953+ step (Deintercalate1RL cnt bR fs sL) a = do
2954+ let cnt1 = cnt + 1
2955+ r <- stepL sL a
2956+ case r of
2957+ Partial n s -> return $ Continue n (Deintercalate1RL (cnt1 - n) bR fs s)
2958+ Continue n s -> return $ Continue n (Deintercalate1RL (cnt1 - n) bR fs s)
2959+ Done n bL -> do
2960+ res <- fstep fs (Right bR)
2961+ case res of
2962+ FL.Partial fs1 -> do
2963+ fres <- fstep fs1 (Left bL)
2964+ case fres of
2965+ FL.Partial fs2 ->
2966+ return $ Partial n (Deintercalate1InitR fs2)
2967+ FL.Done c -> return $ Done n c
2968+ -- XXX We could have the fold accept pairs of (bR, bL)
2969+ FL.Done _ -> error "Fold terminated consuming partial input"
2970+ Error _ -> do
2971+ xs <- fextract fs
2972+ return $ Done cnt1 xs
2973+
2974+ {-# INLINE extractResult #-}
2975+ extractResult n fs r = do
24432976 res <- fstep fs r
24442977 case res of
24452978 FL.Partial fs1 -> fmap (Done n) $ fextract fs1
24462979 FL.Done c -> return (Done n c)
24472980
2448− extract (DeintercalateL fs sL) = do
2981+ extract (Deintercalate1InitL cnt fs sL) = do
24492982 r <- extractL sL
24502983 case r of
2451− Done n b -> processResult n fs (Left b)
2452− Error err -> return $ Error err
2453− Continue n s -> return $ Continue n (DeintercalateL fs s)
2984+ Done n b -> extractResult n fs (Left b)
2985+ Continue n s -> return $ Continue n (Deintercalate1InitL (cnt - n) fs s)
24542986 Partial _ _ -> error "Partial in extract"
2455−
2456− extract (DeintercalateR fs sR consumed) = do
2457− r <- extractR sR
2458− case r of
2459− Done n b -> processResult n fs (Right b)
24602987 Error err -> return $ Error err
2461− -- XXX Review consumed
2462− Continue n s -> return $ Continue n (DeintercalateR fs s consumed)
2988+ extract (Deintercalate1InitR fs) = fmap (Done 0) $ fextract fs
2989+ extract (Deintercalate1R cnt fs _) = fmap (Done cnt) $ fextract fs
2990+ extract (Deintercalate1RL cnt bR fs sL) = do
2991+ r <- extractL sL
2992+ case r of
2993+ Done n bL -> do
2994+ res <- fstep fs (Right bR)
2995+ case res of
2996+ FL.Partial fs1 -> extractResult n fs1 (Left bL)
2997+ FL.Done _ -> error "Fold terminated consuming partial input"
2998+ Continue n s -> return $ Continue n (Deintercalate1RL (cnt - n) bR fs s)
24632999 Partial _ _ -> error "Partial in extract"
3000+ Error _ -> do
3001+ xs <- fextract fs
3002+ return $ Done cnt xs
24643003
3004+{-# ANN type SepByState Fuse #-}
24653005data SepByState fs sp ss =
2466− SepByInit !fs !sp
2467− | SepBySeparator !fs !ss !Bool
3006+ SepByInitL !fs
3007+ | SepByL !Int !fs !sp
3008+ | SepByInitR !fs
3009+ | SepByR !Int !fs !ss
24683010
2469−-- | Run the content parser first, when it is done, the separator parser is
2470−-- run, when it is done content parser is run again and so on. If none of the
2471−-- parsers consumes an input then parser returns a failure.
3011+-- | Apply two parsers alternately to an input stream. Parsing starts at the
3012+-- first parser and stops at the first parser. The output of the first parser
3013+-- is emiited and the output of the second parser is discarded. It can be used
3014+-- to parse a infix style pattern e.g. p1 p2 p1 . Empty input or single parse
3015+-- of the first parser is accepted.
3016+--
3017+-- Definitions:
24723018--
2473−-- >>> sepBy p1 p2 sink = Parser.deintercalate p1 p2 (Fold.catLefts sink)
2474−-- >>> sepBy content sep sink = Parser.sepBy1 content sep sink <|> return mempty
3019+-- >>> sepBy p1 p2 f = Parser.deintercalate p1 p2 (Fold.catLefts f)
3020+-- >>> sepBy p1 p2 f = Parser.sepBy1 p1 p2 f <|> Parser.fromEffect (Fold.extractM f)
3021+--
3022+-- Examples:
3023+--
3024+-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList
3025+-- >>> p2 = Parser.satisfy (== '+')
3026+-- >>> p = Parser.sepBy p1 p2 Fold.toList
3027+-- >>> Stream.parse p $ Stream.fromList ""
3028+-- Right []
3029+-- >>> Stream.parse p $ Stream.fromList "1"
3030+-- Right ["1"]
3031+-- >>> Stream.parse p $ Stream.fromList "1+"
3032+-- Right ["1"]
3033+-- >>> Stream.parse p $ Stream.fromList "1+2+3"
3034+-- Right ["1","2","3"]
24753035--
24763036{-# INLINE sepBy #-}
24773037sepBy :: Monad m =>
24783038 Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c
3039+-- This has similar performance as the custom impl below.
3040+-- sepBy p1 p2 f = deintercalate p1 p2 (FL.catLefts f)
24793041sepBy
2480− (Parser pstep pinitial pextract)
2481− (Parser sstep sinitial _)
3042+ (Parser stepL initialL extractL)
3043+ (Parser stepR initialR _)
24823044 (Fold fstep finitial fextract) = Parser step initial extract
24833045
24843046 where
@@ -2490,70 +3052,101 @@ sepBy
24903052 initial = do
24913053 res <- finitial
24923054 case res of
2493− FL.Partial fs -> do
2494− resP <- pinitial
2495− case resP of
2496− IPartial sp -> return $ IPartial $ SepByInit fs sp
2497− IDone _ -> errMsg "content" "succeed"
2498− IError _ -> errMsg "content" "fail"
2499− FL.Done b -> return $ IDone b
3055+ FL.Partial fs -> return $ IPartial $ SepByInitL fs
3056+ FL.Done c -> return $ IDone c
25003057
2501− step (SepByInit fs sp) a = do
2502− r <- pstep sp a
3058+ {-# INLINE processL #-}
3059+ processL foldAction n nextState = do
3060+ fres <- foldAction
3061+ case fres of
3062+ FL.Partial fs1 -> return $ Partial n (nextState fs1)
3063+ FL.Done c -> return $ Done n c
3064+
3065+ {-# INLINE runStepL #-}
3066+ runStepL cnt fs sL a = do
3067+ let cnt1 = cnt + 1
3068+ r <- stepL sL a
25033069 case r of
2504− Partial n s -> return $ Partial n (SepByInit fs s)
2505− Continue n s -> return $ Continue n (SepByInit fs s)
2506− Done n b -> do
2507− fres <- fstep fs b
2508− case fres of
2509− FL.Partial fs1 -> do
2510− resS <- sinitial
2511− case resS of
2512− IPartial ss ->
2513− return $ Partial n (SepBySeparator fs1 ss False)
2514− IDone _ -> errMsg "separator" "succeed"
2515− IError _ -> errMsg "separator" "fail"
2516− FL.Done c -> return $ Done n c
2517− Error err -> return $ Error err
2518− step (SepBySeparator fs ss consumed) a = do
2519− r <- sstep ss a
3070+ Partial n s -> return $ Continue n (SepByL (cnt1 - n) fs s)
3071+ Continue n s -> return $ Continue n (SepByL (cnt1 - n) fs s)
3072+ Done n b ->
3073+ processL (fstep fs b) n SepByInitR
3074+ Error _ -> do
3075+ xs <- fextract fs
3076+ return $ Done cnt1 xs
3077+
3078+ {-# INLINE processR #-}
3079+ processR cnt fs n = do
3080+ res <- initialL
3081+ case res of
3082+ IPartial ps -> return $ Continue n (SepByL cnt fs ps)
3083+ IDone _ -> errMsg "left" "succeed"
3084+ IError _ -> errMsg "left" "fail"
3085+
3086+ {-# INLINE runStepR #-}
3087+ runStepR cnt fs sR a = do
3088+ let cnt1 = cnt + 1
3089+ r <- stepR sR a
25203090 case r of
2521− Partial n s -> return $ Partial n (SepBySeparator fs s True)
2522− Continue n s -> return $ Continue n (SepBySeparator fs s True)
2523− Done n _ ->
2524− if consumed
2525− then do
2526− resP <- pinitial
2527− case resP of
2528− IPartial sp -> return $ Partial n $ SepByInit fs sp
2529− IDone _ -> errMsg "content" "succeed"
2530− IError _ -> errMsg "content" "fail"
2531− else error "sepBy: infinite loop"
2532− Error err -> return $ Error err
3091+ Partial n s -> return $ Continue n (SepByR (cnt1 - n) fs s)
3092+ Continue n s -> return $ Continue n (SepByR (cnt1 - n) fs s)
3093+ Done n _ -> processR (cnt1 - n) fs n
3094+ Error _ -> do
3095+ xs <- fextract fs
3096+ return $ Done cnt1 xs
3097+
3098+ step (SepByInitL fs) a = do
3099+ res <- initialL
3100+ case res of
3101+ IPartial s -> runStepL 0 fs s a
3102+ IDone _ -> errMsg "left" "succeed"
3103+ IError _ -> errMsg "left" "fail"
3104+ step (SepByL cnt fs sL) a = runStepL cnt fs sL a
3105+ step (SepByInitR fs) a = do
3106+ res <- initialR
3107+ case res of
3108+ IPartial s -> runStepR 0 fs s a
3109+ IDone _ -> errMsg "right" "succeed"
3110+ IError _ -> errMsg "right" "fail"
3111+ step (SepByR cnt fs sR) a = runStepR cnt fs sR a
3112+
3113+ {-# INLINE extractResult #-}
3114+ extractResult n fs r = do
3115+ res <- fstep fs r
3116+ case res of
3117+ FL.Partial fs1 -> fmap (Done n) $ fextract fs1
3118+ FL.Done c -> return (Done n c)
25333119
2534− extract (SepByInit fs sp) = do
2535− r <- pextract sp
3120+ extract (SepByInitL fs) = fmap (Done 0) $ fextract fs
3121+ extract (SepByL cnt fs sL) = do
3122+ r <- extractL sL
25363123 case r of
2537− Done n b -> do
2538− res <- fstep fs b
2539− case res of
2540− FL.Partial fs1 -> fmap (Done n) $ fextract fs1
2541− FL.Done c -> return (Done n c)
2542− Error err -> return $ Error err
2543− Continue n s -> return $ Continue n (SepByInit fs s)
3124+ Done n b -> extractResult n fs b
3125+ Continue n s -> return $ Continue n (SepByL (cnt - n) fs s)
25443126 Partial _ _ -> error "Partial in extract"
2545−
2546− extract (SepBySeparator fs _ _) = fmap (Done 0) $ fextract fs
3127+ Error _ -> do
3128+ xs <- fextract fs
3129+ return $ Done cnt xs
3130+ extract (SepByInitR fs) = fmap (Done 0) $ fextract fs
3131+ extract (SepByR cnt fs _) = fmap (Done cnt) $ fextract fs
3132+
3133+-- | Non-backtracking version of sepBy. Several times faster.
3134+{-# INLINE sepByAll #-}
3135+sepByAll :: Monad m =>
3136+ Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c
3137+sepByAll p1 p2 f = deintercalateAll p1 p2 (FL.catLefts f)
25473138
25483139-- XXX This can be implemented using refold, parse one and then continue
25493140-- collecting the rest in that.
25503141
2551−-- | Parse items separated by a separator parsed by the supplied parser. At
2552−-- least one item must be present for the parser to succeed.
2553−--
2554−-- Note that this can go in infinite loop if both the parsers fail on some
2555−-- input. Detection of that would make the implementation more complex.
2556−--
3142+{-# ANN type SepBy1State Fuse #-}
3143+data SepBy1State fs sp ss =
3144+ SepBy1InitL !Int !fs sp
3145+ | SepBy1L !Int !fs !sp
3146+ | SepBy1InitR !fs
3147+ | SepBy1R !Int !fs !ss
3148+
3149+{-
25573150{-# INLINE sepBy1 #-}
25583151sepBy1 :: Monad m =>
25593152 Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c
@@ -2562,6 +3155,139 @@ sepBy1 p sep sink = do
25623155 f <- fromEffect $ FL.reduce sink
25633156 f1 <- fromEffect $ FL.snoc f x
25643157 many (sep >> p) f1
3158+-}
3159+
3160+-- | Like 'sepBy' but requires at least one successful parse.
3161+--
3162+-- Definition:
3163+--
3164+-- >>> sepBy1 p1 p2 f = Parser.deintercalate1 p1 p2 (Fold.catLefts f)
3165+--
3166+-- Examples:
3167+--
3168+-- >>> p1 = Parser.takeWhile1 (not . (== '+')) Fold.toList
3169+-- >>> p2 = Parser.satisfy (== '+')
3170+-- >>> p = Parser.sepBy1 p1 p2 Fold.toList
3171+-- >>> Stream.parse p $ Stream.fromList ""
3172+-- Left (ParseError "takeWhile1: end of input")
3173+-- >>> Stream.parse p $ Stream.fromList "1"
3174+-- Right ["1"]
3175+-- >>> Stream.parse p $ Stream.fromList "1+"
3176+-- Right ["1"]
3177+-- >>> Stream.parse p $ Stream.fromList "1+2+3"
3178+-- Right ["1","2","3"]
3179+--
3180+{-# INLINE sepBy1 #-}
3181+sepBy1 :: Monad m =>
3182+ Parser a m b -> Parser a m x -> Fold m b c -> Parser a m c
3183+sepBy1
3184+ (Parser stepL initialL extractL)
3185+ (Parser stepR initialR _)
3186+ (Fold fstep finitial fextract) = Parser step initial extract
3187+
3188+ where
3189+
3190+ errMsg p status =
3191+ error $ "sepBy: " ++ p ++ " parser cannot "
3192+ ++ status ++ " without input"
3193+
3194+ initial = do
3195+ res <- finitial
3196+ case res of
3197+ FL.Partial fs -> do
3198+ pres <- initialL
3199+ case pres of
3200+ IPartial s -> return $ IPartial $ SepBy1InitL 0 fs s
3201+ IDone _ -> errMsg "left" "succeed"
3202+ IError _ -> errMsg "left" "fail"
3203+ FL.Done c -> return $ IDone c
3204+
3205+ {-# INLINE processL #-}
3206+ processL foldAction n nextState = do
3207+ fres <- foldAction
3208+ case fres of
3209+ FL.Partial fs1 -> return $ Partial n (nextState fs1)
3210+ FL.Done c -> return $ Done n c
3211+
3212+ {-# INLINE runStepInitL #-}
3213+ runStepInitL cnt fs sL a = do
3214+ let cnt1 = cnt + 1
3215+ r <- stepL sL a
3216+ case r of
3217+ Partial n s -> return $ Continue n (SepBy1InitL (cnt1 - n) fs s)
3218+ Continue n s -> return $ Continue n (SepBy1InitL (cnt1 - n) fs s)
3219+ Done n b ->
3220+ processL (fstep fs b) n SepBy1InitR
3221+ Error err -> return $ Error err
3222+
3223+ {-# INLINE runStepL #-}
3224+ runStepL cnt fs sL a = do
3225+ let cnt1 = cnt + 1
3226+ r <- stepL sL a
3227+ case r of
3228+ Partial n s -> return $ Continue n (SepBy1L (cnt1 - n) fs s)
3229+ Continue n s -> return $ Continue n (SepBy1L (cnt1 - n) fs s)
3230+ Done n b ->
3231+ processL (fstep fs b) n SepBy1InitR
3232+ Error _ -> do
3233+ xs <- fextract fs
3234+ return $ Done cnt1 xs
3235+
3236+ {-# INLINE processR #-}
3237+ processR cnt fs n = do
3238+ res <- initialL
3239+ case res of
3240+ IPartial ps -> return $ Continue n (SepBy1L cnt fs ps)
3241+ IDone _ -> errMsg "left" "succeed"
3242+ IError _ -> errMsg "left" "fail"
3243+
3244+ {-# INLINE runStepR #-}
3245+ runStepR cnt fs sR a = do
3246+ let cnt1 = cnt + 1
3247+ r <- stepR sR a
3248+ case r of
3249+ Partial n s -> return $ Continue n (SepBy1R (cnt1 - n) fs s)
3250+ Continue n s -> return $ Continue n (SepBy1R (cnt1 - n) fs s)
3251+ Done n _ -> processR (cnt1 - n) fs n
3252+ Error _ -> do
3253+ xs <- fextract fs
3254+ return $ Done cnt1 xs
3255+
3256+ step (SepBy1InitL cnt fs sL) a = runStepInitL cnt fs sL a
3257+ step (SepBy1L cnt fs sL) a = runStepL cnt fs sL a
3258+ step (SepBy1InitR fs) a = do
3259+ res <- initialR
3260+ case res of
3261+ IPartial s -> runStepR 0 fs s a
3262+ IDone _ -> errMsg "right" "succeed"
3263+ IError _ -> errMsg "right" "fail"
3264+ step (SepBy1R cnt fs sR) a = runStepR cnt fs sR a
3265+
3266+ {-# INLINE extractResult #-}
3267+ extractResult n fs r = do
3268+ res <- fstep fs r
3269+ case res of
3270+ FL.Partial fs1 -> fmap (Done n) $ fextract fs1
3271+ FL.Done c -> return (Done n c)
3272+
3273+ extract (SepBy1InitL cnt fs sL) = do
3274+ r <- extractL sL
3275+ case r of
3276+ Done n b -> extractResult n fs b
3277+ Continue n s -> return $ Continue n (SepBy1InitL (cnt - n) fs s)
3278+ Partial _ _ -> error "Partial in extract"
3279+ Error err -> return $ Error err
3280+ extract (SepBy1L cnt fs sL) = do
3281+ r <- extractL sL
3282+ case r of
3283+ Done n b -> extractResult n fs b
3284+ Continue n s -> return $ Continue n (SepBy1L (cnt - n) fs s)
3285+ Partial _ _ -> error "Partial in extract"
3286+ Error _ -> do
3287+ xs <- fextract fs
3288+ return $ Done cnt xs
3289+ extract (SepBy1InitR fs) = fmap (Done 0) $ fextract fs
3290+ extract (SepBy1R cnt fs _) = fmap (Done cnt) $ fextract fs
25653291
25663292-------------------------------------------------------------------------------
25673293-- Interleaving a collection of parsers