5a0a9c1...master · isoparsec

git.iko.soy/isoparsec

33 files changed+1429−325

since splitsnapshots

unifiedsplit

.github/workflows/haskell.yml+2−2 .hlint.yaml+105−1 README.md+4−1 package.yaml+1 src/Control/Arrow/Extra.hs+7−7 src/Control/Arrow/Extra/BaseArrow.hs+13−1 src/Control/Arrow/Extra/Orphans.hs+1−1 src/Control/Arrow/Extra/PolyArrow.hs+10−11 src/Control/Arrow/Reader.hs+34 src/Control/Arrow/Trans/Class.hs+9 src/Control/Arrow/Trans/Reader.hs+53 src/Data/Isoparsec/Cokleisli.hs → src/Control/Cokleisli.hs+5−7 src/Control/Prism.hs+3−1 src/Control/SemiIso.hs+122 src/Control/Tuple/Morph.hs+179−4 src/Data/Isoparsec.hs+246−90 src/Data/Isoparsec/ByteString.hs+12−11 src/Data/Isoparsec/Char.hs+4−4 src/Data/Isoparsec/Chunks.hs+1−1 src/Data/Isoparsec/Internal.hs+47−48 src/Data/Isoparsec/Megaparsec.hs+57−19 src/Data/Isoparsec/Printer.hs+63−19 src/Data/Isoparsec/ToIsoparsec.hs+11−15 stack.yaml+1−1 test/Spec.hs+23−1 test/Spec/BasicReader.hs+38 test/Spec/Helper.hs+28−15 test/Spec/JSON.hs+27−23 test/Spec/JSONHList.hs+92 test/Spec/Megaparsec/BasicNums.hs+5−6 test/Spec/Ssh.hs+19−20 test/Spec/SshHList.hs+192 test/Spec/TwoDigits.hs+15−16

.github/workflows/haskell.yml+2−2

@@ -9,7 +9,7 @@ jobs:

1010 strategy:

1111 matrix:

12− resolver: [lts-13.11, lts-13.19, lts-14, nightly]

12+ resolver: [lts-13.11, lts-13.19, lts-14.27, lts-15, nightly]

1313

1414 steps:

1515 - uses: actions/checkout@v1

@@ -29,6 +29,6 @@ jobs:

2929 stack test --fast --pedantic --ghc-options '-j' --resolver=${{ matrix.resolver }}

3030

3131 - name: Weeder

32− if: matrix.resolver == 'lts-14'

32+ if: matrix.resolver == 'lts-15'

3333 run: |

3434 curl -sSL https://raw.github.com/ndmitchell/weeder/master/misc/run.sh | sh -s . --build

.hlint.yaml+105−1

@@ -52,7 +52,7 @@

5252# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules

5353

5454

55−# Define some custom infix operators

55+# Define some custom fixity operators

5656# - fixity: infixr 3 ~^#^~

5757

5858

@@ -85,3 +85,107 @@

8585 - -XTypeOperators

8686 - -XUndecidableInstances

8787 - -XRankNTypes

88+

89+# hints found in src/Control/SemiIso.hs

90+- warn: {lhs: "SI (pure . a) (pure . b)", rhs: "siPure a b"}

91+- warn: {lhs: "SemiIso (pure . a) (pure . b)", rhs: "siPure a b"}

92+- warn: {lhs: "SemiIso (const empty) (const empty)", rhs: "zeroArrow"}

93+

94+# hints found in src/Control/Arrow/Extra.hs

95+- fixity: "infixl 5 <+^"

96+- fixity: "infixl 5 ^+>"

97+- fixity: "infixl 5 ^+^"

98+- warn: {lhs: "a <+> arr b", rhs: "a <+^ b"}

99+- warn: {lhs: "arr a <+> b", rhs: "a ^+> b"}

100+- warn: {lhs: "arr a <+> arr b", rhs: "a ^+^ b"}

101+

102+# hints found in src/Control/Arrow/Extra/ArrowChoice.hs

103+- fixity: "infixl 2 +++"

104+- fixity: "infixl 2 |||"

105+

106+# hints found in src/Control/Arrow/Extra/ArrowPlus.hs

107+- fixity: "infixl 5 <+>"

108+

109+# hints found in src/Control/Arrow/Extra/ArrowZero.hs

110+# no hints found

111+

112+# hints found in src/Control/Arrow/Extra/BaseArrow.hs

113+- fixity: "infixl 3 ***"

114+- fixity: "infixl 3 &&&"

115+- fixity: "infixl 1 >>>"

116+- fixity: "infixl 1 <<<"

117+

118+# hints found in src/Control/Arrow/Extra/Orphans.hs

119+# no hints found

120+

121+# hints found in src/Control/Arrow/Extra/PolyArrow.hs

122+- fixity: "infixl 1 ^>>"

123+- fixity: "infixl 1 >>^"

124+- fixity: "infixl 1 ^<<"

125+- fixity: "infixl 1 <<^"

126+- fixity: "infixl 1 ^>^"

127+- fixity: "infixl 1 ^<^"

128+- warn: {lhs: "arr a >>> arr b", rhs: "a ^>^ b"}

129+- warn: {lhs: "arr a <<< arr b", rhs: "a ^<^ b"}

130+- warn: {lhs: "arr a >>> b", rhs: "a ^>> b"}

131+- warn: {lhs: "a >>> arr b", rhs: "a >>^ b"}

132+- warn: {lhs: "a <<< arr b", rhs: "a <<^ b"}

133+- warn: {lhs: "arr a <<< b", rhs: "a ^<< b"}

134+

135+# hints found in src/Data/Isoparsec.hs

136+- warn: {lhs: "a <+^ konst ()", rhs: "opt a"}

137+- warn: {lhs: "opt (b >>^ turn (konst a))", rhs: "opt' a b"}

138+- warn: {lhs: "(a &&& (repeating a <+^ konst [])) >>^ siCons", rhs: "repeating a"}

139+- warn: {lhs: "sepBy1 a b <+^ konst []", rhs: "sepBy a b"}

140+- warn: {lhs: "(b &&& repeating (a *>> b) <+^ konst []) >>^ siCons", rhs: "sepBy1 a b"}

141+- fixity: "infixl 0 <.>"

142+- warn: {lhs: "(b >>^ morphed) >>^ siPrism a", rhs: "a <.> b"}

143+- warn: {lhs: "withPrism a\n (\\ x y -> SemiIso (pure . x) (either (const empty) pure . y))", rhs: "siPrism a"}

144+- fixity: "infixl 8 ~>"

145+- fixity: "infixl 8 ~>^"

146+- fixity: "infixl 8 ^~>"

147+- fixity: "infixl 8 ^~>^"

148+- warn: {lhs: "turn siHFst ^>> (enlist a *** enlist b) >>^ siHFst", rhs: "a ~> b"}

149+- warn: {lhs: "siPure fst (, HNil)", rhs: "siHFst"}

150+- fixity: "infixl 5 ~|"

151+- warn: {lhs: "enlist a <+> enlist b", rhs: "a ~| b"}

152+- fixity: "infixl 7 ~&"

153+- warn: {lhs: "(enlist a &&& enlist b) >>^ consHList", rhs: "a ~& b"}

154+- fixity: "infixl 9 ~*"

155+- warn: {lhs: "turn consHList ^>> (enlist a *** enlist b) >>^ consHList", rhs: "a ~* b"}

156+- fixity: "infixl 6 ~$>"

157+- warn: {lhs: "enlist a >>> enlist (arr (siPrism b))", rhs: "a ~$> b"}

158+- warn: {lhs: "turn fMorphed ^>>\n (a (fMorphed ^>> b >>^ turn fMorphed)) >>^ fMorphed", rhs: "hmap a b"}

159+- warn: {lhs: "siPure coerce coerce", rhs: "coercing"}

160+- warn: {lhs: "siPure morphTuples morphTuples", rhs: "morphed"}

161+- warn: {lhs: "siPure flatUnmorph flatMorph", rhs: "fMorphed"}

162+- warn: {lhs: "turn fMorphed ^>> a >>^ fMorphed", rhs: "enlist a"}

163+- warn: {lhs: "fMorphed ^>> a >>^ turn fMorphed", rhs: "delist a"}

164+- warn: {lhs: "siPure (uncurry (++:))\n (\\ c -> (hTake @(Length a) Proxy c, hDrop @(Length a) Proxy c))", rhs: "consHList"}

165+- warn: {lhs: "auto @x >>^ turn (konst a)", rhs: "specific a"}

166+- warn: {lhs: "siPure fromIntegral fromIntegral", rhs: "throughIntegral"}

167+

168+# hints found in src/Data/Isoparsec/ByteString.hs

169+- warn: {lhs: "arr (siPure C.unpack C.pack)", rhs: "utf8"}

170+- warn: {lhs: "bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte16 e) @Word16", rhs: "toIsoparsec"}

171+- warn: {lhs: "bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte32 e) @Word32", rhs: "toIsoparsec"}

172+- warn: {lhs: "bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte64 e) @Word64", rhs: "toIsoparsec"}

173+- warn: {lhs: "anyToken >>> mapIso [(0, False), (1, True)]", rhs: "toIsoparsec"}

174+

175+# hints found in src/Data/Isoparsec/Char.hs

176+- warn: {lhs: "token ' '", rhs: "space"}

177+- warn: {lhs: "tokensWhile isSpace >>^ ((maskr . turn . konst) mempty)", rhs: "unsafeWhiteSpace"}

178+- warn: {lhs: "tokensWhile1 isSpace >>^ ((maskr . turn . konst) (singleton ' '))", rhs: "unsafeWhiteSpace1"}

179+

180+# hints found in src/Data/Isoparsec/Cokleisli.hs

181+- warn: {lhs: "Cokleisli\n (\\ t ->\n case project a t of\n Just x -> return x\n Nothing -> mzero)", rhs: "arr a"}

182+- warn: {lhs: "Cokleisli (const mzero)", rhs: "zeroArrow"}

183+

184+# hints found in src/Data/Isoparsec/Internal.hs

185+- warn: {lhs: "((a &&& arrowsWhile a) >>^ siCons) <+^ isoConst () []", rhs: "arrowsWhile a"}

186+- warn: {lhs: "siMaybe (pure . uncurry cons) uncons", rhs: "siCons"}

187+- warn: {lhs: "SI (\\ c -> guard (a c) >> b c)\n (c >=> (\\ c -> guard (a c) >> pure c))", rhs: "siCheck a b c"}

188+- warn: {lhs: "siCheck a (pure . b) (pure . c)", rhs: "isoCheck a b c"}

189+- warn: {lhs: "SI (const (pure b)) (const (pure a))", rhs: "isoConst a b"}

190+- warn: {lhs: "isoCheck a id id", rhs: "check a"}

191+- warn: {lhs: "SI (const (pure a)) (const (pure ())) >>> check (== a)", rhs: "konst a"}

README.md+4−1

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

1−# isoparsec ![](https://github.com/ilyakooo0/isoparsec/workflows/Haskell%20CI/badge.svg)

1+# 🔄 🔡 isoparsec ![](https://github.com/ilyakooo0/isoparsec/workflows/Haskell%20CI/badge.svg)

23Isomorphic (invertible) parser library

5+### 🚧 Under construction 🚧

47![](https://media.giphy.com/media/xDQ3Oql1BN54c/giphy.gif)

package.yaml+1

@@ -28,6 +28,7 @@ dependencies:

2828- mtl

2929- profunctors

3030- mono-traversable

31+- split

3132

3233library:

3334 source-dirs: src

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

@@ -14,19 +14,19 @@ import Control.Arrow.Extra.ArrowPlus as X

1414import Control.Arrow.Extra.ArrowZero as X

1515import Control.Arrow.Extra.BaseArrow as X

1616import Control.Arrow.Extra.PolyArrow as X

17−import Control.Category as X

17+import Control.Category as X hiding ((<<<), (>>>))

1818

19−infixr 5 <+^

19+infixl 5 <+^

2020

21−infixr 5 ^+>

21+infixl 5 ^+>

2222

23−infixr 5 ^+^

23+infixl 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/BaseArrow.hs+13−1

@@ -2,10 +2,12 @@

33module Control.Arrow.Extra.BaseArrow

44 ( BaseArrow (..),

5+ (>>>),

6+ (<<<),

57 )

68where

8−import Control.Category

10+import Control.Category hiding ((<<<), (>>>))

911

1012infixl 3 ***

1113

@@ -23,3 +25,13 @@ class Category a => BaseArrow a where

2325 (***) :: a b c -> a b' c' -> a (b, b') (c, c')

2426

2527 (&&&) :: a b c -> a b c' -> a b (c, c')

28+

29+infixl 1 >>>

30+

31+(>>>) :: Category cat => cat a b -> cat b c -> cat a c

32+x >>> y = y . x

33+

34+infixl 1 <<<

35+

36+(<<<) :: Category cat => cat b c -> cat a b -> cat a c

37+x <<< y = x . y

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+10−11

@@ -10,31 +10,30 @@ module Control.Arrow.Extra.PolyArrow

1010where

1111

1212import Control.Arrow.Extra.BaseArrow

13−import Control.Category

1413

15−infixr 1 ^>>, >>^

14+infixl 1 ^>>, >>^

1615

17−infixr 1 ^<<, <<^

16+infixl 1 ^<<, <<^

1817

19−infixr 1 ^>^, ^<^

18+infixl 1 ^>^, ^<^

2019

21−class BaseArrow a => PolyArrow a p where

20+class BaseArrow a => PolyArrow p a where

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

2322

24−(^>>) :: 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

2524f ^>> a = arr f >>> a

2625

27−(>>^) :: 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

2827a >>^ f = a >>> arr f

2928

30−(<<^) :: 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

3130a <<^ f = a <<< arr f

3231

33−(^<<) :: 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

3433f ^<< a = arr f <<< a

3534

36−(^>^) :: 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

3736a ^>^ b = arr a >>> arr b

3837

39−(^<^) :: 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

4039a ^<^ 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+5−7

@@ -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,10 +26,8 @@ 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 MonadPlus m => PolyArrow (Cokleisli m) SemiIso where

30− arr si = Cokleisli $ \t -> case project si t of

31− Just x -> return x

32− Nothing -> mzero

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

30+ arr si = Cokleisli $ \t -> project si t

3331

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

3533 zeroArrow = Cokleisli $ const mzero

src/Control/Prism.hs+3−1

@@ -1,7 +1,7 @@

11module Control.Prism

22 ( withPrism,

3− Market,

43 Identity,

4+ Prism',

55 )

66where

@@ -9,6 +9,8 @@ import Data.Coerce

99import Data.Functor.Identity

1010import Data.Profunctor

1111

12+type Prism' a b = Market a a a (Identity a) -> Market a a b (Identity b)

13+

1214data Market a b s t = Market (b -> t) (s -> Either t a)

1315

1416instance Functor (Market a b s) where

src/Control/SemiIso.hs+122

@@ -7,13 +7,42 @@ module Control.SemiIso

77 turn,

88 withSemiIso,

99 AlternativeMonad,

10+ maskr,

11+ maskl,

12+ isoCheck,

13+ siCheck,

14+ check,

15+ konst,

16+ isoConst,

17+ assoc,

18+ ($$$),

19+ (*>>),

20+ (&>>),

21+ (**>),

22+ (>>*),

23+ (>>&),

24+ (>**),

25+ (<<*),

26+ (<<&),

27+ (<**),

28+ (*<<),

29+ (&<<),

30+ (**<),

31+ siFst,

32+ siSnd,

33+ siDouble,

34+ siSwap,

35+ siTranspose2,

36+ siSequenceEither,

1037 )

1138where

1239

1340import Control.Applicative as X

1441import Control.Arrow.Extra

1542import Control.Monad as X

43+import qualified Data.Bifunctor as Bi

1644import Data.Bitraversable

45+import Data.Tuple

1746import Prelude hiding ((.), id)

1847

1948type AlternativeMonad m = (Alternative m, Monad m)

@@ -82,3 +111,96 @@ withSemiIso ::

82111 ((a -> f b) -> (b -> f a) -> c) ->

83112 c

84113withSemiIso (SemiIso a b) f = f a b

114+

115+maskr :: SemiIso a () -> SemiIso a ()

116+maskr (SemiIso e p) = SemiIso (\a -> e a <|> pure ()) p

117+

118+maskl :: SemiIso () b -> SemiIso () b

119+maskl (SemiIso e p) = SemiIso e (\b -> p b <|> pure ())

120+

121+infixl 1 *>>, **>, >>*, >**, <<*, <**, *<<, **<

122+

123+infixl 3 $$$

124+

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

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

127+

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

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

130+

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

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

133+

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

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

136+

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

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

139+

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

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

142+

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

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

145+

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

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

148+

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

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

151+

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

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

154+

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

156+a *<< b = b &&& a >>^ siFst

157+

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

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

160+

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

162+a **< b = turn siFst ^>> b *** a >>^ siFst

163+

164+check :: (s -> Bool) -> SemiIso s s

165+check f = isoCheck f id id

166+

167+siCheck ::

168+ (s -> Bool) ->

169+ (forall f. AlternativeMonad f => s -> f a) ->

170+ (forall f. AlternativeMonad f => a -> f s) ->

171+ SemiIso s a

172+siCheck f a b =

173+ SI

174+ (\c -> guard (f c) >> a c)

175+ (b >=> (\c -> guard (f c) >> pure c))

176+

177+isoCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso s a

178+isoCheck f a b = siCheck f (pure . a) (pure . b)

179+

180+isoConst :: s -> a -> SemiIso s a

181+isoConst s a = SI (const $ pure a) (const $ pure s)

182+

183+konst :: Eq x => x -> SemiIso () x

184+konst x = isoConst () x >>> check (== x)

185+

186+assoc :: SemiIso (a, (b, c)) ((a, b), c)

187+assoc = 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/Control/Tuple/Morph.hs+179−4

@@ -7,11 +7,22 @@ module Control.Tuple.Morph

77 TupleMorphable,

88 CheckListsForTupleIso,

99 ReorderList,

10+ FlatMorphable (..),

11+ TupleHListContents,

12+ HListContentsTuple,

13+ Nat (..),

14+ HList (..),

15+ AppendableList (..),

16+ DroppableList (..),

17+ TakeableList (..),

18+ Length,

19+ Proxy (..),

1020 )

1121where

1222

1323import Data.Kind

1424import Data.Proxy

25+import Data.Type.Equality

1526import GHC.Generics

1627import GHC.TypeLits hiding (Nat)

1728

@@ -60,7 +71,7 @@ data HList (ts :: [*]) where

6071 HCons :: t -> HList tt -> HList (t ': tt)

6172 HNil :: HList '[]

6273

63−infixr 5 :+

74+infixl 5 :+

6475

6576pattern (:+) :: (ts ~ (t : tt)) => t -> HList tt -> HList ts

6677pattern (:+) a b = HCons a b

@@ -92,10 +103,16 @@ instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where

92103

93104-- ## Appending

94105

95−infixr 4 ++:

106+infixl 4 ++:

96107

97−class AppendableList aa bb cc | aa bb -> cc where

98− (++:) :: HList aa -> HList bb -> HList (aa ++ bb)

108+class

109+ ( (aa ++ bb) ~ cc,

110+ DroppableList (Length aa) cc bb,

111+ TakeableList (Length aa) cc aa

112+ ) =>

113+ AppendableList aa bb cc

114+ | aa bb -> cc where

115+ (++:) :: HList aa -> HList bb -> HList cc

99116

100117instance AppendableList '[] bb bb where

101118 HNil ++: bb = bb

@@ -243,6 +260,33 @@ instance

243260 aa = hTake @(Length a) Proxy cc

244261 bb = hDrop @(Length a) Proxy cc

245262

263+-- ## FlatMorphable

264+

265+class

266+ ( TupleHListContents t ~ th,

267+ flag ~ (t == HList th)

268+ ) =>

269+ FlatMorphable t th flag

270+ | t -> th,

271+ th flag -> t where

272+ flatUnmorph :: t -> HList th

273+ flatMorph :: HList th -> t

274+

275+instance

276+ ( TupleMorphable' t th (IsMophableTuple t),

277+ TupleHListContents t ~ th,

278+ HListContentsTuple th ~ t,

279+ (t == HList th) ~ 'False

280+ ) =>

281+ FlatMorphable t th 'False

282+ where

283+ flatUnmorph = unmorph' (Proxy @(IsMophableTuple t))

284+ flatMorph = morph' (Proxy @(IsMophableTuple t))

285+

286+instance (th == th) ~ 'True => FlatMorphable (HList th) th 'True where

287+ flatMorph = id

288+ flatUnmorph = id

289+

246290-- ## Other

247291

248292type family IsMophableTuple t :: Bool where

@@ -309,3 +353,134 @@ type family IsMophableTuple t :: Bool where

309353 IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2) = 'True

310354 IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = 'True

311355 IsMophableTuple c = 'False

356+

357+type family TupleHListContents t :: [*] where

358+ TupleHListContents (HList ts) = ts

359+ TupleHListContents () = '[]

360+ TupleHListContents (a, b) = '[a, b]

361+ TupleHListContents (a, b, c) = '[a, b, c]

362+ TupleHListContents (a, b, c, d) = '[a, b, c, d]

363+ TupleHListContents (a, b, c, d, e) = '[a, b, c, d, e]

364+ TupleHListContents (a, b, c, d, e, f) = '[a, b, c, d, e, f]

365+ TupleHListContents (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]

366+ TupleHListContents (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]

367+ TupleHListContents (a, b, c, d, e, f, g, h, i) = '[a, b, c, d, e, f, g, h, i]

368+ TupleHListContents (a, b, c, d, e, f, g, h, i, j) = '[a, b, c, d, e, f, g, h, i, j]

369+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k) = '[a, b, c, d, e, f, g, h, i, j, k]

370+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l) = '[a, b, c, d, e, f, g, h, i, j, k, l]

371+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m) = '[a, b, c, d, e, f, g, h, i, j, k, l, m]

372+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n]

373+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o]

374+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p]

375+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q]

376+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r]

377+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s]

378+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t]

379+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u]

380+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v]

381+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w]

382+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x]

383+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y]

384+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z]

385+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1]

386+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1]

387+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1]

388+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1]

389+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1]

390+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1]

391+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1]

392+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1]

393+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1]

394+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1]

395+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1]

396+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1]

397+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1]

398+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1]

399+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1]

400+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1]

401+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1]

402+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1]

403+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1]

404+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1]

405+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1]

406+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1]

407+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1]

408+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1]

409+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1]

410+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1]

411+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2]

412+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2]

413+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2]

414+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2]

415+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2]

416+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2]

417+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2]

418+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2]

419+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2]

420+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2]

421+ TupleHListContents a = '[a]

422+

423+type family HListContentsTuple t :: * where

424+ HListContentsTuple '[] = ()

425+ HListContentsTuple '[a] = a

426+ HListContentsTuple '[a, b] = (a, b)

427+ HListContentsTuple '[a, b, c] = (a, b, c)

428+ HListContentsTuple '[a, b, c, d] = (a, b, c, d)

429+ HListContentsTuple '[a, b, c, d, e] = (a, b, c, d, e)

430+ HListContentsTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)

431+ HListContentsTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)

432+ HListContentsTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)

433+ HListContentsTuple '[a, b, c, d, e, f, g, h, i] = (a, b, c, d, e, f, g, h, i)

434+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j] = (a, b, c, d, e, f, g, h, i, j)

435+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k] = (a, b, c, d, e, f, g, h, i, j, k)

436+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l] = (a, b, c, d, e, f, g, h, i, j, k, l)

437+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m] = (a, b, c, d, e, f, g, h, i, j, k, l, m)

438+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n)

439+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)

440+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)

441+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)

442+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)

443+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)

444+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)

445+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)

446+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)

447+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)

448+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)

449+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y)

450+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z)

451+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1)

452+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1)

453+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1)

454+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1)

455+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1)

456+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1)

457+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1)

458+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1)

459+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1)

460+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1)

461+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1)

462+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1)

463+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1)

464+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1)

465+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1)

466+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1)

467+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1)

468+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1)

469+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1)

470+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1)

471+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1)

472+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1)

473+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1)

474+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1)

475+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1)

476+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1)

477+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2)

478+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2)

479+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2)

480+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2)

481+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2)

482+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2)

483+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2)

484+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2)

485+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2)

486+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2)

src/Data/Isoparsec.hs+246−90

@@ -2,27 +2,32 @@

33module Data.Isoparsec

44 ( module X,

5− -- Isoparsec,

6− (%>>),

7− (%>%),

8− (>>%),

9− (%<<),

10− (%<%),

11− (<<%),

12− (<+%),

13− (%+>),

14− (%+%),

155 (<.>),

16− (<^>),

176 repeating,

7+ sepBy,

8+ sepBy1,

189 opt,

1910 opt',

2011 morphed,

12+ fMorphed,

2113 coercing,

2214 mapIso,

2315 auto,

2416 specific,

2517 throughIntegral,

18+ (~>),

19+ (~>^),

20+ (^~>),

21+ (^~>^),

22+ (~|),

23+ (~$>),

24+ (~&),

25+ (~*),

26+ siPrism,

27+ delist,

28+ enlist,

29+ Listed,

30+ hmap,

2631 )

2732where

2833

@@ -36,95 +41,246 @@ import Data.Isoparsec.ToIsoparsec as X

3641import qualified Data.Map as M

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

3843

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

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

4045opt m = m <+^ konst ()

4146

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

43−opt' a m = (m >>^ tsnok a) <+^ konst ()

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

48+opt' a m = opt (m >>^ turn (konst a))

4449

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

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

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

4752

48−infixr 1 %>>

53+sepBy :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]

54+sepBy sep a = sepBy1 sep a <+^ konst []

4955

50−(%>>) :: (PolyArrow a SemiIso, ToSemiIso p b c) => p -> a c d -> a b d

51−p %>> a = si p ^>> a

56+sepBy1 :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]

57+sepBy1 sep a = (a &&& repeating (sep *>> a) <+^ konst []) >>^ siCons

5258

53−infixr 1 %>%

54−

55−(%>%) :: (PolyArrow a SemiIso, ToSemiIso p b c, ToSemiIso p' c d) => p -> p' -> a b d

56−p %>% a = si p ^>^ si a

57−

58−infixr 1 >>%

59−

60−(>>%) :: (PolyArrow a SemiIso, ToSemiIso p c d) => a b c -> p -> a b d

61−p >>% a = p >>^ si a

62−

63−infixr 1 %<<

64−

65−(%<<) :: (PolyArrow a SemiIso, ToSemiIso p c d) => p -> a b c -> a b d

66−p %<< a = si p ^<< a

67−

68−infixr 1 %<%

69−

70−(%<%) :: (PolyArrow a SemiIso, ToSemiIso p c d, ToSemiIso p' b c) => p -> p' -> a b d

71−p %<% a = si p ^<^ si a

72−

73−infixr 1 <<%

74−

75−(<<%) :: (PolyArrow a SemiIso, ToSemiIso p b c) => a c d -> p -> a b d

76−p <<% a = p <<^ si a

77−

78−infixr 5 <+%

79−

80−(<+%) :: (PolyArrow a SemiIso, ArrowPlus a, ToSemiIso p b c) => a b c -> p -> a b c

81−a <+% b = a <+^ si b

82−

83−infixr 5 %+>

84−

85−(%+>) :: (PolyArrow a SemiIso, ArrowPlus a, ToSemiIso p b c) => p -> a b c -> a b c

86−a %+> b = si a ^+> b

87−

88−infixr 5 %+%

89−

90−(%+%) :: (PolyArrow a SemiIso, ArrowPlus a, ToSemiIso p b c) => p -> p -> a b c

91−a %+% b = si a ^+^ si b

92−

93−infixr 0 <.>

59+infixl 0 <.>

9460

9561(<.>) ::

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

97− (Market y y y (Identity y) -> Market y y y' (Identity y')) ->

98− m x' x ->

99− m x' y'

100−b <.> p = (p >>^ morphed) >>^ si b

101−

102−infixr 0 <^>

103−

104−(<^>) ::

105− (PolyArrow m SemiIso, TupleMorphable x c, TupleMorphable y c, ToSemiIso b y y') =>

62+ (PolyArrow SemiIso m, TupleMorphable x c, TupleMorphable a c) =>

63+ (Prism' a b) ->

10664 m x' x ->

107− b ->

108− m x' y'

109−b <^> p = b >>> morphed %>% p

65+ m x' b

66+b <.> p = (p >>^ morphed) >>^ siPrism b

67+

68+siPrism ::

69+ (Prism' a b) ->

70+ SemiIso a b

71+siPrism p = withPrism p $ \x y -> SemiIso (pure . x) (either (const empty) pure . y)

72+

73+type Listed m a b = m (HList (TupleHListContents a)) (HList (TupleHListContents b))

74+

75+infixl 8 ~>, ~>^, ^~>, ^~>^

76+

77+type family If cond t f where

78+ If 'True t _ = t

79+ If 'False _ f = f

80+

81+type family BothEmpty a b where

82+ BothEmpty '[] '[] = 'True

83+ BothEmpty _ _ = 'False

84+

85+class BothEmpty c' d' ~ flag => SmartCompose b' c' d' flag | c' d' -> flag where

86+ -- | Conceptually an analog to '>>>':

87+ --

88+ -- > Listed m a b -> Listed m b c -> Listed m a c

89+ (~>) ::

90+ ( PolyArrow SemiIso m,

91+ FlatMorphable a a' fa,

92+ FlatMorphable b b' fb,

93+ FlatMorphable c c' fc,

94+ FlatMorphable d d' fd

95+ ) =>

96+ m a b ->

97+ m c d ->

98+ m (HList a') (HList (If flag b' d'))

99+

100+instance SmartCompose b '[] '[] 'True where

101+ (~>) lhs rhs = turn siHFst ^>> (enlist lhs *** enlist rhs) >>^ siHFst

102+

103+instance SmartCompose (c ': cc) (c ': cc) d 'False where

104+ (~>) lhs rhs = enlist lhs >>> enlist rhs

105+

106+instance SmartCompose '[] '[] (d ': dd) 'False where

107+ (~>) lhs rhs = enlist lhs >>> enlist rhs

108+

109+siHFst :: SemiIso (a, HList '[]) a

110+siHFst = siPure fst (,HNil)

111+

112+-- | Conceptually an analog to '>>^':

113+--

114+-- > Listed m a b -> SemiIso b c -> Listed m a c

115+(~>^) ::

116+ ( PolyArrow SemiIso m,

117+ FlatMorphable a a' fa,

118+ FlatMorphable b bc fb,

119+ FlatMorphable c bc 'False,

120+ FlatMorphable d d' 'False

121+ ) =>

122+ m a b ->

123+ SemiIso c d ->

124+ m (HList a') (HList d')

125+lhs ~>^ rhs = enlist lhs >>> enlist (arr rhs)

126+

127+-- | Conceptually an analog to '^>>':

128+--

129+-- > SemiIso a b -> Listed m b c -> Listed m a c

130+(^~>) ::

131+ ( PolyArrow SemiIso m,

132+ FlatMorphable a a' 'False,

133+ FlatMorphable b bc 'False,

134+ FlatMorphable c bc fc,

135+ FlatMorphable d d' fd

136+ ) =>

137+ SemiIso a b ->

138+ m c d ->

139+ m (HList a') (HList d')

140+lhs ^~> rhs = enlist (arr lhs) >>> enlist rhs

141+

142+-- | Conceptually an analog to '^>^':

143+--

144+-- > SemiIso a b -> SemiIso b c -> Listed m a c

145+(^~>^) ::

146+ ( PolyArrow SemiIso m,

147+ FlatMorphable a a' 'False,

148+ FlatMorphable b b' 'False,

149+ FlatMorphable d d' 'False

150+ ) =>

151+ SemiIso a b ->

152+ SemiIso b d ->

153+ m (HList a') (HList d')

154+lhs ^~>^ rhs = enlist . arr $ lhs >>> rhs

155+

156+infixl 5 ~|

157+

158+-- | Conceptually an analog to '<+>':

159+--

160+-- > Listed m a b -> Listed m a b -> Listed m a b

161+(~|) ::

162+ ( PolyArrow SemiIso m,

163+ ArrowPlus m,

164+ FlatMorphable a ac fa,

165+ FlatMorphable c ac fb,

166+ FlatMorphable b bd fc,

167+ FlatMorphable d bd fd

168+ ) =>

169+ m a b ->

170+ m c d ->

171+ m (HList ac) (HList bd)

172+lhs ~| rhs = enlist lhs <+> enlist rhs

173+

174+infixl 7 ~&

175+

176+-- | Conceptually an analog to '&&&':

177+--

178+-- > Listed m a b -> Listed m a c -> Listed m a (b, c)

179+(~&) ::

180+ ( PolyArrow SemiIso m,

181+ FlatMorphable a ac' fa,

182+ FlatMorphable c ac' fc,

183+ FlatMorphable b b' fb,

184+ FlatMorphable d d' fd,

185+ AppendableList b' d' f

186+ ) =>

187+ m a b ->

188+ m c d ->

189+ m (HList ac') (HList f)

190+lhs ~& rhs = (enlist lhs &&& enlist rhs) >>^ consHList

191+

192+infixl 9 ~*

193+

194+-- | Conceptually an analog to '***':

195+--

196+-- > Listed m a b -> Listed m c d -> Listed m (a, b) (c, d)

197+(~*) ::

198+ ( PolyArrow SemiIso m,

199+ FlatMorphable a a' fa,

200+ FlatMorphable c c' fc,

201+ FlatMorphable b b' fb,

202+ FlatMorphable d d' fd,

203+ AppendableList a' c' e',

204+ AppendableList b' d' f'

205+ ) =>

206+ m a b ->

207+ m c d ->

208+ m (HList e') (HList f')

209+lhs ~* rhs = turn consHList ^>> (enlist lhs *** enlist rhs) >>^ consHList

210+

211+infixl 6 ~$>

212+

213+(~$>) ::

214+ ( PolyArrow SemiIso m,

215+ FlatMorphable a a' fa,

216+ FlatMorphable b bc fb,

217+ FlatMorphable c bc fc,

218+ FlatMorphable d d' fd

219+ ) =>

220+ m a b ->

221+ Prism' c d ->

222+ m (HList a') (HList d')

223+lhs ~$> rhs = enlist lhs >>> enlist (arr (siPrism rhs))

224+

225+-- | Conceptually:

226+--

227+-- > (m a b -> m c d) -> Listed m a b -> Listed m c d

228+hmap ::

229+ ( FlatMorphable b b' fb,

230+ FlatMorphable a a' fa,

231+ FlatMorphable d d' fd,

232+ FlatMorphable c c' fc,

233+ PolyArrow SemiIso m

234+ ) =>

235+ (m a b -> m c d) ->

236+ m (HList a') (HList b') ->

237+ m (HList c') (HList d')

238+hmap f m = turn fMorphed ^>> (f $ fMorphed ^>> m >>^ turn fMorphed) >>^ fMorphed

110239

111240coercing :: forall b a. Coercible a b => SemiIso a b

112241coercing = siPure coerce coerce

113242

114−morphed ::

115− (TupleMorphable a c, TupleMorphable b c) => SemiIso a b

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

116244morphed = siPure morphTuples morphTuples

117245

118−class ToSemiIso x a b | x -> a b where

119− si :: x -> SemiIso a b

120−

121−instance ToSemiIso (Market a a a (Identity a) -> Market a a b (Identity b)) a b where

122− si p = withPrism p $ \x y -> SemiIso (pure . x) (either (const empty) pure . y)

123−

124−instance ToSemiIso (SemiIso a b) a b where

125− si = id

126−

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

246+fMorphed :: (FlatMorphable a b fa) => SemiIso a (HList b)

247+fMorphed = siPure flatUnmorph flatMorph

248+

249+-- | Conceptually:

250+--

251+-- > m a b -> Listed m a b

252+enlist ::

253+ (FlatMorphable a a' fa, FlatMorphable b b' fb, PolyArrow SemiIso m) =>

254+ m a b ->

255+ m (HList a') (HList b')

256+enlist m = turn fMorphed ^>> m >>^ fMorphed

257+

258+-- | Conceptually:

259+--

260+-- > Listed m a b -> m a b

261+delist ::

262+ ( FlatMorphable a a' 'False,

263+ FlatMorphable b b' 'False,

264+ PolyArrow SemiIso m,

265+ HListContentsTuple a' ~ a,

266+ HListContentsTuple b' ~ b,

267+ TupleHListContents a ~ a',

268+ TupleHListContents b ~ b'

269+ ) =>

270+ m (HList a') (HList b') ->

271+ m a b

272+delist m = fMorphed ^>> m >>^ turn fMorphed

273+

274+consHList ::

275+ forall a b c.

276+ AppendableList a b c =>

277+ SemiIso (HList a, HList b) (HList c)

278+consHList =

279+ siPure

280+ (uncurry (++:))

281+ (\c -> (hTake @(Length a) Proxy c, hDrop @(Length a) Proxy c))

282+

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

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

129285 where

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

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

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

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

134290

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

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

136292auto = toIsoparsec

137293

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

139−specific x = auto @x >>> check (== x) ^>^ tsnok x

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

295+specific x = auto @x >>^ turn (konst x)

140296

141297throughIntegral ::

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

143− m a b

144−throughIntegral = arr $ siPure fromIntegral fromIntegral

298+ (Integral a, Integral b, Num a, Num b) =>

299+ SemiIso a b

300+throughIntegral = siPure fromIntegral fromIntegral

src/Data/Isoparsec/ByteString.hs+12−11

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

2020import Data.Word

2121import Prelude as P hiding ((.))

2222

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

24−utf8 = arr $ siPure C.unpack C.pack

23+utf8 :: SemiIso ByteString String

24+utf8 = siPure C.unpack C.pack

2525

2626data Endianness = BE | LE

2727

@@ -67,25 +67,26 @@ 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 =

87− auto @(Byte32 'BE) >>> coercing @Word32

88− ^>> siPure fromIntegral fromIntegral

89− ^>> manyTokens

90− >>> utf8

87+ auto @(Byte32 'BE)

88+ >>^ coercing @Word32

89+ >>^ siPure fromIntegral fromIntegral

90+ >>> manyTokens

91+ >>^ utf8

9192 >>^ siPure SSHString unSSHString

src/Data/Isoparsec/Char.hs+4−4

@@ -14,11 +14,11 @@ import Prelude hiding ((.), id)

1414space :: (Isoparsec m s, Element s ~ Char) => m () ()

1515space = token ' '

1616

17−unsafeWhiteSpace :: (Isoparsec m s, Element s ~ Char) => m () ()

18−unsafeWhiteSpace = tokensWhile isSpace >>^ badTsnok mempty

17+unsafeWhiteSpace :: (Isoparsec m s, Element s ~ Char, Eq s) => m () ()

18+unsafeWhiteSpace = tokensWhile isSpace >>^ (maskr . turn . konst $ mempty)

1919

20−unsafeWhiteSpace1 :: (Isoparsec m s, Element s ~ Char) => m () ()

21−unsafeWhiteSpace1 = tokensWhile1 isSpace >>^ badTsnok (singleton ' ')

20+unsafeWhiteSpace1 :: (Isoparsec m s, Element s ~ Char, Eq s) => m () ()

21+unsafeWhiteSpace1 = tokensWhile1 isSpace >>^ (maskr . turn . konst $ singleton ' ')

2222

2323number :: (Isoparsec m s, Element s ~ Char) => m () Integer

2424number =

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+47−48

@@ -2,20 +2,16 @@ module Data.Isoparsec.Internal

22 ( module X,

33 IsoparsecFail (..),

44 Isoparsec (..),

5− konst,

6− tsnok,

75 siCons,

8− isoCheck,

9− siCheck,

10− check,

11− badKonst,

12− badTsnok,

136 unroll,

147 arrowsWhile,

8+ arrowsUntil,

9+ EffectOnly,

1510 )

1611where

1712

1813import Control.Arrow.Extra

14+import Control.Arrow.Trans.Reader

1915import Control.Monad

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

2117import Data.MonoTraversable as X

@@ -24,25 +20,36 @@ import Numeric.Natural

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

2521

2622class

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

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

2824 Isoparsec m s

2925 | m -> s where

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

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

3127

3228 anyToken :: m () (Element s)

3329

34− token :: Element s -> m () ()

35− default token :: Eq (Element s) => Element s -> m () ()

36− token x = anyToken >>^ tsnok x

30+ token :: Element s -> EffectOnly m

31+ default token :: Eq (Element s) => Element s -> EffectOnly m

32+ token x = anyToken >>^ turn (konst x)

3733

38− tokens :: [Element s] -> m () ()

39− default tokens :: [Element s] -> m () ()

34+ token' :: m (Element s) (Element s)

35+ default token' :: Eq (Element s) => m (Element s) (Element s)

36+ token' = id >>& anyToken >>^ check (uncurry (==)) >>^ siPure fst (\x -> (x, x))

37+

38+ tokens :: [Element s] -> EffectOnly m

4039 tokens [] = arr $ isoConst () ()

41− tokens (t : ts) = token t &&& tokens ts >>> arr (isoConst ((), ()) ())

40+ tokens (t : ts) = token t &&& tokens ts >>^ isoConst ((), ()) ()

41+

42+ tokens' :: m [Element s] [Element s]

43+ tokens' = (turn siCons ^>> token' *** tokens' >>^ siCons) <+^ isoConst [] []

4244

43− chunk :: s -> m () ()

45+ chunk :: s -> EffectOnly m

4446 chunk = tokens . otoList

4547

48+ chunk' :: m s s

49+ chunk' = list ^>> tokens' >>^ turn list

50+ where

51+ list = siPure otoList fromList

52+

4653 notToken :: Element s -> m () (Element s)

4754 default notToken :: Eq (Element s) => Element s -> m () (Element s)

4855 notToken t = tokenWhere (/= t)

@@ -81,11 +88,19 @@ class

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

8289 -- > └─────┘ └─────┘

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

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

92+

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

8494

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

95+type EffectOnly m = m () ()

96+

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

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

8799

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

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

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

102+

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

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

90105 where

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

@@ -99,33 +114,17 @@ siCons =

99114class IsoparsecFail m e where

100115 failure :: e -> m a b

101116

102−siCheck ::

103− (s -> Bool) ->

104− (forall f. AlternativeMonad f => s -> f a) ->

105− (forall f. AlternativeMonad f => a -> f s) ->

106− SemiIso s a

107−siCheck f a b =

108− SI

109− (\c -> guard (f c) >> a c)

110− (b >=> (\c -> guard (f c) >> pure c))

111−

112−isoCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso s a

113−isoCheck f a b = siCheck f (pure . a) (pure . b)

114−

115−isoConst :: s -> a -> SemiIso s a

116−isoConst s a = SI (const $ pure a) (const $ pure s)

117−

118−konst :: Eq x => x -> SemiIso () x

119−konst x = badKonst x >>> check (== x)

120−

121−badKonst :: x -> SemiIso () x

122−badKonst x = SI (const $ pure x) (const $ pure ())

123−

124−tsnok :: Eq x => x -> SemiIso x ()

125−tsnok x = check (== x) >>> badTsnok x

126−

127−badTsnok :: x -> SemiIso x ()

128−badTsnok x = SI (const $ pure ()) (const $ pure x)

129−

130−check :: (s -> Bool) -> SemiIso s s

131−check f = isoCheck f id id

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

118+ anyToken = raise anyToken

119+ token' = raise token'

120+ tokens = raise . tokens

121+ tokens' = raise tokens'

122+ chunk = raise . chunk

123+ chunk' = raise chunk'

124+ notToken = raise . notToken

125+ tokenWhere = raise . tokenWhere

126+ manyTokens = raise manyTokens

127+ takeUntil = raise . takeUntil

128+ tokensWhile = raise . tokensWhile

129+ tokensWhile1 = raise . tokensWhile1

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

src/Data/Isoparsec/Megaparsec.hs+57−19

@@ -1,7 +1,9 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

33module Data.Isoparsec.Megaparsec

4− ( runMegaparsec,

4+ ( runMegaparsecParser,

5+ ParseErrorBundle (..),

6+ MegaparsecParser (..),

57 )

68where

@@ -9,42 +11,78 @@ import Control.Arrow.Extra

911import Control.Arrow.Extra.Orphans ()

1012import Control.Monad

1113import Data.Functor

12−import Data.Isoparsec.Internal as I

14+import Data.Functor.Identity

15+import Data.Isoparsec

16+import Data.Void

1317import Text.Megaparsec hiding (Token)

1418import qualified Text.Megaparsec as M

1519import Prelude hiding ((.))

1620

17−runMegaparsec ::

18− (Ord e, Stream s) =>

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

21+newtype MegaparsecParser s a b

22+ = MegaparsecParser {unMegaparsecParser :: Kleisli (ParsecT Void s Identity) a b}

23+ deriving (Category, BaseArrow, ArrowZero, ArrowChoice, PolyArrow SemiIso)

24+

25+instance

26+ (Stream s, s ~ M.Tokens s, Element s ~ M.Token s) =>

27+ ArrowPlus (MegaparsecParser s)

28+ where

29+ (MegaparsecParser (Kleisli lhs)) <+> (MegaparsecParser (Kleisli rhs)) =

30+ MegaparsecParser . Kleisli $ \x -> try (lhs x) <|> rhs x

31+

32+runMegaparsecParser ::

33+ (Stream s) =>

2034 s ->

21− Either (ParseErrorBundle s e) r

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

35+ MegaparsecParser s () r ->

36+ Either (ParseErrorBundle s Void) r

37+runMegaparsecParser s (MegaparsecParser (Kleisli f)) = runParser (f () <* eof) "" s

2338

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

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

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

2641 Just x -> return x

2742 Nothing -> M.failure Nothing mempty

2843

2944instance

30− (MonadParsec e s m, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>

31− Isoparsec (Kleisli m) s

45+ (Stream s, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>

46+ Isoparsec (MegaparsecParser s) s

3247 where

33− anyToken = Kleisli $ const anySingle

48+ anyToken = MegaparsecParser . Kleisli $ const anySingle

49+

50+ token t = MegaparsecParser . Kleisli . const $ M.single t $> ()

51+

52+ token' = MegaparsecParser . Kleisli $ \t -> M.single t $> t

53+

54+ tokens ts = MegaparsecParser . Kleisli . const $ M.chunk (fromList ts) $> ()

55+

56+ tokens' = MegaparsecParser . Kleisli $ \ts -> M.chunk (fromList ts) $> ts

57+

58+ chunk c = MegaparsecParser . Kleisli . const $ M.chunk c $> ()

59+

60+ chunk' = MegaparsecParser . Kleisli $ \c -> M.chunk c $> c

3461

35− token t = Kleisli . const $ M.single t $> ()

62+ notToken t = MegaparsecParser . Kleisli . const $ M.anySingleBut t

3663

37− manyTokens = Kleisli $ takeP Nothing . fromIntegral

64+ tokenWhere f = MegaparsecParser . Kleisli . const $ satisfy f

3865

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

66+ manyTokens = MegaparsecParser . Kleisli $ takeP Nothing . fromIntegral

67+

68+ takeUntil c = MegaparsecParser . Kleisli $ \() -> do

69+ ta <- M.manyTill M.anySingle (M.chunk c)

70+ return $ fromList ta

71+

72+ tokensWhile f = MegaparsecParser . Kleisli . const $ M.takeWhileP Nothing f

73+

74+ tokensWhile1 f = MegaparsecParser . Kleisli . const $ M.takeWhile1P Nothing f

75+

76+ tuck (MegaparsecParser (Kleisli f)) = MegaparsecParser . Kleisli $ \sub -> do

4077 sup <- getInput

4178 setInput sub

4279 r <- f () <* eof

4380 setInput sup

4481 return r

4582

46−instance MonadParsec e s m => IsoparsecFail (Kleisli m) e where

47− failure e = Kleisli $ \_ -> customFailure e

48−

49−instance (MonadParsec e s m, M.Token s ~ Element s, s ~ M.Tokens s) => ArrowPlus (Kleisli m) where

50− (Kleisli lhs) <+> (Kleisli rhs) = Kleisli $ \x -> try (lhs x) <|> rhs x

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

84+ sup <- getInput

85+ setInput sub

86+ r <- f x <* eof

87+ setInput sup

88+ return r

src/Data/Isoparsec/Printer.hs+63−19

@@ -1,39 +1,83 @@

11{-# OPTIONS_GHC -Wno-orphans #-}

33module Data.Isoparsec.Printer

4− ( runPrinter,

4+ ( runMonoidPrinter,

5+ MonoidPrinter (..),

56 )

67where

9+import Control.Cokleisli

810import Control.Monad.Writer.Lazy

11+import Data.Functor

912import Data.Isoparsec

10−import Data.Isoparsec.Cokleisli

13+import Data.List.Split

1114import Prelude hiding ((.), id)

1215

13−runPrinter ::

14− forall m s a.

15− Monad m =>

16− Cokleisli (WriterT (Dual s) m) () a ->

17− a ->

18− m s

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

16+newtype MonoidPrinter s a b

17+ = MonoidPrinter {unMonoidPrinter :: Cokleisli (WriterT (Dual s) Maybe) a b}

18+ deriving (Category, BaseArrow, ArrowZero, ArrowPlus, ArrowChoice, PolyArrow SemiIso)

2019

21−instance IsoparsecFail (Cokleisli (WriterT s Maybe)) e where

22− failure _ = Cokleisli . const $ WriterT Nothing

20+runMonoidPrinter ::

21+ forall s a.

22+ MonoidPrinter s () a ->

23+ a ->

24+ Maybe s

25+runMonoidPrinter p = fmap getDual . execWriterT . runCokleisli (unMonoidPrinter p)

2326

24−instance IsoparsecFail (Cokleisli (WriterT s (Either e))) e where

25− failure = Cokleisli . const . WriterT . Left

27+instance IsoparsecFail (MonoidPrinter s) e where

28+ failure _ = MonoidPrinter . Cokleisli . const $ WriterT Nothing

2629

2730instance

28− (MonadPlus m, Monoid s, Eq (Element s), Eq s, IsSequence s, Show s) =>

29− Isoparsec (Cokleisli (WriterT (Dual s) m)) s

31+ (Monoid s, Eq (Element s), IsSequence s) =>

32+ Isoparsec (MonoidPrinter s) s

3033 where

31− token t = Cokleisli $ const $ tell . Dual . singleton $ t

34+ anyToken = MonoidPrinter . Cokleisli $ tell . Dual . singleton

35+

36+ token t = MonoidPrinter . Cokleisli $ const $ tell . Dual . singleton $ t

37+

38+ token' = MonoidPrinter . Cokleisli $ \t -> (tell . Dual . singleton) t $> t

39+

40+ tokens ts = MonoidPrinter . Cokleisli $ const $ tell . Dual . fromList $ ts

41+

42+ tokens' = MonoidPrinter . Cokleisli $ \ts -> (tell . Dual . fromList) ts $> ts

43+

44+ chunk c = MonoidPrinter . Cokleisli . const $ tell . Dual $ c

3245

33− anyToken = Cokleisli $ tell . Dual . singleton

46+ chunk' = MonoidPrinter . Cokleisli $ \c -> (tell . Dual) c $> c

3447

35− manyTokens = Cokleisli $ \w -> do

48+ notToken nt = MonoidPrinter . Cokleisli $ \t ->

49+ if t == nt

50+ then empty

51+ else (tell . Dual . singleton) t

52+

53+ tokenWhere f = MonoidPrinter . Cokleisli $ \t ->

54+ if f t

55+ then (tell . Dual . singleton) t

56+ else empty

57+

58+ manyTokens = MonoidPrinter . Cokleisli $ \w -> do

3659 tell $ Dual w

3760 return . fromIntegral . olength $ w

3861

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

62+ takeUntil end = MonoidPrinter . Cokleisli $ \s ->

63+ if length ((split . onSublist $ otoList end) . otoList $ s) > 1

64+ then empty

65+ else do

66+ tell . Dual $ s

67+ tell . Dual $ end

68+

69+ tokensWhile f = MonoidPrinter . Cokleisli $ \s ->

70+ if oall f s

71+ then (tell . Dual) s

72+ else empty

73+

74+ tokensWhile1 f = MonoidPrinter . Cokleisli $ \s ->

75+ if oall f s && not (onull s)

76+ then (tell . Dual) s

77+ else empty

78+

79+ tuck (MonoidPrinter (Cokleisli f)) =

80+ MonoidPrinter . Cokleisli $ lift . fmap getDual . execWriterT . f

81+

82+ tuck' (MonoidPrinter (Cokleisli f)) =

83+ MonoidPrinter . Cokleisli $ lift . (fmap . fmap) getDual . runWriterT . f

src/Data/Isoparsec/ToIsoparsec.hs+11−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))

stack.yaml+1−1

@@ -17,7 +17,7 @@

1717#

1818# resolver: ./custom-snapshot.yaml

1919# resolver: https://example.com/snapshots/2018-01-01.yaml

20−resolver: lts-14.25

20+resolver: lts-15.8

2121

2222# User packages to be built.

2323# Various formats can be used as shown in the example below.

test/Spec.hs+23−1

@@ -1,6 +1,9 @@

1+import qualified Spec.BasicReader as BasicReader

12import qualified Spec.JSON as JSON

3+import qualified Spec.JSONHList as JSONHList

24import qualified Spec.Megaparsec.BasicNums as BasicNums

35import qualified Spec.Ssh as Ssh

6+import qualified Spec.SshHList as SshHList

47import qualified Spec.TwoDigits as TwoDigits

58import Test.Tasty

69import Test.Tasty.Hspec

@@ -10,6 +13,10 @@ main = do

1013 bsicNumSpec <- testSpec "Basic megaparsec test" BasicNums.spec

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

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

16+ sshHListSpec <- testSpec "ssh HList spec" SshHList.spec

17+ jsonSpec <- testSpec "json spec" JSON.spec

18+ jsonHListSpec <- testSpec "json spec" JSONHList.spec

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

1320 defaultMain

1421 ( testGroup

1522 "tests"

@@ -20,7 +27,13 @@ main = do

2027 ],

2128 testGroup

2229 "JSON"

23− [ JSON.quickSpec

30+ [ jsonSpec,

31+ JSON.quickSpec

32+ ],

33+ testGroup

34+ "JSONHList"

35+ [ jsonHListSpec,

36+ JSONHList.quickSpec

2437 ],

2538 testGroup

2639 "TwoDigits"

@@ -31,6 +44,15 @@ main = do

3144 "ssh"

3245 [ sshSpec,

3346 Ssh.quickSpec

47+ ],

48+ testGroup

49+ "ssh HList"

50+ [ sshHListSpec,

51+ SshHList.quickSpec

52+ ],

53+ testGroup

54+ "BasicReader"

55+ [ basicReaderSpec

3456 ]

3557 ]

3658 )

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+ runMegaparsecParser 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+28−15

@@ -2,6 +2,7 @@ module Spec.Helper

22 ( shouldParseBS,

33 roundtrip,

44 parseSatisfyBS,

5+ shouldParseS,

56 )

67where

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

2021

2122parseSatisfy ::

2223 forall x s.

23− ( ToIsoparsec x s,

24+ ( ToIsoparsec x s (MegaparsecParser s),

2425 Stream s,

2526 Show x,

2627 Show (M.Token s),

2728 Show s,

28− Isoparsec (Kleisli (Parsec Void s)) s

29+ Isoparsec (MegaparsecParser s) s

2930 ) =>

3031 s ->

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

3233 Expectation

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

34+parseSatisfy s p = runMegaparsecParser @s s toIsoparsec `shouldSatisfy` p

3435

3536parseSatisfyBS ::

3637 forall x.

37− ( ToIsoparsec x ByteString,

38+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

3839 Show x,

39− Isoparsec (Kleisli (Parsec Void ByteString)) ByteString

40+ Isoparsec (MegaparsecParser ByteString) ByteString

4041 ) =>

4142 ByteString ->

4243 (Either (ParseErrorBundle ByteString Void) x -> Bool) ->

@@ -45,45 +46,57 @@ parseSatisfyBS = parseSatisfy

4546

4647shouldParse ::

4748 forall x s.

48− ( ToIsoparsec x s,

49+ ( ToIsoparsec x s (MegaparsecParser s),

4950 Stream s,

5051 Show x,

5152 Eq x,

52− Isoparsec (Kleisli (Parsec Void s)) s

53+ Isoparsec (MegaparsecParser s) s

5354 ) =>

5455 s ->

5556 x ->

5657 Expectation

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

58+shouldParse s e = case runMegaparsecParser @s s toIsoparsec of

5859 Right e' -> e' `shouldBe` e

5960 Left err -> expectationFailure $ errorBundlePretty err

6061

6162shouldParseBS ::

6263 forall x.

63− ( ToIsoparsec x ByteString,

64+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

6465 Show x,

6566 Eq x,

66− Isoparsec (Kleisli (Parsec Void ByteString)) ByteString

67+ Isoparsec (MegaparsecParser ByteString) ByteString

6768 ) =>

6869 ByteString ->

6970 x ->

7071 Expectation

7172shouldParseBS = shouldParse

7273

74+shouldParseS ::

75+ forall x.

76+ ( ToIsoparsec x String (MegaparsecParser String),

77+ Show x,

78+ Eq x,

79+ Isoparsec (MegaparsecParser String) String

80+ ) =>

81+ String ->

82+ x ->

83+ Expectation

84+shouldParseS = shouldParse

85+

7386roundtrip ::

7487 forall x s.

75− ( ToIsoparsec x s,

88+ ( ToIsoparsec x s (MegaparsecParser s),

89+ ToIsoparsec x s (MonoidPrinter s),

7690 Stream s,

7791 Show s,

7892 I.Element s ~ M.Token s,

7993 Eq x,

80− Eq s,

81− Isoparsec (Kleisli (Parsec Void s)) s

94+ Isoparsec (MegaparsecParser s) s

8295 ) =>

8396 x ->

8497 Property

8598roundtrip x =

86− let s = fromJust $ runPrinter @Maybe @s toIsoparsec x

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

99+ let s = fromJust $ runMonoidPrinter @s toIsoparsec x

100+ in counterexample (show s) $ case runMegaparsecParser @s s toIsoparsec of

88101 Right y -> property $ x == y

89102 Left err -> counterexample (errorBundlePretty err) False

test/Spec/JSON.hs+27−23

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

33module Spec.JSON

44 ( quickSpec,

5+ spec,

56 )

67where

@@ -12,7 +13,8 @@ import Data.Isoparsec.Char

1213import Data.Isoparsec.Megaparsec

1314import Data.Isoparsec.Printer

1415import Data.Maybe

15−import Data.Void

16+import Spec.Helper

17+import Test.Hspec

1618import Test.Tasty

1719import Test.Tasty.QuickCheck

1820import Text.Megaparsec.Error

@@ -41,44 +43,46 @@ instance Arbitrary JSON where

4143

4244makePrisms ''JSON

4345

46+spec :: Spec

47+spec =

48+ it "deserializes" $ do

49+ "{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]

50+ "{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]

51+ "{}" `shouldParseS` Object []

52+ "[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]

53+ "[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]

54+

4455quickSpec :: TestTree

4556quickSpec =

4657 testProperty "roundtrips" $ \x ->

47− let s = fromJust $ runPrinter @Maybe @String json x

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

58+ let s = fromJust $ runMonoidPrinter @String json x

59+ in counterexample s $ case runMegaparsecParser s json of

4960 Right y -> property $ x == y

5061 Left err -> counterexample (errorBundlePretty err) False

5162

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

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

63+instance ToIsoparsec JSON String a where

64+ toIsoparsec = json

65+

66+json :: forall m. Isoparsec m String => m () JSON

67+json = string <+> array <+> integer <+> object

5468 where

55− string' = token '"' &&& tokensWhile (/= '"') &&& token '"'

69+ string' = token '"' **> tokensWhile (/= '"') >** token '"'

5670 string = _JString <.> string'

5771 array =

5872 _Array

5973 <.> token '['

6074 &&& unsafeWhiteSpace

61− &&& ( ( ( ( json &&& unsafeWhiteSpace

62− &&& repeating

63− ( (token ',' &&& unsafeWhiteSpace &&& json) >>% morphed

64− )

65− <+^ konst []

66− )

67− >>% morphed

68− )

69− >>^ siCons

70− )

71− <+^ konst []

72− )

75+ &&& sepByComma json

7376 &&& unsafeWhiteSpace

7477 &&& token ']'

7578 integer = _JInteger <.> number

7679 object =

7780 _Object <.> token '{' &&& unsafeWhiteSpace

78− &&& ( ( let pair = (unsafeWhiteSpace &&& string' &&& unsafeWhiteSpace &&& token ':' &&& unsafeWhiteSpace &&& json &&& unsafeWhiteSpace) >>^ morphed

79− in (pair &&& (repeating ((token ',' &&& unsafeWhiteSpace &&& pair) >>^ morphed) <+^ konst [])) >>^ siCons

80− )

81− <+^ konst []

82− )

81+ &&& sepByComma pair

8382 &&& unsafeWhiteSpace

8483 &&& token '}'

84+ pair =

85+ (unsafeWhiteSpace **> string' >** unsafeWhiteSpace >** token ':' >** unsafeWhiteSpace)

86+ &&& (json >** unsafeWhiteSpace)

87+ sepByComma :: Eq a => m () a -> m () [a]

88+ sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)

test/Spec/JSONHList.hsnew file+92

@@ -0,0 +1,92 @@

1+{-# LANGUAGE TemplateHaskell #-}

3+module Spec.JSONHList

4+ ( quickSpec,

5+ spec,

6+ )

7+where

9+import Control.Arrow.Extra

10+import Control.Lens.TH

11+import Data.Isoparsec

12+import Data.Isoparsec.Char

13+import Data.Isoparsec.Megaparsec

14+import Data.Isoparsec.Printer

15+import Data.Maybe

16+import Spec.Helper

17+import Test.Hspec

18+import Test.Tasty

19+import Test.Tasty.QuickCheck

20+import Text.Megaparsec.Error

21+import Prelude hiding ((.))

22+

23+data JSON

24+ = Object [(String, JSON)]

25+ | JString String

26+ | Array [JSON]

27+ | JInteger Integer

28+ deriving (Show, Eq)

29+

30+instance Arbitrary JSON where

31+ arbitrary =

32+ oneof

33+ [ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),

34+ JString <$> listOf (elements ['.' .. 'z']),

35+ Array <$> listOf (scale (`div` 2) arbitrary),

36+ JInteger <$> arbitrary

37+ ]

38+

39+ shrink (Object a) = Object <$> shrink a

40+ shrink (JString a) = JString <$> shrink a

41+ shrink (Array a) = Array <$> shrink a

42+ shrink (JInteger a) = JInteger <$> shrink a

43+

44+makePrisms ''JSON

45+

46+spec :: Spec

47+spec =

48+ it "deserializes" $ do

49+ "{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]

50+ "{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]

51+ "{}" `shouldParseS` Object []

52+ "[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]

53+ "[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]

54+

55+quickSpec :: TestTree

56+quickSpec =

57+ testProperty "roundtrips" $ \x ->

58+ let s = fromJust $ runMonoidPrinter @String json x

59+ in counterexample s $ case runMegaparsecParser s json of

60+ Right y -> property $ x == y

61+ Left err -> counterexample (errorBundlePretty err) False

62+

63+instance ToIsoparsec JSON String a where

64+ toIsoparsec = json

65+

66+json :: forall m. Isoparsec m String => m () JSON

67+json = delist $ string ~| array ~| integer ~| object

68+ where

69+ string' :: Listed m () String

70+ string' = token '"' ~> tokensWhile (/= '"') ~> token '"'

71+ string :: Listed m () JSON

72+ string = string' ~$> _JString

73+ array :: Listed m () JSON

74+ array =

75+ token '['

76+ ~> unsafeWhiteSpace

77+ ~> sepByComma json

78+ ~> unsafeWhiteSpace

79+ ~> token ']'

80+ ~$> _Array

81+ integer = number ~$> _JInteger

82+ object =

83+ token '{' ~> unsafeWhiteSpace

84+ ~> hmap sepByComma pair

85+ ~> unsafeWhiteSpace

86+ ~> token '}'

87+ ~$> _Object

88+ pair =

89+ unsafeWhiteSpace ~> string' ~> unsafeWhiteSpace ~> token ':' ~> unsafeWhiteSpace

90+ ~& json ~> unsafeWhiteSpace

91+ sepByComma :: Eq a => m () a -> m () [a]

92+ sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)

test/Spec/Megaparsec/BasicNums.hs+5−6

@@ -13,7 +13,6 @@ import Data.Isoparsec.Char

1313import Data.Isoparsec.Megaparsec

1414import Data.Isoparsec.Printer

1515import Data.Maybe

16−import Data.Void

1716import Test.Hspec

1817import Test.Tasty

1918import Test.Tasty.QuickCheck

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

3433spec :: Spec

3534spec =

3635 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

36+ runMegaparsecParser "12 31" parser `shouldBe` Right (Foo 12 31)

37+ runMegaparsecParser "1 33" parser `shouldBe` Right (Foo 1 33)

38+ runMegaparsecParser "1562" parser `shouldSatisfy` isLeft

4039

4140quickSpec :: TestTree

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

43− let s = fromJust $ runPrinter @Maybe @String parser x

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

42+ let s = fromJust $ runMonoidPrinter @String parser x

43+ in counterexample s $ case runMegaparsecParser s parser of

4544 Right y -> property $ x == y

4645 Left err -> counterexample (errorBundlePretty err) False

test/Spec/Ssh.hs+19−20

@@ -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,19 +88,19 @@ 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

9595 &&& auto @DisconnectReasonCode

96− &&& (tokensWhile (const True) >>> utf8)

96+ &&& (tokensWhile (const True) >>^ utf8)

9797 )

9898 <+> ( _ServiceRequest <.> specific ServiceRequestMsg

9999 &&& auto @SSHString

100100 )

101101 <+> ( _VersionPayload <.> chunk "SSH-2.0-"

102− &&& (tokensWhile (`BS.notElem` " \n\r") >>> utf8)

103− &&& ( (chunk " " >>> takeUntil "\r\n" >>^ turn (badKonst ""))

102+ &&& (tokensWhile (`BS.notElem` " \n\r") >>^ utf8)

103+ &&& ( (chunk " " >>> takeUntil "\r\n" >>^ (maskr . turn . konst $ ""))

104104 <+> chunk "\r\n"

105105 )

106106 )

@@ -125,7 +125,7 @@ newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}

125125badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding

126126badZeroPadding =

127127 throughIntegral

128− >>> manyTokens

128+ ^>> manyTokens

129129 >>^ siPure

130130 (ZeroPadding . fromIntegral . BS.length)

131131 (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)

@@ -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,18 +151,17 @@ 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 =

156− ( ( (auto @(Byte32 'BE) &&& auto @Byte8)

157− >>> (throughIntegral *** throughIntegral)

158− >>> siPure

159− (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))

160− (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))

161− ^>> (manyTokens *** throughIntegral)

162− >>> (tuck (auto @Payload) *** badZeroPadding)

163− )

164− &&& auto @mac

156+ ( auto @(Byte32 'BE) &&& anyToken

157+ >>^ throughIntegral *** throughIntegral

158+ >>^ siPure

159+ (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))

160+ (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))

161+ >>> manyTokens *** arr throughIntegral

162+ >>> tuck (auto @Payload) *** badZeroPadding

165163 )

164+ &&& auto @mac

166165 >>^ siPure (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))

167166

168167spec :: Spec

test/Spec/SshHList.hsnew file+192

@@ -0,0 +1,192 @@

1+{-# LANGUAGE TemplateHaskell #-}

3+module Spec.SshHList

4+ ( spec,

5+ quickSpec,

6+ )

7+where

9+import Control.Lens.TH

10+import Data.ByteString as BS

11+import qualified Data.Char as C

12+import Data.Either

13+import Data.Isoparsec

14+import Data.Isoparsec.ByteString

15+import Data.Word

16+import GHC.Generics

17+import Numeric.Natural

18+import Spec.Helper

19+import Spec.Orphans ()

20+import Test.Hspec

21+import Test.Tasty

22+import Test.Tasty.QuickCheck

23+import Prelude as P hiding ((.), id)

24+

25+data MessageNumber

26+ = DisconnectMsg

27+ | IgnoreMsg

28+ | UnimplementedMsg

29+ | DebugMsg

30+ | ServiceRequestMsg

31+ | ServiceAcceptMsg

32+ | KextInitMsg

33+ | NewKeysMsg

34+ deriving (Eq, Show, Ord)

35+

36+instance ToIsoparsec MessageNumber ByteString a where

37+ toIsoparsec =

38+ delist $

39+ anyToken

40+ ~> mapIso

41+ [ (1 :: Word8, DisconnectMsg),

42+ (2, IgnoreMsg),

43+ (3, UnimplementedMsg),

44+ (4, DebugMsg),

45+ (5, ServiceRequestMsg),

46+ (6, ServiceAcceptMsg),

47+ (20, KextInitMsg),

48+ (21, NewKeysMsg)

49+ ]

50+

51+newtype DisconnectReasonCode

52+ = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}

53+ deriving (Eq, Ord, Show, Generic, Arbitrary)

54+

55+instance ToIsoparsec DisconnectReasonCode ByteString a

56+

57+newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}

58+ deriving (Eq, Ord, Show, Generic, Arbitrary)

59+

60+instance ToIsoparsec AlwaysDisplay ByteString a

61+

62+newtype PacketSequenceNumber

63+ = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}

64+ deriving (Eq, Ord, Show, Generic, Arbitrary)

65+

66+instance ToIsoparsec PacketSequenceNumber ByteString a

67+

68+data Payload

69+ = VersionPayload String

70+ | IgnorePayload ByteString

71+ | ServiceRequest SSHString

72+ | DebugPayload AlwaysDisplay SSHString

73+ | DisconnectPayload DisconnectReasonCode String

74+ | ServiceAccept SSHString

75+ | UnimplementedPayload PacketSequenceNumber

76+ deriving (Show, Eq)

77+

78+instance Arbitrary Payload where

79+ arbitrary =

80+ oneof

81+ [ VersionPayload . P.filter (not . C.isSpace) <$> s,

82+ IgnorePayload <$> arbitrary,

83+ ServiceRequest . SSHString <$> s,

84+ DebugPayload <$> arbitrary <*> (SSHString <$> s),

85+ DisconnectPayload <$> arbitrary <*> s,

86+ ServiceAccept . SSHString <$> s,

87+ UnimplementedPayload <$> arbitrary

88+ ]

89+ where

90+ s = getASCIIString <$> arbitrary

91+

92+makePrisms ''Payload

93+

94+instance ToIsoparsec Payload ByteString a where

95+ toIsoparsec =

96+ delist $

97+ specific DisconnectMsg ~> auto @DisconnectReasonCode

98+ ~& tokensWhile (const True)

99+ ~>^ utf8

100+ ~$> _DisconnectPayload

101+ ~| specific ServiceRequestMsg ~> auto @SSHString ~$> _ServiceRequest

102+ ~| chunk "SSH-2.0-"

103+ ~> tokensWhile (`BS.notElem` " \n\r")

104+ ~>^ utf8

105+ ~> ( chunk " " ~> takeUntil "\r\n" ~>^ (maskr . turn . konst $ ("" :: ByteString))

106+ ~| chunk "\r\n"

107+ )

108+ ~$> _VersionPayload

109+ ~| specific IgnoreMsg ~> tokensWhile (const True) ~$> _IgnorePayload

110+ ~| specific DebugMsg ~> auto @AlwaysDisplay

111+ ~& auto @SSHString

112+ ~$> _DebugPayload

113+ ~| specific UnimplementedMsg ~> auto @PacketSequenceNumber ~$> _UnimplementedPayload

114+ ~| specific ServiceAcceptMsg ~> auto @SSHString ~$> _ServiceAccept

115+

116+newtype Padding = Padding {unPadding :: ByteString}

117+ deriving (Eq, Ord, Show, Generic, Arbitrary)

118+

119+newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}

120+ deriving (Eq, Ord, Show, Generic, Arbitrary)

121+

122+badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding

123+badZeroPadding =

124+ delist $

125+ throughIntegral

126+ ^~> manyTokens

127+ ~>^ siPure

128+ (ZeroPadding . fromIntegral . BS.length)

129+ (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)

130+

131+newtype MAC = MAC {unMAC :: ByteString}

132+ deriving (Eq, Ord, Show, Generic, Arbitrary)

133+

134+data NoneMAC = NoneMAC

135+ deriving (Eq, Ord, Show, Generic)

136+

137+instance ToIsoparsec NoneMAC b a where

138+ toIsoparsec = arr $ konst NoneMAC

139+

140+instance Arbitrary NoneMAC where

141+ arbitrary = return NoneMAC

142+

143+data Packet mac

144+ = Packet Payload ZeroPadding mac

145+ deriving (Eq, Show)

146+

147+instance Arbitrary mac => Arbitrary (Packet mac) where

148+ arbitrary = Packet <$> arbitrary <*> arbitrary <*> arbitrary

149+

150+makePrisms ''Packet

151+

152+instance ToIsoparsec (Packet NoneMAC) ByteString a where

153+ toIsoparsec =

154+ delist $

155+ ( ( (auto @(Byte32 'BE) ~* anyToken)

156+ ~> (arr (throughIntegral @(Byte32 'BE) @Natural) ~* arr (throughIntegral @Byte8 @Natural))

157+ ~>^ siPure

158+ (\(packetL, paddingL :: Natural) -> (packetL - paddingL - 1 :: Natural, paddingL :: Natural))

159+ (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))

160+ ~> (manyTokens ~* arr (throughIntegral @Natural @Byte8))

161+ ~> (tuck (auto @Payload) ~* badZeroPadding)

162+ )

163+ ~& auto @NoneMAC

164+ )

165+ ~$> _Packet

166+

167+spec :: Spec

168+spec = do

169+ it "deserialize payload" $ do

170+ "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"

171+ "SSH-2.0-TesT" `parseSatisfyBS` isLeft @_ @Payload

172+ "SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"

173+ "SSH-2.0-TesT random comment" `parseSatisfyBS` isLeft @_ @Payload

174+ "\x2__" `shouldParseBS` IgnorePayload "__"

175+ "\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")

176+ it "deserialize packet" $ do

177+ ("\0\0\0\xd" <> "\x2" <> "\x5\0\0\0\x5henlo" <> "69")

178+ `shouldParseBS` Packet (ServiceRequest (SSHString "henlo")) (ZeroPadding 2) NoneMAC

179+ ("\0\0\0\xd" <> "\x2" <> "\x2\0\0\0\x5henlo" <> "69")

180+ `shouldParseBS` Packet (IgnorePayload "\0\0\0\x5henlo") (ZeroPadding 2) NoneMAC

181+ ("\0\0\0\xd" <> "\x3" <> "\x2\0\0henlo!" <> "69a")

182+ `shouldParseBS` Packet (IgnorePayload "\0\0henlo!") (ZeroPadding 3) NoneMAC

183+ ("\0\0\0\xb" <> "\x3" <> "\x2henlo!" <> "69a")

184+ `shouldParseBS` Packet (IgnorePayload "henlo!") (ZeroPadding 3) NoneMAC

185+

186+quickSpec :: TestTree

187+quickSpec =

188+ testGroup

189+ "roundtrips"

190+ [ testProperty "payload" $ roundtrip @Payload @ByteString,

191+ testProperty "packet" $ roundtrip @(Packet NoneMAC) @ByteString

192+ ]

test/Spec/TwoDigits.hs+15−16

@@ -11,7 +11,6 @@ import Data.Isoparsec.Chunks

1111import Data.Isoparsec.Megaparsec

1212import Data.Isoparsec.Printer

1313import Data.Maybe

14−import Data.Void

1514import GHC.Generics

1615import Test.Hspec

1716import Test.Tasty

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

2221newtype SingleDigit = SingleDigit {unSingleDigit :: String}

2322 deriving (Eq, Show, Generic)

2423

25−instance ToIsoparsec SingleDigit String where

24+instance ToIsoparsec SingleDigit String m where

2625 toIsoparsec =

2726 toIsoparsec @(Chunk 1 String)

28− >>> coercing

29− ^>> check (all @[] isDigit)

30− ^>^ coercing

27+ >>^ coercing

28+ >>^ check (all @[] isDigit)

29+ >>^ coercing

3130

32−instance (Arbitrary SingleDigit) where

31+instance Arbitrary SingleDigit where

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

3433

3534data Digits

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

4645 TwoDigits <$> arbitrary <*> arbitrary

4746 ]

4847

49−instance ToIsoparsec Digits String

48+instance ToIsoparsec Digits String m

5049

5150spec :: Spec

5251spec = do

5352 let parser = toIsoparsec @_ @String

5453 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

54+ runMegaparsecParser "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))

55+ runMegaparsecParser "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))

56+ runMegaparsecParser "1253" parser `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))

57+ runMegaparsecParser "12538" parser `shouldSatisfy` isLeft

58+ runMegaparsecParser "2" parser `shouldSatisfy` isLeft

59+ runMegaparsecParser "a" parser `shouldSatisfy` isLeft

60+ runMegaparsecParser "1a" parser `shouldSatisfy` isLeft

6261

6362quickSpec :: TestTree

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

65− let s = fromJust $ runPrinter @Maybe @String parser x

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

64+ let s = fromJust $ runMonoidPrinter @String parser x

65+ in counterexample s $ case runMegaparsecParser s parser of

6766 Right y -> property $ x == y

6867 Left err -> counterexample (errorBundlePretty err) False

6968 where