ffdd327..master · isoparsec

git.iko.soy/isoparsec

35 files changed+1707−536

unifiedsplit

.github/workflows/haskell.yml+4−3

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

1010 strategy:

1111 matrix:

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

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

1313

1414 steps:

1515 - uses: actions/checkout@v1

@@ -22,12 +22,13 @@ jobs:

2222

2323 - name: Build

2424 run: |

25− stack build --fast --pedantic --ghc-options '-j' --test --no-run-tests --bench --no-run-benchmarks --resolver=${{ matrix.resolver }}

25+ stack build --fast --pedantic --ghc-options '-j -ddump-to-file -ddump-hi' --test --no-run-tests --bench --no-run-benchmarks --resolver=${{ matrix.resolver }}

2626

2727 - name: Test

2828 run: |

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

3030

3131 - name: Weeder

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

3233 run: |

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

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

.hlint.yaml+130−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

@@ -60,3 +60,132 @@

6060# $ hlint --default > .hlint.yaml

6161

6262- ignore: {name: "Use list comprehension"}

63+

64+- arguments:

65+ - -XAllowAmbiguousTypes

66+ - -XConstraintKinds

67+ - -XDataKinds

68+ - -XDefaultSignatures

69+ - -XDeriveGeneric

70+ - -XFlexibleContexts

71+ - -XFlexibleInstances

72+ - -XFunctionalDependencies

73+ - -XGADTs

74+ - -XGeneralizedNewtypeDeriving

75+ - -XLambdaCase

76+ - -XMultiParamTypeClasses

77+ - -XOverloadedStrings

78+ - -XPatternSynonyms

79+ - -XPolyKinds

80+ - -XScopedTypeVariables

81+ - -XStandaloneDeriving

82+ - -XTupleSections

83+ - -XTypeApplications

84+ - -XTypeFamilies

85+ - -XTypeOperators

86+ - -XUndecidableInstances

87+ - -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+6−1

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

1−# isoparsec

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

23Isomorphic (invertible) parser library

5+### 🚧 Under construction 🚧

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

package.yaml+6−3

@@ -22,14 +22,17 @@ description: Please see the README on GitHub at <https://github.com/ilya

2222dependencies:

2323- base >= 4.7 && < 5

2424- containers

25−- optics-core

2625- megaparsec

2726- bytestring

2827# - text

2928- mtl

29+- profunctors

30+- mono-traversable

31+- split

3032

3133library:

3234 source-dirs: src

35+ other-modules: Control.Prism

3336 dependencies: []

3437

3538default-extensions:

@@ -55,6 +58,7 @@ default-extensions:

5558- TypeFamilies

5659- TypeOperators

5760- UndecidableInstances

61+- RankNTypes

5862

5963tests:

6064 isoparsec-test:

@@ -70,9 +74,8 @@ tests:

7074 - tasty

7175 - tasty-hspec

7276 - hspec

73− - optics

77+ - lens

7478 - tasty-quickcheck

7579 - QuickCheck

7680 - megaparsec

7781 - bytestring

78− - word8

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−8

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

1−module Data.Isoparsec.Cokleisli

1+module Control.Cokleisli

22 ( Cokleisli (..),

33 )

44where

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

66import Control.Applicative

77import Control.Arrow.Extra

88import Control.Monad

9−import Data.Isoparsec.Internal

10−import Optics.Iso

9+import Control.SemiIso

1110import Prelude hiding ((.))

1211

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

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

1413

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

1615 id = Cokleisli return

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

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

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

2928

30−instance MonadPlus m => PolyArrow (Cokleisli m) SemiIso' where

31− arr (SemiIso' si) = Cokleisli $ \t -> case withIso si (flip const) t of

32− Just x -> return x

33− Nothing -> mzero

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

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

3431

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

3633 zeroArrow = Cokleisli $ const mzero

src/Control/Prism.hsnew file+40

@@ -0,0 +1,40 @@

1+module Control.Prism

2+ ( withPrism,

3+ Identity,

4+ Prism',

5+ )

6+where

8+import Data.Coerce

9+import Data.Functor.Identity

10+import Data.Profunctor

11+

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

13+

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

15+

16+instance Functor (Market a b s) where

17+ fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)

18+

19+instance Profunctor (Market a b) where

20+ dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)

21+ lmap f (Market bt seta) = Market bt (seta . f)

22+ rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)

23+

24+instance Choice (Market a b) where

25+ left' (Market bt seta) = Market (Left . bt) $ \case

26+ Left s -> case seta s of

27+ Left t -> Left (Left t)

28+ Right a -> Right a

29+ Right c -> Left (Right c)

30+ right' (Market bt seta) = Market (Right . bt) $ \case

31+ Left c -> Left (Left c)

32+ Right s -> case seta s of

33+ Left t -> Left (Right t)

34+ Right a -> Right a

35+

36+type APrism b a = Market a a a (Identity a) -> Market a a b (Identity b)

37+

38+withPrism :: APrism b a -> ((a -> b) -> (b -> Either b a) -> r) -> r

39+withPrism k f = case coerce (k (Market Identity Right)) of

40+ Market bt seta -> f bt seta

src/Control/SemiIso.hsnew file+206

@@ -0,0 +1,206 @@

1+module Control.SemiIso

2+ ( module X,

3+ SemiIso (..),

4+ pattern SI,

5+ siMaybe,

6+ siPure,

7+ turn,

8+ withSemiIso,

9+ 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,

37+ )

38+where

39+

40+import Control.Applicative as X

41+import Control.Arrow.Extra

42+import Control.Monad as X

43+import qualified Data.Bifunctor as Bi

44+import Data.Bitraversable

45+import Data.Tuple

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

47+

48+type AlternativeMonad m = (Alternative m, Monad m)

49+

50+data SemiIso a b

51+ = SemiIso

52+ { embed :: forall f. AlternativeMonad f => a -> f b,

53+ project :: forall f. AlternativeMonad f => b -> f a

54+ }

55+

56+pattern SI ::

57+ forall a b.

58+ (forall f. AlternativeMonad f => a -> f b) ->

59+ (forall f. AlternativeMonad f => b -> f a) ->

60+ SemiIso a b

61+pattern SI a b = SemiIso a b

62+

63+siMaybe :: (a -> Maybe b) -> (b -> Maybe a) -> SemiIso a b

64+siMaybe a b = SI (maybeToAlternative . a) (maybeToAlternative . b)

65+ where

66+ maybeToAlternative :: Alternative f => Maybe a -> f a

67+ maybeToAlternative (Just x) = pure x

68+ maybeToAlternative Nothing = empty

69+

70+siPure :: (a -> b) -> (b -> a) -> SemiIso a b

71+siPure a b = SI (pure . a) (pure . b)

72+

73+instance Category SemiIso where

74+ id = SemiIso pure pure

75+ (SemiIso a1 b1) . (SemiIso a2 b2) = SemiIso (a1 <=< a2) (b2 <=< b1)

76+

77+instance BaseArrow SemiIso where

78+ (SemiIso a1 b1) *** (SemiIso a2 b2) =

79+ SemiIso

80+ (\(x, y) -> (,) <$> a1 x <*> a2 y)

81+ (\(x, y) -> (,) <$> b1 x <*> b2 y)

82+ (SemiIso a1 b1) &&& (SemiIso a2 b2) =

83+ SemiIso

84+ (\x -> (,) <$> a1 x <*> a2 x)

85+ (\(x, y) -> b1 x <|> b2 y)

86+

87+instance ArrowChoice SemiIso where

88+ (SemiIso a1 b1) +++ (SemiIso a2 b2) =

89+ SemiIso (bitraverse a1 a2) (bitraverse b1 b2)

90+ (SemiIso a1 b1) ||| (SemiIso a2 b2) =

91+ SemiIso

92+ (either a1 a2)

93+ (\x -> (Left <$> b1 x) <|> (Right <$> b2 x))

94+

95+instance ArrowZero SemiIso where

96+ zeroArrow = SemiIso (const empty) (const empty)

97+

98+instance ArrowPlus SemiIso where

99+ (SemiIso a1 b1) <+> (SemiIso a2 b2) =

100+ SemiIso

101+ (\x -> a1 x <|> a2 x)

102+ (\x -> b1 x <|> b2 x)

103+

104+-- | prop> turn . turn = id

105+turn :: SemiIso a b -> SemiIso b a

106+turn (SemiIso a b) = SemiIso b a

107+

108+withSemiIso ::

109+ AlternativeMonad f =>

110+ SemiIso a b ->

111+ ((a -> f b) -> (b -> f a) -> c) ->

112+ c

113+withSemiIso (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+257−112

@@ -2,154 +2,299 @@

33module Data.Isoparsec

44 ( module X,

5− -- Isoparsec,

6− (%>>),

7− (%>%),

8− (>>%),

9− (%<<),

10− (%<%),

11− (<<%),

12− (<?>),

13− (<+%),

14− (%+>),

15− (%+%),

165 (<.>),

17− (<^>),

186 repeating,

7+ sepBy,

8+ sepBy1,

199 opt,

2010 opt',

2111 morphed,

12+ fMorphed,

2213 coercing,

2314 mapIso,

2415 auto,

2516 specific,

2617 throughIntegral,

18+ (~>),

19+ (~>^),

20+ (^~>),

21+ (^~>^),

22+ (~|),

23+ (~$>),

24+ (~&),

25+ (~*),

26+ siPrism,

27+ delist,

28+ enlist,

29+ Listed,

30+ hmap,

2731 )

2832where

2933

3034import Control.Arrow.Extra as X

35+import Control.Prism

3136import Control.Tuple.Morph

3237import Data.Coerce

38+import Data.Either

3339import Data.Isoparsec.Internal as X

3440import Data.Isoparsec.ToIsoparsec as X

35−import Data.Isoparsec.Tokenable as X

3641import qualified Data.Map as M

37−import Optics.Iso

38−import Optics.Optic

39−import Optics.Prism

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

4143

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

43−opt m = try m <+> konst ()

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

45+opt m = m <+^ konst ()

4446

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

46−opt' a m = (try 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))

4749

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

49−repeating m = (try m &&& (try (repeating m) <+> konst [])) >>^ cons'

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

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

5052

51−infix 0 <?>

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

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

5255

53−(<?>) :: IsoparsecLabel m l => m a b -> l -> m a b

54−thing <?> msg = label msg thing

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

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

5558

56−infixr 1 %>>

57−

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

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

60−

61−infixr 1 %>%

62−

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

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

65−

66−infixr 1 >>%

67−

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

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

70−

71−infixr 1 %<<

72−

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

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

75−

76−infixr 1 %<%

77−

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

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

80−

81−infixr 1 <<%

82−

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

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

85−

86−infixr 5 <+%

87−

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

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

90−

91−infixr 5 %+>

92−

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

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

95−

96−infixr 5 %+%

97−

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

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

100−

101−infixr 0 <.>

59+infixl 0 <.>

10260

10361(<.>) ::

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

105− b ->

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

63+ (Prism' a b) ->

10664 m x' x ->

107− m x' y'

108−b <.> p = (p >>% morphed) >>% b

109−

110−infixr 0 <^>

111−

112−(<^>) ::

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

114− m x' x ->

115− b ->

116− m x' y'

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

118−

119−coercing :: forall b a m. (Coercible a b, PolyArrow m SemiIso') => m a b

120−coercing = arr $ siJust coerce coerce

121−

122−morphed ::

123− (TupleMorphable a c, TupleMorphable b c) =>

124− Iso' a b

125−morphed = iso morphTuples morphTuples

126−

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

128− si :: x -> SemiIso' a b

129−

130−instance (k `Is` A_Prism) => ToSemiIso (Optic' k NoIx b a) a b where

131− si p = si' (Just . n) (either (const Nothing) Just . u)

132− where

133− (n, u) = withPrism p (,)

134−

135−instance ToSemiIso (SemiIso' a b) a b where

136− si = id

137−

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

139−mapIso m = arr $ si' (`M.lookup` n) (`M.lookup` u)

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

239+

240+coercing :: forall b a. Coercible a b => SemiIso a b

241+coercing = siPure coerce coerce

242+

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

244+morphed = siPure morphTuples morphTuples

245+

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

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

140285 where

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

142287 u =

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

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

145290

146−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

147292auto = toIsoparsec

148293

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

150−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)

151296

152297throughIntegral ::

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

154− m a b

155−throughIntegral = arr $ siJust 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+23−32

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

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

23module Data.Isoparsec.ByteString

34 ( utf8,

4− ftu8,

55 ByteString,

66 Endianness (..),

77 Byte8,

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

2020import Data.Word

2121import Prelude as P hiding ((.))

2222

23−utf8 :: Isoparsec m ByteString => String -> m () ()

24−utf8 = chunk . C.pack

25−

26−ftu8 :: PolyArrow m SemiIso' => m ByteString String

27−ftu8 = arr $ siJust C.unpack C.pack

23+utf8 :: SemiIso ByteString String

24+utf8 = siPure C.unpack C.pack

2825

2926data Endianness = BE | LE

3027

@@ -33,10 +30,10 @@ class BytesToIsoparsec b (e :: Endianness) where

3330

3431instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'BE where

3532 bytesToIsoparsec _ =

36− konst word8s >>> manyTokens

37− >>^ siJust

33+ konst word8s ^>> manyTokens

34+ >>^ siPure

3835 (fromInteger . BS.foldl (\i w -> shiftL i 8 .|. toInteger w) 0)

39− ( liftTokens . snd . P.head

36+ ( fromList . snd . P.head

4037 . P.drop (fromIntegral word8s)

4138 . iterate (\(i, ww) -> (shiftR i 8, fromInteger i : ww))

4239 . (,[])

@@ -47,10 +44,10 @@ instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'BE where

4744

4845instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'LE where

4946 bytesToIsoparsec _ =

50− konst word8s >>> manyTokens

51− >>^ siJust

47+ konst word8s ^>> manyTokens

48+ >>^ siPure

5249 (fromInteger . BS.foldr (\w i -> shiftL i 8 .|. toInteger w) 0)

53− ( liftTokens . P.reverse . snd . P.head

50+ ( fromList . P.reverse . snd . P.head

5451 . P.drop (fromIntegral word8s)

5552 . iterate (\(i, ww) -> (shiftR i 8, fromInteger i : ww))

5653 . (,[])

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

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

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

7269

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

74− toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte16 e) @Word16

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

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

7572

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

77− toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte32 e) @Word32

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

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

7875

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

80− toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte64 e) @Word64

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

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

8178

82−instance ToIsoparsec Bool ByteString where

79+instance ToIsoparsec Bool ByteString m where

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

8481

8582newtype SSHString = SSHString {unSSHString :: String}

8683 deriving (Show, Eq, Ord)

8784

88−instance ToIsoparsec SSHString ByteString where

85+instance ToIsoparsec SSHString ByteString m where

8986 toIsoparsec =

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

91− >>> siJust fromIntegral fromIntegral ^>> manyTokens

92− >>> ftu8

93− >>^ siJust SSHString unSSHString

94−

95−instance Tokenable ByteString where

96−

97− type Token ByteString = Word8

98−

99− liftTokens = pack

100−

101− lowerTokens = unpack

87+ auto @(Byte32 'BE)

88+ >>^ coercing @Word32

89+ >>^ siPure fromIntegral fromIntegral

90+ >>> manyTokens

91+ >>^ utf8

92+ >>^ siPure SSHString unSSHString

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

@@ -11,16 +11,16 @@ import Data.Isoparsec

1111import Text.Read

1212import Prelude hiding ((.), id)

1313

14−space :: (Isoparsec m s, Token s ~ Char) => m () ()

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

1515space = token ' '

1616

17−unsafeWhiteSpace :: (Isoparsec m s, Token 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, Token s ~ Char) => m () ()

21−unsafeWhiteSpace1 = tokensWhile1 isSpace >>> badTsnok (liftToken ' ')

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

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

2222

23−number :: (Isoparsec m s, Token s ~ Char) => m () Integer

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

2424number =

2525 tokensWhile1 (\c -> isNumber c || c == '+' || c == '-')

26− >>^ si' (readMaybe @Integer . lowerTokens) (Just . liftTokens . show)

26+ >>^ siMaybe (readMaybe @Integer . otoList) (Just . fromList . show)

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

@@ -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 =

15− konst (fromIntegral $ natVal @n Proxy) >>> manyTokens >>> coercing

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

src/Data/Isoparsec/Internal.hs+75−112

@@ -1,87 +1,76 @@

11module Data.Isoparsec.Internal

2− ( SemiIso' (..),

3− SemiIso,

4− si',

2+ ( module X,

53 IsoparsecFail (..),

64 Isoparsec (..),

7− IsoparsecTry (..),

8− IsoparsecLabel (..),

9− konst,

10− tsnok,

11− cons',

12− siJust,

13− siCheck,

14− siCheck',

15− check,

16− levitate,

17− siDecompose,

18− badKonst,

19− badTsnok,

5+ siCons,

6+ unroll,

7+ arrowsWhile,

8+ arrowsUntil,

9+ EffectOnly,

2010 )

2111where

2212

2313import Control.Arrow.Extra

14+import Control.Arrow.Trans.Reader

2415import Control.Monad

25−import Data.Isoparsec.Tokenable

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

17+import Data.MonoTraversable as X

18+import Data.Sequences as X

2619import Numeric.Natural

27−import Optics.Iso

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

2921

3022class

31− (PolyArrow m SemiIso', ArrowPlus m, ArrowChoice m, IsoparsecTry m, Tokenable s) =>

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

3224 Isoparsec m s

3325 | m -> s where

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

3427

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

28+ anyToken :: m () (Element s)

3629

37− anyToken :: m () (Token s)

30+ token :: Element s -> EffectOnly m

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

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

3833

39− token :: Token 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))

4037

41− default token :: Eq (Token s) => Token s -> m () ()

42− token x = anyToken >>> tsnok x

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

39+ tokens [] = arr $ isoConst () ()

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

4341

44− tokens :: [Token s] -> m () ()

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

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

4544

46− default tokens :: [Token s] -> m () ()

47− tokens [] = arr $ isoConst' () ()

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

45+ chunk :: s -> EffectOnly m

46+ chunk = tokens . otoList

4947

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

51− chunk = tokens . lowerTokens

52−

53− notToken :: Token s -> m () (Token s)

48+ chunk' :: m s s

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

50+ where

51+ list = siPure otoList fromList

5452

55− default notToken :: Eq (Token s) => Token s -> m () (Token s)

53+ notToken :: Element s -> m () (Element s)

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

5655 notToken t = tokenWhere (/= t)

5756

58− tokenWhere :: (Token s -> Bool) -> m () (Token s)

59− tokenWhere f =

60− anyToken >>> check f

57+ tokenWhere :: (Element s -> Bool) -> m () (Element s)

58+ tokenWhere f = anyToken >>^ check f

6159

6260 manyTokens :: m Natural s

6361

64− tokensWhile :: (Token s -> Bool) -> m () s

65−

6662 takeUntil :: s -> m () s

63+ default takeUntil :: Eq s => s -> m () s

64+ takeUntil s = (chunk s >>^ konst mempty) <+> ((anyToken &&& takeUntil s) >>^ siCons)

6765

68− default takeUntil :: Eq (Token s) => s -> m () s

69− takeUntil s = takeUntil' s >>^ levitate

70− where

71− takeUntil' s' = try (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ cons')

72−

73− default tokensWhile :: (Token s -> Bool) -> m () s

66+ tokensWhile :: (Element s -> Bool) -> m () s

67+ default tokensWhile :: (Element s -> Bool) -> m () s

7468 tokensWhile f =

75− tokensWhile' f >>> check (P.all f) >>^ levitate

76− where

77− tokensWhile' g =

78− try (tokenWhere g &&& tokensWhile' g >>^ cons')

79− <+^ isoConst' () []

69+ (((tokenWhere f >>^ check f) &&& tokensWhile f) >>^ siCons)

70+ <+^ isoConst () mempty

8071

81− tokensWhile1 :: (Token s -> Bool) -> m () s

82− tokensWhile1 f =

83− tokenWhere f &&& tokensWhile f

84− >>^ si' (\(a, aa) -> Just $ liftToken a <> aa) levitateHead

72+ tokensWhile1 :: (Element s -> Bool) -> m () s

73+ tokensWhile1 f = tokenWhere f &&& tokensWhile f >>^ siCons

8574

8675 -- | "tucks" the context of the parser into its input.

8776 -- > ┌─────┐

@@ -99,69 +88,43 @@ class

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

10089 -- > └─────┘ └─────┘

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

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

10292

103−class IsoparsecLabel m l where

104− label :: l -> m a b -> m a b

105−

106−levitateHead :: Tokenable s => s -> Maybe (Token s, s)

107−levitateHead s = case lowerTokens s of

108− (t : tt) -> Just (t, liftTokens tt)

109− [] -> Nothing

110−

111−cons' :: SemiIso' (t, [t]) [t]

112−cons' =

113− si'

114− (Just . uncurry (:))

115− ( \case

116− (t : ts) -> Just (t, ts)

117− _ -> Nothing

118− )

119−

120−levitate :: Tokenable s => SemiIso' [Token s] s

121−levitate = siJust liftTokens lowerTokens

122−

123−class IsoparsecTry m where

124− try :: m a b -> m a b

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

12594

126−class IsoparsecFail m e where

127− fail :: e -> m a b

128−

129−newtype SemiIso' s a = SemiIso' (SemiIso s s a a)

130−

131−siDecompose :: SemiIso' a b -> (a -> Maybe b, b -> Maybe a)

132−siDecompose (SemiIso' s) = withIso s (,)

133−

134−type SemiIso s t a b = Iso s (Maybe t) (Maybe a) b

135−

136−si' :: (s -> Maybe a) -> (a -> Maybe s) -> SemiIso' s a

137−si' n u = SemiIso' $ iso n u

95+type EffectOnly m = m () ()

13896

139−siCheck' :: (s -> Bool) -> (s -> Maybe a) -> (a -> Maybe s) -> SemiIso' s a

140−siCheck' f a b =

141− si'

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

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

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

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

14499

145−siCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso' s a

146−siCheck f a b = siCheck' f (Just . a) (Just . 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))

147102

148−siJust :: (s -> a) -> (a -> s) -> SemiIso' s a

149−siJust a b = si' (Just . a) (Just . b)

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

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

105+ where

106+ unroll' g = (g >>> second (unroll' g)) >>^ siCons

150107

151−isoConst' :: s -> a -> SemiIso' s a

152−isoConst' s a = si' (const $ Just a) (const $ Just s)

108+siCons :: IsSequence s => SemiIso (Element s, s) s

109+siCons =

110+ siMaybe

111+ (pure . uncurry cons)

112+ uncons

153113

154−konst :: (PolyArrow a SemiIso', Eq x) => x -> a () x

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

156−

157−badKonst :: (PolyArrow a SemiIso') => x -> a () x

158−badKonst x = arr $ si' (const $ Just x) (const $ Just ())

159−

160−tsnok :: (PolyArrow a SemiIso', Eq x) => x -> a x ()

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

162−

163−badTsnok :: (PolyArrow a SemiIso') => x -> a x ()

164−badTsnok x = arr $ si' (const $ Just ()) (const $ Just x)

165−

166−check :: PolyArrow a SemiIso' => (s -> Bool) -> a s s

167−check f = arr $ siCheck f id id

114+class IsoparsecFail m e where

115+ failure :: e -> m a b

116+

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+59−27

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

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

33module Data.Isoparsec.Megaparsec

4− ( runMegaparsec,

4+ ( runMegaparsecParser,

5+ ParseErrorBundle (..),

6+ MegaparsecParser (..),

57 )

68where

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

911import Control.Arrow.Extra.Orphans ()

1012import Control.Monad

1113import Data.Functor

12−import Data.Isoparsec.Internal as I

13−import Data.Isoparsec.Tokenable

14−import Optics.Getter

15−import Optics.ReadOnly

14+import Data.Functor.Identity

15+import Data.Isoparsec

16+import Data.Void

1617import Text.Megaparsec hiding (Token)

1718import qualified Text.Megaparsec as M

1819import Prelude hiding ((.))

1920

20−runMegaparsec ::

21− (Ord e, Stream s) =>

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

23− s ->

24− Either (ParseErrorBundle s e) r

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

21+newtype MegaparsecParser s a b

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

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

2624

27−instance (MonadParsec e s m) => IsoparsecTry (Kleisli m) where

28− try (Kleisli f) = Kleisli $ \a -> M.try (f a)

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) =>

34+ s ->

35+ MegaparsecParser s () r ->

36+ Either (ParseErrorBundle s Void) r

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

2938

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

31− arr (SemiIso' si) = Kleisli $ \t -> case view (getting si) t of

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

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

3241 Just x -> return x

33− Nothing -> failure Nothing mempty

42+ Nothing -> M.failure Nothing mempty

3443

3544instance

36− (MonadParsec e s m, M.Token s ~ Token s, s ~ M.Tokens s, Tokenable s) =>

37− Isoparsec (Kleisli m) s

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

46+ Isoparsec (MegaparsecParser s) s

3847 where

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

4059

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

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

4261

43− manyTokens = Kleisli $ takeP Nothing . fromIntegral

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

4463

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

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

65+

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

4677 sup <- getInput

4778 setInput sub

4879 r <- f () <* eof

4980 setInput sup

5081 return r

5182

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

53− fail e = Kleisli $ \_ -> customFailure e

54−

55−instance MonadParsec e s m => IsoparsecLabel (Kleisli m) String where

56− label s (Kleisli m) = Kleisli $ \x -> M.label s (m 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+62−27

@@ -1,48 +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 ->

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)

19+

20+runMonoidPrinter ::

21+ forall s a.

22+ MonoidPrinter s () a ->

1723 a ->

18− m s

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

24+ Maybe s

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

26+

27+instance IsoparsecFail (MonoidPrinter s) e where

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

2029

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

22− fail _ = Cokleisli . const $ WriterT Nothing

30+instance

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

32+ Isoparsec (MonoidPrinter s) s

33+ where

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

2335

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

25− fail = Cokleisli . const . WriterT . Left

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

2637

27−instance IsoparsecLabel (Cokleisli (WriterT s Maybe)) e where

28− label _ = id

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

2939

30−instance IsoparsecLabel (Cokleisli (WriterT s (Either e))) y where

31− label _ = id

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

3241

33−instance IsoparsecTry (Cokleisli (WriterT (Dual s) m)) where

34− try = id

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

3543

36−instance

37− (MonadPlus m, Monoid s, Eq (Token s), Tokenable s, Show s) =>

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

39− where

40− token t = Cokleisli $ const $ tell . Dual . liftToken $ t

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

4145

42− anyToken = Cokleisli $ tell . Dual . liftToken

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

4347

44− 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

4559 tell $ Dual w

46− return . fromIntegral . length . lowerTokens $ w

60+ return . fromIntegral . olength $ w

61+

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

4781

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

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

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

src/Data/Isoparsec/ToIsoparsec.hs+21−26

@@ -5,45 +5,40 @@ where

66import Control.Arrow.Extra

77import Data.Isoparsec.Internal

8−import Data.Isoparsec.Tokenable

98import GHC.Generics

109import Prelude hiding ((.))

1110

12−instance {-# OVERLAPPABLE #-} t ~ Token s => ToIsoparsec t s where

13− toIsoparsec = anyToken

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

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

1415

15−class ToIsoparsec a s where

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

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

18− toIsoparsec = gToIsoparsec >>^ si' (Just . to) (Just . from)

19−

20−class GToIsoparsec a s where

16+class GToIsoparsec a s m where

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

2218

23−instance GToIsoparsec U1 s where

24− gToIsoparsec = konst U1

19+instance GToIsoparsec U1 s m where

20+ gToIsoparsec = arr $ konst U1

2521

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

27− gToIsoparsec =

28− toIsoparsec >>^ si' (Just . K1) (Just . unK1)

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

23+ gToIsoparsec = toIsoparsec >>^ siPure K1 unK1

2924

30−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

3126 gToIsoparsec =

32− gToIsoparsec >>^ si' (Just . M1) (Just . unM1)

27+ gToIsoparsec >>^ siPure M1 unM1

3328

34−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

3530 gToIsoparsec =

3631 (gToIsoparsec &&& gToIsoparsec)

37− >>^ si' (\(a, b) -> Just (a :*: b)) (\(a :*: b) -> Just (a, b))

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

3833

39−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

4035 gToIsoparsec =

41− ( try (gToIsoparsec >>^ si' (Just . Left) (either Just (const Nothing)))

42− <+> (gToIsoparsec >>^ si' (Just . Right) (either (const Nothing) Just))

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

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

4338 )

44− >>> (arr (si' (Just . L1) fromL) ||| arr (si' (Just . R1) fromR))

39+ >>> (arr (SI (pure . L1) fromL) ||| arr (SI (pure . R1) fromR))

4540 where

46− fromL (L1 a) = Just a

47− fromL _ = Nothing

48− fromR (R1 b) = Just b

49− fromR _ = Nothing

41+ fromL (L1 a) = pure a

42+ fromL _ = empty

43+ fromR (R1 b) = pure b

44+ fromR _ = empty

src/Data/Isoparsec/Tokenable.hsdeleted−24

@@ -1,24 +0,0 @@

1−module Data.Isoparsec.Tokenable

2− ( Tokenable (..),

3− )

4−where

5−

6−class Monoid s => Tokenable s where

7− type Token s

8−

9− {-# MINIMAL (liftTokens | liftToken), lowerTokens #-}

10−

11− liftTokens :: [Token s] -> s

12− liftTokens = mconcat . fmap liftToken

13−

14− liftToken :: Token s -> s

15− liftToken = liftTokens . pure

16−

17− lowerTokens :: s -> [Token s]

18−

19−instance Tokenable [t] where

20− type Token [t] = t

21−

22− liftTokens = id

23−

24− lowerTokens = id

stack.yaml+2−7

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

1717#

1818# resolver: ./custom-snapshot.yaml

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

20−resolver: lts-14.23

20+resolver: lts-15.8

2121

2222# User packages to be built.

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

@@ -39,11 +39,6 @@ packages:

3939# - git: https://github.com/commercialhaskell/stack.git

4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

4141#

42−extra-deps:

43−- optics-core-0.1

44−- optics-0.1

45−- optics-extra-0.1

46−- optics-th-0.1

4742

4843# Override default flag values for local packages and extra-deps

4944# flags: {}

@@ -70,4 +65,4 @@ extra-deps:

7065# compiler-check: newer-minor

7166

7267ghc-options:

73− "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists

68+ "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists -Wunused-imports

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

@@ -1,6 +1,8 @@

11module Spec.Helper

22 ( shouldParseBS,

33 roundtrip,

4+ parseSatisfyBS,

5+ shouldParseS,

46 )

57where

@@ -17,46 +19,84 @@ import Test.Tasty.QuickCheck

1719import Text.Megaparsec as M

1820import Prelude as P hiding ((.))

1921

22+parseSatisfy ::

23+ forall x s.

24+ ( ToIsoparsec x s (MegaparsecParser s),

25+ Stream s,

26+ Show x,

27+ Show (M.Token s),

28+ Show s,

29+ Isoparsec (MegaparsecParser s) s

30+ ) =>

31+ s ->

32+ (Either (ParseErrorBundle s Void) x -> Bool) ->

33+ Expectation

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

35+

36+parseSatisfyBS ::

37+ forall x.

38+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

39+ Show x,

40+ Isoparsec (MegaparsecParser ByteString) ByteString

41+ ) =>

42+ ByteString ->

43+ (Either (ParseErrorBundle ByteString Void) x -> Bool) ->

44+ Expectation

45+parseSatisfyBS = parseSatisfy

46+

2047shouldParse ::

2148 forall x s.

22− ( ToIsoparsec x s,

49+ ( ToIsoparsec x s (MegaparsecParser s),

2350 Stream s,

2451 Show x,

2552 Eq x,

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

53+ Isoparsec (MegaparsecParser s) s

2754 ) =>

2855 s ->

2956 x ->

3057 Expectation

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

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

3259 Right e' -> e' `shouldBe` e

3360 Left err -> expectationFailure $ errorBundlePretty err

3461

3562shouldParseBS ::

3663 forall x.

37− ( ToIsoparsec x ByteString,

64+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

3865 Show x,

3966 Eq x,

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

67+ Isoparsec (MegaparsecParser ByteString) ByteString

4168 ) =>

4269 ByteString ->

4370 x ->

4471 Expectation

4572shouldParseBS = shouldParse

4673

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+

4786roundtrip ::

4887 forall x s.

49− ( ToIsoparsec x s,

88+ ( ToIsoparsec x s (MegaparsecParser s),

89+ ToIsoparsec x s (MonoidPrinter s),

5090 Stream s,

5191 Show s,

52− I.Token s ~ M.Token s,

92+ I.Element s ~ M.Token s,

5393 Eq x,

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

94+ Isoparsec (MegaparsecParser s) s

5595 ) =>

5696 x ->

5797 Property

5898roundtrip x =

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

60− 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

61101 Right y -> property $ x == y

62102 Left err -> counterexample (errorBundlePretty err) False

test/Spec/JSON.hs+28−28

@@ -2,17 +2,19 @@

33module Spec.JSON

44 ( quickSpec,

5+ spec,

56 )

67where

89import Control.Arrow.Extra

10+import Control.Lens.TH

911import Data.Isoparsec

1012import Data.Isoparsec.Char

1113import Data.Isoparsec.Megaparsec

1214import Data.Isoparsec.Printer

1315import Data.Maybe

14−import Data.Void

15−import Optics hiding (elements)

16+import Spec.Helper

17+import Test.Hspec

1618import Test.Tasty

1719import Test.Tasty.QuickCheck

1820import Text.Megaparsec.Error

@@ -41,48 +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' Just Just ^<< (try string <+> try array <+> try 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− &&& ( try

62− ( ( ( json &&& unsafeWhiteSpace

63− &&& try

64− ( repeating

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

66− )

67− )

68− <+> konst []

69− )

70− >>% morphed

71− )

72− >>^ cons'

73− )

74− <+> konst []

75− )

75+ &&& sepByComma json

7676 &&& unsafeWhiteSpace

7777 &&& token ']'

7878 integer = _JInteger <.> number

7979 object =

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

81− &&& ( try

82− ( let pair = (unsafeWhiteSpace &&& string' &&& unsafeWhiteSpace &&& token ':' &&& unsafeWhiteSpace &&& json &&& unsafeWhiteSpace) >>% morphed

83− in (pair &&& try (repeating ((token ',' &&& unsafeWhiteSpace &&& pair) >>% morphed) <+> konst [])) >>^ cons'

84− )

85− <+> konst []

86− )

81+ &&& sepByComma pair

8782 &&& unsafeWhiteSpace

8883 &&& 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+8−9

@@ -6,14 +6,13 @@ module Spec.Megaparsec.BasicNums

66 )

77where

9+import Control.Lens.TH

910import Data.Either

1011import Data.Isoparsec

1112import Data.Isoparsec.Char

1213import Data.Isoparsec.Megaparsec

1314import Data.Isoparsec.Printer

1415import Data.Maybe

15−import Data.Void

16−import Optics

1716import Test.Hspec

1817import Test.Tasty

1918import Test.Tasty.QuickCheck

@@ -28,19 +27,19 @@ instance Arbitrary Foo where

2827

2928makePrisms ''Foo

3029

31−parser :: (Isoparsec m String, IsoparsecLabel m String) => m () Foo

32−parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number <?> ("oh no" :: String))

30+parser :: (Isoparsec m String) => m () Foo

31+parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number)

3332

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/Orphans.hs+3−3

@@ -15,13 +15,13 @@ import Test.Tasty.QuickCheck

1515import Prelude hiding ((.))

1616

1717instance

18− (CmpNat n 0 ~ 'GT, KnownNat n, Arbitrary (Token s), Tokenable s) =>

18+ (CmpNat n 0 ~ 'GT, KnownNat n, Arbitrary (Element s), IsSequence s) =>

1919 Arbitrary (Chunk n s)

2020 where

21− arbitrary = Chunk . liftTokens <$> vectorOf (fromIntegral $ natVal @n Proxy) arbitrary

21+ arbitrary = Chunk . fromList <$> vectorOf (fromIntegral $ natVal @n Proxy) arbitrary

2222

2323instance Arbitrary ByteString where

24− arbitrary = liftTokens <$> listOf arbitrary

24+ arbitrary = fromList <$> listOf arbitrary

2525

2626deriving instance Arbitrary (Byte16 e)

2727

test/Spec/Ssh.hs+47−53

@@ -6,13 +6,13 @@ module Spec.Ssh

66 )

77where

9+import Control.Lens.TH

910import Data.ByteString as BS

1011import qualified Data.Char as C

12+import Data.Either

1113import Data.Isoparsec

1214import Data.Isoparsec.ByteString

13−import qualified Data.Word8 as W8

1415import GHC.Generics

15−import Optics

1616import Spec.Helper

1717import Spec.Orphans ()

1818import Test.Hspec

@@ -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,40 +88,33 @@ instance Arbitrary Payload where

8888

8989makePrisms ''Payload

9090

91−instance ToIsoparsec Payload ByteString where

91+instance ToIsoparsec Payload ByteString a where

9292 toIsoparsec =

93− try

94− ( _DisconnectPayload

95− <.> specific DisconnectMsg

96− &&& auto @DisconnectReasonCode

97− &&& (tokensWhile (const True) >>> ftu8)

98− )

99− <+> try

100− ( _ServiceRequest <.> specific ServiceRequestMsg

101− &&& auto @SSHString

102− )

103− <+> try

104− ( _VersionPayload <.> utf8 "SSH-2.0-"

105− &&& ( ( try (takeUntil "\r\n" >>> check (BS.all (not . W8.isSpace)))

106− <+> ((takeUntil " " &&& (takeUntil "\r\n" >>> badTsnok "")) >>% morphed)

93+ ( _DisconnectPayload

94+ <.> specific DisconnectMsg

95+ &&& auto @DisconnectReasonCode

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

97+ )

98+ <+> ( _ServiceRequest <.> specific ServiceRequestMsg

99+ &&& auto @SSHString

100+ )

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

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

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

104+ <+> chunk "\r\n"

107105 )

108− >>> ftu8

109− )

110− )

111− <+> try (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))

112− <+> try

113− ( _DebugPayload <.> specific DebugMsg

114− &&& auto @AlwaysDisplay

115− &&& auto @SSHString

116− )

117− <+> try

118− ( _UnimplementedPayload <.> specific UnimplementedMsg

119− &&& auto @PacketSequenceNumber

120− )

121− <+> try

122− ( _ServiceAccept <.> specific ServiceAcceptMsg

123− &&& auto @SSHString

124− )

106+ )

107+ <+> (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))

108+ <+> ( _DebugPayload <.> specific DebugMsg

109+ &&& auto @AlwaysDisplay

110+ &&& auto @SSHString

111+ )

112+ <+> ( _UnimplementedPayload <.> specific UnimplementedMsg

113+ &&& auto @PacketSequenceNumber

114+ )

115+ <+> ( _ServiceAccept <.> specific ServiceAcceptMsg

116+ &&& auto @SSHString

117+ )

125118

126119newtype Padding = Padding {unPadding :: ByteString}

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

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

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

133126badZeroPadding =

134127 throughIntegral

135− >>> manyTokens

136− >>^ siJust

128+ ^>> manyTokens

129+ >>^ siPure

137130 (ZeroPadding . fromIntegral . BS.length)

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

139132

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

143136data NoneMAC = NoneMAC

144137 deriving (Eq, Ord, Show, Generic)

145138

146−instance ToIsoparsec NoneMAC b where

147− toIsoparsec = konst NoneMAC

139+instance ToIsoparsec NoneMAC b a where

140+ toIsoparsec = arr $ konst NoneMAC

148141

149142instance Arbitrary NoneMAC where

150143 arbitrary = return NoneMAC

@@ -158,25 +151,26 @@ instance Arbitrary mac => Arbitrary (Packet mac) where

158151

159152makePrisms ''Packet

160153

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

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

162155 toIsoparsec =

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

164− >>> (throughIntegral *** throughIntegral)

165− >>> siJust

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

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

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

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

170− )

171− &&& 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

172163 )

173− >>^ siJust (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))

164+ &&& auto @mac

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

174166

175167spec :: Spec

176168spec = do

177169 it "deserialize payload" $ do

178170 "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"

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

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

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

180174 "\x2__" `shouldParseBS` IgnorePayload "__"

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

182176 it "deserialize packet" $ do

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