fe34b95...master · isoparsec

git.iko.soy/isoparsec

43 files changed+3076−33

since splitsnapshots

unifiedsplit

.github/workflows/haskell.yml+17−5 .hlint.yaml+191 .vscode/tasks.json+50 .weeder.yaml+1 README.md+6−1 app/Main.hs−6 hie.yaml+4 package.yaml+45−12 random-notes.md+5 src/Control/Arrow/Extra.hs+32 src/Control/Arrow/Extra/ArrowChoice.hs+25 src/Control/Arrow/Extra/ArrowPlus.hs+11 src/Control/Arrow/Extra/ArrowZero.hs+9 src/Control/Arrow/Extra/BaseArrow.hs+37 src/Control/Arrow/Extra/Orphans.hs+36 src/Control/Arrow/Extra/PolyArrow.hs+39 src/Control/Arrow/Reader.hs+34 src/Control/Arrow/Trans/Class.hs+9 src/Control/Arrow/Trans/Reader.hs+53 src/Control/Cokleisli.hs+52 src/Control/Prism.hs+40 src/Control/SemiIso.hs+206 src/Control/Tuple/Morph.hs+486 src/Data/Isoparsec.hs+300 src/Data/Isoparsec/ByteString.hs+92 src/Data/Isoparsec/Char.hs+26 src/Data/Isoparsec/Chunks.hs+15 src/Data/Isoparsec/Internal.hs+130 src/Data/Isoparsec/Megaparsec.hs+88 src/Data/Isoparsec/Printer.hs+83 src/Data/Isoparsec/ToIsoparsec.hs+44 src/Lib.hs−6 stack.yaml+4−2 test/Spec.hs+57−1 test/Spec/BasicReader.hs+38 test/Spec/Helper.hs+102 test/Spec/JSON.hs+88 test/Spec/JSONHList.hs+92 test/Spec/Megaparsec/BasicNums.hs+45 test/Spec/Orphans.hs+30 test/Spec/Ssh.hs+192 test/Spec/SshHList.hs+192 test/Spec/TwoDigits.hs+70

.github/workflows/haskell.yml+17−5

@@ -1,22 +1,34 @@

11name: Haskell CI

3−on: [push, pull_request]

3+on: [push]

55jobs:

66 build:

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

12− - name: Install Stack

13− run: |

14− wget -qO- https://get.haskellstack.org/ | sh

16+

17+ - name: Cache

18+ uses: actions/cache@v1

19+ with:

20+ path: ~/.stack

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

1522

1623 - name: Build

1724 run: |

18− stack build --fast --pedantic --ghc-options '-j'

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

26+

27+ - name: Test

28+ run: |

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

1930

2031 - name: Weeder

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

2133 run: |

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

.hlint.yamlnew file+191

@@ -0,0 +1,191 @@

1+# HLint configuration file

2+# https://github.com/ndmitchell/hlint

3+##########################

5+# This file contains a template configuration file, which is typically

6+# placed as .hlint.yaml in the root of your project

9+# Specify additional command line arguments

10+#

11+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]

12+

13+

14+# Control which extensions/flags/modules/functions can be used

15+#

16+# - extensions:

17+# - default: false # all extension are banned by default

18+# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used

19+# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module

20+#

21+# - flags:

22+# - {name: -w, within: []} # -w is allowed nowhere

23+#

24+# - modules:

25+# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'

26+# - {name: Control.Arrow, within: []} # Certain modules are banned entirely

27+#

28+# - functions:

29+# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules

30+

31+

32+# Add custom hints for this project

33+#

34+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"

35+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}

36+

37+

38+# Turn on hints that are off by default

39+#

40+# Ban "module X(module X) where", to require a real export list

41+# - warn: {name: Use explicit module export list}

42+#

43+# Replace a $ b $ c with a . b $ c

44+# - group: {name: dollar, enabled: true}

45+#

46+# Generalise map to fmap, ++ to <>

47+# - group: {name: generalise, enabled: true}

48+

49+

50+# Ignore some builtin hints

51+# - ignore: {name: Use let}

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

53+

54+

55+# Define some custom fixity operators

56+# - fixity: infixr 3 ~^#^~

57+

58+

59+# To generate a suitable file for HLint do:

60+# $ hlint --default > .hlint.yaml

61+

62+- 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"}

.vscode/tasks.jsonnew file+50

@@ -0,0 +1,50 @@

1+{

2+ // See https://go.microsoft.com/fwlink/?LinkId=733558

3+ // for the documentation about the tasks.json format

4+ "version": "2.0.0",

5+ "tasks": [

6+ {

7+ "label": "Stack Build",

8+ "group": {

9+ "kind": "build",

10+ "isDefault": true

11+ },

12+ "type": "shell",

13+ "command": "stack build --fast --no-interleaved-output",

14+ "problemMatcher": {

15+ "owner": "haskell",

16+ "fileLocation": [

17+ "absolute"

18+ ],

19+ "pattern": [

20+ {

21+ "regexp": "^(\\S+\\s+>\\s*)?\\s*(\\S+):(\\d+):(\\d+): (warning|error|info):.*$",

22+ "file": 2,

23+ "line": 3,

24+ "column": 4,

25+ "severity": 5

26+ },

27+ {

28+ "regexp": "^(\\s+•\\s+| \\s*)([^\\d\\W].+)$",

29+ "message": 2

30+ }

31+ ]

32+ },

33+ "presentation": {

34+ "showReuseMessage": false,

35+ "focus": false

36+ }

37+ },

38+ {

39+ "label": "Stack Install",

40+ "type": "shell",

41+ "command": "stack install --fast",

42+ "dependsOn": "Stack Build",

43+ "problemMatcher": [],

44+ "presentation": {

45+ "showReuseMessage": false,

46+ "focus": false

47+ }

48+ }

49+ ]

50+}

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

@@ -1,6 +0,0 @@

1−module Main where

2−

3−import Lib

4−

5−main :: IO ()

6−main = someFunc

hie.yamlnew file+4

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

1+cradle:

2+ stack:

3+ - path: "."

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

package.yaml+45−12

@@ -21,28 +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−executables:

29− isoparsec-exe:

30− main: Main.hs

31− source-dirs: app

32− ghc-options:

33− - -threaded

34− - -rtsopts

35− - -with-rtsopts=-N

36− dependencies:

37− - isoparsec

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

3862

3963tests:

4064 isoparsec-test:

4165 main: Spec.hs

42− source-dirs: test

66+ source-dirs:

67+ - test

68+ - src

4369 ghc-options:

4470 - -threaded

4571 - -rtsopts

4672 - -with-rtsopts=-N

4773 dependencies:

48− - isoparsec

74+ - tasty

75+ - tasty-hspec

76+ - hspec

77+ - lens

78+ - tasty-quickcheck

79+ - QuickCheck

80+ - megaparsec

81+ - bytestring

random-notes.mdnew file+5

@@ -0,0 +1,5 @@

1+Implied `Isoparse m =>` everywhere

3+`m () a` -- parser produces an `a` out of thin air and printer consumes an `a`.

4+`m a ()` -- printer consumes an `a` and the printer produces an `a`.

5+`a -> m () ()` -- `a` is a global constant used by both the parser and the printer.

src/Control/Arrow/Extra.hsnew file+32

@@ -0,0 +1,32 @@

1+{-# LANGUAGE MonoLocalBinds #-}

3+module Control.Arrow.Extra

4+ ( module X,

5+ (<+^),

6+ (^+>),

7+ (^+^),

8+ )

9+where

10+

11+import Control.Arrow as X (Kleisli (..))

12+import Control.Arrow.Extra.ArrowChoice as X

13+import Control.Arrow.Extra.ArrowPlus as X

14+import Control.Arrow.Extra.ArrowZero as X

15+import Control.Arrow.Extra.BaseArrow as X

16+import Control.Arrow.Extra.PolyArrow as X

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

18+

19+infixl 5 <+^

20+

21+infixl 5 ^+>

22+

23+infixl 5 ^+^

24+

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

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

27+

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

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

30+

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

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

src/Control/Arrow/Extra/ArrowChoice.hsnew file+25

@@ -0,0 +1,25 @@

1+{-# LANGUAGE NoImplicitPrelude #-}

3+module Control.Arrow.Extra.ArrowChoice

4+ ( ArrowChoice (..),

5+ )

6+where

8+import Control.Arrow.Extra.BaseArrow

9+import Control.Category

10+import Data.Either

11+

12+infixl 2 +++

13+

14+infixl 2 |||

15+

16+class BaseArrow a => ArrowChoice a where

17+ left :: a b c -> a (Either b d) (Either c d)

18+ left = (+++ id)

19+

20+ right :: a b c -> a (Either d b) (Either d c)

21+ right = (id +++)

22+

23+ (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')

24+

25+ (|||) :: a b d -> a c d -> a (Either b c) d

src/Control/Arrow/Extra/ArrowPlus.hsnew file+11

@@ -0,0 +1,11 @@

1+module Control.Arrow.Extra.ArrowPlus

2+ ( ArrowPlus (..),

3+ )

4+where

6+import Control.Arrow.Extra.ArrowZero

8+infixl 5 <+>

10+class ArrowZero a => ArrowPlus a where

11+ (<+>) :: a b c -> a b c -> a b c

src/Control/Arrow/Extra/ArrowZero.hsnew file+9

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

1+module Control.Arrow.Extra.ArrowZero

2+ ( ArrowZero (..),

3+ )

4+where

6+import Control.Arrow.Extra.BaseArrow

8+class BaseArrow a => ArrowZero a where

9+ zeroArrow :: a b c

src/Control/Arrow/Extra/BaseArrow.hsnew file+37

@@ -0,0 +1,37 @@

1+{-# LANGUAGE NoImplicitPrelude #-}

3+module Control.Arrow.Extra.BaseArrow

4+ ( BaseArrow (..),

5+ (>>>),

6+ (<<<),

7+ )

8+where

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

11+

12+infixl 3 ***

13+

14+infixl 3 &&&

15+

16+class Category a => BaseArrow a where

17+ {-# MINIMAL (***), (&&&) #-}

18+

19+ first :: a b c -> a (b, d) (c, d)

20+ first = (*** id)

21+

22+ second :: a b c -> a (d, b) (d, c)

23+ second = (id ***)

24+

25+ (***) :: a b c -> a b' c' -> a (b, b') (c, c')

26+

27+ (&&&) :: 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.hsnew file+36

@@ -0,0 +1,36 @@

1+{-# OPTIONS_GHC -Wno-orphans #-}

3+module Control.Arrow.Extra.Orphans

4+ (

5+ )

6+where

8+import qualified Control.Arrow as A

9+import Control.Arrow.Extra

10+

11+instance {-# OVERLAPPABLE #-} A.ArrowZero a => ArrowZero a where

12+ zeroArrow = A.zeroArrow

13+

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

15+ left = A.left

16+

17+ right = A.right

18+

19+ (+++) = (A.+++)

20+

21+ (|||) = (A.|||)

22+

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

24+ first = A.first

25+

26+ second = A.second

27+

28+ (***) = (A.***)

29+

30+ (&&&) = (A.&&&)

31+

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

33+ arr = A.arr

34+

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

36+ (<+>) = (A.<+>)

src/Control/Arrow/Extra/PolyArrow.hsnew file+39

@@ -0,0 +1,39 @@

1+module Control.Arrow.Extra.PolyArrow

2+ ( PolyArrow (..),

3+ (^>>),

4+ (>>^),

5+ (<<^),

6+ (^<<),

7+ (^>^),

8+ (^<^),

9+ )

10+where

11+

12+import Control.Arrow.Extra.BaseArrow

13+

14+infixl 1 ^>>, >>^

15+

16+infixl 1 ^<<, <<^

17+

18+infixl 1 ^>^, ^<^

19+

20+class BaseArrow a => PolyArrow p a where

21+ arr :: p b c -> a b c

22+

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

24+f ^>> a = arr f >>> a

25+

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

27+a >>^ f = a >>> arr f

28+

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

30+a <<^ f = a <<< arr f

31+

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

33+f ^<< a = arr f <<< a

34+

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

36+a ^>^ b = arr a >>> arr b

37+

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

39+a ^<^ 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/Control/Cokleisli.hsnew file+52

@@ -0,0 +1,52 @@

1+module Control.Cokleisli

2+ ( Cokleisli (..),

3+ )

4+where

6+import Control.Applicative

7+import Control.Arrow.Extra

8+import Control.Monad

9+import Control.SemiIso

10+import Prelude hiding ((.))

11+

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

13+

14+instance Monad m => Category (Cokleisli m) where

15+ id = Cokleisli return

16+

17+ (Cokleisli cb) . (Cokleisli ba) = Cokleisli $ cb >=> ba

18+

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

20+ (Cokleisli cb) *** (Cokleisli c'b') = Cokleisli $

21+ \(c, c') -> do

22+ b' <- c'b' c'

23+ b <- cb c

24+ return (b, b')

25+

26+ (Cokleisli cb) &&& (Cokleisli c'b) = Cokleisli $

27+ \(c, c') -> c'b c' >> cb c

28+

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

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

31+

32+instance MonadPlus m => ArrowZero (Cokleisli m) where

33+ zeroArrow = Cokleisli $ const mzero

34+

35+instance MonadPlus m => ArrowPlus (Cokleisli m) where

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

37+

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

39+ left (Cokleisli cb) = Cokleisli $ \case

40+ Left c -> Left <$> cb c

41+ Right d -> return $ Right d

42+

43+ right (Cokleisli cb) = Cokleisli $ \case

44+ Left d -> return $ Left d

45+ Right c -> Right <$> cb c

46+

47+ (Cokleisli cb) +++ (Cokleisli c'b') = Cokleisli $ \case

48+ Left c -> Left <$> cb c

49+ Right c' -> Right <$> c'b' c'

50+

51+ (Cokleisli db) ||| (Cokleisli dc) = Cokleisli $ \d ->

52+ (Left <$> db d) <|> (Right <$> dc 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.hsnew file+486

@@ -0,0 +1,486 @@

1+{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-redundant-constraints #-}

3+module Control.Tuple.Morph

4+ ( morphTuples,

5+ morphReorderTuples,

6+ morphPickTuples,

7+ TupleMorphable,

8+ CheckListsForTupleIso,

9+ ReorderList,

10+ FlatMorphable (..),

11+ TupleHListContents,

12+ HListContentsTuple,

13+ Nat (..),

14+ HList (..),

15+ AppendableList (..),

16+ DroppableList (..),

17+ TakeableList (..),

18+ Length,

19+ Proxy (..),

20+ )

21+where

22+

23+import Data.Kind

24+import Data.Proxy

25+import Data.Type.Equality

26+import GHC.Generics

27+import GHC.TypeLits hiding (Nat)

28+

29+morphTuples :: (TupleMorphable a c, TupleMorphable b c) => a -> b

30+morphTuples = morph . unmorph

31+

32+morphPickTuples ::

33+ ( TupleMorphable a b,

34+ TupleMorphable c d,

35+ ReorderList b d

36+ ) =>

37+ a ->

38+ c

39+morphPickTuples = morph . hReorder Proxy . unmorph

40+

41+type CheckListsForTupleIso b d =

42+ EqOrError (Length b) (Length d)

43+ ( 'Text "Not isomorphic tuple contents:"

44+ ':$$: 'Text " " ':<>: 'ShowType b

45+ ':$$: 'Text " " ':<>: 'ShowType d

46+ )

47+

48+morphReorderTuples ::

49+ ( TupleMorphable a b,

50+ TupleMorphable c d,

51+ ReorderList b d,

52+ CheckListsForTupleIso b d

53+ ) =>

54+ a ->

55+ c

56+morphReorderTuples = morph . hReorder Proxy . unmorph

57+

58+type family EqOrError a b e :: Constraint where

59+ EqOrError a a _ = a ~ a

60+ EqOrError _ _ e = TypeError e

61+

62+-- # Nat

63+

64+data Nat where

65+ S :: Nat -> Nat

66+ Z :: Nat

67+

68+-- # HList

69+

70+data HList (ts :: [*]) where

71+ HCons :: t -> HList tt -> HList (t ': tt)

72+ HNil :: HList '[]

73+

74+infixl 5 :+

75+

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

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

78+

79+-- ## Taking

80+

81+class TakeableList (n :: Nat) aa bb | n aa -> bb where

82+ hTake :: Proxy n -> HList aa -> HList bb

83+

84+instance TakeableList 'Z a '[] where

85+ hTake _ _ = HNil

86+

87+instance

88+ (TakeableList n aa bb', bb ~ (a ': bb')) =>

89+ TakeableList ('S n) (a ': aa) bb

90+ where

91+ hTake (Proxy :: Proxy ('S n)) (a :+ aa) = a :+ hTake @n Proxy aa

92+

93+-- ## Dropping

94+

95+class DroppableList (n :: Nat) (aa :: [*]) (bb :: [*]) | n aa -> bb where

96+ hDrop :: Proxy n -> HList aa -> HList bb

97+

98+instance DroppableList 'Z aa aa where

99+ hDrop _ aa = aa

100+

101+instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where

102+ hDrop (Proxy :: Proxy ('S n)) (_ :+ aa) = hDrop @n Proxy aa

103+

104+-- ## Appending

105+

106+infixl 4 ++:

107+

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

116+

117+instance AppendableList '[] bb bb where

118+ HNil ++: bb = bb

119+

120+instance

121+ ( AppendableList aa bb cc,

122+ cc ~ (aa ++ bb),

123+ ((a ': aa) ++ bb) ~ (a ': cc)

124+ ) =>

125+ AppendableList (a ': aa) bb (a ': cc)

126+ where

127+ (a :+ aa) ++: bb = a :+ (aa ++: bb)

128+

129+-- ## Finding

130+

131+class FindableList ts t where

132+ hFind :: HList ts -> t

133+

134+instance

135+ {-# OVERLAPPING #-}

136+ (NotFindableList ts t) =>

137+ FindableList (t ': ts) t

138+ where

139+ hFind (t :+ _) = t

140+

141+instance

142+ (TEq a t ~ 'False, FindableList ts a) =>

143+ FindableList (t ': ts) a

144+ where

145+ hFind (_ :+ ts) = hFind ts

146+

147+instance

148+ ( TypeError

149+ ('Text "Could not find type " ':<>: 'ShowType a ':<>: 'Text " in tuple.")

150+ ) =>

151+ FindableList '[] a

152+ where

153+ hFind = error "oh no"

154+

155+class NotFindableList ts t

156+

157+instance

158+ {-# OVERLAPPING #-}

159+ ( TypeError

160+ ('Text "Type " ':<>: 'ShowType t ':<>: 'Text " is not unique in tuple.")

161+ ) =>

162+ NotFindableList (t ': ts) t

163+

164+instance (NotFindableList ts a) => NotFindableList (t ': ts) a

165+

166+instance NotFindableList '[] a

167+

168+class ReorderList as bs where

169+ hReorder :: Proxy bs -> HList as -> HList bs

170+

171+instance (FindableList as b, ReorderList as bs) => ReorderList as (b ': bs) where

172+ hReorder _ as = hFind as :+ hReorder (Proxy @bs) as

173+

174+instance ReorderList as '[] where

175+ hReorder _ _ = HNil

176+

177+type family TEq a b :: Bool where

178+ TEq a a = 'True

179+ TEq a b = 'False

180+

181+-- ## Other

182+

183+type family (++) (as :: [k]) (bs :: [k]) :: [k] where

184+ (++) '[] b = b

185+ (++) (a ': as) bs = a ': (as ++ bs)

186+

187+type family Length (aa :: [k]) :: Nat where

188+ Length '[] = 'Z

189+ Length (a ': aa) = 'S (Length aa)

190+

191+-- # Morphing

192+

193+class TupleMorphable t th | t -> th where

194+ unmorph :: t -> HList th

195+

196+ morph :: HList th -> t

197+

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

199+ unmorph = unmorph' (Proxy @flag)

200+

201+ morph = morph' (Proxy @flag)

202+

203+-- ## Implementation

204+

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

206+ unmorph' :: Proxy flag -> t -> HList th

207+

208+ morph' :: Proxy flag -> HList th -> t

209+

210+instance TupleMorphable' t '[t] 'False where

211+ unmorph' _ t = t :+ HNil

212+

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

214+

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

216+ unmorph' _ = genericUnmorph . from

217+

218+ morph' _ = to . genericMorph

219+

220+-- ### Generics

221+

222+class GenericTupleMorphable f th | f -> th where

223+ genericUnmorph :: f p -> HList th

224+

225+ genericMorph :: HList th -> f p

226+

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

228+ genericUnmorph = genericUnmorph . unM1

229+

230+ genericMorph = M1 . genericMorph

231+

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

233+ genericUnmorph = unmorph . unK1

234+

235+ genericMorph = K1 . morph

236+

237+instance GenericTupleMorphable U1 '[] where

238+ genericUnmorph _ = HNil

239+

240+ genericMorph _ = U1

241+

242+type CanTakeDrop a b c =

243+ ( TakeableList (Length a) c a,

244+ DroppableList (Length a) c b,

245+ c ~ (a ++ b)

246+ )

247+

248+instance

249+ ( GenericTupleMorphable f a,

250+ GenericTupleMorphable g b,

251+ AppendableList a b c,

252+ CanTakeDrop a b c

253+ ) =>

254+ GenericTupleMorphable (f :*: g) c

255+ where

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

257+

258+ genericMorph cc = genericMorph aa :*: genericMorph bb

259+ where

260+ aa = hTake @(Length a) Proxy cc

261+ bb = hDrop @(Length a) Proxy cc

262+

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+

290+-- ## Other

291+

292+type family IsMophableTuple t :: Bool where

293+ IsMophableTuple () = 'True

294+ IsMophableTuple (a, b) = 'True

295+ IsMophableTuple (a, b, c) = 'True

296+ IsMophableTuple (a, b, c, d) = 'True

297+ IsMophableTuple (a, b, c, d, e) = 'True

298+ IsMophableTuple (a, b, c, d, e, f) = 'True

299+ IsMophableTuple (a, b, c, d, e, f, g) = 'True

300+ IsMophableTuple (a, b, c, d, e, f, g, h) = 'True

301+ IsMophableTuple (a, b, c, d, e, f, g, h, i) = 'True

302+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j) = 'True

303+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k) = 'True

304+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l) = 'True

305+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m) = 'True

306+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = 'True

307+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = 'True

308+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = 'True

309+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = 'True

310+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = 'True

311+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = 'True

312+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = 'True

313+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = 'True

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

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

316+ 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) = 'True

317+ 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) = 'True

318+ 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) = 'True

319+ 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) = 'True

320+ 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) = 'True

321+ 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) = 'True

322+ 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) = 'True

323+ 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) = 'True

324+ 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) = 'True

325+ 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) = 'True

326+ 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) = 'True

327+ 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) = 'True

328+ 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) = 'True

329+ 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) = 'True

330+ 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) = 'True

331+ 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) = 'True

332+ 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) = 'True

333+ 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) = 'True

334+ 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) = 'True

335+ 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) = 'True

336+ 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) = 'True

337+ 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) = 'True

338+ 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) = 'True

339+ 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) = 'True

340+ 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) = 'True

341+ 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) = 'True

342+ 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) = 'True

343+ 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) = 'True

344+ 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) = 'True

345+ 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) = 'True

346+ 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) = 'True

347+ 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) = 'True

348+ 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) = 'True

349+ 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) = 'True

350+ 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) = 'True

351+ 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) = 'True

352+ 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) = 'True

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

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

355+ 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.hsnew file+300

@@ -0,0 +1,300 @@

1+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

3+module Data.Isoparsec

4+ ( module X,

5+ (<.>),

6+ repeating,

7+ sepBy,

8+ sepBy1,

9+ opt,

10+ opt',

11+ morphed,

12+ fMorphed,

13+ coercing,

14+ mapIso,

15+ auto,

16+ specific,

17+ throughIntegral,

18+ (~>),

19+ (~>^),

20+ (^~>),

21+ (^~>^),

22+ (~|),

23+ (~$>),

24+ (~&),

25+ (~*),

26+ siPrism,

27+ delist,

28+ enlist,

29+ Listed,

30+ hmap,

31+ )

32+where

33+

34+import Control.Arrow.Extra as X

35+import Control.Prism

36+import Control.Tuple.Morph

37+import Data.Coerce

38+import Data.Either

39+import Data.Isoparsec.Internal as X

40+import Data.Isoparsec.ToIsoparsec as X

41+import qualified Data.Map as M

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

43+

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

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

46+

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

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

49+

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

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

52+

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

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

55+

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

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

58+

59+infixl 0 <.>

60+

61+(<.>) ::

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

63+ (Prism' a b) ->

64+ m x' x ->

65+ m x' b

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

67+

68+siPrism ::

69+ (Prism' a b) ->

70+ SemiIso a b

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

72+

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

74+

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

76+

77+type family If cond t f where

78+ If 'True t _ = t

79+ If 'False _ f = f

80+

81+type family BothEmpty a b where

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

83+ BothEmpty _ _ = 'False

84+

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

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

87+ --

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

89+ (~>) ::

90+ ( PolyArrow SemiIso m,

91+ FlatMorphable a a' fa,

92+ FlatMorphable b b' fb,

93+ FlatMorphable c c' fc,

94+ FlatMorphable d d' fd

95+ ) =>

96+ m a b ->

97+ m c d ->

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

99+

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

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

102+

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

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

105+

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

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

108+

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

110+siHFst = siPure fst (,HNil)

111+

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

113+--

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

115+(~>^) ::

116+ ( PolyArrow SemiIso m,

117+ FlatMorphable a a' fa,

118+ FlatMorphable b bc fb,

119+ FlatMorphable c bc 'False,

120+ FlatMorphable d d' 'False

121+ ) =>

122+ m a b ->

123+ SemiIso c d ->

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

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

126+

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

128+--

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

130+(^~>) ::

131+ ( PolyArrow SemiIso m,

132+ FlatMorphable a a' 'False,

133+ FlatMorphable b bc 'False,

134+ FlatMorphable c bc fc,

135+ FlatMorphable d d' fd

136+ ) =>

137+ SemiIso a b ->

138+ m c d ->

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

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

141+

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

143+--

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

145+(^~>^) ::

146+ ( PolyArrow SemiIso m,

147+ FlatMorphable a a' 'False,

148+ FlatMorphable b b' 'False,

149+ FlatMorphable d d' 'False

150+ ) =>

151+ SemiIso a b ->

152+ SemiIso b d ->

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

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

155+

156+infixl 5 ~|

157+

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

159+--

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

161+(~|) ::

162+ ( PolyArrow SemiIso m,

163+ ArrowPlus m,

164+ FlatMorphable a ac fa,

165+ FlatMorphable c ac fb,

166+ FlatMorphable b bd fc,

167+ FlatMorphable d bd fd

168+ ) =>

169+ m a b ->

170+ m c d ->

171+ m (HList ac) (HList bd)

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

173+

174+infixl 7 ~&

175+

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

177+--

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

179+(~&) ::

180+ ( PolyArrow SemiIso m,

181+ FlatMorphable a ac' fa,

182+ FlatMorphable c ac' fc,

183+ FlatMorphable b b' fb,

184+ FlatMorphable d d' fd,

185+ AppendableList b' d' f

186+ ) =>

187+ m a b ->

188+ m c d ->

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

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

191+

192+infixl 9 ~*

193+

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

195+--

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

197+(~*) ::

198+ ( PolyArrow SemiIso m,

199+ FlatMorphable a a' fa,

200+ FlatMorphable c c' fc,

201+ FlatMorphable b b' fb,

202+ FlatMorphable d d' fd,

203+ AppendableList a' c' e',

204+ AppendableList b' d' f'

205+ ) =>

206+ m a b ->

207+ m c d ->

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

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

210+

211+infixl 6 ~$>

212+

213+(~$>) ::

214+ ( PolyArrow SemiIso m,

215+ FlatMorphable a a' fa,

216+ FlatMorphable b bc fb,

217+ FlatMorphable c bc fc,

218+ FlatMorphable d d' fd

219+ ) =>

220+ m a b ->

221+ Prism' c d ->

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

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

224+

225+-- | Conceptually:

226+--

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

228+hmap ::

229+ ( FlatMorphable b b' fb,

230+ FlatMorphable a a' fa,

231+ FlatMorphable d d' fd,

232+ FlatMorphable c c' fc,

233+ PolyArrow SemiIso m

234+ ) =>

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

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

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

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

239+

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

241+coercing = siPure coerce coerce

242+

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

244+morphed = siPure morphTuples morphTuples

245+

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

247+fMorphed = siPure flatUnmorph flatMorph

248+

249+-- | Conceptually:

250+--

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

252+enlist ::

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

254+ m a b ->

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

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

257+

258+-- | Conceptually:

259+--

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

261+delist ::

262+ ( FlatMorphable a a' 'False,

263+ FlatMorphable b b' 'False,

264+ PolyArrow SemiIso m,

265+ HListContentsTuple a' ~ a,

266+ HListContentsTuple b' ~ b,

267+ TupleHListContents a ~ a',

268+ TupleHListContents b ~ b'

269+ ) =>

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

271+ m a b

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

273+

274+consHList ::

275+ forall a b c.

276+ AppendableList a b c =>

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

278+consHList =

279+ siPure

280+ (uncurry (++:))

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

282+

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

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

285+ where

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

287+ u =

288+ M.fromListWith (error "mapping not unique") $

289+ (\(a, b) -> (b, a)) <$> m

290+

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

292+auto = toIsoparsec

293+

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)

296+

297+throughIntegral ::

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

299+ SemiIso a b

300+throughIntegral = siPure fromIntegral fromIntegral

src/Data/Isoparsec/ByteString.hsnew file+92

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

1+{-# OPTIONS_GHC -Wno-orphans #-}

3+module Data.Isoparsec.ByteString

4+ ( utf8,

5+ ByteString,

6+ Endianness (..),

7+ Byte8,

8+ Byte16 (..),

9+ Byte32 (..),

10+ Byte64 (..),

11+ SSHString (..),

12+ )

13+where

14+

15+import Data.Bits

16+import Data.ByteString as BS

17+import qualified Data.ByteString.Char8 as C

18+import Data.Isoparsec

19+import Data.Proxy

20+import Data.Word

21+import Prelude as P hiding ((.))

22+

23+utf8 :: SemiIso ByteString String

24+utf8 = siPure C.unpack C.pack

25+

26+data Endianness = BE | LE

27+

28+class BytesToIsoparsec b (e :: Endianness) where

29+ bytesToIsoparsec :: (Isoparsec m ByteString) => Proxy e -> m () b

30+

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

32+ bytesToIsoparsec _ =

33+ konst word8s ^>> manyTokens

34+ >>^ siPure

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

36+ ( fromList . snd . P.head

37+ . P.drop (fromIntegral word8s)

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

39+ . (,[])

40+ . toInteger

41+ )

42+ where

43+ word8s = fromIntegral $ finiteBitSize (undefined :: b) `div` 8

44+

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

46+ bytesToIsoparsec _ =

47+ konst word8s ^>> manyTokens

48+ >>^ siPure

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

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

51+ . P.drop (fromIntegral word8s)

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

53+ . (,[])

54+ . toInteger

55+ )

56+ where

57+ word8s = fromIntegral $ finiteBitSize (undefined :: b) `div` 8

58+

59+type Byte8 = Word8

60+

61+newtype Byte16 (e :: Endianness) = Byte16 {unByte16 :: Word16}

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

63+

64+newtype Byte32 (e :: Endianness) = Byte32 {unByte32 :: Word32}

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

66+

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

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

69+

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

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

72+

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

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

75+

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

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

78+

79+instance ToIsoparsec Bool ByteString m where

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

81+

82+newtype SSHString = SSHString {unSSHString :: String}

83+ deriving (Show, Eq, Ord)

84+

85+instance ToIsoparsec SSHString ByteString m where

86+ toIsoparsec =

87+ auto @(Byte32 'BE)

88+ >>^ coercing @Word32

89+ >>^ siPure fromIntegral fromIntegral

90+ >>> manyTokens

91+ >>^ utf8

92+ >>^ siPure SSHString unSSHString

src/Data/Isoparsec/Char.hsnew file+26

@@ -0,0 +1,26 @@

1+module Data.Isoparsec.Char

2+ ( unsafeWhiteSpace,

3+ unsafeWhiteSpace1,

4+ space,

5+ number,

6+ )

7+where

9+import Data.Char

10+import Data.Isoparsec

11+import Text.Read

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

13+

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

15+space = token ' '

16+

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

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

19+

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

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

22+

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

24+number =

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

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

src/Data/Isoparsec/Chunks.hsnew file+15

@@ -0,0 +1,15 @@

1+module Data.Isoparsec.Chunks

2+ ( Chunk (..),

3+ )

4+where

6+import Data.Isoparsec

7+import Data.Proxy

8+import GHC.TypeLits

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

11+ deriving (Show, Eq, Ord)

12+

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

14+ toIsoparsec =

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

src/Data/Isoparsec/Internal.hsnew file+130

@@ -0,0 +1,130 @@

1+module Data.Isoparsec.Internal

2+ ( module X,

3+ IsoparsecFail (..),

4+ Isoparsec (..),

5+ siCons,

6+ unroll,

7+ arrowsWhile,

8+ arrowsUntil,

9+ EffectOnly,

10+ )

11+where

12+

13+import Control.Arrow.Extra

14+import Control.Arrow.Trans.Reader

15+import Control.Monad

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

17+import Data.MonoTraversable as X

18+import Data.Sequences as X

19+import Numeric.Natural

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

21+

22+class

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

24+ Isoparsec m s

25+ | m -> s where

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

27+

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

29+

30+ token :: Element s -> EffectOnly m

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

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

33+

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

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

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

37+

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

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

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

41+

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

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

44+

45+ chunk :: s -> EffectOnly m

46+ chunk = tokens . otoList

47+

48+ chunk' :: m s s

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

50+ where

51+ list = siPure otoList fromList

52+

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

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

55+ notToken t = tokenWhere (/= t)

56+

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

58+ tokenWhere f = anyToken >>^ check f

59+

60+ manyTokens :: m Natural s

61+

62+ takeUntil :: s -> m () s

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

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

65+

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

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

68+ tokensWhile f =

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

70+ <+^ isoConst () mempty

71+

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

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

74+

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

76+ -- > ┌─────┐

77+ -- > │ s ├───────┐

78+ -- > └─────┘ │

79+ -- > ┌────┐ │ ┌─────┐

80+ -- > ───┤ () ├────▶ └──────┤ a ├▶

81+ -- > └────┘ └─────┘

82+ -- > │

83+ -- > ┌────┴─────┐

84+ -- > │ tuck │

85+ -- > └────┬─────┘

86+ -- > ▼

87+ -- > ┌─────┐ ┌─────┐

88+ -- > ──┤ s ├──────────────────────────┤ a ├─▶

89+ -- > └─────┘ └─────┘

90+ tuck :: m () a -> m s a

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

92+

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

94+

95+type EffectOnly m = m () ()

96+

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

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

99+

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

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

102+

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

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

105+ where

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

107+

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

109+siCons =

110+ siMaybe

111+ (pure . uncurry cons)

112+ uncons

113+

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.hsnew file+88

@@ -0,0 +1,88 @@

1+{-# OPTIONS_GHC -Wno-orphans #-}

3+module Data.Isoparsec.Megaparsec

4+ ( runMegaparsecParser,

5+ ParseErrorBundle (..),

6+ MegaparsecParser (..),

7+ )

8+where

10+import Control.Arrow.Extra

11+import Control.Arrow.Extra.Orphans ()

12+import Control.Monad

13+import Data.Functor

14+import Data.Functor.Identity

15+import Data.Isoparsec

16+import Data.Void

17+import Text.Megaparsec hiding (Token)

18+import qualified Text.Megaparsec as M

19+import Prelude hiding ((.))

20+

21+newtype MegaparsecParser s a b

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

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

24+

25+instance

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

27+ ArrowPlus (MegaparsecParser s)

28+ where

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

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

31+

32+runMegaparsecParser ::

33+ (Stream s) =>

34+ s ->

35+ MegaparsecParser s () r ->

36+ Either (ParseErrorBundle s Void) r

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

38+

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

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

41+ Just x -> return x

42+ Nothing -> M.failure Nothing mempty

43+

44+instance

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

46+ Isoparsec (MegaparsecParser s) s

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

59+

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

61+

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

63+

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

65+

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

67+

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

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

70+ return $ fromList ta

71+

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

73+

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

75+

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

77+ sup <- getInput

78+ setInput sub

79+ r <- f () <* eof

80+ setInput sup

81+ return r

82+

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.hsnew file+83

@@ -0,0 +1,83 @@

1+{-# OPTIONS_GHC -Wno-orphans #-}

3+module Data.Isoparsec.Printer

4+ ( runMonoidPrinter,

5+ MonoidPrinter (..),

6+ )

7+where

9+import Control.Cokleisli

10+import Control.Monad.Writer.Lazy

11+import Data.Functor

12+import Data.Isoparsec

13+import Data.List.Split

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

15+

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

23+ a ->

24+ Maybe s

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

26+

27+instance IsoparsecFail (MonoidPrinter s) e where

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

29+

30+instance

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

32+ Isoparsec (MonoidPrinter s) s

33+ where

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

35+

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

37+

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

39+

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

41+

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

43+

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

45+

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

47+

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

49+ if t == nt

50+ then empty

51+ else (tell . Dual . singleton) t

52+

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

54+ if f t

55+ then (tell . Dual . singleton) t

56+ else empty

57+

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

59+ tell $ Dual w

60+ return . fromIntegral . olength $ w

61+

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

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

64+ then empty

65+ else do

66+ tell . Dual $ s

67+ tell . Dual $ end

68+

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

70+ if oall f s

71+ then (tell . Dual) s

72+ else empty

73+

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

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

76+ then (tell . Dual) s

77+ else empty

78+

79+ tuck (MonoidPrinter (Cokleisli f)) =

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

81+

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

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

src/Data/Isoparsec/ToIsoparsec.hsnew file+44

@@ -0,0 +1,44 @@

1+module Data.Isoparsec.ToIsoparsec

2+ ( ToIsoparsec (..),

3+ )

4+where

6+import Control.Arrow.Extra

7+import Data.Isoparsec.Internal

8+import GHC.Generics

9+import Prelude hiding ((.))

10+

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)

15+

16+class GToIsoparsec a s m where

17+ gToIsoparsec :: Isoparsec m s => m () (a b)

18+

19+instance GToIsoparsec U1 s m where

20+ gToIsoparsec = arr $ konst U1

21+

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

23+ gToIsoparsec = toIsoparsec >>^ siPure K1 unK1

24+

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

26+ gToIsoparsec =

27+ gToIsoparsec >>^ siPure M1 unM1

28+

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

30+ gToIsoparsec =

31+ (gToIsoparsec &&& gToIsoparsec)

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

33+

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

35+ gToIsoparsec =

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

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

38+ )

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

40+ where

41+ fromL (L1 a) = pure a

42+ fromL _ = empty

43+ fromR (R1 b) = pure b

44+ fromR _ = empty

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

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

1717#

1818# resolver: ./custom-snapshot.yaml

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

20−resolver: lts-14.7

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

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

4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

4141#

42−# extra-deps: []

4342

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

4544# flags: {}

@@ -64,3 +63,6 @@ packages:

6463#

6564# Allow a newer minor version of GHC than the snapshot specifies

6665# compiler-check: newer-minor

66+

67+ghc-options:

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

test/Spec.hs+57−1

@@ -1,2 +1,58 @@

1+import qualified Spec.BasicReader as BasicReader

2+import qualified Spec.JSON as JSON

3+import qualified Spec.JSONHList as JSONHList

4+import qualified Spec.Megaparsec.BasicNums as BasicNums

5+import qualified Spec.Ssh as Ssh

6+import qualified Spec.SshHList as SshHList

7+import qualified Spec.TwoDigits as TwoDigits

8+import Test.Tasty

9+import Test.Tasty.Hspec

10+

111main :: IO ()

2−main = putStrLn "Test suite not yet implemented"

12+main = do

13+ bsicNumSpec <- testSpec "Basic megaparsec test" BasicNums.spec

14+ twoDigitsSpec <- testSpec "Two digits test" TwoDigits.spec

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

20+ defaultMain

21+ ( testGroup

22+ "tests"

23+ [ testGroup

24+ "Basic number test"

25+ [ bsicNumSpec,

26+ BasicNums.quickSpec

27+ ],

28+ testGroup

29+ "JSON"

30+ [ jsonSpec,

31+ JSON.quickSpec

32+ ],

33+ testGroup

34+ "JSONHList"

35+ [ jsonHListSpec,

36+ JSONHList.quickSpec

37+ ],

38+ testGroup

39+ "TwoDigits"

40+ [ twoDigitsSpec,

41+ TwoDigits.quickSpec

42+ ],

43+ testGroup

44+ "ssh"

45+ [ sshSpec,

46+ Ssh.quickSpec

47+ ],

48+ testGroup

49+ "ssh HList"

50+ [ sshHListSpec,

51+ SshHList.quickSpec

52+ ],

53+ testGroup

54+ "BasicReader"

55+ [ basicReaderSpec

56+ ]

57+ ]

58+ )

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.hsnew file+102

@@ -0,0 +1,102 @@

1+module Spec.Helper

2+ ( shouldParseBS,

3+ roundtrip,

4+ parseSatisfyBS,

5+ shouldParseS,

6+ )

7+where

9+import Data.ByteString as BS

10+import Data.Either

11+import Data.Isoparsec as I

12+import Data.Isoparsec.Megaparsec

13+import Data.Isoparsec.Printer

14+import Data.Maybe

15+import Data.Void

16+import Spec.Orphans ()

17+import Test.Hspec

18+import Test.Tasty.QuickCheck

19+import Text.Megaparsec as M

20+import Prelude as P hiding ((.))

21+

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+

47+shouldParse ::

48+ forall x s.

49+ ( ToIsoparsec x s (MegaparsecParser s),

50+ Stream s,

51+ Show x,

52+ Eq x,

53+ Isoparsec (MegaparsecParser s) s

54+ ) =>

55+ s ->

56+ x ->

57+ Expectation

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

59+ Right e' -> e' `shouldBe` e

60+ Left err -> expectationFailure $ errorBundlePretty err

61+

62+shouldParseBS ::

63+ forall x.

64+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

65+ Show x,

66+ Eq x,

67+ Isoparsec (MegaparsecParser ByteString) ByteString

68+ ) =>

69+ ByteString ->

70+ x ->

71+ Expectation

72+shouldParseBS = shouldParse

73+

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+

86+roundtrip ::

87+ forall x s.

88+ ( ToIsoparsec x s (MegaparsecParser s),

89+ ToIsoparsec x s (MonoidPrinter s),

90+ Stream s,

91+ Show s,

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

93+ Eq x,

94+ Isoparsec (MegaparsecParser s) s

95+ ) =>

96+ x ->

97+ Property

98+roundtrip x =

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

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

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

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

test/Spec/JSON.hsnew file+88

@@ -0,0 +1,88 @@

1+{-# LANGUAGE TemplateHaskell #-}

3+module Spec.JSON

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 = string <+> array <+> integer <+> object

68+ where

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

70+ string = _JString <.> string'

71+ array =

72+ _Array

73+ <.> token '['

74+ &&& unsafeWhiteSpace

75+ &&& sepByComma json

76+ &&& unsafeWhiteSpace

77+ &&& token ']'

78+ integer = _JInteger <.> number

79+ object =

80+ _Object <.> token '{' &&& unsafeWhiteSpace

81+ &&& sepByComma pair

82+ &&& unsafeWhiteSpace

83+ &&& 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.hsnew file+45

@@ -0,0 +1,45 @@

1+{-# LANGUAGE TemplateHaskell #-}

3+module Spec.Megaparsec.BasicNums

4+ ( spec,

5+ quickSpec,

6+ )

7+where

9+import Control.Lens.TH

10+import Data.Either

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

17+import Test.Tasty

18+import Test.Tasty.QuickCheck

19+import Text.Megaparsec.Error

20+import Prelude hiding ((.), fail)

21+

22+data Foo = Foo Integer Integer

23+ deriving (Show, Eq)

24+

25+instance Arbitrary Foo where

26+ arbitrary = Foo <$> arbitrary <*> arbitrary

27+

28+makePrisms ''Foo

29+

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

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

32+

33+spec :: Spec

34+spec =

35+ it "deserializes" $ do

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

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

38+ runMegaparsecParser "1562" parser `shouldSatisfy` isLeft

39+

40+quickSpec :: TestTree

41+quickSpec = testProperty "roundtrips" $ \x ->

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

43+ in counterexample s $ case runMegaparsecParser s parser of

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

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

test/Spec/Orphans.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# OPTIONS_GHC -Wno-orphans #-}

3+module Spec.Orphans

4+ (

5+ )

6+where

8+import Data.ByteString

9+import Data.Isoparsec

10+import Data.Isoparsec.ByteString

11+import Data.Isoparsec.Chunks

12+import Data.Proxy

13+import GHC.TypeLits

14+import Test.Tasty.QuickCheck

15+import Prelude hiding ((.))

16+

17+instance

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

19+ Arbitrary (Chunk n s)

20+ where

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

22+

23+instance Arbitrary ByteString where

24+ arbitrary = fromList <$> listOf arbitrary

25+

26+deriving instance Arbitrary (Byte16 e)

27+

28+deriving instance Arbitrary (Byte32 e)

29+

30+deriving instance Arbitrary (Byte64 e)

test/Spec/Ssh.hsnew file+192

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

1+{-# LANGUAGE TemplateHaskell #-}

3+module Spec.Ssh

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

16+import Spec.Helper

17+import Spec.Orphans ()

18+import Test.Hspec

19+import Test.Tasty

20+import Test.Tasty.QuickCheck

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

22+

23+data MessageNumber

24+ = DisconnectMsg

25+ | IgnoreMsg

26+ | UnimplementedMsg

27+ | DebugMsg

28+ | ServiceRequestMsg

29+ | ServiceAcceptMsg

30+ | KextInitMsg

31+ | NewKeysMsg

32+ deriving (Eq, Show, Ord)

33+

34+instance ToIsoparsec MessageNumber ByteString a where

35+ toIsoparsec =

36+ anyToken

37+ >>> mapIso

38+ [ (1, DisconnectMsg),

39+ (2, IgnoreMsg),

40+ (3, UnimplementedMsg),

41+ (4, DebugMsg),

42+ (5, ServiceRequestMsg),

43+ (6, ServiceAcceptMsg),

44+ (20, KextInitMsg),

45+ (21, NewKeysMsg)

46+ ]

47+

48+newtype DisconnectReasonCode

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

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

51+

52+instance ToIsoparsec DisconnectReasonCode ByteString a

53+

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

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

56+

57+instance ToIsoparsec AlwaysDisplay ByteString a

58+

59+newtype PacketSequenceNumber

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

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

62+

63+instance ToIsoparsec PacketSequenceNumber ByteString a

64+

65+data Payload

66+ = VersionPayload String

67+ | IgnorePayload ByteString

68+ | ServiceRequest SSHString

69+ | DebugPayload AlwaysDisplay SSHString

70+ | DisconnectPayload DisconnectReasonCode String

71+ | ServiceAccept SSHString

72+ | UnimplementedPayload PacketSequenceNumber

73+ deriving (Show, Eq)

74+

75+instance Arbitrary Payload where

76+ arbitrary =

77+ oneof

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

79+ IgnorePayload <$> arbitrary,

80+ ServiceRequest . SSHString <$> s,

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

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

83+ ServiceAccept . SSHString <$> s,

84+ UnimplementedPayload <$> arbitrary

85+ ]

86+ where

87+ s = getASCIIString <$> arbitrary

88+

89+makePrisms ''Payload

90+

91+instance ToIsoparsec Payload ByteString a where

92+ toIsoparsec =

93+ ( _DisconnectPayload

94+ <.> specific DisconnectMsg

95+ &&& auto @DisconnectReasonCode

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

97+ )

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

99+ &&& auto @SSHString

100+ )

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

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

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

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

105+ )

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

118+

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

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

121+

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

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

124+

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

126+badZeroPadding =

127+ throughIntegral

128+ ^>> manyTokens

129+ >>^ siPure

130+ (ZeroPadding . fromIntegral . BS.length)

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

132+

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

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

135+

136+data NoneMAC = NoneMAC

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

138+

139+instance ToIsoparsec NoneMAC b a where

140+ toIsoparsec = arr $ konst NoneMAC

141+

142+instance Arbitrary NoneMAC where

143+ arbitrary = return NoneMAC

144+

145+data Packet mac

146+ = Packet Payload ZeroPadding mac

147+ deriving (Eq, Show)

148+

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

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

151+

152+makePrisms ''Packet

153+

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

155+ toIsoparsec =

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

157+ >>^ throughIntegral *** throughIntegral

158+ >>^ siPure

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

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

161+ >>> manyTokens *** arr throughIntegral

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

163+ )

164+ &&& auto @mac

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

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/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.hsnew file+70

@@ -0,0 +1,70 @@

1+module Spec.TwoDigits

2+ ( spec,

3+ quickSpec,

4+ )

5+where

7+import Data.Char

8+import Data.Either

9+import Data.Isoparsec

10+import Data.Isoparsec.Chunks

11+import Data.Isoparsec.Megaparsec

12+import Data.Isoparsec.Printer

13+import Data.Maybe

14+import GHC.Generics

15+import Test.Hspec

16+import Test.Tasty

17+import Test.Tasty.QuickCheck

18+import Text.Megaparsec.Error

19+import Prelude hiding ((.))

20+

21+newtype SingleDigit = SingleDigit {unSingleDigit :: String}

22+ deriving (Eq, Show, Generic)

23+

24+instance ToIsoparsec SingleDigit String m where

25+ toIsoparsec =

26+ toIsoparsec @(Chunk 1 String)

27+ >>^ coercing

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

29+ >>^ coercing

30+

31+instance Arbitrary SingleDigit where

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

33+

34+data Digits

35+ = FourDigits SingleDigit SingleDigit SingleDigit SingleDigit

36+ | ThreeDigits SingleDigit SingleDigit SingleDigit

37+ | TwoDigits SingleDigit SingleDigit

38+ deriving (Generic, Show, Eq)

39+

40+instance Arbitrary Digits where

41+ arbitrary =

42+ oneof

43+ [ FourDigits <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary,

44+ ThreeDigits <$> arbitrary <*> arbitrary <*> arbitrary,

45+ TwoDigits <$> arbitrary <*> arbitrary

46+ ]

47+

48+instance ToIsoparsec Digits String m

49+

50+spec :: Spec

51+spec = do

52+ let parser = toIsoparsec @_ @String

53+ it "deserializes" $ do

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

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

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

57+ runMegaparsecParser "12538" parser `shouldSatisfy` isLeft

58+ runMegaparsecParser "2" parser `shouldSatisfy` isLeft

59+ runMegaparsecParser "a" parser `shouldSatisfy` isLeft

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

61+

62+quickSpec :: TestTree

63+quickSpec = testProperty "roundtrips" $ \x ->

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

65+ in counterexample s $ case runMegaparsecParser s parser of

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

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

68+ where

69+ parser :: Isoparsec m String => m () Digits

70+ parser = toIsoparsec