@@ -4,14 +4,15 @@ module Data.Isoparsec.Internal
44 Isoparsec (..),
55 konst,
66 tsnok,
7− cons',
8− siJust,
7+ siCons,
8+ isoCheck,
99 siCheck,
10− siCheck',
1110 check,
1211 levitate,
1312 badKonst,
1413 badTsnok,
14+ unroll,
15+ arrowsWhile,
1516 )
1617where
1718
@@ -36,8 +37,8 @@ class
3637
3738 tokens :: [Token s] -> m () ()
3839 default tokens :: [Token s] -> m () ()
39− tokens [] = arr $ isoConst' () ()
40− tokens (t : ts) = token t &&& tokens ts >>> arr (isoConst' ((), ()) ())
40+ tokens [] = arr $ isoConst () ()
41+ tokens (t : ts) = token t &&& tokens ts >>> arr (isoConst ((), ()) ())
4142
4243 chunk :: s -> m () ()
4344 chunk = tokens . lowerTokens
@@ -58,15 +59,15 @@ class
5859 default takeUntil :: Eq (Token s) => s -> m () s
5960 takeUntil s = takeUntil' s >>^ levitate
6061 where
61− takeUntil' s' = (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ cons')
62+ takeUntil' s' = (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ siCons)
6263
6364 default tokensWhile :: (Token s -> Bool) -> m () s
6465 tokensWhile f =
6566 tokensWhile' f >>> check (P.all f) >>^ levitate
6667 where
6768 tokensWhile' g =
68− (tokenWhere g &&& tokensWhile' g >>^ cons')
69− <+^ isoConst' () []
69+ (tokenWhere g &&& tokensWhile' g >>^ siCons)
70+ <+^ isoConst () []
7071
7172 tokensWhile1 :: (Token s -> Bool) -> m () s
7273 tokensWhile1 f =
@@ -90,13 +91,21 @@ class
9091 -- > └─────┘ └─────┘
9192 tuck :: m () a -> m s a
9293
94+arrowsWhile :: (PolyArrow m SemiIso, ArrowPlus m) => m () a -> m () [a]
95+arrowsWhile f = ((f &&& arrowsWhile f) >>^ siCons) <+^ isoConst () []
96+
97+unroll :: (PolyArrow m SemiIso, ArrowPlus m, Eq a) => a -> m a (b, a) -> m () [b]
98+unroll a f = (konst a >>> unroll' f) <+^ isoConst () []
99+ where
100+ unroll' g = (g >>> second (unroll' g)) >>^ siCons
101+
93102levitateHead :: Alternative f => Tokenable s => s -> f (Token s, s)
94103levitateHead s = case lowerTokens s of
95104 (t : tt) -> pure (t, liftTokens tt)
96105 [] -> empty
97106
98−cons' :: SemiIso (t, [t]) [t]
99−cons' =
107+siCons :: SemiIso (t, [t]) [t]
108+siCons =
100109 SI
101110 (pure . uncurry (:))
102111 ( \case
@@ -105,35 +114,32 @@ cons' =
105114 )
106115
107116levitate :: Tokenable s => SemiIso [Token s] s
108−levitate = siJust liftTokens lowerTokens
117+levitate = siPure liftTokens lowerTokens
109118
110119class IsoparsecFail m e where
111120 failure :: e -> m a b
112121
113−siCheck' ::
122+siCheck ::
114123 (s -> Bool) ->
115124 (forall f. AlternativeMonad f => s -> f a) ->
116125 (forall f. AlternativeMonad f => a -> f s) ->
117126 SemiIso s a
118−siCheck' f a b =
127+siCheck f a b =
119128 SI
120129 (\c -> guard (f c) >> a c)
121130 (b >=> (\c -> guard (f c) >> pure c))
122131
123−siCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso s a
124−siCheck f a b = siCheck' f (pure . a) (pure . b)
125−
126−siJust :: (s -> a) -> (a -> s) -> SemiIso s a
127−siJust a b = SI (pure . a) (pure . b)
132+isoCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso s a
133+isoCheck f a b = siCheck f (pure . a) (pure . b)
128134
129−isoConst' :: s -> a -> SemiIso s a
130−isoConst' s a = SI (const $ pure a) (const $ pure s)
135+isoConst :: s -> a -> SemiIso s a
136+isoConst s a = SI (const $ pure a) (const $ pure s)
131137
132138konst :: (PolyArrow a SemiIso, Eq x) => x -> a () x
133−konst x = badKonst x >>> check (== x)
139+konst x = badKonst x ^>> check (== x)
134140
135−badKonst :: (PolyArrow a SemiIso) => x -> a () x
136−badKonst x = arr $ SI (const $ pure x) (const $ pure ())
141+badKonst :: x -> SemiIso () x
142+badKonst x = SI (const $ pure x) (const $ pure ())
137143
138144tsnok :: (PolyArrow a SemiIso, Eq x) => x -> a x ()
139145tsnok x = check (== x) >>> badTsnok x
@@ -142,4 +148,4 @@ badTsnok :: (PolyArrow a SemiIso) => x -> a x ()
142148badTsnok x = arr $ SI (const $ pure ()) (const $ pure x)
143149
144150check :: PolyArrow a SemiIso => (s -> Bool) -> a s s
145−check f = arr $ siCheck f id id
151+check f = arr $ isoCheck f id id