49556aa...master · isoparsec

git.iko.soy/isoparsec

42 files changed+1752−754

since splitsnapshots

unifiedsplit

.github/workflows/haskell.yml+14−3 .hlint.yaml+130−1 .weeder.yaml+1 README.md+6−1 app/Main.hs−7 hie.yaml+4 package.yaml+38−22 src/Control/Arrow/Extra.hs+7−7 src/Control/Arrow/Extra/ArrowChoice.hs−4 src/Control/Arrow/Extra/ArrowPlus.hs−4 src/Control/Arrow/Extra/ArrowZero.hs−4 src/Control/Arrow/Extra/BaseArrow.hs+13−4 src/Control/Arrow/Extra/Orphans.hs+1−6 src/Control/Arrow/Extra/PolyArrow.hs+10−15 src/Control/Arrow/Reader.hs+34 src/Control/Arrow/Trans/Class.hs+9 src/Control/Arrow/Trans/Reader.hs+53 src/Data/Isoparsec/Cokleisli.hs → src/Control/Cokleisli.hs+5−14 src/Control/Prism.hs+40 src/Control/SemiIso.hs+206 src/Control/Tuple/Morph.hs+179−29 src/Data/Isoparsec.hs+257−123 src/Data/Isoparsec/ByteString.hs+22−41 src/Data/Isoparsec/Char.hs+7−14 src/Data/Isoparsec/Chunks.hs+2−9 src/Data/Isoparsec/Internal.hs+75−124 src/Data/Isoparsec/Megaparsec.hs+58−36 src/Data/Isoparsec/Printer.hs+61−32 src/Data/Isoparsec/ToIsoparsec.hs+21−37 src/Data/Isoparsec/Tokenable.hs−28 src/Lib.hs−6 stack.yaml+2−7 test/Spec.hs+23−1 test/Spec/BasicReader.hs+38 test/Spec/Helper.hs+50−16 test/Spec/JSON.hs+28−39 test/Spec/JSONHList.hs+92 test/Spec/Megaparsec/BasicNums.hs+8−14 test/Spec/Orphans.hs+3−12 test/Spec/Ssh.hs+47−67 test/Spec/SshHList.hs+192 test/Spec/TwoDigits.hs+16−27

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

@@ -7,17 +7,28 @@ jobs:

88 runs-on: ubuntu-latest

10+ strategy:

11+ matrix:

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

13+

1014 steps:

1115 - uses: actions/checkout@v1

1216

17+ - name: Cache

18+ uses: actions/cache@v1

19+ with:

20+ path: ~/.stack

21+ key: ${{ runner.os }}-stack-${{ matrix.resolver }}

22+

1323 - name: Build

1424 run: |

15− stack build --fast --pedantic --ghc-options '-j' --test --no-run-tests --bench --no-run-benchmarks

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

1626

1727 - name: Test

1828 run: |

19− stack test --fast --pedantic --ghc-options '-j'

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

2030

2131 - name: Weeder

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

2233 run: |

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

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

.hlint.yaml+130−1

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

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

5353

5454

55−# Define some custom infix operators

55+# Define some custom fixity operators

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

5757

5858

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

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

6161

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

63+

64+- arguments:

65+ - -XAllowAmbiguousTypes

66+ - -XConstraintKinds

67+ - -XDataKinds

68+ - -XDefaultSignatures

69+ - -XDeriveGeneric

70+ - -XFlexibleContexts

71+ - -XFlexibleInstances

72+ - -XFunctionalDependencies

73+ - -XGADTs

74+ - -XGeneralizedNewtypeDeriving

75+ - -XLambdaCase

76+ - -XMultiParamTypeClasses

77+ - -XOverloadedStrings

78+ - -XPatternSynonyms

79+ - -XPolyKinds

80+ - -XScopedTypeVariables

81+ - -XStandaloneDeriving

82+ - -XTupleSections

83+ - -XTypeApplications

84+ - -XTypeFamilies

85+ - -XTypeOperators

86+ - -XUndecidableInstances

87+ - -XRankNTypes

88+

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

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

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

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

93+

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

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

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

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

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

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

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

101+

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

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

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

105+

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

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

108+

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

110+# no hints found

111+

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

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

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

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

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

117+

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

119+# no hints found

120+

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

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

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

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

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

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

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

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

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

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

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

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

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

134+

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

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

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

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

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

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

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

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

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

144+- fixity: "infixl 8 ~>"

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

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

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

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

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

150+- fixity: "infixl 5 ~|"

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

152+- fixity: "infixl 7 ~&"

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

154+- fixity: "infixl 9 ~*"

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

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

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

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

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

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

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

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

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

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

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

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

167+

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

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

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

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

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

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

174+

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

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

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

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

179+

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

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

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

183+

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

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

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

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

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

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

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

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

.weeder.yamlnew file+1

@@ -0,0 +1 @@

1+- message: Module reused between components

README.md+6−1

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

1−# isoparsec

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

23Isomorphic (invertible) parser library

5+### 🚧 Under construction 🚧

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

app/Main.hsdeleted−7

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

1−module Main

2− ( main,

3− )

4−where

5−

6−main :: IO ()

7−main = putStrLn "henlo."

hie.yamlnew file+4

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

1+cradle:

2+ stack:

3+ - path: "."

4+ component: "isoparsec:test:isoparsec-test"

package.yaml+38−22

@@ -21,45 +21,61 @@ description: Please see the README on GitHub at <https://github.com/ilya

2121

2222dependencies:

2323- base >= 4.7 && < 5

24+- containers

25+- megaparsec

26+- bytestring

27+# - text

28+- mtl

29+- profunctors

30+- mono-traversable

31+- split

2432

2533library:

2634 source-dirs: src

35+ other-modules: Control.Prism

36+ dependencies: []

2737

28− dependencies:

29− - optics-core

30− - megaparsec

31− - containers

32− - bytestring

33− # - text

34− - mtl

35−

36−

37−executables:

38− isoparsec-exe:

39− main: Main.hs

40− source-dirs: app

41− ghc-options:

42− - -threaded

43− - -rtsopts

44− - -with-rtsopts=-N

45− dependencies: []

38+default-extensions:

39+- AllowAmbiguousTypes

40+- ConstraintKinds

41+- DataKinds

42+- DefaultSignatures

43+- DeriveGeneric

44+- FlexibleContexts

45+- FlexibleInstances

46+- FunctionalDependencies

47+- GADTs

48+- GeneralizedNewtypeDeriving

49+- LambdaCase

50+- MultiParamTypeClasses

51+- OverloadedStrings

52+- PatternSynonyms

53+- PolyKinds

54+- ScopedTypeVariables

55+- StandaloneDeriving

56+- TupleSections

57+- TypeApplications

58+- TypeFamilies

59+- TypeOperators

60+- UndecidableInstances

61+- RankNTypes

4662

4763tests:

4864 isoparsec-test:

4965 main: Spec.hs

50− source-dirs: test

66+ source-dirs:

67+ - test

68+ - src

5169 ghc-options:

5270 - -threaded

5371 - -rtsopts

5472 - -with-rtsopts=-N

5573 dependencies:

56− - isoparsec

5774 - tasty

5875 - tasty-hspec

5976 - hspec

60− - optics

77+ - lens

6178 - tasty-quickcheck

6279 - QuickCheck

6380 - megaparsec

6481 - bytestring

65− - word8

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

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

1414import Control.Arrow.Extra.ArrowZero as X

1515import Control.Arrow.Extra.BaseArrow as X

1616import Control.Arrow.Extra.PolyArrow as X

17−import Control.Category as X

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

1818

19−infixr 5 <+^

19+infixl 5 <+^

2020

21−infixr 5 ^+>

21+infixl 5 ^+>

2222

23−infixr 5 ^+^

23+infixl 5 ^+^

2424

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

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

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

2727

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

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

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

3030

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

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

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

src/Control/Arrow/Extra/ArrowChoice.hs−4

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

1−{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE MonoLocalBinds #-}

31{-# LANGUAGE NoImplicitPrelude #-}

4−{-# LANGUAGE UndecidableInstances #-}

63module Control.Arrow.Extra.ArrowChoice

74 ( ArrowChoice (..),

@@ -17,7 +14,6 @@ infixl 2 +++

1714infixl 2 |||

1815

1916class BaseArrow a => ArrowChoice a where

20−

2117 left :: a b c -> a (Either b d) (Either c d)

2218 left = (+++ id)

2319

src/Control/Arrow/Extra/ArrowPlus.hs−4

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

1−{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE MonoLocalBinds #-}

3−{-# LANGUAGE UndecidableInstances #-}

4−

51module Control.Arrow.Extra.ArrowPlus

62 ( ArrowPlus (..),

73 )

src/Control/Arrow/Extra/ArrowZero.hs−4

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

1−{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE MonoLocalBinds #-}

3−{-# LANGUAGE UndecidableInstances #-}

4−

51module Control.Arrow.Extra.ArrowZero

62 ( ArrowZero (..),

73 )

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

@@ -1,20 +1,19 @@

1−{-# LANGUAGE FlexibleInstances #-}

21{-# LANGUAGE NoImplicitPrelude #-}

3−{-# LANGUAGE UndecidableInstances #-}

53module Control.Arrow.Extra.BaseArrow

64 ( BaseArrow (..),

5+ (>>>),

6+ (<<<),

77 )

88where

10−import Control.Category

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

1111

1212infixl 3 ***

1313

1414infixl 3 &&&

1515

1616class Category a => BaseArrow a where

17−

1817 {-# MINIMAL (***), (&&&) #-}

1918

2019 first :: a b c -> a (b, d) (c, d)

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

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

2726

2827 (&&&) :: 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−6

@@ -1,6 +1,3 @@

1−{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE MultiParamTypeClasses #-}

3−{-# LANGUAGE UndecidableInstances #-}

41{-# OPTIONS_GHC -Wno-orphans #-}

63module Control.Arrow.Extra.Orphans

@@ -15,7 +12,6 @@ instance {-# OVERLAPPABLE #-} A.ArrowZero a => ArrowZero a where

1512 zeroArrow = A.zeroArrow

1613

1714instance {-# OVERLAPPABLE #-} A.ArrowChoice a => ArrowChoice a where

18−

1915 left = A.left

2016

2117 right = A.right

@@ -25,7 +21,6 @@ instance {-# OVERLAPPABLE #-} A.ArrowChoice a => ArrowChoice a where

2521 (|||) = (A.|||)

2622

2723instance {-# OVERLAPPABLE #-} (Category a, A.Arrow a) => BaseArrow a where

28−

2924 first = A.first

3025

3126 second = A.second

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

3429

3530 (&&&) = (A.&&&)

3631

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

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

3833 arr = A.arr

3934

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

src/Control/Arrow/Extra/PolyArrow.hs+10−15

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

1−{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE MonoLocalBinds #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−

51module Control.Arrow.Extra.PolyArrow

62 ( PolyArrow (..),

73 (^>>),

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

1410where

1511

1612import Control.Arrow.Extra.BaseArrow

17−import Control.Category

1813

19−infixr 1 ^>>, >>^

14+infixl 1 ^>>, >>^

2015

21−infixr 1 ^<<, <<^

16+infixl 1 ^<<, <<^

2217

23−infixr 1 ^>^, ^<^

18+infixl 1 ^>^, ^<^

2419

25−class BaseArrow a => PolyArrow a p where

20+class BaseArrow a => PolyArrow p a where

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

2722

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

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

2924f ^>> a = arr f >>> a

3025

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

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

3227a >>^ f = a >>> arr f

3328

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

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

3530a <<^ f = a <<< arr f

3631

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

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

3833f ^<< a = arr f <<< a

3934

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

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

4136a ^>^ b = arr a >>> arr b

4237

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

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

4439a ^<^ b = arr a <<< arr b

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

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

1+module Control.Arrow.Reader

2+ ( ArrowReader (..),

3+ asksr,

4+ asksl,

5+ biask,

6+ biasks,

7+ module Control.Arrow.Trans.Reader,

8+ )

9+where

10+

11+import Control.Arrow.Extra

12+import Control.Arrow.Trans.Reader

13+import Control.SemiIso

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

15+

16+class ArrowReader r a where

17+ askr :: a () r

18+ askl :: a r ()

19+

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

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

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

23+

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

25+asksr si = askr >>^ si

26+

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

28+asksl si = turn si ^>> askl

29+

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

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

32+

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

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

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

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

1+module Control.Arrow.Trans.Class

2+ ( ArrowTrans (..),

3+ )

4+where

6+import Control.Arrow.Extra

8+class ArrowTrans s where

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

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

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

1+module Control.Arrow.Trans.Reader

2+ ( ReaderArrow (..),

3+ runReaderArrow,

4+ module Control.Arrow.Trans.Class,

5+ )

6+where

8+import Control.Arrow.Extra

9+import Control.Arrow.Trans.Class

10+import Control.SemiIso

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

12+

13+newtype ReaderArrow r s a b

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

15+

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

17+ id = ReaderArrow . second $ id

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

19+

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

21+ arr = ReaderArrow . second . arr

22+

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

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

25+ ReaderArrow $

26+ siDouble *** id

27+ ^>^ turn siTranspose2

28+ >>> lhs *** rhs

29+ >>^ siTranspose2

30+ >>^ turn siDouble *** id

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

32+ ReaderArrow $

33+ lhs &&& rhs

34+ >>^ siTranspose2

35+ >>^ turn siDouble *** id

36+

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

38+ zeroArrow = ReaderArrow $ id *** zeroArrow

39+

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

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

42+

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

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

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

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

47+

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

49+runReaderArrow r a =

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

51+

52+instance ArrowTrans (ReaderArrow r) where

53+ raise = ReaderArrow . second

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

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

1−{-# LANGUAGE LambdaCase #-}

2−{-# LANGUAGE MultiParamTypeClasses #-}

3−

4−module Data.Isoparsec.Cokleisli

1+module Control.Cokleisli

52 ( Cokleisli (..),

63 )

74where

@@ -9,20 +6,17 @@ where

96import Control.Applicative

107import Control.Arrow.Extra

118import Control.Monad

12−import Data.Isoparsec.Internal

13−import Optics.Iso

9+import Control.SemiIso

1410import Prelude hiding ((.))

1511

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

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

1713

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

19−

2015 id = Cokleisli return

2116

2217 (Cokleisli cb) . (Cokleisli ba) = Cokleisli $ cb >=> ba

2318

2419instance (Alternative m, Monad m) => BaseArrow (Cokleisli m) where

25−

2620 (Cokleisli cb) *** (Cokleisli c'b') = Cokleisli $

2721 \(c, c') -> do

2822 b' <- c'b' c'

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

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

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

3428

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

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

37− Just x -> return x

38− Nothing -> mzero

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

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

3931

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

4133 zeroArrow = Cokleisli $ const mzero

@@ -44,7 +36,6 @@ instance MonadPlus m => ArrowPlus (Cokleisli m) where

4436 (Cokleisli lhs) <+> (Cokleisli rhs) = Cokleisli $ \x -> lhs x `mplus` rhs x

4537

4638instance (Alternative m, Monad m) => ArrowChoice (Cokleisli m) where

47−

4839 left (Cokleisli cb) = Cokleisli $ \case

4940 Left c -> Left <$> cb c

5041 Right d -> return $ Right d

src/Control/Prism.hsnew file+40

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

1+module Control.Prism

2+ ( withPrism,

3+ Identity,

4+ Prism',

5+ )

6+where

8+import Data.Coerce

9+import Data.Functor.Identity

10+import Data.Profunctor

11+

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

13+

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

15+

16+instance Functor (Market a b s) where

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

18+

19+instance Profunctor (Market a b) where

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

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

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

23+

24+instance Choice (Market a b) where

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

26+ Left s -> case seta s of

27+ Left t -> Left (Left t)

28+ Right a -> Right a

29+ Right c -> Left (Right c)

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

31+ Left c -> Left (Left c)

32+ Right s -> case seta s of

33+ Left t -> Left (Right t)

34+ Right a -> Right a

35+

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

37+

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

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

40+ Market bt seta -> f bt seta

src/Control/SemiIso.hsnew file+206

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

1+module Control.SemiIso

2+ ( module X,

3+ SemiIso (..),

4+ pattern SI,

5+ siMaybe,

6+ siPure,

7+ turn,

8+ withSemiIso,

9+ AlternativeMonad,

10+ maskr,

11+ maskl,

12+ isoCheck,

13+ siCheck,

14+ check,

15+ konst,

16+ isoConst,

17+ assoc,

18+ ($$$),

19+ (*>>),

20+ (&>>),

21+ (**>),

22+ (>>*),

23+ (>>&),

24+ (>**),

25+ (<<*),

26+ (<<&),

27+ (<**),

28+ (*<<),

29+ (&<<),

30+ (**<),

31+ siFst,

32+ siSnd,

33+ siDouble,

34+ siSwap,

35+ siTranspose2,

36+ siSequenceEither,

37+ )

38+where

39+

40+import Control.Applicative as X

41+import Control.Arrow.Extra

42+import Control.Monad as X

43+import qualified Data.Bifunctor as Bi

44+import Data.Bitraversable

45+import Data.Tuple

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

47+

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

49+

50+data SemiIso a b

51+ = SemiIso

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

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

54+ }

55+

56+pattern SI ::

57+ forall a b.

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

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

60+ SemiIso a b

61+pattern SI a b = SemiIso a b

62+

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

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

65+ where

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

67+ maybeToAlternative (Just x) = pure x

68+ maybeToAlternative Nothing = empty

69+

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

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

72+

73+instance Category SemiIso where

74+ id = SemiIso pure pure

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

76+

77+instance BaseArrow SemiIso where

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

79+ SemiIso

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

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

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

83+ SemiIso

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

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

86+

87+instance ArrowChoice SemiIso where

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

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

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

91+ SemiIso

92+ (either a1 a2)

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

94+

95+instance ArrowZero SemiIso where

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

97+

98+instance ArrowPlus SemiIso where

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

100+ SemiIso

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

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

103+

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

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

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

107+

108+withSemiIso ::

109+ AlternativeMonad f =>

110+ SemiIso a b ->

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

112+ c

113+withSemiIso (SemiIso a b) f = f a b

114+

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

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

117+

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

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

120+

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

122+

123+infixl 3 $$$

124+

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

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

127+

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

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

130+

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

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

133+

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

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

136+

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

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

139+

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

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

142+

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

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

145+

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

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

148+

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

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

151+

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

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

154+

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

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

157+

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

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

160+

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

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

163+

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

165+check f = isoCheck f id id

166+

167+siCheck ::

168+ (s -> Bool) ->

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

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

171+ SemiIso s a

172+siCheck f a b =

173+ SI

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

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

176+

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

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

179+

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

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

182+

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

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

185+

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

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

188+

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

190+siFst = siPure fst (,())

191+

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

193+siSnd = siPure snd ((),)

194+

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

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

197+

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

199+siSwap = siPure swap swap

200+

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

202+siTranspose2 =

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

204+

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

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

src/Control/Tuple/Morph.hs+179−29

@@ -1,18 +1,3 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE GADTs #-}

8−{-# LANGUAGE PatternSynonyms #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TypeApplications #-}

13−{-# LANGUAGE TypeFamilies #-}

14−{-# LANGUAGE TypeOperators #-}

15−{-# LANGUAGE UndecidableInstances #-}

161{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-redundant-constraints #-}

172

183module Control.Tuple.Morph

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

227 TupleMorphable,

238 CheckListsForTupleIso,

249 ReorderList,

10+ FlatMorphable (..),

11+ TupleHListContents,

12+ HListContentsTuple,

13+ Nat (..),

14+ HList (..),

15+ AppendableList (..),

16+ DroppableList (..),

17+ TakeableList (..),

18+ Length,

19+ Proxy (..),

2520 )

2621where

2722

2823import Data.Kind

2924import Data.Proxy

25+import Data.Type.Equality

3026import GHC.Generics

3127import GHC.TypeLits hiding (Nat)

3228

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

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

7672 HNil :: HList '[]

7773

78−infixr 5 :+

74+infixl 5 :+

7975

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

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

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

107103

108104-- ## Appending

109105

110−infixr 4 ++:

106+infixl 4 ++:

111107

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

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

108+class

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

110+ DroppableList (Length aa) cc bb,

111+ TakeableList (Length aa) cc aa

112+ ) =>

113+ AppendableList aa bb cc

114+ | aa bb -> cc where

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

114116

115117instance AppendableList '[] bb bb where

116118 HNil ++: bb = bb

@@ -189,13 +191,11 @@ type family Length (aa :: [k]) :: Nat where

189191-- # Morphing

190192

191193class TupleMorphable t th | t -> th where

192−

193194 unmorph :: t -> HList th

194195

195196 morph :: HList th -> t

196197

197198instance (IsMophableTuple t ~ flag, TupleMorphable' t th flag) => TupleMorphable t th where

198−

199199 unmorph = unmorph' (Proxy @flag)

200200

201201 morph = morph' (Proxy @flag)

@@ -203,19 +203,16 @@ instance (IsMophableTuple t ~ flag, TupleMorphable' t th flag) => TupleMorphable

203203-- ## Implementation

204204

205205class TupleMorphable' t th (flag :: Bool) | t flag -> th where

206−

207206 unmorph' :: Proxy flag -> t -> HList th

208207

209208 morph' :: Proxy flag -> HList th -> t

210209

211210instance TupleMorphable' t '[t] 'False where

212−

213211 unmorph' _ t = t :+ HNil

214212

215213 morph' _ (t :+ HNil) = t

216214

217215instance (GenericTupleMorphable (Rep t) th, Generic t) => TupleMorphable' t th 'True where

218−

219216 unmorph' _ = genericUnmorph . from

220217

221218 morph' _ = to . genericMorph

@@ -223,25 +220,21 @@ instance (GenericTupleMorphable (Rep t) th, Generic t) => TupleMorphable' t th '

223220-- ### Generics

224221

225222class GenericTupleMorphable f th | f -> th where

226−

227223 genericUnmorph :: f p -> HList th

228224

229225 genericMorph :: HList th -> f p

230226

231227instance (GenericTupleMorphable f t) => GenericTupleMorphable (M1 i c f) t where

232−

233228 genericUnmorph = genericUnmorph . unM1

234229

235230 genericMorph = M1 . genericMorph

236231

237232instance (TupleMorphable c t) => GenericTupleMorphable (K1 i c) t where

238−

239233 genericUnmorph = unmorph . unK1

240234

241235 genericMorph = K1 . morph

242236

243237instance GenericTupleMorphable U1 '[] where

244−

245238 genericUnmorph _ = HNil

246239

247240 genericMorph _ = U1

@@ -260,7 +253,6 @@ instance

260253 ) =>

261254 GenericTupleMorphable (f :*: g) c

262255 where

263−

264256 genericUnmorph (a :*: b) = genericUnmorph a ++: genericUnmorph b

265257

266258 genericMorph cc = genericMorph aa :*: genericMorph bb

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

268260 aa = hTake @(Length a) Proxy cc

269261 bb = hDrop @(Length a) Proxy cc

270262

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+

271290-- ## Other

272291

273292type family IsMophableTuple t :: Bool where

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

334353 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

335354 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

336355 IsMophableTuple c = 'False

356+

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

358+ TupleHListContents (HList ts) = ts

359+ TupleHListContents () = '[]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

421+ TupleHListContents a = '[a]

422+

423+type family HListContentsTuple t :: * where

424+ HListContentsTuple '[] = ()

425+ HListContentsTuple '[a] = a

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

src/Data/Isoparsec.hs+257−123

@@ -1,166 +1,300 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE ExistentialQuantification #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE PolyKinds #-}

8−{-# LANGUAGE ScopedTypeVariables #-}

9−{-# LANGUAGE TypeApplications #-}

10−{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeOperators #-}

121{-# OPTIONS_GHC -Wno-redundant-constraints #-}

132

143module Data.Isoparsec

154 ( module X,

16− -- Isoparsec,

17− (%>>),

18− (%>%),

19− (>>%),

20− (%<<),

21− (%<%),

22− (<<%),

23− (<?>),

24− (<+%),

25− (%+>),

26− (%+%),

275 (<.>),

28− (<^>),

296 repeating,

7+ sepBy,

8+ sepBy1,

309 opt,

3110 opt',

3211 morphed,

12+ fMorphed,

3313 coercing,

3414 mapIso,

3515 auto,

3616 specific,

3717 throughIntegral,

18+ (~>),

19+ (~>^),

20+ (^~>),

21+ (^~>^),

22+ (~|),

23+ (~$>),

24+ (~&),

25+ (~*),

26+ siPrism,

27+ delist,

28+ enlist,

29+ Listed,

30+ hmap,

3831 )

3932where

4033

4134import Control.Arrow.Extra as X

35+import Control.Prism

4236import Control.Tuple.Morph

4337import Data.Coerce

38+import Data.Either

4439import Data.Isoparsec.Internal as X

4540import Data.Isoparsec.ToIsoparsec as X

46−import Data.Isoparsec.Tokenable as X

4741import qualified Data.Map as M

48−import Optics.Iso

49−import Optics.Optic

50−import Optics.Prism

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

5243

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

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

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

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

5546

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

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

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

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

5849

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

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

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

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

6152

62−infix 0 <?>

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

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

6355

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

65−thing <?> msg = label msg thing

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

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

6658

67−infixr 1 %>>

68−

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

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

71−

72−infixr 1 %>%

73−

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

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

76−

77−infixr 1 >>%

78−

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

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

81−

82−infixr 1 %<<

83−

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

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

86−

87−infixr 1 %<%

88−

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

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

91−

92−infixr 1 <<%

93−

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

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

96−

97−infixr 5 <+%

98−

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

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

101−

102−infixr 5 %+>

103−

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

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

106−

107−infixr 5 %+%

108−

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

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

111−

112−infixr 0 <.>

59+infixl 0 <.>

11360

11461(<.>) ::

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

116− b ->

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

63+ (Prism' a b) ->

11764 m x' x ->

118− m x' y'

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

120−

121−infixr 0 <^>

122−

123−(<^>) ::

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

125− m x' x ->

126− b ->

127− m x' y'

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

129−

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

131−coercing = arr $ siJust coerce coerce

132−

133−morphed ::

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

135− Iso' a b

136−morphed = iso morphTuples morphTuples

137−

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

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

140−

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

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

143− where

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

145−

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

147− si = id

148−

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

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

65+ m x' b

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

67+

68+siPrism ::

69+ (Prism' a b) ->

70+ SemiIso a b

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

72+

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

74+

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

76+

77+type family If cond t f where

78+ If 'True t _ = t

79+ If 'False _ f = f

80+

81+type family BothEmpty a b where

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

83+ BothEmpty _ _ = 'False

84+

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

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

87+ --

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

89+ (~>) ::

90+ ( PolyArrow SemiIso m,

91+ FlatMorphable a a' fa,

92+ FlatMorphable b b' fb,

93+ FlatMorphable c c' fc,

94+ FlatMorphable d d' fd

95+ ) =>

96+ m a b ->

97+ m c d ->

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

99+

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

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

102+

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

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

105+

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

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

108+

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

110+siHFst = siPure fst (,HNil)

111+

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

113+--

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

115+(~>^) ::

116+ ( PolyArrow SemiIso m,

117+ FlatMorphable a a' fa,

118+ FlatMorphable b bc fb,

119+ FlatMorphable c bc 'False,

120+ FlatMorphable d d' 'False

121+ ) =>

122+ m a b ->

123+ SemiIso c d ->

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

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

126+

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

128+--

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

130+(^~>) ::

131+ ( PolyArrow SemiIso m,

132+ FlatMorphable a a' 'False,

133+ FlatMorphable b bc 'False,

134+ FlatMorphable c bc fc,

135+ FlatMorphable d d' fd

136+ ) =>

137+ SemiIso a b ->

138+ m c d ->

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

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

141+

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

143+--

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

145+(^~>^) ::

146+ ( PolyArrow SemiIso m,

147+ FlatMorphable a a' 'False,

148+ FlatMorphable b b' 'False,

149+ FlatMorphable d d' 'False

150+ ) =>

151+ SemiIso a b ->

152+ SemiIso b d ->

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

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

155+

156+infixl 5 ~|

157+

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

159+--

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

161+(~|) ::

162+ ( PolyArrow SemiIso m,

163+ ArrowPlus m,

164+ FlatMorphable a ac fa,

165+ FlatMorphable c ac fb,

166+ FlatMorphable b bd fc,

167+ FlatMorphable d bd fd

168+ ) =>

169+ m a b ->

170+ m c d ->

171+ m (HList ac) (HList bd)

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

173+

174+infixl 7 ~&

175+

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

177+--

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

179+(~&) ::

180+ ( PolyArrow SemiIso m,

181+ FlatMorphable a ac' fa,

182+ FlatMorphable c ac' fc,

183+ FlatMorphable b b' fb,

184+ FlatMorphable d d' fd,

185+ AppendableList b' d' f

186+ ) =>

187+ m a b ->

188+ m c d ->

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

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

191+

192+infixl 9 ~*

193+

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

195+--

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

197+(~*) ::

198+ ( PolyArrow SemiIso m,

199+ FlatMorphable a a' fa,

200+ FlatMorphable c c' fc,

201+ FlatMorphable b b' fb,

202+ FlatMorphable d d' fd,

203+ AppendableList a' c' e',

204+ AppendableList b' d' f'

205+ ) =>

206+ m a b ->

207+ m c d ->

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

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

210+

211+infixl 6 ~$>

212+

213+(~$>) ::

214+ ( PolyArrow SemiIso m,

215+ FlatMorphable a a' fa,

216+ FlatMorphable b bc fb,

217+ FlatMorphable c bc fc,

218+ FlatMorphable d d' fd

219+ ) =>

220+ m a b ->

221+ Prism' c d ->

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

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

224+

225+-- | Conceptually:

226+--

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

228+hmap ::

229+ ( FlatMorphable b b' fb,

230+ FlatMorphable a a' fa,

231+ FlatMorphable d d' fd,

232+ FlatMorphable c c' fc,

233+ PolyArrow SemiIso m

234+ ) =>

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

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

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

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

239+

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

241+coercing = siPure coerce coerce

242+

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

244+morphed = siPure morphTuples morphTuples

245+

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

247+fMorphed = siPure flatUnmorph flatMorph

248+

249+-- | Conceptually:

250+--

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

252+enlist ::

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

254+ m a b ->

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

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

257+

258+-- | Conceptually:

259+--

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

261+delist ::

262+ ( FlatMorphable a a' 'False,

263+ FlatMorphable b b' 'False,

264+ PolyArrow SemiIso m,

265+ HListContentsTuple a' ~ a,

266+ HListContentsTuple b' ~ b,

267+ TupleHListContents a ~ a',

268+ TupleHListContents b ~ b'

269+ ) =>

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

271+ m a b

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

273+

274+consHList ::

275+ forall a b c.

276+ AppendableList a b c =>

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

278+consHList =

279+ siPure

280+ (uncurry (++:))

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

282+

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

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

151285 where

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

153287 u =

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

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

156290

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

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

158292auto = toIsoparsec

159293

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

161−specific x = auto @x >>> check (== x) >>> tsnok x

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

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

162296

163297throughIntegral ::

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

165− m a b

166−throughIntegral = arr $ siJust fromIntegral fromIntegral

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

299+ SemiIso a b

300+throughIntegral = siPure fromIntegral fromIntegral

src/Data/Isoparsec/ByteString.hs+22−41

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

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE MultiParamTypeClasses #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TupleSections #-}

8−{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

101{-# OPTIONS_GHC -Wno-orphans #-}

112

123module Data.Isoparsec.ByteString

134 ( utf8,

14− ftu8,

155 ByteString,

166 Endianness (..),

177 Byte8,

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

3020import Data.Word

3121import Prelude as P hiding ((.))

3222

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

34−utf8 = chunk . C.pack

35−

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

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

23+utf8 :: SemiIso ByteString String

24+utf8 = siPure C.unpack C.pack

3825

3926data Endianness = BE | LE

4027

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

4330

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

4532 bytesToIsoparsec _ =

46− konst word8s >>> manyTokens

47− >>^ siJust

33+ konst word8s ^>> manyTokens

34+ >>^ siPure

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

49− ( liftTokens . snd . P.head

36+ ( fromList . snd . P.head

5037 . P.drop (fromIntegral word8s)

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

5239 . (,[])

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

5744

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

5946 bytesToIsoparsec _ =

60− konst word8s >>> manyTokens

61− >>^ siJust

47+ konst word8s ^>> manyTokens

48+ >>^ siPure

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

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

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

6451 . P.drop (fromIntegral word8s)

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

6653 . (,[])

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

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

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

8269

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

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

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

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

8572

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

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

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

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

8875

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

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

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

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

9178

92−instance ToIsoparsec Bool ByteString where

79+instance ToIsoparsec Bool ByteString m where

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

9481

9582newtype SSHString = SSHString {unSSHString :: String}

9683 deriving (Show, Eq, Ord)

9784

98−instance ToIsoparsec SSHString ByteString where

85+instance ToIsoparsec SSHString ByteString m where

9986 toIsoparsec =

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

101− >>> siJust fromIntegral fromIntegral ^>> manyTokens

102− >>> ftu8

103− >>^ siJust SSHString unSSHString

104−

105−instance Tokenable ByteString where

106−

107− type Token ByteString = Word8

108−

109− liftTokens = pack

110−

111− lowerTokens = unpack

87+ auto @(Byte32 'BE)

88+ >>^ coercing @Word32

89+ >>^ siPure fromIntegral fromIntegral

90+ >>> manyTokens

91+ >>^ utf8

92+ >>^ siPure SSHString unSSHString

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

@@ -1,10 +1,3 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE TypeApplications #-}

6−{-# LANGUAGE TypeFamilies #-}

7−

81module Data.Isoparsec.Char

92 ( unsafeWhiteSpace,

103 unsafeWhiteSpace1,

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

1811import Text.Read

1912import Prelude hiding ((.), id)

2013

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

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

2215space = token ' '

2316

24−unsafeWhiteSpace :: (Isoparsec m s, Token s ~ Char) => m () ()

25−unsafeWhiteSpace = tokensWhile isSpace >>> badTsnok mempty

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

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

2619

27−unsafeWhiteSpace1 :: (Isoparsec m s, Token s ~ Char) => m () ()

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

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

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

2922

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

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

3124number =

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

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

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

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

@@ -1,10 +1,3 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE ScopedTypeVariables #-}

5−{-# LANGUAGE TypeApplications #-}

6−{-# LANGUAGE TypeFamilies #-}

7−

81module Data.Isoparsec.Chunks

92 ( Chunk (..),

103 )

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

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

1811 deriving (Show, Eq, Ord)

1912

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

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

2114 toIsoparsec =

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

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

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

@@ -1,99 +1,76 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DefaultSignatures #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE LambdaCase #-}

8−{-# LANGUAGE LiberalTypeSynonyms #-}

9−{-# LANGUAGE TypeFamilies #-}

10−{-# LANGUAGE TypeOperators #-}

11−{-# LANGUAGE UndecidableInstances #-}

12−

131module Data.Isoparsec.Internal

14− ( SemiIso' (..),

15− SemiIso,

16− si',

2+ ( module X,

173 IsoparsecFail (..),

184 Isoparsec (..),

19− IsoparsecTry (..),

20− IsoparsecLabel (..),

21− konst,

22− tsnok,

23− cons',

24− siJust,

25− siCheck,

26− siCheck',

27− check,

28− levitate,

29− siDecompose,

30− badKonst,

31− badTsnok,

5+ siCons,

6+ unroll,

7+ arrowsWhile,

8+ arrowsUntil,

9+ EffectOnly,

3210 )

3311where

3412

3513import Control.Arrow.Extra

14+import Control.Arrow.Trans.Reader

3615import Control.Monad

37−import Data.Isoparsec.Tokenable

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

17+import Data.MonoTraversable as X

18+import Data.Sequences as X

3819import Numeric.Natural

39−import Optics.Iso

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

4121

4222class

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

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

4424 Isoparsec m s

4525 | m -> s where

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

4627

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

48−

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

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

5029

51− token :: Token s -> m () ()

30+ token :: Element s -> EffectOnly m

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

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

5233

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

54− token x = anyToken >>> tsnok x

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

5537

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

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

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

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

5741

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

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

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

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

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

6144

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

63− chunk = tokens . lowerTokens

45+ chunk :: s -> EffectOnly m

46+ chunk = tokens . otoList

6447

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

48+ chunk' :: m s s

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

50+ where

51+ list = siPure otoList fromList

6652

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

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

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

6855 notToken t = tokenWhere (/= t)

6956

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

71− tokenWhere f =

72− anyToken >>> check f

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

58+ tokenWhere f = anyToken >>^ check f

7359

7460 manyTokens :: m Natural s

7561

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

77−

7862 takeUntil :: s -> m () s

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

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

7965

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

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

82− where

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

84−

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

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

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

8668 tokensWhile f =

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

88− where

89− tokensWhile' g =

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

91− <+^ isoConst' () []

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

70+ <+^ isoConst () mempty

9271

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

94− tokensWhile1 f =

95− tokenWhere f &&& tokensWhile f

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

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

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

9774

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

9976 -- > ┌─────┐

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

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

11289 -- > └─────┘ └─────┘

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

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

11492

115−class IsoparsecLabel m l where

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

117−

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

119−levitateHead s = case lowerTokens s of

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

121− [] -> Nothing

122−

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

124−cons' =

125− si'

126− (Just . uncurry (:))

127− ( \case

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

129− _ -> Nothing

130− )

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

13194

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

133−levitate = siJust liftTokens lowerTokens

95+type EffectOnly m = m () ()

13496

135−class IsoparsecTry m where

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

137−

138−class IsoparsecFail m e where

139− fail :: e -> m a b

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

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

14099

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

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

142102

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

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

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

145107

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

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

109+siCons =

110+ siMaybe

111+ (pure . uncurry cons)

112+ uncons

147113

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

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

150−

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

152−siCheck' f a b =

153− si'

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

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

156−

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

158−siCheck f a b = siCheck' f (Just . a) (Just . b)

159−

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

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

162−

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

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

165−

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

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

168−

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

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

171−

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

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

174−

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

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

177−

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

179−check f = arr $ siCheck f id id

114+class IsoparsecFail m e where

115+ failure :: e -> m a b

116+

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

118+ anyToken = raise anyToken

119+ token' = raise token'

120+ tokens = raise . tokens

121+ tokens' = raise tokens'

122+ chunk = raise . chunk

123+ chunk' = raise chunk'

124+ notToken = raise . notToken

125+ tokenWhere = raise . tokenWhere

126+ manyTokens = raise manyTokens

127+ takeUntil = raise . takeUntil

128+ tokensWhile = raise . tokensWhile

129+ tokensWhile1 = raise . tokensWhile1

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

src/Data/Isoparsec/Megaparsec.hs+58−36

@@ -1,16 +1,9 @@

1−{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE LambdaCase #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE QuantifiedConstraints #-}

5−{-# LANGUAGE RankNTypes #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7−{-# LANGUAGE TypeApplications #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE UndecidableInstances #-}

101{-# OPTIONS_GHC -Wno-orphans #-}

112

123module Data.Isoparsec.Megaparsec

13− ( runMegaparsec,

4+ ( runMegaparsecParser,

5+ ParseErrorBundle (..),

6+ MegaparsecParser (..),

147 )

158where

169

@@ -18,49 +11,78 @@ import Control.Arrow.Extra

1811import Control.Arrow.Extra.Orphans ()

1912import Control.Monad

2013import Data.Functor

21−import Data.Isoparsec.Internal as I

22−import Data.Isoparsec.Tokenable

23−import Optics.Getter

24−import Optics.ReadOnly

14+import Data.Functor.Identity

15+import Data.Isoparsec

16+import Data.Void

2517import Text.Megaparsec hiding (Token)

2618import qualified Text.Megaparsec as M

2719import Prelude hiding ((.))

2820

29−runMegaparsec ::

30− (Ord e, Stream s) =>

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

32− s ->

33− Either (ParseErrorBundle s e) r

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

21+newtype MegaparsecParser s a b

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

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

3524

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

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

25+instance

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

27+ ArrowPlus (MegaparsecParser s)

28+ where

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

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

31+

32+runMegaparsecParser ::

33+ (Stream s) =>

34+ s ->

35+ MegaparsecParser s () r ->

36+ Either (ParseErrorBundle s Void) r

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

3838

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

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

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

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

4141 Just x -> return x

42− Nothing -> failure Nothing mempty

42+ Nothing -> M.failure Nothing mempty

4343

4444instance

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

46− Isoparsec (Kleisli m) s

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

46+ Isoparsec (MegaparsecParser s) s

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

4859

49− anyToken = Kleisli $ const anySingle

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

5061

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

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

5263

53− manyTokens = Kleisli $ takeP Nothing . fromIntegral

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

5465

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

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

67+

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

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

70+ return $ fromList ta

71+

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

73+

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

75+

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

5677 sup <- getInput

5778 setInput sub

5879 r <- f () <* eof

5980 setInput sup

6081 return r

6182

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

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

64−

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

66− label s (Kleisli m) = Kleisli $ \x -> M.label s (m x)

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

84+ sup <- getInput

85+ setInput sub

86+ r <- f x <* eof

87+ setInput sup

88+ return r

src/Data/Isoparsec/Printer.hs+61−32

@@ -1,54 +1,83 @@

1−{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE FlexibleInstances #-}

3−{-# LANGUAGE MultiParamTypeClasses #-}

4−{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE UndecidableInstances #-}

61{-# OPTIONS_GHC -Wno-orphans #-}

83module Data.Isoparsec.Printer

9− ( runPrinter,

4+ ( runMonoidPrinter,

5+ MonoidPrinter (..),

106 )

117where

128

9+import Control.Cokleisli

1310import Control.Monad.Writer.Lazy

11+import Data.Functor

1412import Data.Isoparsec

15−import Data.Isoparsec.Cokleisli

13+import Data.List.Split

1614import Prelude hiding ((.), id)

1715

18−runPrinter ::

19− forall m s a.

20− Monad m =>

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

16+newtype MonoidPrinter s a b

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

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

19+

20+runMonoidPrinter ::

21+ forall s a.

22+ MonoidPrinter s () a ->

2223 a ->

23− m s

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

24+ Maybe s

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

26+

27+instance IsoparsecFail (MonoidPrinter s) e where

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

2529

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

27− fail _ = Cokleisli . const $ WriterT Nothing

30+instance

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

32+ Isoparsec (MonoidPrinter s) s

33+ where

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

2835

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

30− fail = Cokleisli . const . WriterT . Left

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

3137

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

33− label _ = id

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

3439

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

36− label _ = id

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

3741

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

39− try = id

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

4043

41−instance

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

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

44− where

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

4545

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

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

4747

48− anyToken = Cokleisli $ tell . Dual . liftToken

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

49+ if t == nt

50+ then empty

51+ else (tell . Dual . singleton) t

4952

50− manyTokens = Cokleisli $ \w -> do

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

54+ if f t

55+ then (tell . Dual . singleton) t

56+ else empty

57+

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

5159 tell $ Dual w

52− return . fromIntegral . length . lowerTokens $ w

60+ return . fromIntegral . olength $ w

61+

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

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

64+ then empty

65+ else do

66+ tell . Dual $ s

67+ tell . Dual $ end

68+

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

70+ if oall f s

71+ then (tell . Dual) s

72+ else empty

73+

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

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

76+ then (tell . Dual) s

77+ else empty

78+

79+ tuck (MonoidPrinter (Cokleisli f)) =

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

5381

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

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

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

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

@@ -1,12 +1,3 @@

1−{-# LANGUAGE DefaultSignatures #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE FlexibleInstances #-}

4−{-# LANGUAGE MultiParamTypeClasses #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeFamilies #-}

7−{-# LANGUAGE TypeOperators #-}

8−{-# LANGUAGE UndecidableInstances #-}

9−

101module Data.Isoparsec.ToIsoparsec

112 ( ToIsoparsec (..),

123 )

@@ -14,47 +5,40 @@ where

145

156import Control.Arrow.Extra

167import Data.Isoparsec.Internal

17−import Data.Isoparsec.Tokenable

188import GHC.Generics

199import Prelude hiding ((.))

2010

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

22− toIsoparsec = anyToken

23−

24−class ToIsoparsec a s where

25−

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

11+class ToIsoparsec a s m where

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

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

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

2715

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

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

30−

31−class GToIsoparsec a s where

16+class GToIsoparsec a s m where

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

3318

34−instance GToIsoparsec U1 s where

35− gToIsoparsec = konst U1

19+instance GToIsoparsec U1 s m where

20+ gToIsoparsec = arr $ konst U1

3621

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

38− gToIsoparsec =

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

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

23+ gToIsoparsec = toIsoparsec >>^ siPure K1 unK1

4024

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

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

4226 gToIsoparsec =

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

27+ gToIsoparsec >>^ siPure M1 unM1

4428

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

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

4630 gToIsoparsec =

4731 (gToIsoparsec &&& gToIsoparsec)

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

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

4933

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

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

5135 gToIsoparsec =

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

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

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

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

5438 )

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

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

5640 where

57− fromL (L1 a) = Just a

58− fromL _ = Nothing

59− fromR (R1 b) = Just b

60− fromR _ = Nothing

41+ fromL (L1 a) = pure a

42+ fromL _ = empty

43+ fromR (R1 b) = pure b

44+ fromR _ = empty

src/Data/Isoparsec/Tokenable.hsdeleted−28

@@ -1,28 +0,0 @@

1−{-# LANGUAGE TypeFamilies #-}

2−

3−module Data.Isoparsec.Tokenable

4− ( Tokenable (..),

5− )

6−where

7−

8−class Monoid s => Tokenable s where

9−

10− type Token s

11−

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

13−

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

15− liftTokens = mconcat . fmap liftToken

16−

17− liftToken :: Token s -> s

18− liftToken = liftTokens . pure

19−

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

21−

22−instance Tokenable [t] where

23−

24− type Token [t] = t

25−

26− liftTokens = id

27−

28− lowerTokens = id

src/Lib.hsdeleted−6

@@ -1,6 +0,0 @@

1−module Lib

2− ( someFunc

3− ) where

4−

5−someFunc :: IO ()

6−someFunc = putStrLn "someFunc"

stack.yaml+2−7

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

1717#

1818# resolver: ./custom-snapshot.yaml

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

20−resolver: lts-14.15

20+resolver: lts-15.8

2121

2222# User packages to be built.

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

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

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

4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

4141#

42−extra-deps:

43−- optics-core-0.1

44−- optics-0.1

45−- optics-extra-0.1

46−- optics-th-0.1

4742

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

4944# flags: {}

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

7065# compiler-check: newer-minor

7166

7267ghc-options:

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

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

test/Spec.hs+23−1

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

1+import qualified Spec.BasicReader as BasicReader

12import qualified Spec.JSON as JSON

3+import qualified Spec.JSONHList as JSONHList

24import qualified Spec.Megaparsec.BasicNums as BasicNums

35import qualified Spec.Ssh as Ssh

6+import qualified Spec.SshHList as SshHList

47import qualified Spec.TwoDigits as TwoDigits

58import Test.Tasty

69import Test.Tasty.Hspec

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

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

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

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

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

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

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

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

1320 defaultMain

1421 ( testGroup

1522 "tests"

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

2027 ],

2128 testGroup

2229 "JSON"

23− [ JSON.quickSpec

30+ [ jsonSpec,

31+ JSON.quickSpec

32+ ],

33+ testGroup

34+ "JSONHList"

35+ [ jsonHListSpec,

36+ JSONHList.quickSpec

2437 ],

2538 testGroup

2639 "TwoDigits"

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

3144 "ssh"

3245 [ sshSpec,

3346 Ssh.quickSpec

47+ ],

48+ testGroup

49+ "ssh HList"

50+ [ sshHListSpec,

51+ SshHList.quickSpec

52+ ],

53+ testGroup

54+ "BasicReader"

55+ [ basicReaderSpec

3456 ]

3557 ]

3658 )

test/Spec/BasicReader.hsnew file+38

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

1+{-# LANGUAGE PartialTypeSignatures #-}

2+{-# LANGUAGE TemplateHaskell #-}

4+module Spec.BasicReader

5+ ( spec,

6+ )

7+where

9+import Control.Arrow.Extra

10+import Control.Arrow.Reader

11+import Control.Lens.TH

12+import Data.Either

13+import Data.Isoparsec

14+import Data.Isoparsec.Char

15+import Data.Isoparsec.Megaparsec

16+import Test.Hspec

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

18+

19+data ConstSep = ConstSep Integer Integer

20+ deriving (Eq, Show)

21+

22+makePrisms ''ConstSep

23+

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

25+ toIsoparsec = _ConstSep <.> (number >** biask chunk') &&& number

26+

27+spec :: Spec

28+spec = do

29+ let run (sep :: String) (s :: String) =

30+ runMegaparsecParser s . runReaderArrow sep $ (auto @ConstSep)

31+ it "deserializes" $ do

32+ run "s" "12s31" `shouldBe` Right (ConstSep 12 31)

33+ run " " "12 31" `shouldBe` Right (ConstSep 12 31)

34+ run "oh no" "12oh no31" `shouldBe` Right (ConstSep 12 31)

35+ run "oh no" "12oh no 31" `shouldSatisfy` isLeft

36+ run "oh no" "12ohno31" `shouldSatisfy` isLeft

37+ run "&" "12 31" `shouldSatisfy` isLeft

38+ run "&" "12&31" `shouldBe` Right (ConstSep 12 31)

test/Spec/Helper.hs+50−16

@@ -1,12 +1,8 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE TypeApplications #-}

5−{-# LANGUAGE TypeFamilies #-}

6−

71module Spec.Helper

82 ( shouldParseBS,

93 roundtrip,

4+ parseSatisfyBS,

5+ shouldParseS,

106 )

117where

128

@@ -23,46 +19,84 @@ import Test.Tasty.QuickCheck

2319import Text.Megaparsec as M

2420import Prelude as P hiding ((.))

2521

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+

2647shouldParse ::

2748 forall x s.

28− ( ToIsoparsec x s,

49+ ( ToIsoparsec x s (MegaparsecParser s),

2950 Stream s,

3051 Show x,

3152 Eq x,

32− Isoparsec (Kleisli (Parsec Void s)) s

53+ Isoparsec (MegaparsecParser s) s

3354 ) =>

3455 s ->

3556 x ->

3657 Expectation

37−shouldParse s e = case runMegaparsec @Void @s toIsoparsec s of

58+shouldParse s e = case runMegaparsecParser @s s toIsoparsec of

3859 Right e' -> e' `shouldBe` e

3960 Left err -> expectationFailure $ errorBundlePretty err

4061

4162shouldParseBS ::

4263 forall x.

43− ( ToIsoparsec x ByteString,

64+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

4465 Show x,

4566 Eq x,

46− Isoparsec (Kleisli (Parsec Void ByteString)) ByteString

67+ Isoparsec (MegaparsecParser ByteString) ByteString

4768 ) =>

4869 ByteString ->

4970 x ->

5071 Expectation

5172shouldParseBS = shouldParse

5273

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+

5386roundtrip ::

5487 forall x s.

55− ( ToIsoparsec x s,

88+ ( ToIsoparsec x s (MegaparsecParser s),

89+ ToIsoparsec x s (MonoidPrinter s),

5690 Stream s,

5791 Show s,

58− I.Token s ~ M.Token s,

92+ I.Element s ~ M.Token s,

5993 Eq x,

60− Isoparsec (Kleisli (Parsec Void s)) s

94+ Isoparsec (MegaparsecParser s) s

6195 ) =>

6296 x ->

6397 Property

6498roundtrip x =

65− let s = fromJust $ runPrinter @Maybe @s toIsoparsec x

66− in counterexample (show s) $ case runMegaparsec @Void @s toIsoparsec s of

99+ let s = fromJust $ runMonoidPrinter @s toIsoparsec x

100+ in counterexample (show s) $ case runMegaparsecParser @s s toIsoparsec of

67101 Right y -> property $ x == y

68102 Left err -> counterexample (errorBundlePretty err) False

test/Spec/JSON.hs+28−39

@@ -1,28 +1,20 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE ExistentialQuantification #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE FunctionalDependencies #-}

7−{-# LANGUAGE PolyKinds #-}

81{-# LANGUAGE TemplateHaskell #-}

9−{-# LANGUAGE TypeApplications #-}

10−{-# LANGUAGE TypeFamilies #-}

11−{-# LANGUAGE TypeOperators #-}

122

133module Spec.JSON

144 ( quickSpec,

5+ spec,

156 )

167where

178

189import Control.Arrow.Extra

10+import Control.Lens.TH

1911import Data.Isoparsec

2012import Data.Isoparsec.Char

2113import Data.Isoparsec.Megaparsec

2214import Data.Isoparsec.Printer

2315import Data.Maybe

24−import Data.Void

25−import Optics hiding (elements)

16+import Spec.Helper

17+import Test.Hspec

2618import Test.Tasty

2719import Test.Tasty.QuickCheck

2820import Text.Megaparsec.Error

@@ -36,7 +28,6 @@ data JSON

3628 deriving (Show, Eq)

3729

3830instance Arbitrary JSON where

39−

4031 arbitrary =

4132 oneof

4233 [ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),

@@ -52,48 +43,46 @@ instance Arbitrary JSON where

5243

5344makePrisms ''JSON

5445

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+

5555quickSpec :: TestTree

5656quickSpec =

5757 testProperty "roundtrips" $ \x ->

58− let s = fromJust $ runPrinter @Maybe @String json x

59− in counterexample s $ case runMegaparsec @Void json s of

58+ let s = fromJust $ runMonoidPrinter @String json x

59+ in counterexample s $ case runMegaparsecParser s json of

6060 Right y -> property $ x == y

6161 Left err -> counterexample (errorBundlePretty err) False

6262

63−json :: (PolyArrow m SemiIso', Isoparsec m String) => m () JSON

64−json = si' Just Just ^<< (try string <+> try array <+> try integer <+> object)

63+instance ToIsoparsec JSON String a where

64+ toIsoparsec = json

65+

66+json :: forall m. Isoparsec m String => m () JSON

67+json = string <+> array <+> integer <+> object

6568 where

66− string' = token '"' &&& tokensWhile (/= '"') &&& token '"'

69+ string' = token '"' **> tokensWhile (/= '"') >** token '"'

6770 string = _JString <.> string'

6871 array =

6972 _Array

7073 <.> token '['

7174 &&& unsafeWhiteSpace

72− &&& ( try

73− ( ( ( json &&& unsafeWhiteSpace

74− &&& try

75− ( repeating

76− ( (token ',' &&& unsafeWhiteSpace &&& json) >>% morphed

77− )

78− )

79− <+> konst []

80− )

81− >>% morphed

82− )

83− >>^ cons'

84− )

85− <+> konst []

86− )

75+ &&& sepByComma json

8776 &&& unsafeWhiteSpace

8877 &&& token ']'

8978 integer = _JInteger <.> number

9079 object =

9180 _Object <.> token '{' &&& unsafeWhiteSpace

92− &&& ( try

93− ( let pair = (unsafeWhiteSpace &&& string' &&& unsafeWhiteSpace &&& token ':' &&& unsafeWhiteSpace &&& json &&& unsafeWhiteSpace) >>% morphed

94− in (pair &&& try (repeating ((token ',' &&& unsafeWhiteSpace &&& pair) >>% morphed) <+> konst [])) >>^ cons'

95− )

96− <+> konst []

97− )

81+ &&& sepByComma pair

9882 &&& unsafeWhiteSpace

9983 &&& token '}'

84+ pair =

85+ (unsafeWhiteSpace **> string' >** unsafeWhiteSpace >** token ':' >** unsafeWhiteSpace)

86+ &&& (json >** unsafeWhiteSpace)

87+ sepByComma :: Eq a => m () a -> m () [a]

88+ sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)

test/Spec/JSONHList.hsnew file+92

@@ -0,0 +1,92 @@

1+{-# LANGUAGE TemplateHaskell #-}

3+module Spec.JSONHList

4+ ( quickSpec,

5+ spec,

6+ )

7+where

9+import Control.Arrow.Extra

10+import Control.Lens.TH

11+import Data.Isoparsec

12+import Data.Isoparsec.Char

13+import Data.Isoparsec.Megaparsec

14+import Data.Isoparsec.Printer

15+import Data.Maybe

16+import Spec.Helper

17+import Test.Hspec

18+import Test.Tasty

19+import Test.Tasty.QuickCheck

20+import Text.Megaparsec.Error

21+import Prelude hiding ((.))

22+

23+data JSON

24+ = Object [(String, JSON)]

25+ | JString String

26+ | Array [JSON]

27+ | JInteger Integer

28+ deriving (Show, Eq)

29+

30+instance Arbitrary JSON where

31+ arbitrary =

32+ oneof

33+ [ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),

34+ JString <$> listOf (elements ['.' .. 'z']),

35+ Array <$> listOf (scale (`div` 2) arbitrary),

36+ JInteger <$> arbitrary

37+ ]

38+

39+ shrink (Object a) = Object <$> shrink a

40+ shrink (JString a) = JString <$> shrink a

41+ shrink (Array a) = Array <$> shrink a

42+ shrink (JInteger a) = JInteger <$> shrink a

43+

44+makePrisms ''JSON

45+

46+spec :: Spec

47+spec =

48+ it "deserializes" $ do

49+ "{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]

50+ "{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]

51+ "{}" `shouldParseS` Object []

52+ "[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]

53+ "[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]

54+

55+quickSpec :: TestTree

56+quickSpec =

57+ testProperty "roundtrips" $ \x ->

58+ let s = fromJust $ runMonoidPrinter @String json x

59+ in counterexample s $ case runMegaparsecParser s json of

60+ Right y -> property $ x == y

61+ Left err -> counterexample (errorBundlePretty err) False

62+

63+instance ToIsoparsec JSON String a where

64+ toIsoparsec = json

65+

66+json :: forall m. Isoparsec m String => m () JSON

67+json = delist $ string ~| array ~| integer ~| object

68+ where

69+ string' :: Listed m () String

70+ string' = token '"' ~> tokensWhile (/= '"') ~> token '"'

71+ string :: Listed m () JSON

72+ string = string' ~$> _JString

73+ array :: Listed m () JSON

74+ array =

75+ token '['

76+ ~> unsafeWhiteSpace

77+ ~> sepByComma json

78+ ~> unsafeWhiteSpace

79+ ~> token ']'

80+ ~$> _Array

81+ integer = number ~$> _JInteger

82+ object =

83+ token '{' ~> unsafeWhiteSpace

84+ ~> hmap sepByComma pair

85+ ~> unsafeWhiteSpace

86+ ~> token '}'

87+ ~$> _Object

88+ pair =

89+ unsafeWhiteSpace ~> string' ~> unsafeWhiteSpace ~> token ':' ~> unsafeWhiteSpace

90+ ~& json ~> unsafeWhiteSpace

91+ sepByComma :: Eq a => m () a -> m () [a]

92+ sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)

test/Spec/Megaparsec/BasicNums.hs+8−14

@@ -1,9 +1,4 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE FlexibleContexts #-}

3−{-# LANGUAGE RankNTypes #-}

41{-# LANGUAGE TemplateHaskell #-}

5−{-# LANGUAGE TypeApplications #-}

6−{-# LANGUAGE TypeFamilies #-}

83module Spec.Megaparsec.BasicNums

94 ( spec,

@@ -11,14 +6,13 @@ module Spec.Megaparsec.BasicNums

116 )

127where

138

9+import Control.Lens.TH

1410import Data.Either

1511import Data.Isoparsec

1612import Data.Isoparsec.Char

1713import Data.Isoparsec.Megaparsec

1814import Data.Isoparsec.Printer

1915import Data.Maybe

20−import Data.Void

21−import Optics

2216import Test.Hspec

2317import Test.Tasty

2418import Test.Tasty.QuickCheck

@@ -33,19 +27,19 @@ instance Arbitrary Foo where

3327

3428makePrisms ''Foo

3529

36−parser :: (Isoparsec m s, Token s ~ Char, IsoparsecLabel m String) => m () Foo

37−parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number <?> "oh no")

30+parser :: (Isoparsec m String) => m () Foo

31+parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number)

3832

3933spec :: Spec

4034spec =

4135 it "deserializes" $ do

42− runMegaparsec @() parser "12 31" `shouldBe` (Right $ Foo 12 31)

43− runMegaparsec @() parser "1 33" `shouldBe` (Right $ Foo 1 33)

44− runMegaparsec @() parser "1562" `shouldSatisfy` isLeft

36+ runMegaparsecParser "12 31" parser `shouldBe` Right (Foo 12 31)

37+ runMegaparsecParser "1 33" parser `shouldBe` Right (Foo 1 33)

38+ runMegaparsecParser "1562" parser `shouldSatisfy` isLeft

4539

4640quickSpec :: TestTree

4741quickSpec = testProperty "roundtrips" $ \x ->

48− let s = fromJust $ runPrinter @Maybe @String parser x

49− in counterexample s $ case runMegaparsec @Void parser s of

42+ let s = fromJust $ runMonoidPrinter @String parser x

43+ in counterexample s $ case runMegaparsecParser s parser of

5044 Right y -> property $ x == y

5145 Left err -> counterexample (errorBundlePretty err) False

test/Spec/Orphans.hs+3−12

@@ -1,12 +1,3 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE ExistentialQuantification #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StandaloneDeriving #-}

7−{-# LANGUAGE TypeApplications #-}

8−{-# LANGUAGE TypeFamilies #-}

9−{-# LANGUAGE UndecidableInstances #-}

101{-# OPTIONS_GHC -Wno-orphans #-}

112

123module Spec.Orphans

@@ -24,13 +15,13 @@ import Test.Tasty.QuickCheck

2415import Prelude hiding ((.))

2516

2617instance

27− (CmpNat n 0 ~ 'GT, KnownNat n, Arbitrary (Token s), Tokenable s) =>

18+ (CmpNat n 0 ~ 'GT, KnownNat n, Arbitrary (Element s), IsSequence s) =>

2819 Arbitrary (Chunk n s)

2920 where

30− arbitrary = Chunk . liftTokens <$> vectorOf (fromIntegral $ natVal @n Proxy) arbitrary

21+ arbitrary = Chunk . fromList <$> vectorOf (fromIntegral $ natVal @n Proxy) arbitrary

3122

3223instance Arbitrary ByteString where

33− arbitrary = liftTokens <$> listOf arbitrary

24+ arbitrary = fromList <$> listOf arbitrary

3425

3526deriving instance Arbitrary (Byte16 e)

3627

test/Spec/Ssh.hs+47−67

@@ -1,18 +1,4 @@

1−{-# LANGUAGE BinaryLiterals #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE DataKinds #-}

4−{-# LANGUAGE DeriveGeneric #-}

5−{-# LANGUAGE DerivingStrategies #-}

6−{-# LANGUAGE FlexibleContexts #-}

7−{-# LANGUAGE FlexibleInstances #-}

8−{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9−{-# LANGUAGE MultiParamTypeClasses #-}

10−{-# LANGUAGE OverloadedStrings #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE StandaloneDeriving #-}

131{-# LANGUAGE TemplateHaskell #-}

14−{-# LANGUAGE TypeApplications #-}

15−{-# LANGUAGE TypeFamilies #-}

162

173module Spec.Ssh

184 ( spec,

@@ -20,13 +6,13 @@ module Spec.Ssh

206 )

217where

228

9+import Control.Lens.TH

2310import Data.ByteString as BS

2411import qualified Data.Char as C

12+import Data.Either

2513import Data.Isoparsec

2614import Data.Isoparsec.ByteString

27−import qualified Data.Word8 as W8

2815import GHC.Generics

29−import Optics

3016import Spec.Helper

3117import Spec.Orphans ()

3218import Test.Hspec

@@ -45,7 +31,7 @@ data MessageNumber

4531 | NewKeysMsg

4632 deriving (Eq, Show, Ord)

4733

48−instance ToIsoparsec MessageNumber ByteString where

34+instance ToIsoparsec MessageNumber ByteString a where

4935 toIsoparsec =

5036 anyToken

5137 >>> mapIso

@@ -63,18 +49,18 @@ newtype DisconnectReasonCode

6349 = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}

6450 deriving (Eq, Ord, Show, Generic, Arbitrary)

6551

66−instance ToIsoparsec DisconnectReasonCode ByteString

52+instance ToIsoparsec DisconnectReasonCode ByteString a

6753

6854newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}

6955 deriving (Eq, Ord, Show, Generic, Arbitrary)

7056

71−instance ToIsoparsec AlwaysDisplay ByteString

57+instance ToIsoparsec AlwaysDisplay ByteString a

7258

7359newtype PacketSequenceNumber

7460 = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}

7561 deriving (Eq, Ord, Show, Generic, Arbitrary)

7662

77−instance ToIsoparsec PacketSequenceNumber ByteString

63+instance ToIsoparsec PacketSequenceNumber ByteString a

7864

7965data Payload

8066 = VersionPayload String

@@ -102,40 +88,33 @@ instance Arbitrary Payload where

10288

10389makePrisms ''Payload

10490

105−instance ToIsoparsec Payload ByteString where

91+instance ToIsoparsec Payload ByteString a where

10692 toIsoparsec =

107− try

108− ( _DisconnectPayload

109− <.> specific DisconnectMsg

110− &&& auto @DisconnectReasonCode

111− &&& (tokensWhile (const True) >>> ftu8)

112− )

113− <+> try

114− ( _ServiceRequest <.> specific ServiceRequestMsg

115− &&& auto @SSHString

116− )

117− <+> try

118− ( _VersionPayload <.> utf8 "SSH-2.0-"

119− &&& ( ( try (takeUntil "\r\n" >>> check (BS.all (not . W8.isSpace)))

120− <+> ((takeUntil " " &&& (takeUntil "\r\n" >>> badTsnok "")) >>% morphed)

93+ ( _DisconnectPayload

94+ <.> specific DisconnectMsg

95+ &&& auto @DisconnectReasonCode

96+ &&& (tokensWhile (const True) >>^ utf8)

97+ )

98+ <+> ( _ServiceRequest <.> specific ServiceRequestMsg

99+ &&& auto @SSHString

100+ )

101+ <+> ( _VersionPayload <.> chunk "SSH-2.0-"

102+ &&& (tokensWhile (`BS.notElem` " \n\r") >>^ utf8)

103+ &&& ( (chunk " " >>> takeUntil "\r\n" >>^ (maskr . turn . konst $ ""))

104+ <+> chunk "\r\n"

121105 )

122− >>> ftu8

123− )

124− )

125− <+> try (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))

126− <+> try

127− ( _DebugPayload <.> specific DebugMsg

128− &&& auto @AlwaysDisplay

129− &&& auto @SSHString

130− )

131− <+> try

132− ( _UnimplementedPayload <.> specific UnimplementedMsg

133− &&& auto @PacketSequenceNumber

134− )

135− <+> try

136− ( _ServiceAccept <.> specific ServiceAcceptMsg

137− &&& auto @SSHString

138− )

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+ )

139118

140119newtype Padding = Padding {unPadding :: ByteString}

141120 deriving (Eq, Ord, Show, Generic, Arbitrary)

@@ -146,8 +125,8 @@ newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}

146125badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding

147126badZeroPadding =

148127 throughIntegral

149− >>> manyTokens

150− >>^ siJust

128+ ^>> manyTokens

129+ >>^ siPure

151130 (ZeroPadding . fromIntegral . BS.length)

152131 (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)

153132

@@ -157,8 +136,8 @@ newtype MAC = MAC {unMAC :: ByteString}

157136data NoneMAC = NoneMAC

158137 deriving (Eq, Ord, Show, Generic)

159138

160−instance ToIsoparsec NoneMAC b where

161− toIsoparsec = konst NoneMAC

139+instance ToIsoparsec NoneMAC b a where

140+ toIsoparsec = arr $ konst NoneMAC

162141

163142instance Arbitrary NoneMAC where

164143 arbitrary = return NoneMAC

@@ -172,25 +151,26 @@ instance Arbitrary mac => Arbitrary (Packet mac) where

172151

173152makePrisms ''Packet

174153

175−instance ToIsoparsec mac ByteString => ToIsoparsec (Packet mac) ByteString where

154+instance ToIsoparsec mac ByteString a => ToIsoparsec (Packet mac) ByteString a where

176155 toIsoparsec =

177− ( ( (auto @(Byte32 'BE) &&& auto @Byte8)

178− >>> (throughIntegral *** throughIntegral)

179− >>> siJust

180− (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))

181− (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))

182− ^>> (manyTokens *** throughIntegral)

183− >>> (tuck (auto @Payload) *** badZeroPadding)

184− )

185− &&& auto @mac

156+ ( auto @(Byte32 'BE) &&& anyToken

157+ >>^ throughIntegral *** throughIntegral

158+ >>^ siPure

159+ (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))

160+ (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))

161+ >>> manyTokens *** arr throughIntegral

162+ >>> tuck (auto @Payload) *** badZeroPadding

186163 )

187− >>^ siJust (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))

164+ &&& auto @mac

165+ >>^ siPure (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))

188166

189167spec :: Spec

190168spec = do

191169 it "deserialize payload" $ do

192170 "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"

171+ "SSH-2.0-TesT" `parseSatisfyBS` isLeft @_ @Payload

193172 "SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"

173+ "SSH-2.0-TesT random comment" `parseSatisfyBS` isLeft @_ @Payload

194174 "\x2__" `shouldParseBS` IgnorePayload "__"

195175 "\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")

196176 it "deserialize packet" $ do

test/Spec/SshHList.hsnew file+192

@@ -0,0 +1,192 @@

1+{-# LANGUAGE TemplateHaskell #-}

3+module Spec.SshHList

4+ ( spec,

5+ quickSpec,

6+ )

7+where

9+import Control.Lens.TH

10+import Data.ByteString as BS

11+import qualified Data.Char as C

12+import Data.Either

13+import Data.Isoparsec

14+import Data.Isoparsec.ByteString

15+import Data.Word

16+import GHC.Generics

17+import Numeric.Natural

18+import Spec.Helper

19+import Spec.Orphans ()

20+import Test.Hspec

21+import Test.Tasty

22+import Test.Tasty.QuickCheck

23+import Prelude as P hiding ((.), id)

24+

25+data MessageNumber

26+ = DisconnectMsg

27+ | IgnoreMsg

28+ | UnimplementedMsg

29+ | DebugMsg

30+ | ServiceRequestMsg

31+ | ServiceAcceptMsg

32+ | KextInitMsg

33+ | NewKeysMsg

34+ deriving (Eq, Show, Ord)

35+

36+instance ToIsoparsec MessageNumber ByteString a where

37+ toIsoparsec =

38+ delist $

39+ anyToken

40+ ~> mapIso

41+ [ (1 :: Word8, DisconnectMsg),

42+ (2, IgnoreMsg),

43+ (3, UnimplementedMsg),

44+ (4, DebugMsg),

45+ (5, ServiceRequestMsg),

46+ (6, ServiceAcceptMsg),

47+ (20, KextInitMsg),

48+ (21, NewKeysMsg)

49+ ]

50+

51+newtype DisconnectReasonCode

52+ = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}

53+ deriving (Eq, Ord, Show, Generic, Arbitrary)

54+

55+instance ToIsoparsec DisconnectReasonCode ByteString a

56+

57+newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}

58+ deriving (Eq, Ord, Show, Generic, Arbitrary)

59+

60+instance ToIsoparsec AlwaysDisplay ByteString a

61+

62+newtype PacketSequenceNumber

63+ = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}

64+ deriving (Eq, Ord, Show, Generic, Arbitrary)

65+

66+instance ToIsoparsec PacketSequenceNumber ByteString a

67+

68+data Payload

69+ = VersionPayload String

70+ | IgnorePayload ByteString

71+ | ServiceRequest SSHString

72+ | DebugPayload AlwaysDisplay SSHString

73+ | DisconnectPayload DisconnectReasonCode String

74+ | ServiceAccept SSHString

75+ | UnimplementedPayload PacketSequenceNumber

76+ deriving (Show, Eq)

77+

78+instance Arbitrary Payload where

79+ arbitrary =

80+ oneof

81+ [ VersionPayload . P.filter (not . C.isSpace) <$> s,

82+ IgnorePayload <$> arbitrary,

83+ ServiceRequest . SSHString <$> s,

84+ DebugPayload <$> arbitrary <*> (SSHString <$> s),

85+ DisconnectPayload <$> arbitrary <*> s,

86+ ServiceAccept . SSHString <$> s,

87+ UnimplementedPayload <$> arbitrary

88+ ]

89+ where

90+ s = getASCIIString <$> arbitrary

91+

92+makePrisms ''Payload

93+

94+instance ToIsoparsec Payload ByteString a where

95+ toIsoparsec =

96+ delist $

97+ specific DisconnectMsg ~> auto @DisconnectReasonCode

98+ ~& tokensWhile (const True)

99+ ~>^ utf8

100+ ~$> _DisconnectPayload

101+ ~| specific ServiceRequestMsg ~> auto @SSHString ~$> _ServiceRequest

102+ ~| chunk "SSH-2.0-"

103+ ~> tokensWhile (`BS.notElem` " \n\r")

104+ ~>^ utf8

105+ ~> ( chunk " " ~> takeUntil "\r\n" ~>^ (maskr . turn . konst $ ("" :: ByteString))

106+ ~| chunk "\r\n"

107+ )

108+ ~$> _VersionPayload

109+ ~| specific IgnoreMsg ~> tokensWhile (const True) ~$> _IgnorePayload

110+ ~| specific DebugMsg ~> auto @AlwaysDisplay

111+ ~& auto @SSHString

112+ ~$> _DebugPayload

113+ ~| specific UnimplementedMsg ~> auto @PacketSequenceNumber ~$> _UnimplementedPayload

114+ ~| specific ServiceAcceptMsg ~> auto @SSHString ~$> _ServiceAccept

115+

116+newtype Padding = Padding {unPadding :: ByteString}

117+ deriving (Eq, Ord, Show, Generic, Arbitrary)

118+

119+newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}

120+ deriving (Eq, Ord, Show, Generic, Arbitrary)

121+

122+badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding

123+badZeroPadding =

124+ delist $

125+ throughIntegral

126+ ^~> manyTokens

127+ ~>^ siPure

128+ (ZeroPadding . fromIntegral . BS.length)

129+ (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)

130+

131+newtype MAC = MAC {unMAC :: ByteString}

132+ deriving (Eq, Ord, Show, Generic, Arbitrary)

133+

134+data NoneMAC = NoneMAC

135+ deriving (Eq, Ord, Show, Generic)

136+

137+instance ToIsoparsec NoneMAC b a where

138+ toIsoparsec = arr $ konst NoneMAC

139+

140+instance Arbitrary NoneMAC where

141+ arbitrary = return NoneMAC

142+

143+data Packet mac

144+ = Packet Payload ZeroPadding mac

145+ deriving (Eq, Show)

146+

147+instance Arbitrary mac => Arbitrary (Packet mac) where

148+ arbitrary = Packet <$> arbitrary <*> arbitrary <*> arbitrary

149+

150+makePrisms ''Packet

151+

152+instance ToIsoparsec (Packet NoneMAC) ByteString a where

153+ toIsoparsec =

154+ delist $

155+ ( ( (auto @(Byte32 'BE) ~* anyToken)

156+ ~> (arr (throughIntegral @(Byte32 'BE) @Natural) ~* arr (throughIntegral @Byte8 @Natural))

157+ ~>^ siPure

158+ (\(packetL, paddingL :: Natural) -> (packetL - paddingL - 1 :: Natural, paddingL :: Natural))

159+ (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))

160+ ~> (manyTokens ~* arr (throughIntegral @Natural @Byte8))

161+ ~> (tuck (auto @Payload) ~* badZeroPadding)

162+ )

163+ ~& auto @NoneMAC

164+ )

165+ ~$> _Packet

166+

167+spec :: Spec

168+spec = do

169+ it "deserialize payload" $ do

170+ "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"

171+ "SSH-2.0-TesT" `parseSatisfyBS` isLeft @_ @Payload

172+ "SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"

173+ "SSH-2.0-TesT random comment" `parseSatisfyBS` isLeft @_ @Payload

174+ "\x2__" `shouldParseBS` IgnorePayload "__"

175+ "\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")

176+ it "deserialize packet" $ do

177+ ("\0\0\0\xd" <> "\x2" <> "\x5\0\0\0\x5henlo" <> "69")

178+ `shouldParseBS` Packet (ServiceRequest (SSHString "henlo")) (ZeroPadding 2) NoneMAC

179+ ("\0\0\0\xd" <> "\x2" <> "\x2\0\0\0\x5henlo" <> "69")

180+ `shouldParseBS` Packet (IgnorePayload "\0\0\0\x5henlo") (ZeroPadding 2) NoneMAC

181+ ("\0\0\0\xd" <> "\x3" <> "\x2\0\0henlo!" <> "69a")

182+ `shouldParseBS` Packet (IgnorePayload "\0\0henlo!") (ZeroPadding 3) NoneMAC

183+ ("\0\0\0\xb" <> "\x3" <> "\x2henlo!" <> "69a")

184+ `shouldParseBS` Packet (IgnorePayload "henlo!") (ZeroPadding 3) NoneMAC

185+

186+quickSpec :: TestTree

187+quickSpec =

188+ testGroup

189+ "roundtrips"

190+ [ testProperty "payload" $ roundtrip @Payload @ByteString,

191+ testProperty "packet" $ roundtrip @(Packet NoneMAC) @ByteString

192+ ]

test/Spec/TwoDigits.hs+16−27

@@ -1,13 +1,3 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE DeriveGeneric #-}

3−{-# LANGUAGE DerivingVia #-}

4−{-# LANGUAGE FlexibleContexts #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE MultiParamTypeClasses #-}

7−{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TypeApplications #-}

9−{-# LANGUAGE TypeFamilies #-}

10−

111module Spec.TwoDigits

122 ( spec,

133 quickSpec,

@@ -21,7 +11,6 @@ import Data.Isoparsec.Chunks

2111import Data.Isoparsec.Megaparsec

2212import Data.Isoparsec.Printer

2313import Data.Maybe

24−import Data.Void

2514import GHC.Generics

2615import Test.Hspec

2716import Test.Tasty

@@ -32,14 +21,14 @@ import Prelude hiding ((.))

3221newtype SingleDigit = SingleDigit {unSingleDigit :: String}

3322 deriving (Eq, Show, Generic)

3423

35−instance ToIsoparsec SingleDigit String where

24+instance ToIsoparsec SingleDigit String m where

3625 toIsoparsec =

3726 toIsoparsec @(Chunk 1 String)

38− >>> coercing

39− >>> check (all @[] isDigit)

40− >>> coercing

27+ >>^ coercing

28+ >>^ check (all @[] isDigit)

29+ >>^ coercing

4130

42−instance (Arbitrary SingleDigit) where

31+instance Arbitrary SingleDigit where

4332 arbitrary = SingleDigit . pure <$> elements ['0' .. '9']

4433

4534data Digits

@@ -56,24 +45,24 @@ instance Arbitrary Digits where

5645 TwoDigits <$> arbitrary <*> arbitrary

5746 ]

5847

59−instance ToIsoparsec Digits String

48+instance ToIsoparsec Digits String m

6049

6150spec :: Spec

6251spec = do

63− let parser = toIsoparsec

52+ let parser = toIsoparsec @_ @String

6453 it "deserializes" $ do

65− runMegaparsec @() parser "12" `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))

66− runMegaparsec @() parser "125" `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))

67− runMegaparsec @() parser "1253" `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))

68− runMegaparsec @() parser "12538" `shouldSatisfy` isLeft

69− runMegaparsec @() parser "2" `shouldSatisfy` isLeft

70− runMegaparsec @() parser "a" `shouldSatisfy` isLeft

71− runMegaparsec @() parser "1a" `shouldSatisfy` isLeft

54+ runMegaparsecParser "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))

55+ runMegaparsecParser "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))

56+ runMegaparsecParser "1253" parser `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))

57+ runMegaparsecParser "12538" parser `shouldSatisfy` isLeft

58+ runMegaparsecParser "2" parser `shouldSatisfy` isLeft

59+ runMegaparsecParser "a" parser `shouldSatisfy` isLeft

60+ runMegaparsecParser "1a" parser `shouldSatisfy` isLeft

7261

7362quickSpec :: TestTree

7463quickSpec = testProperty "roundtrips" $ \x ->

75− let s = fromJust $ runPrinter @Maybe @String parser x

76− in counterexample s $ case runMegaparsec @Void parser s of

64+ let s = fromJust $ runMonoidPrinter @String parser x

65+ in counterexample s $ case runMegaparsecParser s parser of

7766 Right y -> property $ x == y

7867 Left err -> counterexample (errorBundlePretty err) False

7968 where