e622c05 · isoparsec · git.iko.soy

git.iko.soy/isoparsec

Transformers (#43)

* wip * wip * Removed orphans * new freearrow * Added arrowreader * Added reader transformer * Removed unneeded extension

commite622c054a394e0557a6c4eb01bab67e44ef01b6d authoriko <ilyakooo0@gmail.com> dateMon 2 Mar 2020, 12:14 (7 years ago) parent34fd837

22 files changed+313−118

compare with master

unifiedsplit

src/Control/Arrow/Extra.hs+3−3

@@ -22,11 +22,11 @@ infixl 5 ^+>

2222

2323infixl 5 ^+^

2424

25−(<+^) :: (ArrowPlus a, PolyArrow a p) => a b c -> p b c -> a b c

25+(<+^) :: (ArrowPlus a, PolyArrow p a) => a b c -> p b c -> a b c

2626a <+^ b = a <+> arr b

2727

28−(^+>) :: (ArrowPlus a, PolyArrow a p) => p b c -> a b c -> a b c

28+(^+>) :: (ArrowPlus a, PolyArrow p a) => p b c -> a b c -> a b c

2929a ^+> b = arr a <+> b

3030

31−(^+^) :: (ArrowPlus a, PolyArrow a p) => p b c -> p b c -> a b c

31+(^+^) :: (ArrowPlus a, PolyArrow p a) => p b c -> p b c -> a b c

3232a ^+^ b = arr a <+> arr b

src/Control/Arrow/Extra/Orphans.hs+1−1

@@ -29,7 +29,7 @@ instance {-# OVERLAPPABLE #-} (Category a, A.Arrow a) => BaseArrow a where

2929

3030 (&&&) = (A.&&&)

3131

32−instance A.Arrow a => PolyArrow a (->) where

32+instance A.Arrow a => PolyArrow (->) a where

3333 arr = A.arr

3434

3535instance {-# OVERLAPPABLE #-} A.ArrowPlus a => ArrowPlus a where

src/Control/Arrow/Extra/PolyArrow.hs+7−7

@@ -17,23 +17,23 @@ infixl 1 ^<<, <<^

1717

1818infixl 1 ^>^, ^<^

1919

20−class BaseArrow a => PolyArrow a p where

20+class BaseArrow a => PolyArrow p a where

2121 arr :: p b c -> a b c

2222

23−(^>>) :: PolyArrow a p => p b c -> a c d -> a b d

23+(^>>) :: PolyArrow p a => p b c -> a c d -> a b d

2424f ^>> a = arr f >>> a

2525

26−(>>^) :: PolyArrow a p => a b c -> p c d -> a b d

26+(>>^) :: PolyArrow p a => a b c -> p c d -> a b d

2727a >>^ f = a >>> arr f

2828

29−(<<^) :: PolyArrow a p => a c d -> p b c -> a b d

29+(<<^) :: PolyArrow p a => a c d -> p b c -> a b d

3030a <<^ f = a <<< arr f

3131

32−(^<<) :: PolyArrow a p => p c d -> a b c -> a b d

32+(^<<) :: PolyArrow p a => p c d -> a b c -> a b d

3333f ^<< a = arr f <<< a

3434

35−(^>^) :: PolyArrow a p => p b c -> p c d -> a b d

35+(^>^) :: PolyArrow p a => p b c -> p c d -> a b d

3636a ^>^ b = arr a >>> arr b

3737

38−(^<^) :: PolyArrow a p => p c d -> p b c -> a b d

38+(^<^) :: PolyArrow p a => p c d -> p b c -> a b d

3939a ^<^ b = arr a <<< arr b

src/Control/Arrow/Reader.hsnew file+34

@@ -0,0 +1,34 @@

1+module Control.Arrow.Reader

2+ ( ArrowReader (..),

3+ asksr,

4+ asksl,

5+ biask,

6+ biasks,

7+ module Control.Arrow.Trans.Reader,

8+ )

9+where

10+

11+import Control.Arrow.Extra

12+import Control.Arrow.Trans.Reader

13+import Control.SemiIso

14+import Prelude hiding ((.), id)

15+

16+class ArrowReader r a where

17+ askr :: a () r

18+ askl :: a r ()

19+

20+instance (PolyArrow SemiIso a, Eq r) => ArrowReader r (ReaderArrow r a) where

21+ askr = ReaderArrow . arr $ siFst >>> siDouble

22+ askl = ReaderArrow . arr $ turn siDouble >>> turn siFst

23+

24+asksr :: (PolyArrow SemiIso a, ArrowReader r a) => SemiIso r s -> a () s

25+asksr si = askr >>^ si

26+

27+asksl :: (PolyArrow SemiIso a, ArrowReader r a) => SemiIso r s -> a s ()

28+asksl si = turn si ^>> askl

29+

30+biask :: (ArrowReader r a, Category a) => a r r -> a () ()

31+biask a = askr >>> a >>> askl

32+

33+biasks :: (ArrowReader r a, PolyArrow SemiIso a) => SemiIso r s -> a s s -> a () ()

34+biasks si a = asksr si >>> a >>> asksl si

src/Control/Arrow/Trans/Class.hsnew file+9

@@ -0,0 +1,9 @@

1+module Control.Arrow.Trans.Class

2+ ( ArrowTrans (..),

3+ )

4+where

6+import Control.Arrow.Extra

8+class ArrowTrans s where

9+ raise :: BaseArrow a => a b c -> s a b c

src/Control/Arrow/Trans/Reader.hsnew file+53

@@ -0,0 +1,53 @@

1+module Control.Arrow.Trans.Reader

2+ ( ReaderArrow (..),

3+ runReaderArrow,

4+ module Control.Arrow.Trans.Class,

5+ )

6+where

8+import Control.Arrow.Extra

9+import Control.Arrow.Trans.Class

10+import Control.SemiIso

11+import Prelude hiding ((.), fail, id)

12+

13+newtype ReaderArrow r s a b

14+ = ReaderArrow {unReaderArrow :: s (r, a) (r, b)}

15+

16+instance BaseArrow a => Category (ReaderArrow r a) where

17+ id = ReaderArrow . second $ id

18+ (ReaderArrow lhs) . (ReaderArrow rhs) = ReaderArrow $ lhs . rhs

19+

20+instance (PolyArrow p a, PolyArrow SemiIso a, Eq r) => PolyArrow p (ReaderArrow r a) where

21+ arr = ReaderArrow . second . arr

22+

23+instance (BaseArrow a, PolyArrow SemiIso a, Eq r) => BaseArrow (ReaderArrow r a) where

24+ (ReaderArrow lhs) *** (ReaderArrow rhs) =

25+ ReaderArrow $

26+ siDouble *** id

27+ ^>^ turn siTranspose2

28+ >>> lhs *** rhs

29+ >>^ siTranspose2

30+ >>^ turn siDouble *** id

31+ (ReaderArrow lhs) &&& (ReaderArrow rhs) =

32+ ReaderArrow $

33+ lhs &&& rhs

34+ >>^ siTranspose2

35+ >>^ turn siDouble *** id

36+

37+instance (ArrowZero a, BaseArrow (ReaderArrow r a)) => ArrowZero (ReaderArrow r a) where

38+ zeroArrow = ReaderArrow $ id *** zeroArrow

39+

40+instance (ArrowPlus a, ArrowZero (ReaderArrow r a)) => ArrowPlus (ReaderArrow r a) where

41+ (ReaderArrow lhs) <+> (ReaderArrow rhs) = ReaderArrow $ lhs <+> rhs

42+

43+instance (ArrowChoice a, PolyArrow SemiIso a, Eq r) => ArrowChoice (ReaderArrow r a) where

44+ (ReaderArrow lhs) ||| (ReaderArrow rhs) = ReaderArrow $ siSequenceEither ^>> lhs ||| rhs

45+ (ReaderArrow lhs) +++ (ReaderArrow rhs) =

46+ ReaderArrow $ siSequenceEither ^>> lhs +++ rhs >>^ turn siSequenceEither

47+

48+runReaderArrow :: (PolyArrow SemiIso s, Eq r) => r -> ReaderArrow r s a b -> s a b

49+runReaderArrow r a =

50+ turn siSnd >>> first (konst r) ^>> unReaderArrow a >>^ (first . turn $ konst r) >>^ siSnd

51+

52+instance ArrowTrans (ReaderArrow r) where

53+ raise = ReaderArrow . second

src/Data/Isoparsec/Cokleisli.hs → src/Control/Cokleisli.hsrenamed+4−4

@@ -1,4 +1,4 @@

1−module Data.Isoparsec.Cokleisli

1+module Control.Cokleisli

22 ( Cokleisli (..),

33 )

44where

@@ -6,10 +6,10 @@ where

66import Control.Applicative

77import Control.Arrow.Extra

88import Control.Monad

9−import Data.Isoparsec.Internal

9+import Control.SemiIso

1010import Prelude hiding ((.))

1111

12−newtype Cokleisli m a b = Cokleisli {unCokleisli :: b -> m a}

12+newtype Cokleisli m a b = Cokleisli {runCokleisli :: b -> m a}

1313

1414instance Monad m => Category (Cokleisli m) where

1515 id = Cokleisli return

@@ -26,7 +26,7 @@ instance (Alternative m, Monad m) => BaseArrow (Cokleisli m) where

2626 (Cokleisli cb) &&& (Cokleisli c'b) = Cokleisli $

2727 \(c, c') -> c'b c' >> cb c

2828

29−instance (Alternative m, Monad m) => PolyArrow (Cokleisli m) SemiIso where

29+instance (Alternative m, Monad m) => PolyArrow SemiIso (Cokleisli m) where

3030 arr si = Cokleisli $ \t -> project si t

3131

3232instance MonadPlus m => ArrowZero (Cokleisli m) where

src/Control/SemiIso.hs+52−26

@@ -28,12 +28,19 @@ module Control.SemiIso

2828 (*<<),

2929 (&<<),

3030 (**<),

31+ siFst,

32+ siSnd,

33+ siDouble,

34+ siSwap,

35+ siTranspose2,

36+ siSequenceEither,

3137 )

3238where

3339

3440import Control.Applicative as X

3541import Control.Arrow.Extra

3642import Control.Monad as X

43+import qualified Data.Bifunctor as Bi

3744import Data.Bitraversable

3845import Data.Tuple

3946import Prelude hiding ((.), id)

@@ -115,44 +122,44 @@ infixl 1 *>>, **>, >>*, >**, <<*, <**, *<<, **<

115122

116123infixl 3 $$$

117124

118−($$$) :: (PolyArrow m SemiIso, Eq b) => m a b -> m c b -> m (a, c) b

119−a $$$ c = a *** c >>^ check (uncurry (==)) >>^ siPure fst (\x -> (x, x))

125+($$$) :: (PolyArrow SemiIso m, Eq b) => m a b -> m c b -> m (a, c) b

126+a $$$ c = a *** c >>^ turn siDouble

120127

121−(*>>) :: (PolyArrow m SemiIso) => m a () -> m a b -> m a b

122−a *>> b = a &&& b >>^ siPure snd ((),)

128+(*>>) :: (PolyArrow SemiIso m) => m a () -> m a b -> m a b

129+a *>> b = a &&& b >>^ siSnd

123130

124−(&>>) :: (PolyArrow m SemiIso) => m a () -> m b c -> m (a, b) c

125−a &>> b = a *** b >>^ siPure snd ((),)

131+(&>>) :: (PolyArrow SemiIso m) => m a () -> m b c -> m (a, b) c

132+a &>> b = a *** b >>^ siSnd

126133

127−(**>) :: (PolyArrow m SemiIso) => m () () -> m a b -> m a b

128−a **> b = siPure ((),) snd ^>> a *** b >>^ siPure snd ((),)

134+(**>) :: (PolyArrow SemiIso m) => m () () -> m a b -> m a b

135+a **> b = turn siSnd ^>> a *** b >>^ siSnd

129136

130−(>>*) :: (PolyArrow m SemiIso, Eq b) => m a b -> m () b -> m a b

131−a >>* b = siPure (,()) fst ^>> a $$$ b

137+(>>*) :: (PolyArrow SemiIso m, Eq b) => m a b -> m () b -> m a b

138+a >>* b = turn siFst ^>> a $$$ b

132139

133−(>>&) :: (PolyArrow m SemiIso) => m a b -> m () c -> m a (b, c)

134−a >>& b = siPure (,()) fst ^>> a *** b >>> undefined

140+(>>&) :: (PolyArrow SemiIso m) => m a b -> m () c -> m a (b, c)

141+a >>& b = turn siFst ^>> a *** b

135142

136−(>**) :: (PolyArrow m SemiIso) => m a b -> m () () -> m a b

137−a >** b = siPure (,()) fst ^>> a *** b >>^ siPure fst (,())

143+(>**) :: (PolyArrow SemiIso m) => m a b -> m () () -> m a b

144+a >** b = turn siFst ^>> a *** b >>^ siFst

138145

139−(<<*) :: (PolyArrow m SemiIso, Eq b) => m a b -> m () b -> m a b

140−a <<* b = siPure ((),) snd ^>> b $$$ a

146+(<<*) :: (PolyArrow SemiIso m, Eq b) => m a b -> m () b -> m a b

147+a <<* b = turn siSnd ^>> b $$$ a

141148

142−(<<&) :: (PolyArrow m SemiIso) => m a b -> m () c -> m a (b, c)

143−a <<& b = siPure ((),) snd ^>> b *** a >>^ siPure swap swap

149+(<<&) :: (PolyArrow SemiIso m) => m a b -> m () c -> m a (b, c)

150+a <<& b = turn siSnd ^>> b *** a >>^ siSwap

144151

145−(<**) :: (PolyArrow m SemiIso) => m a b -> m () () -> m a b

146−a <** b = siPure ((),) snd ^>> b *** a >>^ siPure snd ((),)

152+(<**) :: (PolyArrow SemiIso m) => m a b -> m () () -> m a b

153+a <** b = turn siSnd ^>> b *** a >>^ siSnd

147154

148−(*<<) :: (PolyArrow m SemiIso) => m a () -> m a b -> m a b

149−a *<>^ siPure fst (,())

155+(*<<) :: (PolyArrow SemiIso m) => m a () -> m a b -> m a b

156+a *<>^ siFst

150157

151−(&<<) :: (PolyArrow m SemiIso) => m a () -> m b c -> m (a, b) c

152−a &<> b *** a >>^ siPure fst (,())

158+(&<<) :: (PolyArrow SemiIso m) => m a () -> m b c -> m (a, b) c

159+a &<> b *** a >>^ siFst

153160

154−(**<) :: (PolyArrow m SemiIso) => m () () -> m a b -> m a b

155−a **> b *** a >>^ siPure fst (,())

161+(**<) :: (PolyArrow SemiIso m) => m () () -> m a b -> m a b

162+a **> b *** a >>^ siFst

156163

157164check :: (s -> Bool) -> SemiIso s s

158165check f = isoCheck f id id

@@ -178,3 +185,22 @@ konst x = isoConst () x >>> check (== x)

178185

179186assoc :: SemiIso (a, (b, c)) ((a, b), c)

180187assoc = siPure (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))

188+

189+siFst :: SemiIso (a, ()) a

190+siFst = siPure fst (,())

191+

192+siSnd :: SemiIso ((), a) a

193+siSnd = siPure snd ((),)

194+

195+siDouble :: (Eq a) => SemiIso a (a, a)

196+siDouble = siPure (\x -> (x, x)) fst >>> check (uncurry (==))

197+

198+siSwap :: SemiIso (a, b) (b, a)

199+siSwap = siPure swap swap

200+

201+siTranspose2 :: SemiIso ((a, b), (c, d)) ((a, c), (b, d))

202+siTranspose2 =

203+ siPure (\((r1, b), (r2, c)) -> ((r1, r2), (b, c))) (\((r1, r2), (b, c)) -> ((r1, b), (r2, c)))

204+

205+siSequenceEither :: SemiIso (r, Either a b) (Either (r, a) (r, b))

206+siSequenceEither = siPure (\(r, e) -> Bi.bimap (r,) (r,) e) (either (Bi.second Left) (Bi.second Right))

src/Data/Isoparsec.hs+8−8

@@ -25,19 +25,19 @@ import Data.Isoparsec.ToIsoparsec as X

2525import qualified Data.Map as M

2626import Prelude hiding ((.), fail, id)

2727

28−opt :: (ArrowPlus m, PolyArrow m SemiIso) => m () () -> m () ()

28+opt :: (ArrowPlus m, PolyArrow SemiIso m) => m () () -> m () ()

2929opt m = m <+^ konst ()

3030

31−opt' :: (ArrowPlus m, PolyArrow m SemiIso, Eq a) => a -> m () a -> m () ()

31+opt' :: (ArrowPlus m, PolyArrow SemiIso m, Eq a) => a -> m () a -> m () ()

3232opt' a m = opt (m >>^ turn (konst a))

3333

34−repeating :: (PolyArrow m SemiIso, ArrowPlus m, Eq b) => m () b -> m () [b]

34+repeating :: (PolyArrow SemiIso m, ArrowPlus m, Eq b) => m () b -> m () [b]

3535repeating m = (m &&& (repeating m <+^ konst [])) >>^ siCons

3636

3737infixl 0 <.>

3838

3939(<.>) ::

40− (PolyArrow m SemiIso, TupleMorphable x c, TupleMorphable y c) =>

40+ (PolyArrow SemiIso m, TupleMorphable x c, TupleMorphable y c) =>

4141 (Market y y y (Identity y) -> Market y y y' (Identity y')) ->

4242 m x' x ->

4343 m x' y'

@@ -51,7 +51,7 @@ coercing = siPure coerce coerce

5151morphed :: (TupleMorphable a c, TupleMorphable b c) => SemiIso a b

5252morphed = siPure morphTuples morphTuples

5353

54−mapIso :: (PolyArrow m SemiIso, Ord a, Ord b) => [(a, b)] -> m a b

54+mapIso :: (PolyArrow SemiIso m, Ord a, Ord b) => [(a, b)] -> m a b

5555mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)

5656 where

5757 n = M.fromListWith (error "mapping not unique") m

@@ -59,13 +59,13 @@ mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)

5959 M.fromListWith (error "mapping not unique") $

6060 (\(a, b) -> (b, a)) <$> m

6161

62−auto :: forall x s m. (ToIsoparsec x s, Isoparsec m s) => m () x

62+auto :: forall x s m. (ToIsoparsec x s m, Isoparsec m s) => m () x

6363auto = toIsoparsec

6464

65−specific :: forall x s m. (ToIsoparsec x s, Isoparsec m s, Eq x) => x -> m () ()

65+specific :: forall x s m. (ToIsoparsec x s m, Isoparsec m s, Eq x) => x -> m () ()

6666specific x = auto @x >>^ turn (konst x)

6767

6868throughIntegral ::

69− (Integral a, Integral b, Num a, Num b, PolyArrow m SemiIso) =>

69+ (Integral a, Integral b, Num a, Num b, PolyArrow SemiIso m) =>

7070 m a b

7171throughIntegral = arr $ siPure fromIntegral fromIntegral

src/Data/Isoparsec/ByteString.hs+6−6

@@ -20,7 +20,7 @@ import Data.Proxy

2020import Data.Word

2121import Prelude as P hiding ((.))

2222

23−utf8 :: PolyArrow m SemiIso => m ByteString String

23+utf8 :: PolyArrow SemiIso m => m ByteString String

2424utf8 = arr $ siPure C.unpack C.pack

2525

2626data Endianness = BE | LE

@@ -67,22 +67,22 @@ newtype Byte32 (e :: Endianness) = Byte32 {unByte32 :: Word32}

6767newtype Byte64 (e :: Endianness) = Byte64 {unByte64 :: Word64}

6868 deriving (Show, Eq, Ord, Enum, Num, Real, Integral, Bounded)

6969

70−instance BytesToIsoparsec Word16 e => ToIsoparsec (Byte16 e) ByteString where

70+instance BytesToIsoparsec Word16 e => ToIsoparsec (Byte16 e) ByteString m where

7171 toIsoparsec = bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte16 e) @Word16

7272

73−instance BytesToIsoparsec Word32 e => ToIsoparsec (Byte32 e) ByteString where

73+instance BytesToIsoparsec Word32 e => ToIsoparsec (Byte32 e) ByteString m where

7474 toIsoparsec = bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte32 e) @Word32

7575

76−instance BytesToIsoparsec Word64 e => ToIsoparsec (Byte64 e) ByteString where

76+instance BytesToIsoparsec Word64 e => ToIsoparsec (Byte64 e) ByteString m where

7777 toIsoparsec = bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte64 e) @Word64

7878

79−instance ToIsoparsec Bool ByteString where

79+instance ToIsoparsec Bool ByteString m where

8080 toIsoparsec = anyToken >>> mapIso [(0, False), (1, True)]

8181

8282newtype SSHString = SSHString {unSSHString :: String}

8383 deriving (Show, Eq, Ord)

8484

85−instance ToIsoparsec SSHString ByteString where

85+instance ToIsoparsec SSHString ByteString m where

8686 toIsoparsec =

8787 auto @(Byte32 'BE)

8888 >>^ coercing @Word32

src/Data/Isoparsec/Chunks.hs+1−1

@@ -10,6 +10,6 @@ import GHC.TypeLits

1010newtype Chunk (n :: Nat) s = Chunk {unChunk :: s}

1111 deriving (Show, Eq, Ord)

1212

13−instance (CmpNat n 0 ~ 'GT, KnownNat n) => ToIsoparsec (Chunk n s) s where

13+instance (CmpNat n 0 ~ 'GT, KnownNat n) => ToIsoparsec (Chunk n s) s m where

1414 toIsoparsec =

1515 konst (fromIntegral $ natVal @n Proxy) ^>> manyTokens >>^ coercing

src/Data/Isoparsec/Internal.hs+24−5

@@ -10,6 +10,7 @@ module Data.Isoparsec.Internal

1010where

1111

1212import Control.Arrow.Extra

13+import Control.Arrow.Trans.Reader

1314import Control.Monad

1415import Control.SemiIso as X hiding (filterM, replicateM)

1516import Data.MonoTraversable as X

@@ -18,10 +19,10 @@ import Numeric.Natural

1819import Prelude as P hiding ((.), id)

1920

2021class

21− (PolyArrow m SemiIso, ArrowPlus m, ArrowChoice m, IsSequence s) =>

22+ (PolyArrow SemiIso m, ArrowPlus m, ArrowChoice m, IsSequence s) =>

2223 Isoparsec m s

2324 | m -> s where

24− {-# MINIMAL anyToken, manyTokens, tuck #-}

25+ {-# MINIMAL anyToken, manyTokens, tuck' #-}

2526

2627 anyToken :: m () (Element s)

2728

@@ -86,14 +87,17 @@ class

8687 -- > ──┤ s ├──────────────────────────┤ a ├─▶

8788 -- > └─────┘ └─────┘

8889 tuck :: m () a -> m s a

90+ tuck a = turn siSnd ^>> tuck' a

8991

90−arrowsWhile :: (PolyArrow m SemiIso, ArrowPlus m) => m () a -> m () [a]

92+ tuck' :: m a b -> m (a, s) b

93+

94+arrowsWhile :: (PolyArrow SemiIso m, ArrowPlus m) => m () a -> m () [a]

9195arrowsWhile f = ((f &&& arrowsWhile f) >>^ siCons) <+^ isoConst () []

9296

93−arrowsUntil :: (ArrowPlus m, Eq a, PolyArrow m SemiIso) => m () a -> m () b -> m () ([a], b)

97+arrowsUntil :: (ArrowPlus m, Eq a, PolyArrow SemiIso m) => m () a -> m () b -> m () ([a], b)

9498arrowsUntil a b = (arr (konst []) &&& b) <+> (a &&& arrowsUntil a b >>^ (assoc >>> first siCons))

9599

96−unroll :: (PolyArrow m SemiIso, ArrowPlus m, Eq a) => a -> m a (b, a) -> m () [b]

100+unroll :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => a -> m a (b, a) -> m () [b]

97101unroll a f = (konst a ^>> unroll' f) <+^ isoConst () []

98102 where

99103 unroll' g = (g >>> second (unroll' g)) >>^ siCons

@@ -106,3 +110,18 @@ siCons =

106110

107111class IsoparsecFail m e where

108112 failure :: e -> m a b

113+

114+instance (Isoparsec a s, Eq (Element s), Eq r) => Isoparsec (ReaderArrow r a) s where

115+ anyToken = raise anyToken

116+ token' = raise token'

117+ tokens = raise . tokens

118+ tokens' = raise tokens'

119+ chunk = raise . chunk

120+ chunk' = raise chunk'

121+ notToken = raise . notToken

122+ tokenWhere = raise . tokenWhere

123+ manyTokens = raise manyTokens

124+ takeUntil = raise . takeUntil

125+ tokensWhile = raise . tokensWhile

126+ tokensWhile1 = raise . tokensWhile1

127+ tuck' (ReaderArrow a) = ReaderArrow $ assoc ^>> tuck' a

src/Data/Isoparsec/Megaparsec.hs+13−5

@@ -2,6 +2,7 @@

33module Data.Isoparsec.Megaparsec

44 ( runMegaparsec,

5+ runMegaparsecT,

56 )

67where

@@ -16,12 +17,19 @@ import Prelude hiding ((.))

1617

1718runMegaparsec ::

1819 (Ord e, Stream s) =>

19− Kleisli (Parsec e s) () r ->

2020 s ->

21+ Kleisli (Parsec e s) () r ->

2122 Either (ParseErrorBundle s e) r

22−runMegaparsec (Kleisli f) = runParser (f () <* eof) ""

23+runMegaparsec s (Kleisli f) = runParser (f () <* eof) "" s

24+

25+runMegaparsecT ::

26+ (Ord e, Stream s, Monad m) =>

27+ s ->

28+ Kleisli (ParsecT e s m) () r ->

29+ m (Either (ParseErrorBundle s e) r)

30+runMegaparsecT s (Kleisli f) = runParserT (f () <* eof) "" s

2331

24−instance (MonadParsec e s m) => PolyArrow (Kleisli m) SemiIso where

32+instance (MonadParsec e s m) => PolyArrow SemiIso (Kleisli m) where

2533 arr si = Kleisli $ \t -> case embed si t of

2634 Just x -> return x

2735 Nothing -> M.failure Nothing mempty

@@ -36,10 +44,10 @@ instance

3644

3745 manyTokens = Kleisli $ takeP Nothing . fromIntegral

3846

39− tuck (Kleisli f) = Kleisli $ \sub -> do

47+ tuck' (Kleisli f) = Kleisli $ \(x, sub) -> do

4048 sup <- getInput

4149 setInput sub

42− r <- f () <* eof

50+ r <- f x <* eof

4351 setInput sup

4452 return r

4553

src/Data/Isoparsec/Printer.hs+3−3

@@ -5,9 +5,9 @@ module Data.Isoparsec.Printer

55 )

66where

8+import Control.Cokleisli

89import Control.Monad.Writer.Lazy

910import Data.Isoparsec

10−import Data.Isoparsec.Cokleisli

1111import Prelude hiding ((.), id)

1212

1313runPrinter ::

@@ -16,7 +16,7 @@ runPrinter ::

1616 Cokleisli (WriterT (Dual s) m) () a ->

1717 a ->

1818 m s

19−runPrinter p = fmap getDual . execWriterT . unCokleisli p

19+runPrinter p = fmap getDual . execWriterT . runCokleisli p

2020

2121instance IsoparsecFail (Cokleisli (WriterT s Maybe)) e where

2222 failure _ = Cokleisli . const $ WriterT Nothing

@@ -36,4 +36,4 @@ instance

3636 tell $ Dual w

3737 return . fromIntegral . olength $ w

3838

39− tuck (Cokleisli f) = Cokleisli $ lift . fmap getDual . execWriterT . f

39+ tuck' (Cokleisli f) = Cokleisli $ lift . (fmap . fmap) getDual . runWriterT . f

src/Data/Isoparsec/ToIsoparsec.hs+14−15

@@ -8,34 +8,30 @@ import Data.Isoparsec.Internal

88import GHC.Generics

99import Prelude hiding ((.))

1010

11−instance {-# OVERLAPPABLE #-} t ~ Element s => ToIsoparsec t s where

12− toIsoparsec = anyToken

13−

14−class ToIsoparsec a s where

15− toIsoparsec :: Isoparsec m s => m () a

16− default toIsoparsec :: (Isoparsec m s, Generic a, GToIsoparsec (Rep a) s) => m () a

11+class ToIsoparsec a s m where

12+ toIsoparsec :: (Isoparsec m s) => m () a

13+ default toIsoparsec :: (Isoparsec m s, Generic a, GToIsoparsec (Rep a) s m) => m () a

1714 toIsoparsec = gToIsoparsec >>^ SI (pure . to) (pure . from)

1815

19−class GToIsoparsec a s where

16+class GToIsoparsec a s m where

2017 gToIsoparsec :: Isoparsec m s => m () (a b)

2118

22−instance GToIsoparsec U1 s where

19+instance GToIsoparsec U1 s m where

2320 gToIsoparsec = arr $ konst U1

2421

25−instance ToIsoparsec c s => GToIsoparsec (K1 i c) s where

26− gToIsoparsec =

27− toIsoparsec >>^ SI (pure . K1) (pure . unK1)

22+instance ToIsoparsec c s m => GToIsoparsec (K1 i c) s m where

23+ gToIsoparsec = toIsoparsec >>^ siPure K1 unK1

2824

29−instance GToIsoparsec c s => GToIsoparsec (M1 i t c) s where

25+instance GToIsoparsec c s m => GToIsoparsec (M1 i t c) s m where

3026 gToIsoparsec =

31− gToIsoparsec >>^ SI (pure . M1) (pure . unM1)

27+ gToIsoparsec >>^ siPure M1 unM1

3228

33−instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :*: b) s where

29+instance (GToIsoparsec a s m, GToIsoparsec b s m) => GToIsoparsec (a :*: b) s m where

3430 gToIsoparsec =

3531 (gToIsoparsec &&& gToIsoparsec)

3632 >>^ SI (\(a, b) -> pure (a :*: b)) (\(a :*: b) -> pure (a, b))

3733

38−instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :+: b) s where

34+instance (GToIsoparsec a s m, GToIsoparsec b s m) => GToIsoparsec (a :+: b) s m where

3935 gToIsoparsec =

4036 ( (gToIsoparsec >>^ SI (pure . Left) (either pure (const empty)))

4137 <+> (gToIsoparsec >>^ SI (pure . Right) (either (const empty) pure))

@@ -46,3 +42,6 @@ instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :+: b) s where

4642 fromL _ = empty

4743 fromR (R1 b) = pure b

4844 fromR _ = empty

45+

46+instance {-# OVERLAPPABLE #-} t ~ Element s => ToIsoparsec t s m where

47+ toIsoparsec = anyToken

test/Spec.hs+6

@@ -1,3 +1,4 @@

1+import qualified Spec.BasicReader as BasicReader

12import qualified Spec.JSON as JSON

23import qualified Spec.Megaparsec.BasicNums as BasicNums

34import qualified Spec.Ssh as Ssh

@@ -11,6 +12,7 @@ main = do

1112 twoDigitsSpec <- testSpec "Two digits test" TwoDigits.spec

1213 sshSpec <- testSpec "ssh spec" Ssh.spec

1314 jsonSpec <- testSpec "json spec" JSON.spec

15+ basicReaderSpec <- testSpec "json spec" BasicReader.spec

1416 defaultMain

1517 ( testGroup

1618 "tests"

@@ -33,6 +35,10 @@ main = do

3335 "ssh"

3436 [ sshSpec,

3537 Ssh.quickSpec

38+ ],

39+ testGroup

40+ "BasicReader"

41+ [ basicReaderSpec

3642 ]

3743 ]

3844 )

test/Spec/BasicReader.hsnew file+38

@@ -0,0 +1,38 @@

1+{-# LANGUAGE PartialTypeSignatures #-}

2+{-# LANGUAGE TemplateHaskell #-}

4+module Spec.BasicReader

5+ ( spec,

6+ )

7+where

9+import Control.Arrow.Extra

10+import Control.Arrow.Reader

11+import Control.Lens.TH

12+import Data.Either

13+import Data.Isoparsec

14+import Data.Isoparsec.Char

15+import Data.Isoparsec.Megaparsec

16+import Test.Hspec

17+import Prelude hiding ((.), id)

18+

19+data ConstSep = ConstSep Integer Integer

20+ deriving (Eq, Show)

21+

22+makePrisms ''ConstSep

23+

24+instance ArrowReader String a => ToIsoparsec ConstSep String a where

25+ toIsoparsec = _ConstSep <.> (number >** biask chunk') &&& number

26+

27+spec :: Spec

28+spec = do

29+ let run (sep :: String) (s :: String) =

30+ runMegaparsec @() s . runReaderArrow sep $ (auto @ConstSep)

31+ it "deserializes" $ do

32+ run "s" "12s31" `shouldBe` Right (ConstSep 12 31)

33+ run " " "12 31" `shouldBe` Right (ConstSep 12 31)

34+ run "oh no" "12oh no31" `shouldBe` Right (ConstSep 12 31)

35+ run "oh no" "12oh no 31" `shouldSatisfy` isLeft

36+ run "oh no" "12ohno31" `shouldSatisfy` isLeft

37+ run "&" "12 31" `shouldSatisfy` isLeft

38+ run "&" "12&31" `shouldBe` Right (ConstSep 12 31)

test/Spec/Helper.hs+12−9

@@ -6,6 +6,8 @@ module Spec.Helper

66 )

77where

9+import Control.Cokleisli

10+import Control.Monad.Writer.Lazy

911import Data.ByteString as BS

1012import Data.Either

1113import Data.Isoparsec as I

@@ -21,7 +23,7 @@ import Prelude as P hiding ((.))

2123

2224parseSatisfy ::

2325 forall x s.

24− ( ToIsoparsec x s,

26+ ( ToIsoparsec x s (Kleisli (Parsec Void s)),

2527 Stream s,

2628 Show x,

2729 Show (M.Token s),

@@ -31,11 +33,11 @@ parseSatisfy ::

3133 s ->

3234 (Either (ParseErrorBundle s Void) x -> Bool) ->

3335 Expectation

34−parseSatisfy s p = runMegaparsec @Void @s toIsoparsec s `shouldSatisfy` p

36+parseSatisfy s p = runMegaparsec @Void @s s toIsoparsec `shouldSatisfy` p

3537

3638parseSatisfyBS ::

3739 forall x.

38− ( ToIsoparsec x ByteString,

40+ ( ToIsoparsec x ByteString (Kleisli (Parsec Void ByteString)),

3941 Show x,

4042 Isoparsec (Kleisli (Parsec Void ByteString)) ByteString

4143 ) =>

@@ -46,7 +48,7 @@ parseSatisfyBS = parseSatisfy

4648

4749shouldParse ::

4850 forall x s.

49− ( ToIsoparsec x s,

51+ ( ToIsoparsec x s (Kleisli (Parsec Void s)),

5052 Stream s,

5153 Show x,

5254 Eq x,

@@ -55,13 +57,13 @@ shouldParse ::

5557 s ->

5658 x ->

5759 Expectation

58−shouldParse s e = case runMegaparsec @Void @s toIsoparsec s of

60+shouldParse s e = case runMegaparsec @Void @s s toIsoparsec of

5961 Right e' -> e' `shouldBe` e

6062 Left err -> expectationFailure $ errorBundlePretty err

6163

6264shouldParseBS ::

6365 forall x.

64− ( ToIsoparsec x ByteString,

66+ ( ToIsoparsec x ByteString (Kleisli (Parsec Void ByteString)),

6567 Show x,

6668 Eq x,

6769 Isoparsec (Kleisli (Parsec Void ByteString)) ByteString

@@ -73,7 +75,7 @@ shouldParseBS = shouldParse

7375

7476shouldParseS ::

7577 forall x.

76− ( ToIsoparsec x String,

78+ ( ToIsoparsec x String (Kleisli (Parsec Void String)),

7779 Show x,

7880 Eq x,

7981 Isoparsec (Kleisli (Parsec Void String)) String

@@ -85,7 +87,8 @@ shouldParseS = shouldParse

8587

8688roundtrip ::

8789 forall x s.

88− ( ToIsoparsec x s,

90+ ( ToIsoparsec x s (Kleisli (Parsec Void s)),

91+ ToIsoparsec x s (Cokleisli (WriterT (Dual s) Maybe)),

8992 Stream s,

9093 Show s,

9194 I.Element s ~ M.Token s,

@@ -97,6 +100,6 @@ roundtrip ::

97100 Property

98101roundtrip x =

99102 let s = fromJust $ runPrinter @Maybe @s toIsoparsec x

100− in counterexample (show s) $ case runMegaparsec @Void @s toIsoparsec s of

103+ in counterexample (show s) $ case runMegaparsec @Void @s s toIsoparsec of

101104 Right y -> property $ x == y

102105 Left err -> counterexample (errorBundlePretty err) False

test/Spec/JSON.hs+3−3

@@ -57,14 +57,14 @@ quickSpec :: TestTree

5757quickSpec =

5858 testProperty "roundtrips" $ \x ->

5959 let s = fromJust $ runPrinter @Maybe @String json x

60− in counterexample s $ case runMegaparsec @Void json s of

60+ in counterexample s $ case runMegaparsec @Void s json of

6161 Right y -> property $ x == y

6262 Left err -> counterexample (errorBundlePretty err) False

6363

64−instance ToIsoparsec JSON String where

64+instance ToIsoparsec JSON String a where

6565 toIsoparsec = json

6666

67−json :: (PolyArrow m SemiIso, Isoparsec m String) => m () JSON

67+json :: Isoparsec m String => m () JSON

6868json = SI pure pure ^<< (string <+> array <+> integer <+> object)

6969 where

7070 string' = token '"' **> tokensWhile (/= '"') >** token '"'

test/Spec/Megaparsec/BasicNums.hs+4−4

@@ -34,13 +34,13 @@ parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number)

3434spec :: Spec

3535spec =

3636 it "deserializes" $ do

37− runMegaparsec @() parser "12 31" `shouldBe` Right (Foo 12 31)

38− runMegaparsec @() parser "1 33" `shouldBe` Right (Foo 1 33)

39− runMegaparsec @() parser "1562" `shouldSatisfy` isLeft

37+ runMegaparsec @() "12 31" parser `shouldBe` Right (Foo 12 31)

38+ runMegaparsec @() "1 33" parser `shouldBe` Right (Foo 1 33)

39+ runMegaparsec @() "1562" parser `shouldSatisfy` isLeft

4040

4141quickSpec :: TestTree

4242quickSpec = testProperty "roundtrips" $ \x ->

4343 let s = fromJust $ runPrinter @Maybe @String parser x

44− in counterexample s $ case runMegaparsec @Void parser s of

44+ in counterexample s $ case runMegaparsec @Void s parser of

4545 Right y -> property $ x == y

4646 Left err -> counterexample (errorBundlePretty err) False

test/Spec/Ssh.hs+7−7

@@ -31,7 +31,7 @@ data MessageNumber

3131 | NewKeysMsg

3232 deriving (Eq, Show, Ord)

3333

34−instance ToIsoparsec MessageNumber ByteString where

34+instance ToIsoparsec MessageNumber ByteString a where

3535 toIsoparsec =

3636 anyToken

3737 >>> mapIso

@@ -49,18 +49,18 @@ newtype DisconnectReasonCode

4949 = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}

5050 deriving (Eq, Ord, Show, Generic, Arbitrary)

5151

52−instance ToIsoparsec DisconnectReasonCode ByteString

52+instance ToIsoparsec DisconnectReasonCode ByteString a

5353

5454newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}

5555 deriving (Eq, Ord, Show, Generic, Arbitrary)

5656

57−instance ToIsoparsec AlwaysDisplay ByteString

57+instance ToIsoparsec AlwaysDisplay ByteString a

5858

5959newtype PacketSequenceNumber

6060 = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}

6161 deriving (Eq, Ord, Show, Generic, Arbitrary)

6262

63−instance ToIsoparsec PacketSequenceNumber ByteString

63+instance ToIsoparsec PacketSequenceNumber ByteString a

6464

6565data Payload

6666 = VersionPayload String

@@ -88,7 +88,7 @@ instance Arbitrary Payload where

8888

8989makePrisms ''Payload

9090

91−instance ToIsoparsec Payload ByteString where

91+instance ToIsoparsec Payload ByteString a where

9292 toIsoparsec =

9393 ( _DisconnectPayload

9494 <.> specific DisconnectMsg

@@ -136,7 +136,7 @@ newtype MAC = MAC {unMAC :: ByteString}

136136data NoneMAC = NoneMAC

137137 deriving (Eq, Ord, Show, Generic)

138138

139−instance ToIsoparsec NoneMAC b where

139+instance ToIsoparsec NoneMAC b a where

140140 toIsoparsec = arr $ konst NoneMAC

141141

142142instance Arbitrary NoneMAC where

@@ -151,7 +151,7 @@ instance Arbitrary mac => Arbitrary (Packet mac) where

151151

152152makePrisms ''Packet

153153

154−instance ToIsoparsec mac ByteString => ToIsoparsec (Packet mac) ByteString where

154+instance ToIsoparsec mac ByteString a => ToIsoparsec (Packet mac) ByteString a where

155155 toIsoparsec =

156156 ( auto @(Byte32 'BE) &&& auto @Byte8

157157 >>> throughIntegral *** throughIntegral

test/Spec/TwoDigits.hs+11−11

@@ -22,14 +22,14 @@ import Prelude hiding ((.))

2222newtype SingleDigit = SingleDigit {unSingleDigit :: String}

2323 deriving (Eq, Show, Generic)

2424

25−instance ToIsoparsec SingleDigit String where

25+instance ToIsoparsec SingleDigit String m where

2626 toIsoparsec =

2727 toIsoparsec @(Chunk 1 String)

2828 >>^ coercing

2929 >>^ check (all @[] isDigit)

3030 >>^ coercing

3131

32−instance (Arbitrary SingleDigit) where

32+instance Arbitrary SingleDigit where

3333 arbitrary = SingleDigit . pure <$> elements ['0' .. '9']

3434

3535data Digits

@@ -46,24 +46,24 @@ instance Arbitrary Digits where

4646 TwoDigits <$> arbitrary <*> arbitrary

4747 ]

4848

49−instance ToIsoparsec Digits String

49+instance ToIsoparsec Digits String m

5050

5151spec :: Spec

5252spec = do

5353 let parser = toIsoparsec @_ @String

5454 it "deserializes" $ do

55− runMegaparsec @() parser "12" `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))

56− runMegaparsec @() parser "125" `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))

57− runMegaparsec @() parser "1253" `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))

58− runMegaparsec @() parser "12538" `shouldSatisfy` isLeft

59− runMegaparsec @() parser "2" `shouldSatisfy` isLeft

60− runMegaparsec @() parser "a" `shouldSatisfy` isLeft

61− runMegaparsec @() parser "1a" `shouldSatisfy` isLeft

55+ runMegaparsec @() "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))

56+ runMegaparsec @() "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))

57+ runMegaparsec @() "1253" parser `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))

58+ runMegaparsec @() "12538" parser `shouldSatisfy` isLeft

59+ runMegaparsec @() "2" parser `shouldSatisfy` isLeft

60+ runMegaparsec @() "a" parser `shouldSatisfy` isLeft

61+ runMegaparsec @() "1a" parser `shouldSatisfy` isLeft

6262

6363quickSpec :: TestTree

6464quickSpec = testProperty "roundtrips" $ \x ->

6565 let s = fromJust $ runPrinter @Maybe @String parser x

66− in counterexample s $ case runMegaparsec @Void parser s of

66+ in counterexample s $ case runMegaparsec @Void s parser of

6767 Right y -> property $ x == y

6868 Left err -> counterexample (errorBundlePretty err) False

6969 where