git.iko.soy/isoparsec
on master help sign in
Added extra operators and passthough combinators (#42)
ba2d36ciko
src/Control/SemiIso.hs+17
compare with master
unifiedsplit
@@ -17,12 +17,16 @@ module Control.SemiIso
17 assoc,
17 assoc,
18 ($$$),
18 ($$$),
19 (*>>),
19 (*>>),
20+ (&>>),
20 (**>),
21 (**>),
21 (>>*),
22 (>>*),
23+ (>>&),
22 (>**),
24 (>**),
23 (<<*),
25 (<<*),
26+ (<<&),
24 (<**),
27 (<**),
25 (*<<),
28 (*<<),
29+ (&<<),
26 (**<),
30 (**<),
27 )
31 )
28where
32where
@@ -31,6 +35,7 @@ import Control.Applicative as X
31import Control.Arrow.Extra
35import Control.Arrow.Extra
32import Control.Monad as X
36import Control.Monad as X
33import Data.Bitraversable
37import Data.Bitraversable
38+import Data.Tuple
34import Prelude hiding ((.), id)
39import Prelude hiding ((.), id)
35
40
36type AlternativeMonad m = (Alternative m, Monad m)
41type AlternativeMonad m = (Alternative m, Monad m)
@@ -116,24 +121,36 @@ a $$$ c = a *** c >>^ check (uncurry (==)) >>^ siPure fst (\x -> (x, x))
116(*>>) :: (PolyArrow m SemiIso) => m a () -> m a b -> m a b
121(*>>) :: (PolyArrow m SemiIso) => m a () -> m a b -> m a b
117a *>> b = a &&& b >>^ siPure snd ((),)
122a *>> b = a &&& b >>^ siPure snd ((),)
118
123
124+(&>>) :: (PolyArrow m SemiIso) => m a () -> m b c -> m (a, b) c
125+a &>> b = a *** b >>^ siPure snd ((),)
126+
119(**>) :: (PolyArrow m SemiIso) => m () () -> m a b -> m a b
127(**>) :: (PolyArrow m SemiIso) => m () () -> m a b -> m a b
120a **> b = siPure ((),) snd ^>> a *** b >>^ siPure snd ((),)
128a **> b = siPure ((),) snd ^>> a *** b >>^ siPure snd ((),)
121
129
122(>>*) :: (PolyArrow m SemiIso, Eq b) => m a b -> m () b -> m a b
130(>>*) :: (PolyArrow m SemiIso, Eq b) => m a b -> m () b -> m a b
123a >>* b = siPure (,()) fst ^>> a $$$ b
131a >>* b = siPure (,()) fst ^>> a $$$ b
124
132
133+(>>&) :: (PolyArrow m SemiIso) => m a b -> m () c -> m a (b, c)
134+a >>& b = siPure (,()) fst ^>> a *** b >>> undefined
135+
125(>**) :: (PolyArrow m SemiIso) => m a b -> m () () -> m a b
136(>**) :: (PolyArrow m SemiIso) => m a b -> m () () -> m a b
126a >** b = siPure (,()) fst ^>> a *** b >>^ siPure fst (,())
137a >** b = siPure (,()) fst ^>> a *** b >>^ siPure fst (,())
127
138
128(<<*) :: (PolyArrow m SemiIso, Eq b) => m a b -> m () b -> m a b
139(<<*) :: (PolyArrow m SemiIso, Eq b) => m a b -> m () b -> m a b
129a <<* b = siPure ((),) snd ^>> b $$$ a
140a <<* b = siPure ((),) snd ^>> b $$$ a
130
141
142+(<<&) :: (PolyArrow m SemiIso) => m a b -> m () c -> m a (b, c)
143+a <<& b = siPure ((),) snd ^>> b *** a >>^ siPure swap swap
144+
131(<**) :: (PolyArrow m SemiIso) => m a b -> m () () -> m a b
145(<**) :: (PolyArrow m SemiIso) => m a b -> m () () -> m a b
132a <** b = siPure ((),) snd ^>> b *** a >>^ siPure snd ((),)
146a <** b = siPure ((),) snd ^>> b *** a >>^ siPure snd ((),)
133
147
134(*<<) :: (PolyArrow m SemiIso) => m a () -> m a b -> m a b
148(*<<) :: (PolyArrow m SemiIso) => m a () -> m a b -> m a b
135a *<< b = b &&& a >>^ siPure fst (,())
149a *<< b = b &&& a >>^ siPure fst (,())
136
150
151+(&<<) :: (PolyArrow m SemiIso) => m a () -> m b c -> m (a, b) c
152+a &<< b = siPure swap swap ^>> b *** a >>^ siPure fst (,())
153+
137(**<) :: (PolyArrow m SemiIso) => m () () -> m a b -> m a b
154(**<) :: (PolyArrow m SemiIso) => m () () -> m a b -> m a b
138a **< b = siPure (,()) fst ^>> b *** a >>^ siPure fst (,())
155a **< b = siPure (,()) fst ^>> b *** a >>^ siPure fst (,())
139
156
src/Data/Isoparsec/Internal.hs+12−1
@@ -29,14 +29,25 @@ class
29 default token :: Eq (Element s) => Element s -> m () ()
29 default token :: Eq (Element s) => Element s -> m () ()
30 token x = anyToken >>^ turn (konst x)
30 token x = anyToken >>^ turn (konst x)
31
31
32+ token' :: m (Element s) (Element s)
33+ default token' :: Eq (Element s) => m (Element s) (Element s)
34+ token' = id >>& anyToken >>^ check (uncurry (==)) >>^ siPure fst (\x -> (x, x))
35+
32 tokens :: [Element s] -> m () ()
36 tokens :: [Element s] -> m () ()
33− default tokens :: [Element s] -> m () ()
34 tokens [] = arr $ isoConst () ()
37 tokens [] = arr $ isoConst () ()
35 tokens (t : ts) = token t &&& tokens ts >>^ isoConst ((), ()) ()
38 tokens (t : ts) = token t &&& tokens ts >>^ isoConst ((), ()) ()
36
39
40+ tokens' :: m [Element s] [Element s]
41+ tokens' = (turn siCons ^>> token' *** tokens' >>^ siCons) <+^ isoConst [] []
42+
37 chunk :: s -> m () ()
43 chunk :: s -> m () ()
38 chunk = tokens . otoList
44 chunk = tokens . otoList
39
45
46+ chunk' :: m s s
47+ chunk' = list ^>> tokens' >>^ turn list
48+ where
49+ list = siPure otoList fromList
50+
40 notToken :: Element s -> m () (Element s)
51 notToken :: Element s -> m () (Element s)
41 default notToken :: Eq (Element s) => Element s -> m () (Element s)
52 default notToken :: Eq (Element s) => Element s -> m () (Element s)
42 notToken t = tokenWhere (/= t)
53 notToken t = tokenWhere (/= t)