master..ffdd327 · isoparsec

git.iko.soy/isoparsec

35 files changed+536−1707

unifiedsplit

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

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

1010 strategy:

1111 matrix:

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

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

1313

1414 steps:

1515 - uses: actions/checkout@v1

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

2222

2323 - name: Build

2424 run: |

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

25+ stack build --fast --pedantic --ghc-options '-j' --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'

3332 run: |

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

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

.hlint.yaml+1−130

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

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

5353

5454

55−# Define some custom fixity operators

55+# Define some custom infix operators

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

5757

5858

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

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

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

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

2−

1+# isoparsec

32Isomorphic (invertible) parser library

4−

5−### 🚧 Under construction 🚧

6−

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

package.yaml+3−6

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

2222dependencies:

2323- base >= 4.7 && < 5

2424- containers

25+- optics-core

2526- megaparsec

2627- bytestring

2728# - text

2829- mtl

29−- profunctors

30−- mono-traversable

31−- split

3230

3331library:

3432 source-dirs: src

35− other-modules: Control.Prism

3633 dependencies: []

3734

3835default-extensions:

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

5855- TypeFamilies

5956- TypeOperators

6057- UndecidableInstances

61−- RankNTypes

6258

6359tests:

6460 isoparsec-test:

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

7470 - tasty

7571 - tasty-hspec

7672 - hspec

77− - lens

73+ - optics

7874 - tasty-quickcheck

7975 - QuickCheck

8076 - megaparsec

8177 - 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 hiding ((<<<), (>>>))

17+import Control.Category as X

1818

19−infixl 5 <+^

19+infixr 5 <+^

2020

21−infixl 5 ^+>

21+infixr 5 ^+>

2222

23−infixl 5 ^+^

23+infixr 5 ^+^

2424

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

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

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

2727

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

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

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

3030

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

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

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

src/Control/Arrow/Extra/BaseArrow.hs+1−13

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

33module Control.Arrow.Extra.BaseArrow

44 ( BaseArrow (..),

5− (>>>),

6− (<<<),

75 )

86where

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

8+import Control.Category

119

1210infixl 3 ***

1311

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

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

2624

2725 (&&&) :: 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+11−10

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

1010where

1111

1212import Control.Arrow.Extra.BaseArrow

13+import Control.Category

1314

14−infixl 1 ^>>, >>^

15+infixr 1 ^>>, >>^

1516

16−infixl 1 ^<<, <<^

17+infixr 1 ^<<, <<^

1718

18−infixl 1 ^>^, ^<^

19+infixr 1 ^>^, ^<^

1920

20−class BaseArrow a => PolyArrow p a where

21+class BaseArrow a => PolyArrow a p where

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

2223

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

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

2425f ^>> a = arr f >>> a

2526

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

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

2728a >>^ f = a >>> arr f

2829

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

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

3031a <<^ f = a <<< arr f

3132

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

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

3334f ^<< a = arr f <<< a

3435

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

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

3637a ^>^ b = arr a >>> arr b

3738

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

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

3940a ^<^ b = arr a <<< arr b

src/Control/Arrow/Reader.hsdeleted−34

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

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.hsdeleted−9

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

1−module Control.Arrow.Trans.Class

2− ( ArrowTrans (..),

3− )

4−where

5−

6−import Control.Arrow.Extra

7−

8−class ArrowTrans s where

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

src/Control/Arrow/Trans/Reader.hsdeleted−53

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

1−module Control.Arrow.Trans.Reader

2− ( ReaderArrow (..),

3− runReaderArrow,

4− module Control.Arrow.Trans.Class,

5− )

6−where

7−

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/Control/Prism.hsdeleted−40

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

1−module Control.Prism

2− ( withPrism,

3− Identity,

4− Prism',

5− )

6−where

7−

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.hsdeleted−206

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

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+4−179

@@ -7,22 +7,11 @@ 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 (..),

2010 )

2111where

2212

2313import Data.Kind

2414import Data.Proxy

25−import Data.Type.Equality

2615import GHC.Generics

2716import GHC.TypeLits hiding (Nat)

2817

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

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

7261 HNil :: HList '[]

7362

74−infixl 5 :+

63+infixr 5 :+

7564

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

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

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

10392

10493-- ## Appending

10594

106−infixl 4 ++:

95+infixr 4 ++:

10796

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

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

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

11699

117100instance AppendableList '[] bb bb where

118101 HNil ++: bb = bb

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

260243 aa = hTake @(Length a) Proxy cc

261244 bb = hDrop @(Length a) Proxy cc

262245

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−

290246-- ## Other

291247

292248type family IsMophableTuple t :: Bool where

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

353309 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

354310 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

355311 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+112−257

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

33module Data.Isoparsec

44 ( module X,

5+ -- Isoparsec,

6+ (%>>),

7+ (%>%),

8+ (>>%),

9+ (%<<),

10+ (%<%),

11+ (<<%),

12+ (<?>),

13+ (<+%),

14+ (%+>),

15+ (%+%),

516 (<.>),

17+ (<^>),

618 repeating,

7− sepBy,

8− sepBy1,

919 opt,

1020 opt',

1121 morphed,

12− fMorphed,

1322 coercing,

1423 mapIso,

1524 auto,

1625 specific,

1726 throughIntegral,

18− (~>),

19− (~>^),

20− (^~>),

21− (^~>^),

22− (~|),

23− (~$>),

24− (~&),

25− (~*),

26− siPrism,

27− delist,

28− enlist,

29− Listed,

30− hmap,

3127 )

3228where

3329

3430import Control.Arrow.Extra as X

35−import Control.Prism

3631import Control.Tuple.Morph

3732import Data.Coerce

38−import Data.Either

3933import Data.Isoparsec.Internal as X

4034import Data.Isoparsec.ToIsoparsec as X

35+import Data.Isoparsec.Tokenable as X

4136import qualified Data.Map as M

37+import Optics.Iso

38+import Optics.Optic

39+import Optics.Prism

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

4341

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

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

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

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

4644

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

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

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

46+opt' a m = (try m >>> tsnok a) <+> konst ()

4947

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

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

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'

5250

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

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

51+infix 0 <?>

5552

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

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

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

54+thing <?> msg = label msg thing

5855

59−infixl 0 <.>

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 <.>

60102

61103(<.>) ::

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

63− (Prism' a b) ->

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

105+ b ->

64106 m x' x ->

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)

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)

285140 where

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

287142 u =

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

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

290145

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

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

292147auto = toIsoparsec

293148

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)

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

296151

297152throughIntegral ::

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

299− SemiIso a b

300−throughIntegral = siPure fromIntegral fromIntegral

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

154+ m a b

155+throughIntegral = arr $ siJust fromIntegral fromIntegral

src/Data/Isoparsec/ByteString.hs+32−23

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

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

2−

32module Data.Isoparsec.ByteString

43 ( utf8,

4+ ftu8,

55 ByteString,

66 Endianness (..),

77 Byte8,

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

2020import Data.Word

2121import Prelude as P hiding ((.))

2222

23−utf8 :: SemiIso ByteString String

24−utf8 = siPure C.unpack C.pack

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

2528

2629data Endianness = BE | LE

2730

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

3033

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

3235 bytesToIsoparsec _ =

33− konst word8s ^>> manyTokens

34− >>^ siPure

36+ konst word8s >>> manyTokens

37+ >>^ siJust

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

36− ( fromList . snd . P.head

39+ ( liftTokens . snd . P.head

3740 . P.drop (fromIntegral word8s)

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

3942 . (,[])

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

4447

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

4649 bytesToIsoparsec _ =

47− konst word8s ^>> manyTokens

48− >>^ siPure

50+ konst word8s >>> manyTokens

51+ >>^ siJust

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

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

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

5154 . P.drop (fromIntegral word8s)

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

5356 . (,[])

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

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

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

6972

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

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

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

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

7275

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

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

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

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

7578

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

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

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

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

7881

79−instance ToIsoparsec Bool ByteString m where

82+instance ToIsoparsec Bool ByteString where

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

8184

8285newtype SSHString = SSHString {unSSHString :: String}

8386 deriving (Show, Eq, Ord)

8487

85−instance ToIsoparsec SSHString ByteString m where

88+instance ToIsoparsec SSHString ByteString where

8689 toIsoparsec =

87− auto @(Byte32 'BE)

88− >>^ coercing @Word32

89− >>^ siPure fromIntegral fromIntegral

90− >>> manyTokens

91− >>^ utf8

92− >>^ siPure SSHString unSSHString

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

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, Element s ~ Char) => m () ()

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

1515space = token ' '

1616

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

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

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

18+unsafeWhiteSpace = tokensWhile isSpace >>> badTsnok mempty

1919

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

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

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

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

2222

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

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

2424number =

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

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

26+ >>^ si' (readMaybe @Integer . lowerTokens) (Just . liftTokens . 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 m where

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

1414 toIsoparsec =

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

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

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

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

1−module Control.Cokleisli

1+module Data.Isoparsec.Cokleisli

22 ( Cokleisli (..),

33 )

44where

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

66import Control.Applicative

77import Control.Arrow.Extra

88import Control.Monad

9−import Control.SemiIso

9+import Data.Isoparsec.Internal

10+import Optics.Iso

1011import Prelude hiding ((.))

1112

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

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

1314

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

1516 id = Cokleisli return

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

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

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

2829

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

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

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

3134

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

3336 zeroArrow = Cokleisli $ const mzero

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

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

11module Data.Isoparsec.Internal

2− ( module X,

2+ ( SemiIso' (..),

3+ SemiIso,

4+ si',

35 IsoparsecFail (..),

46 Isoparsec (..),

5− siCons,

6− unroll,

7− arrowsWhile,

8− arrowsUntil,

9− EffectOnly,

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,

1020 )

1121where

1222

1323import Control.Arrow.Extra

14−import Control.Arrow.Trans.Reader

1524import Control.Monad

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

17−import Data.MonoTraversable as X

18−import Data.Sequences as X

25+import Data.Isoparsec.Tokenable

1926import Numeric.Natural

27+import Optics.Iso

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

2129

2230class

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

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

2432 Isoparsec m s

2533 | m -> s where

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

2734

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

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

2936

30− token :: Element s -> EffectOnly m

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

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

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

3338

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

39+ token :: Token s -> m () ()

3740

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

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

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

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

42+ token x = anyToken >>> tsnok x

4143

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

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

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

4445

45− chunk :: s -> EffectOnly m

46− chunk = tokens . otoList

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

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

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

4749

48− chunk' :: m s s

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

50− where

51− list = siPure otoList fromList

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

51+ chunk = tokens . lowerTokens

52+

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

5254

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

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

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

5556 notToken t = tokenWhere (/= t)

5657

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

58− tokenWhere f = anyToken >>^ check f

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

59+ tokenWhere f =

60+ anyToken >>> check f

5961

6062 manyTokens :: m Natural s

6163

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

65+

6266 takeUntil :: s -> m () s

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

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

6567

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

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

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

6874 tokensWhile f =

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

70− <+^ isoConst () mempty

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

76+ where

77+ tokensWhile' g =

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

79+ <+^ isoConst' () []

7180

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

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

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

82+ tokensWhile1 f =

83+ tokenWhere f &&& tokensWhile f

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

7485

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

7687 -- > ┌─────┐

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

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

89100 -- > └─────┘ └─────┘

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

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

92−

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

94102

95−type EffectOnly m = m () ()

103+class IsoparsecLabel m l where

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

96105

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

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

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

99110

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

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

112+cons' =

113+ si'

114+ (Just . uncurry (:))

115+ ( \case

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

117+ _ -> Nothing

118+ )

102119

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

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

121+levitate = siJust liftTokens lowerTokens

107122

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

109−siCons =

110− siMaybe

111− (pure . uncurry cons)

112− uncons

123+class IsoparsecTry m where

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

113125

114126class 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

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

138+

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

144+

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

146+siCheck f a b = siCheck' f (Just . a) (Just . b)

147+

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

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

150+

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

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

153+

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

src/Data/Isoparsec/Megaparsec.hs+27−59

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

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

33module Data.Isoparsec.Megaparsec

4− ( runMegaparsecParser,

5− ParseErrorBundle (..),

6− MegaparsecParser (..),

4+ ( runMegaparsec,

75 )

86where

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

119import Control.Arrow.Extra.Orphans ()

1210import Control.Monad

1311import Data.Functor

14−import Data.Functor.Identity

15−import Data.Isoparsec

16−import Data.Void

12+import Data.Isoparsec.Internal as I

13+import Data.Isoparsec.Tokenable

14+import Optics.Getter

15+import Optics.ReadOnly

1716import Text.Megaparsec hiding (Token)

1817import qualified Text.Megaparsec as M

1918import Prelude hiding ((.))

2019

21−newtype MegaparsecParser s a b

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

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

24−

25−instance

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

27− ArrowPlus (MegaparsecParser s)

28− where

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

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

31−

32−runMegaparsecParser ::

33− (Stream s) =>

20+runMegaparsec ::

21+ (Ord e, Stream s) =>

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

3423 s ->

35− MegaparsecParser s () r ->

36− Either (ParseErrorBundle s Void) r

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

24+ Either (ParseErrorBundle s e) r

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

26+

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

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

3829

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

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

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

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

4132 Just x -> return x

42− Nothing -> M.failure Nothing mempty

33+ Nothing -> failure Nothing mempty

4334

4435instance

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

46− Isoparsec (MegaparsecParser s) s

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

37+ Isoparsec (Kleisli m) s

4738 where

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

39+ anyToken = Kleisli $ const anySingle

5940

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

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

6142

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

43+ manyTokens = Kleisli $ takeP Nothing . fromIntegral

6344

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

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

7746 sup <- getInput

7847 setInput sub

7948 r <- f () <* eof

8049 setInput sup

8150 return r

8251

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

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)

src/Data/Isoparsec/Printer.hs+27−62

@@ -1,83 +1,48 @@

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

33module Data.Isoparsec.Printer

4− ( runMonoidPrinter,

5− MonoidPrinter (..),

4+ ( runPrinter,

65 )

76where

9−import Control.Cokleisli

108import Control.Monad.Writer.Lazy

11−import Data.Functor

129import Data.Isoparsec

13−import Data.List.Split

10+import Data.Isoparsec.Cokleisli

1411import Prelude hiding ((.), id)

1512

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

13+runPrinter ::

14+ forall m s a.

15+ Monad m =>

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

2317 a ->

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

29−

30−instance

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

32− Isoparsec (MonoidPrinter s) s

33− where

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

35−

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

18+ m s

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

3720

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

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

22+ fail _ = Cokleisli . const $ WriterT Nothing

3923

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

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

25+ fail = Cokleisli . const . WriterT . Left

4126

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

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

28+ label _ = id

4329

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

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

31+ label _ = id

4532

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

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

34+ try = id

4735

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

49− if t == nt

50− then empty

51− else (tell . Dual . singleton) t

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

5241

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

54− if f t

55− then (tell . Dual . singleton) t

56− else empty

42+ anyToken = Cokleisli $ tell . Dual . liftToken

5743

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

44+ manyTokens = Cokleisli $ \w -> do

5945 tell $ Dual 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

46+ return . fromIntegral . length . lowerTokens $ w

8147

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

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

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

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

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

66import Control.Arrow.Extra

77import Data.Isoparsec.Internal

8+import Data.Isoparsec.Tokenable

89import GHC.Generics

910import Prelude hiding ((.))

1011

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)

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

13+ toIsoparsec = anyToken

1514

16−class GToIsoparsec a s m where

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

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

1822

19−instance GToIsoparsec U1 s m where

20− gToIsoparsec = arr $ konst U1

23+instance GToIsoparsec U1 s where

24+ gToIsoparsec = konst U1

2125

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

23− gToIsoparsec = toIsoparsec >>^ siPure K1 unK1

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

27+ gToIsoparsec =

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

2429

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

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

2631 gToIsoparsec =

27− gToIsoparsec >>^ siPure M1 unM1

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

2833

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

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

3035 gToIsoparsec =

3136 (gToIsoparsec &&& gToIsoparsec)

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

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

3338

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

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

3540 gToIsoparsec =

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

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

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

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

3843 )

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

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

4045 where

41− fromL (L1 a) = pure a

42− fromL _ = empty

43− fromR (R1 b) = pure b

44− fromR _ = empty

46+ fromL (L1 a) = Just a

47+ fromL _ = Nothing

48+ fromR (R1 b) = Just b

49+ fromR _ = Nothing

src/Data/Isoparsec/Tokenable.hsnew file+24

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

1+module Data.Isoparsec.Tokenable

2+ ( Tokenable (..),

3+ )

4+where

6+class Monoid s => Tokenable s where

7+ type Token s

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+7−2

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

1717#

1818# resolver: ./custom-snapshot.yaml

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

20−resolver: lts-15.8

20+resolver: lts-14.23

2121

2222# User packages to be built.

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

@@ -39,6 +39,11 @@ 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

4247

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

4449# flags: {}

@@ -65,4 +70,4 @@ packages:

6570# compiler-check: newer-minor

6671

6772ghc-options:

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

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

test/Spec.hs+1−23

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

1−import qualified Spec.BasicReader as BasicReader

21import qualified Spec.JSON as JSON

3−import qualified Spec.JSONHList as JSONHList

42import qualified Spec.Megaparsec.BasicNums as BasicNums

53import qualified Spec.Ssh as Ssh

6−import qualified Spec.SshHList as SshHList

74import qualified Spec.TwoDigits as TwoDigits

85import Test.Tasty

96import Test.Tasty.Hspec

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

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

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

1512 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

2013 defaultMain

2114 ( testGroup

2215 "tests"

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

2720 ],

2821 testGroup

2922 "JSON"

30− [ jsonSpec,

31− JSON.quickSpec

32− ],

33− testGroup

34− "JSONHList"

35− [ jsonHListSpec,

36− JSONHList.quickSpec

23+ [ JSON.quickSpec

3724 ],

3825 testGroup

3926 "TwoDigits"

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

4431 "ssh"

4532 [ sshSpec,

4633 Ssh.quickSpec

47− ],

48− testGroup

49− "ssh HList"

50− [ sshHListSpec,

51− SshHList.quickSpec

52− ],

53− testGroup

54− "BasicReader"

55− [ basicReaderSpec

5634 ]

5735 ]

5836 )

test/Spec/BasicReader.hsdeleted−38

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

1−{-# LANGUAGE PartialTypeSignatures #-}

2−{-# LANGUAGE TemplateHaskell #-}

3−

4−module Spec.BasicReader

5− ( spec,

6− )

7−where

8−

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

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

11module Spec.Helper

22 ( shouldParseBS,

33 roundtrip,

4− parseSatisfyBS,

5− shouldParseS,

64 )

75where

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

1917import Text.Megaparsec as M

2018import Prelude as P hiding ((.))

2119

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−

4720shouldParse ::

4821 forall x s.

49− ( ToIsoparsec x s (MegaparsecParser s),

22+ ( ToIsoparsec x s,

5023 Stream s,

5124 Show x,

5225 Eq x,

53− Isoparsec (MegaparsecParser s) s

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

5427 ) =>

5528 s ->

5629 x ->

5730 Expectation

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

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

5932 Right e' -> e' `shouldBe` e

6033 Left err -> expectationFailure $ errorBundlePretty err

6134

6235shouldParseBS ::

6336 forall x.

64− ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

37+ ( ToIsoparsec x ByteString,

6538 Show x,

6639 Eq x,

67− Isoparsec (MegaparsecParser ByteString) ByteString

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

6841 ) =>

6942 ByteString ->

7043 x ->

7144 Expectation

7245shouldParseBS = shouldParse

7346

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−

8647roundtrip ::

8748 forall x s.

88− ( ToIsoparsec x s (MegaparsecParser s),

89− ToIsoparsec x s (MonoidPrinter s),

49+ ( ToIsoparsec x s,

9050 Stream s,

9151 Show s,

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

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

9353 Eq x,

94− Isoparsec (MegaparsecParser s) s

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

9555 ) =>

9656 x ->

9757 Property

9858roundtrip x =

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

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

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

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

10161 Right y -> property $ x == y

10262 Left err -> counterexample (errorBundlePretty err) False

test/Spec/JSON.hs+28−28

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

33module Spec.JSON

44 ( quickSpec,

5− spec,

65 )

76where

98import Control.Arrow.Extra

10−import Control.Lens.TH

119import Data.Isoparsec

1210import Data.Isoparsec.Char

1311import Data.Isoparsec.Megaparsec

1412import Data.Isoparsec.Printer

1513import Data.Maybe

16−import Spec.Helper

17−import Test.Hspec

14+import Data.Void

15+import Optics hiding (elements)

1816import Test.Tasty

1917import Test.Tasty.QuickCheck

2018import Text.Megaparsec.Error

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

4341

4442makePrisms ''JSON

4543

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−

5544quickSpec :: TestTree

5645quickSpec =

5746 testProperty "roundtrips" $ \x ->

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

59− in counterexample s $ case runMegaparsecParser s json of

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

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

6049 Right y -> property $ x == y

6150 Left err -> counterexample (errorBundlePretty err) False

6251

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

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

53+json = si' Just Just ^<< (try string <+> try array <+> try integer <+> object)

6854 where

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

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

7056 string = _JString <.> string'

7157 array =

7258 _Array

7359 <.> token '['

7460 &&& unsafeWhiteSpace

75− &&& sepByComma json

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

7676 &&& unsafeWhiteSpace

7777 &&& token ']'

7878 integer = _JInteger <.> number

7979 object =

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

81− &&& sepByComma pair

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

8287 &&& unsafeWhiteSpace

8388 &&& 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.hsdeleted−92

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

1−{-# LANGUAGE TemplateHaskell #-}

2−

3−module Spec.JSONHList

4− ( quickSpec,

5− spec,

6− )

7−where

8−

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

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

66 )

77where

9−import Control.Lens.TH

109import Data.Either

1110import Data.Isoparsec

1211import Data.Isoparsec.Char

1312import Data.Isoparsec.Megaparsec

1413import Data.Isoparsec.Printer

1514import Data.Maybe

15+import Data.Void

16+import Optics

1617import Test.Hspec

1718import Test.Tasty

1819import Test.Tasty.QuickCheck

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

2728

2829makePrisms ''Foo

2930

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

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

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

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

3233

3334spec :: Spec

3435spec =

3536 it "deserializes" $ do

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

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

3940

4041quickSpec :: TestTree

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

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

43− in counterexample s $ case runMegaparsecParser s parser of

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

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

4445 Right y -> property $ x == y

4546 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 (Element s), IsSequence s) =>

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

1919 Arbitrary (Chunk n s)

2020 where

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

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

2222

2323instance Arbitrary ByteString where

24− arbitrary = fromList <$> listOf arbitrary

24+ arbitrary = liftTokens <$> listOf arbitrary

2525

2626deriving instance Arbitrary (Byte16 e)

2727

test/Spec/Ssh.hs+53−47

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

66 )

77where

9−import Control.Lens.TH

109import Data.ByteString as BS

1110import qualified Data.Char as C

12−import Data.Either

1311import Data.Isoparsec

1412import Data.Isoparsec.ByteString

13+import qualified Data.Word8 as W8

1514import 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 a where

34+instance ToIsoparsec MessageNumber ByteString 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 a

52+instance ToIsoparsec DisconnectReasonCode ByteString

5353

5454newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}

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

5656

57−instance ToIsoparsec AlwaysDisplay ByteString a

57+instance ToIsoparsec AlwaysDisplay ByteString

5858

5959newtype PacketSequenceNumber

6060 = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}

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

6262

63−instance ToIsoparsec PacketSequenceNumber ByteString a

63+instance ToIsoparsec PacketSequenceNumber ByteString

6464

6565data Payload

6666 = VersionPayload String

@@ -88,33 +88,40 @@ instance Arbitrary Payload where

8888

8989makePrisms ''Payload

9090

91−instance ToIsoparsec Payload ByteString a where

91+instance ToIsoparsec Payload ByteString where

9292 toIsoparsec =

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"

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)

105107 )

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

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

118125

119126newtype Padding = Padding {unPadding :: ByteString}

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

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

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

126133badZeroPadding =

127134 throughIntegral

128− ^>> manyTokens

129− >>^ siPure

135+ >>> manyTokens

136+ >>^ siJust

130137 (ZeroPadding . fromIntegral . BS.length)

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

132139

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

136143data NoneMAC = NoneMAC

137144 deriving (Eq, Ord, Show, Generic)

138145

139−instance ToIsoparsec NoneMAC b a where

140− toIsoparsec = arr $ konst NoneMAC

146+instance ToIsoparsec NoneMAC b where

147+ toIsoparsec = konst NoneMAC

141148

142149instance Arbitrary NoneMAC where

143150 arbitrary = return NoneMAC

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

151158

152159makePrisms ''Packet

153160

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

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

155162 toIsoparsec =

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

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

163172 )

164− &&& auto @mac

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

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

166174

167175spec :: Spec

168176spec = do

169177 it "deserialize payload" $ do

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

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

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

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

174180 "\x2__" `shouldParseBS` IgnorePayload "__"

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

176182 it "deserialize packet" $ do

test/Spec/SshHList.hsdeleted−192

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

1−{-# LANGUAGE TemplateHaskell #-}

2−

3−module Spec.SshHList

4− ( spec,

5− quickSpec,

6− )

7−where

8−

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+16−15

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

1111import Data.Isoparsec.Megaparsec

1212import Data.Isoparsec.Printer

1313import Data.Maybe

14+import Data.Void

1415import GHC.Generics

1516import Test.Hspec

1617import Test.Tasty

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

2122newtype SingleDigit = SingleDigit {unSingleDigit :: String}

2223 deriving (Eq, Show, Generic)

2324

24−instance ToIsoparsec SingleDigit String m where

25+instance ToIsoparsec SingleDigit String where

2526 toIsoparsec =

2627 toIsoparsec @(Chunk 1 String)

27− >>^ coercing

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

29− >>^ coercing

28+ >>> coercing

29+ >>> check (all @[] isDigit)

30+ >>> coercing

3031

31−instance Arbitrary SingleDigit where

32+instance (Arbitrary SingleDigit) where

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

3334

3435data Digits

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

4546 TwoDigits <$> arbitrary <*> arbitrary

4647 ]

4748

48−instance ToIsoparsec Digits String m

49+instance ToIsoparsec Digits String

4950

5051spec :: Spec

5152spec = do

5253 let parser = toIsoparsec @_ @String

5354 it "deserializes" $ do

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

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

6162

6263quickSpec :: TestTree

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

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

65− in counterexample s $ case runMegaparsecParser s parser of

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

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

6667 Right y -> property $ x == y

6768 Left err -> counterexample (errorBundlePretty err) False

6869 where