WIP splitCap rewrite

Author: jamesdbrock

src/Parsing/String/Replace.purs

@@ -69,21 +69,24 @@ module Parsing.String.Replace
 
 import Prelude
 
-import Control.Monad.Rec.Class (class MonadRec)
+import Control.Monad.Rec.Class (class MonadRec, Step(..), tailRecM)
 import Data.Either (Either(..), hush)
-import Data.List (List(..), (:))
-import Data.List.NonEmpty (NonEmptyList(..), fold1, singleton)
-import Data.Maybe (Maybe)
+import Data.List (List(..), foldl, uncons, (:))
+import Data.List.NonEmpty (NonEmptyList(..), fold1, fromList, singleton)
+import Data.Maybe (Maybe(..), fromJust)
 import Data.Newtype (unwrap, wrap)
 import Data.NonEmpty ((:|))
-import Data.String (null)
+import Data.String (CodePoint, null)
+import Data.String as CodePoint
+import Data.String as String
 import Data.String.CodeUnits as CodeUnits
 import Data.Traversable (for)
 import Data.Tuple (Tuple(..))
-import Data.Tuple.Nested (T3, (/\))
-import Parsing (ParseState(..), Parser, ParserT, getParserT, runParserT)
-import Parsing.Combinators (many, try)
-import Parsing.String (anyCodePoint, anyTill)
+import Data.Tuple.Nested (T3(..), Tuple3(..), (/\))
+import Parsing (ParseState(..), Parser, ParserT, Position(..), getParserT, position, runParserT)
+import Parsing.Combinators (many, optionMaybe, try)
+import Parsing.String (anyCodePoint, anyTill, rest)
+import Partial.Unsafe (unsafePartial)
 
 -- | Monad transformer version of `breakCap`. The `sep` parser will run
 -- | in the monad context.
@@ -208,50 +211,134 @@ breakCap input sep = unwrap $ breakCapT input sep
 -- | ```purescript
 -- | [Right ('A' /\ 1), Left " ", Right ('B' /\ 2)] /\ 2
 -- | ```
+
+
+-- splitCapT
+--   :: forall m a
+--    . Monad m
+--   => MonadRec m
+--   => String
+--   -> ParserT String m a
+--   -> m (NonEmptyList (Either String a))
+-- splitCapT input sep =
+--   -- We have to make sure we reasonably handle two cases:
+--   -- 1. The sep parser fails but consumes input
+--   -- 2. The sep parser succeeds but does not consume any input
+--   runParse >>= case _ of
+--     Left _ -> pure $ singleton $ Left input
+--     Right (Tuple xs remain) -> do
+--       let final = if null remain then Nil else (Left remain) : Nil
+--       let
+--         go Nil = final
+--         go ((Tuple "" result) : rest) =
+--           Right result : go rest
+--         go ((Tuple prefix result) : rest) =
+--           Left prefix : Right result : go rest
+--       case xs of
+--         Nil -> pure $ singleton $ Left input
+--         Cons (Tuple "" result) rest -> do
+--           let rest' = go rest
+--           pure $ NonEmptyList $ Right result :| rest'
+--         Cons (Tuple prefix result) rest -> do
+--           let rest' = go rest
+--           pure $ NonEmptyList $ Left prefix :| Right result : rest'
+--   where
+--   runParse = runParserT input $ do
+--     -- TODO forceProgress on every failed parse? can we do better?
+--     -- xs <- many (anyTill $ forceProgress sep)
+--     -- xs <- many (try $ forceProgress $ anyTill sep)
+--     xs <- many (try  anyTill sep)
+--     ParseState remain _ _ <- getParserT
+--     pure $ Tuple xs remain
+--   -- If the parser succeeds but consumes no input, then force it to skip
+--   -- ahead one char.
+--   forceProgress p = do
+--     ParseState remain0 _ _ <- getParserT
+--     x <- p
+--     ParseState remain1 _ _ <- getParserT
+--     if CodeUnits.length remain0 == CodeUnits.length remain1 then -- p succeeded but consumed nothing
+--
+--       anyCodePoint *> pure x
+--     else
+--       pure x
+
+
+
 splitCapT
   :: forall m a
    . Monad m
   => MonadRec m
   => String
   -> ParserT String m a
   -> m (NonEmptyList (Either String a))
-splitCapT input sep =
-  runParse >>= case _ of
-    Left _ -> pure $ singleton $ Left input
-    Right (Tuple xs remain) -> do
-      let final = if null remain then Nil else (Left remain) : Nil
-      let
-        go Nil = final
-        go ((Tuple "" result) : rest) =
-          Right result : go rest
-        go ((Tuple prefix result) : rest) =
-          Left prefix : Right result : go rest
-      case xs of
-        Nil -> pure $ singleton $ Left input
-        Cons (Tuple "" result) rest -> do
-          let rest' = go rest
-          pure $ NonEmptyList $ Right result :| rest'
-        Cons (Tuple prefix result) rest -> do
-          let rest' = go rest
-          pure $ NonEmptyList $ Left prefix :| Right result : rest'
+splitCapT input sep = do
+  -- We have to make sure we reasonably handle two cases:
+  -- 1. The sep parser fails but consumes input
+  -- 2. The sep parser succeeds but does not consume any input
+  runParserT input (Tuple <$> (splitCapCombinator sep) <*> rest) >>= case _ of
+    Left _ -> pure (singleton (Left input))
+    Right (Tuple (Tuple rlist _) remain) -> case uncons rlist of
+      Nothing -> pure (singleton (Left input))
+      Just {head: Tuple hunmatched hmatched ,tail} ->
+        let term =
+              if String.null remain then
+                if String.null hunmatched then
+                  (Right hmatched : Nil)
+                else
+                  (Left hunmatched : Right hmatched : Nil)
+              else
+                if String.null hunmatched then
+                  (Right hmatched : Left remain : Nil)
+                else
+                  (Left hunmatched : Right hmatched : Left remain : Nil)
+            list = foldl (\ls (Tuple unmatched matched) ->
+              if String.null unmatched then
+                (Right matched : ls)
+              else
+                (Left unmatched : Right matched : ls)
+              ) term tail
+        in
+        pure $ unsafePartial $ fromJust $ fromList list
+
+-- | Internal splitCap helper combinator. Returns
+-- | - the reversed `many anyTill` List
+-- | - the length of the nonempty tuple elements in the List.
+splitCapCombinator
+  :: forall m a
+   . Monad m
+  => ParserT String m a
+  -> ParserT String m (Tuple (List (Tuple String a)) Int)
+splitCapCombinator sep = tailRecM accum {lastPosIndex:0,carry:Nothing,list:Nil,arraySize:0}
   where
-  runParse = runParserT input $ do
-    -- TODO forceProgress on every failed parse? can we do better?
-    -- xs <- many (anyTill $ forceProgress sep)
-    xs <- many (try $ forceProgress $ anyTill sep)
-    ParseState remain _ _ <- getParserT
-    pure $ Tuple xs remain
-  -- If the parser succeeds but consumes no input, then force it to skip
-  -- ahead one char.
-  forceProgress p = do
-    ParseState remain0 _ _ <- getParserT
-    x <- p
-    ParseState remain1 _ _ <- getParserT
-    if CodeUnits.length remain0 == CodeUnits.length remain1 then -- p succeeded but consumed nothing
+    accum :: {lastPosIndex::Int,carry::Maybe CodePoint,list::List (Tuple String a),arraySize::Int} -> ParserT String m (Step {lastPosIndex::Int,carry::Maybe CodePoint,list::List (Tuple String a),arraySize::Int} (Tuple (List (Tuple String a)) Int))
+    accum {lastPosIndex,carry,list,arraySize} = do
+      optionMaybe (try $ anyTill sep) >>= case _ of
+        Just (Tuple unmatched matched) -> do
+          let
+            carry_unmatched = case carry of
+              Nothing -> unmatched
+              Just cp -> CodePoint.singleton cp <> unmatched
+          Position {index:posIndex} <- position
+          if posIndex == lastPosIndex then do
+            -- sep succeeded but consumed no input, so advance by one codepoint and
+            -- carry the codepoint over to cons to the next unmatched
+            carryNext <- anyCodePoint
+            pure $ Loop
+              { lastPosIndex: posIndex+1
+              , carry: Just carryNext
+              , list: (Tuple carry_unmatched matched : list)
+              , arraySize: if String.null unmatched then arraySize + 1 else arraySize + 2
+              }
+          else
+            pure $ Loop
+              { lastPosIndex: posIndex
+              , carry: Nothing
+              , list: (Tuple carry_unmatched matched : list)
+              , arraySize: if String.null unmatched then arraySize + 1 else arraySize + 2
+              }
+        Nothing -> -- no pattern found, so we're done
+          pure (Done (Tuple list arraySize))
 
-      anyCodePoint *> pure x
-    else
-      pure x
 
 -- | #### Split on and capture all patterns
 -- |
@@ -385,6 +472,7 @@ streamEditT
 streamEditT input sep editor = do
   sections <- splitCapT input sep
   -- TODO Is this fold1 efficient like mconcat?
+  -- Maybe we should use joinWith?
   map fold1 $ for sections $ case _ of
     Left l -> pure l
     Right r -> editor r

test/Main.purs

@@ -926,11 +926,11 @@ main = do
       }
   assertEqual' "splitCap8"
     { actual: splitCap "aa" (lookAhead $ string "a")
-    , expected: NonEmptyList $ Right "a" :| Right "a" : Nil
+    , expected: NonEmptyList $ Right "a" :| Left "a" : Right "a" : Left "a" : Nil
     }
   assertEqual' "splitCap8B"
     { actual: splitCap "BaBa" (lookAhead $ string "B")
-    , expected: NonEmptyList $ Right "B" :| Left "a" : Right "B" : Right "B" : Left "a" : Nil
+    , expected: NonEmptyList $ Right "B" :| Left "Ba" : Right "B" : Left "Ba" : Nil
     }
   assertEqual' "splitCap9" $
     let