@@ -8,7 +8,6 @@ module Data.Isoparsec.Internal
88 isoCheck,
99 siCheck,
1010 check,
11− levitate,
1211 badKonst,
1312 badTsnok,
1413 unroll,
@@ -18,61 +17,53 @@ where
1817
1918import Control.Arrow.Extra
2019import Control.Monad
21−import Control.SemiIso as X
22−import Data.Isoparsec.Tokenable
20+import Control.SemiIso as X hiding (filterM, replicateM)
21+import Data.MonoTraversable as X
22+import Data.Sequences as X
2323import Numeric.Natural
2424import Prelude as P hiding ((.), id)
2525
2626class
27− (PolyArrow m SemiIso, ArrowPlus m, ArrowChoice m, Tokenable s) =>
27+ (PolyArrow m SemiIso, ArrowPlus m, ArrowChoice m, IsSequence s) =>
2828 Isoparsec m s
2929 | m -> s where
3030 {-# MINIMAL anyToken, manyTokens, tuck #-}
3131
32− anyToken :: m () (Token s)
32+ anyToken :: m () (Element s)
3333
34− token :: Token s -> m () ()
35− default token :: Eq (Token s) => Token s -> m () ()
36− token x = anyToken >>> tsnok x
34+ token :: Element s -> m () ()
35+ default token :: Eq (Element s) => Element s -> m () ()
36+ token x = anyToken >>^ tsnok x
3737
38− tokens :: [Token s] -> m () ()
39− default tokens :: [Token s] -> m () ()
38+ tokens :: [Element s] -> m () ()
39+ default tokens :: [Element s] -> m () ()
4040 tokens [] = arr $ isoConst () ()
4141 tokens (t : ts) = token t &&& tokens ts >>> arr (isoConst ((), ()) ())
4242
4343 chunk :: s -> m () ()
44− chunk = tokens . lowerTokens
44+ chunk = tokens . otoList
4545
46− notToken :: Token s -> m () (Token s)
47− default notToken :: Eq (Token s) => Token s -> m () (Token s)
46+ notToken :: Element s -> m () (Element s)
47+ default notToken :: Eq (Element s) => Element s -> m () (Element s)
4848 notToken t = tokenWhere (/= t)
4949
50− tokenWhere :: (Token s -> Bool) -> m () (Token s)
51− tokenWhere f =
52− anyToken >>> check f
50+ tokenWhere :: (Element s -> Bool) -> m () (Element s)
51+ tokenWhere f = anyToken >>^ check f
5352
5453 manyTokens :: m Natural s
5554
56− tokensWhile :: (Token s -> Bool) -> m () s
57−
5855 takeUntil :: s -> m () s
59− default takeUntil :: Eq (Token s) => s -> m () s
60− takeUntil s = takeUntil' s >>^ levitate
61− where
62− takeUntil' s' = (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ siCons)
56+ default takeUntil :: Eq s => s -> m () s
57+ takeUntil s = (chunk s >>^ konst mempty) <+> ((anyToken &&& takeUntil s) >>^ siCons)
6358
64− default tokensWhile :: (Token s -> Bool) -> m () s
59+ tokensWhile :: (Element s -> Bool) -> m () s
60+ default tokensWhile :: (Element s -> Bool) -> m () s
6561 tokensWhile f =
66− tokensWhile' f >>> check (P.all f) >>^ levitate
67− where
68− tokensWhile' g =
69− (tokenWhere g &&& tokensWhile' g >>^ siCons)
70− <+^ isoConst () []
62+ (((tokenWhere f >>^ check f) &&& tokensWhile f) >>^ siCons)
63+ <+^ isoConst () mempty
7164
72− tokensWhile1 :: (Token s -> Bool) -> m () s
73− tokensWhile1 f =
74− tokenWhere f &&& tokensWhile f
75− >>^ SI (\(a, aa) -> pure $ liftToken a <> aa) levitateHead
65+ tokensWhile1 :: (Element s -> Bool) -> m () s
66+ tokensWhile1 f = tokenWhere f &&& tokensWhile f >>^ siCons
7667
7768 -- | "tucks" the context of the parser into its input.
7869 -- > ┌─────┐
@@ -95,26 +86,15 @@ arrowsWhile :: (PolyArrow m SemiIso, ArrowPlus m) => m () a -> m () [a]
9586arrowsWhile f = ((f &&& arrowsWhile f) >>^ siCons) <+^ isoConst () []
9687
9788unroll :: (PolyArrow m SemiIso, ArrowPlus m, Eq a) => a -> m a (b, a) -> m () [b]
98−unroll a f = (konst a >>> unroll' f) <+^ isoConst () []
89+unroll a f = (konst a ^>> unroll' f) <+^ isoConst () []
9990 where
10091 unroll' g = (g >>> second (unroll' g)) >>^ siCons
10192
102−levitateHead :: Alternative f => Tokenable s => s -> f (Token s, s)
103−levitateHead s = case lowerTokens s of
104− (t : tt) -> pure (t, liftTokens tt)
105− [] -> empty
106−
107−siCons :: SemiIso (t, [t]) [t]
93+siCons :: IsSequence s => SemiIso (Element s, s) s
10894siCons =
109− SI
110− (pure . uncurry (:))
111− ( \case
112− (t : ts) -> pure (t, ts)
113− _ -> empty
114− )
115−
116−levitate :: Tokenable s => SemiIso [Token s] s
117−levitate = siPure liftTokens lowerTokens
95+ siMaybe
96+ (pure . uncurry cons)
97+ uncons
11898
11999class IsoparsecFail m e where
120100 failure :: e -> m a b
@@ -135,17 +115,17 @@ isoCheck f a b = siCheck f (pure . a) (pure . b)
135115isoConst :: s -> a -> SemiIso s a
136116isoConst s a = SI (const $ pure a) (const $ pure s)
137117
138−konst :: (PolyArrow a SemiIso, Eq x) => x -> a () x
139−konst x = badKonst x ^>> check (== x)
118+konst :: Eq x => x -> SemiIso () x
119+konst x = badKonst x >>> check (== x)
140120
141121badKonst :: x -> SemiIso () x
142122badKonst x = SI (const $ pure x) (const $ pure ())
143123
144−tsnok :: (PolyArrow a SemiIso, Eq x) => x -> a x ()
124+tsnok :: Eq x => x -> SemiIso x ()
145125tsnok x = check (== x) >>> badTsnok x
146126
147−badTsnok :: (PolyArrow a SemiIso) => x -> a x ()
148−badTsnok x = arr $ SI (const $ pure ()) (const $ pure x)
127+badTsnok :: x -> SemiIso x ()
128+badTsnok x = SI (const $ pure ()) (const $ pure x)
149129
150−check :: PolyArrow a SemiIso => (s -> Bool) -> a s s
151−check f = arr $ isoCheck f id id
130+check :: (s -> Bool) -> SemiIso s s
131+check f = isoCheck f id id