git.iko.soy/isoparsec
on fe34b95 help sign in
04fff3e
swap
0 ahead, 39 behind
43 files changed+33−3076
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml+5−17 .hlint.yaml−191 .vscode/tasks.json−50 .weeder.yaml−1 README.md+1−6 app/Main.hs+6 hie.yaml−4 package.yaml+12−45 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+2−4 test/Spec.hs+1−57 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+5−17
@@ -1,34 +1,22 @@
11name: Haskell CI
22
3−on: [push]
3+on: [push, pull_request]
44
55jobs:
66 build:
77
88 runs-on: ubuntu-latest
99
10− strategy:
11− matrix:
12− resolver: [lts-13.11, lts-13.19, lts-14.27, lts-15, nightly]
13−
1410 steps:
1511 - uses: actions/checkout@v1
16−
17− - name: Cache
18− uses: actions/cache@v1
19− with:
20− path: ~/.stack
21− key: ${{ runner.os }}-stack-${{ matrix.resolver }}
22−
23− - name: Build
12+ - name: Install Stack
2413 run: |
25− stack build --fast --pedantic --ghc-options '-j -ddump-to-file -ddump-hi' --test --no-run-tests --bench --no-run-benchmarks --resolver=${{ matrix.resolver }}
14+ wget -qO- https://get.haskellstack.org/ | sh
2615
27− - name: Test
16+ - name: Build
2817 run: |
29− stack test --fast --pedantic --ghc-options '-j' --resolver=${{ matrix.resolver }}
18+ stack build --fast --pedantic --ghc-options '-j'
3019
3120 - name: Weeder
32− if: matrix.resolver == 'lts-15'
3321 run: |
3422 curl -sSL https://raw.github.com/ndmitchell/weeder/master/misc/run.sh | sh -s . --build
.hlint.yamldeleted−191
@@ -1,191 +0,0 @@
1−# HLint configuration file
2−# https://github.com/ndmitchell/hlint
3−##########################
4−
5−# This file contains a template configuration file, which is typically
6−# placed as .hlint.yaml in the root of your project
7−
8−
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.jsondeleted−50
@@ -1,50 +0,0 @@
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.yamldeleted−1
@@ -1 +0,0 @@
1−- message: Module reused between components
README.md+1−6
@@ -1,7 +1,2 @@
1−# 🔄 🔡 isoparsec ![](https://github.com/ilyakooo0/isoparsec/workflows/Haskell%20CI/badge.svg)
2−
1+# isoparsec
32Isomorphic (invertible) parser library
4−
5−### 🚧 Under construction 🚧
6−
7−![](https://media.giphy.com/media/xDQ3Oql1BN54c/giphy.gif)
app/Main.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+import Lib
4+
5+main :: IO ()
6+main = someFunc
hie.yamldeleted−4
@@ -1,4 +0,0 @@
1−cradle:
2− stack:
3− - path: "."
4− component: "isoparsec:test:isoparsec-test"
package.yaml+12−45
@@ -21,61 +21,28 @@ 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
3224
3325library:
3426 source-dirs: src
35− other-modules: Control.Prism
36− dependencies: []
3727
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
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
6238
6339tests:
6440 isoparsec-test:
6541 main: Spec.hs
66− source-dirs:
67− - test
68− - src
42+ source-dirs: test
6943 ghc-options:
7044 - -threaded
7145 - -rtsopts
7246 - -with-rtsopts=-N
7347 dependencies:
74− - tasty
75− - tasty-hspec
76− - hspec
77− - lens
78− - tasty-quickcheck
79− - QuickCheck
80− - megaparsec
81− - bytestring
48+ - isoparsec
random-notes.mddeleted−5
@@ -1,5 +0,0 @@
1−Implied `Isoparse m =>` everywhere
2−
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.hsdeleted−32
@@ -1,32 +0,0 @@
1−{-# LANGUAGE MonoLocalBinds #-}
2−
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.hsdeleted−25
@@ -1,25 +0,0 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
3−module Control.Arrow.Extra.ArrowChoice
4− ( ArrowChoice (..),
5− )
6−where
7−
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.hsdeleted−11
@@ -1,11 +0,0 @@
1−module Control.Arrow.Extra.ArrowPlus
2− ( ArrowPlus (..),
3− )
4−where
5−
6−import Control.Arrow.Extra.ArrowZero
7−
8−infixl 5 <+>
9−
10−class ArrowZero a => ArrowPlus a where
11− (<+>) :: a b c -> a b c -> a b c
src/Control/Arrow/Extra/ArrowZero.hsdeleted−9
@@ -1,9 +0,0 @@
1−module Control.Arrow.Extra.ArrowZero
2− ( ArrowZero (..),
3− )
4−where
5−
6−import Control.Arrow.Extra.BaseArrow
7−
8−class BaseArrow a => ArrowZero a where
9− zeroArrow :: a b c
src/Control/Arrow/Extra/BaseArrow.hsdeleted−37
@@ -1,37 +0,0 @@
1−{-# LANGUAGE NoImplicitPrelude #-}
2−
3−module Control.Arrow.Extra.BaseArrow
4− ( BaseArrow (..),
5− (>>>),
6− (<<<),
7− )
8−where
9−
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.hsdeleted−36
@@ -1,36 +0,0 @@
1−{-# OPTIONS_GHC -Wno-orphans #-}
2−
3−module Control.Arrow.Extra.Orphans
4− (
5− )
6−where
7−
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.hsdeleted−39
@@ -1,39 +0,0 @@
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.hsdeleted−34
@@ -1,34 +0,0 @@
1−module Control.Arrow.Reader
2− ( ArrowReader (..),
3− asksr,
4− asksl,
5− biask,
6− biasks,
7− module Control.Arrow.Trans.Reader,
8− )
9−where
10−
11−import Control.Arrow.Extra
12−import Control.Arrow.Trans.Reader
13−import Control.SemiIso
14−import Prelude hiding ((.), id)
15−
16−class ArrowReader r a where
17− askr :: a () r
18− askl :: a r ()
19−
20−instance (PolyArrow SemiIso a, Eq r) => ArrowReader r (ReaderArrow r a) where
21− askr = ReaderArrow . arr $ siFst >>> siDouble
22− askl = ReaderArrow . arr $ turn siDouble >>> turn siFst
23−
24−asksr :: (PolyArrow SemiIso a, ArrowReader r a) => SemiIso r s -> a () s
25−asksr si = askr >>^ si
26−
27−asksl :: (PolyArrow SemiIso a, ArrowReader r a) => SemiIso r s -> a s ()
28−asksl si = turn si ^>> askl
29−
30−biask :: (ArrowReader r a, Category a) => a r r -> a () ()
31−biask a = askr >>> a >>> askl
32−
33−biasks :: (ArrowReader r a, PolyArrow SemiIso a) => SemiIso r s -> a s s -> a () ()
34−biasks si a = asksr si >>> a >>> asksl si
src/Control/Arrow/Trans/Class.hsdeleted−9
@@ -1,9 +0,0 @@
1−module Control.Arrow.Trans.Class
2− ( ArrowTrans (..),
3− )
4−where
5−
6−import Control.Arrow.Extra
7−
8−class ArrowTrans s where
9− raise :: BaseArrow a => a b c -> s a b c
src/Control/Arrow/Trans/Reader.hsdeleted−53
@@ -1,53 +0,0 @@
1−module Control.Arrow.Trans.Reader
2− ( ReaderArrow (..),
3− runReaderArrow,
4− module Control.Arrow.Trans.Class,
5− )
6−where
7−
8−import Control.Arrow.Extra
9−import Control.Arrow.Trans.Class
10−import Control.SemiIso
11−import Prelude hiding ((.), fail, id)
12−
13−newtype ReaderArrow r s a b
14− = ReaderArrow {unReaderArrow :: s (r, a) (r, b)}
15−
16−instance BaseArrow a => Category (ReaderArrow r a) where
17− id = ReaderArrow . second $ id
18− (ReaderArrow lhs) . (ReaderArrow rhs) = ReaderArrow $ lhs . rhs
19−
20−instance (PolyArrow p a, PolyArrow SemiIso a, Eq r) => PolyArrow p (ReaderArrow r a) where
21− arr = ReaderArrow . second . arr
22−
23−instance (BaseArrow a, PolyArrow SemiIso a, Eq r) => BaseArrow (ReaderArrow r a) where
24− (ReaderArrow lhs) *** (ReaderArrow rhs) =
25− ReaderArrow $
26− siDouble *** id
27− ^>^ turn siTranspose2
28− >>> lhs *** rhs
29− >>^ siTranspose2
30− >>^ turn siDouble *** id
31− (ReaderArrow lhs) &&& (ReaderArrow rhs) =
32− ReaderArrow $
33− lhs &&& rhs
34− >>^ siTranspose2
35− >>^ turn siDouble *** id
36−
37−instance (ArrowZero a, BaseArrow (ReaderArrow r a)) => ArrowZero (ReaderArrow r a) where
38− zeroArrow = ReaderArrow $ id *** zeroArrow
39−
40−instance (ArrowPlus a, ArrowZero (ReaderArrow r a)) => ArrowPlus (ReaderArrow r a) where
41− (ReaderArrow lhs) <+> (ReaderArrow rhs) = ReaderArrow $ lhs <+> rhs
42−
43−instance (ArrowChoice a, PolyArrow SemiIso a, Eq r) => ArrowChoice (ReaderArrow r a) where
44− (ReaderArrow lhs) ||| (ReaderArrow rhs) = ReaderArrow $ siSequenceEither ^>> lhs ||| rhs
45− (ReaderArrow lhs) +++ (ReaderArrow rhs) =
46− ReaderArrow $ siSequenceEither ^>> lhs +++ rhs >>^ turn siSequenceEither
47−
48−runReaderArrow :: (PolyArrow SemiIso s, Eq r) => r -> ReaderArrow r s a b -> s a b
49−runReaderArrow r a =
50− turn siSnd >>> first (konst r) ^>> unReaderArrow a >>^ (first . turn $ konst r) >>^ siSnd
51−
52−instance ArrowTrans (ReaderArrow r) where
53− raise = ReaderArrow . second
src/Control/Cokleisli.hsdeleted−52
@@ -1,52 +0,0 @@
1−module Control.Cokleisli
2− ( Cokleisli (..),
3− )
4−where
5−
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.hsdeleted−40
@@ -1,40 +0,0 @@
1−module Control.Prism
2− ( withPrism,
3− Identity,
4− Prism',
5− )
6−where
7−
8−import Data.Coerce
9−import Data.Functor.Identity
10−import Data.Profunctor
11−
12−type Prism' a b = Market a a a (Identity a) -> Market a a b (Identity b)
13−
14−data Market a b s t = Market (b -> t) (s -> Either t a)
15−
16−instance Functor (Market a b s) where
17− fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
18−
19−instance Profunctor (Market a b) where
20− dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)
21− lmap f (Market bt seta) = Market bt (seta . f)
22− rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
23−
24−instance Choice (Market a b) where
25− left' (Market bt seta) = Market (Left . bt) $ \case
26− Left s -> case seta s of
27− Left t -> Left (Left t)
28− Right a -> Right a
29− Right c -> Left (Right c)
30− right' (Market bt seta) = Market (Right . bt) $ \case
31− Left c -> Left (Left c)
32− Right s -> case seta s of
33− Left t -> Left (Right t)
34− Right a -> Right a
35−
36−type APrism b a = Market a a a (Identity a) -> Market a a b (Identity b)
37−
38−withPrism :: APrism b a -> ((a -> b) -> (b -> Either b a) -> r) -> r
39−withPrism k f = case coerce (k (Market Identity Right)) of
40− Market bt seta -> f bt seta
src/Control/SemiIso.hsdeleted−206
@@ -1,206 +0,0 @@
1−module Control.SemiIso
2− ( module X,
3− SemiIso (..),
4− pattern SI,
5− siMaybe,
6− siPure,
7− turn,
8− withSemiIso,
9− AlternativeMonad,
10− maskr,
11− maskl,
12− isoCheck,
13− siCheck,
14− check,
15− konst,
16− isoConst,
17− assoc,
18− ($$$),
19− (*>>),
20− (&>>),
21− (**>),
22− (>>*),
23− (>>&),
24− (>**),
25− (<<*),
26− (<<&),
27− (<**),
28− (*<<),
29− (&<<),
30− (**<),
31− siFst,
32− siSnd,
33− siDouble,
34− siSwap,
35− siTranspose2,
36− siSequenceEither,
37− )
38−where
39−
40−import Control.Applicative as X
41−import Control.Arrow.Extra
42−import Control.Monad as X
43−import qualified Data.Bifunctor as Bi
44−import Data.Bitraversable
45−import Data.Tuple
46−import Prelude hiding ((.), id)
47−
48−type AlternativeMonad m = (Alternative m, Monad m)
49−
50−data SemiIso a b
51− = SemiIso
52− { embed :: forall f. AlternativeMonad f => a -> f b,
53− project :: forall f. AlternativeMonad f => b -> f a
54− }
55−
56−pattern SI ::
57− forall a b.
58− (forall f. AlternativeMonad f => a -> f b) ->
59− (forall f. AlternativeMonad f => b -> f a) ->
60− SemiIso a b
61−pattern SI a b = SemiIso a b
62−
63−siMaybe :: (a -> Maybe b) -> (b -> Maybe a) -> SemiIso a b
64−siMaybe a b = SI (maybeToAlternative . a) (maybeToAlternative . b)
65− where
66− maybeToAlternative :: Alternative f => Maybe a -> f a
67− maybeToAlternative (Just x) = pure x
68− maybeToAlternative Nothing = empty
69−
70−siPure :: (a -> b) -> (b -> a) -> SemiIso a b
71−siPure a b = SI (pure . a) (pure . b)
72−
73−instance Category SemiIso where
74− id = SemiIso pure pure
75− (SemiIso a1 b1) . (SemiIso a2 b2) = SemiIso (a1 <=< a2) (b2 <=< b1)
76−
77−instance BaseArrow SemiIso where
78− (SemiIso a1 b1) *** (SemiIso a2 b2) =
79− SemiIso
80− (\(x, y) -> (,) <$> a1 x <*> a2 y)
81− (\(x, y) -> (,) <$> b1 x <*> b2 y)
82− (SemiIso a1 b1) &&& (SemiIso a2 b2) =
83− SemiIso
84− (\x -> (,) <$> a1 x <*> a2 x)
85− (\(x, y) -> b1 x <|> b2 y)
86−
87−instance ArrowChoice SemiIso where
88− (SemiIso a1 b1) +++ (SemiIso a2 b2) =
89− SemiIso (bitraverse a1 a2) (bitraverse b1 b2)
90− (SemiIso a1 b1) ||| (SemiIso a2 b2) =
91− SemiIso
92− (either a1 a2)
93− (\x -> (Left <$> b1 x) <|> (Right <$> b2 x))
94−
95−instance ArrowZero SemiIso where
96− zeroArrow = SemiIso (const empty) (const empty)
97−
98−instance ArrowPlus SemiIso where
99− (SemiIso a1 b1) <+> (SemiIso a2 b2) =
100− SemiIso
101− (\x -> a1 x <|> a2 x)
102− (\x -> b1 x <|> b2 x)
103−
104−-- | prop> turn . turn = id
105−turn :: SemiIso a b -> SemiIso b a
106−turn (SemiIso a b) = SemiIso b a
107−
108−withSemiIso ::
109− AlternativeMonad f =>
110− SemiIso a b ->
111− ((a -> f b) -> (b -> f a) -> c) ->
112− c
113−withSemiIso (SemiIso a b) f = f a b
114−
115−maskr :: SemiIso a () -> SemiIso a ()
116−maskr (SemiIso e p) = SemiIso (\a -> e a <|> pure ()) p
117−
118−maskl :: SemiIso () b -> SemiIso () b
119−maskl (SemiIso e p) = SemiIso e (\b -> p b <|> pure ())
120−
121−infixl 1 *>>, **>, >>*, >**, <<*, <**, *<<, **<
122−
123−infixl 3 $$$
124−
125−($$$) :: (PolyArrow SemiIso m, Eq b) => m a b -> m c b -> m (a, c) b
126−a $$$ c = a *** c >>^ turn siDouble
127−
128−(*>>) :: (PolyArrow SemiIso m) => m a () -> m a b -> m a b
129−a *>> b = a &&& b >>^ siSnd
130−
131−(&>>) :: (PolyArrow SemiIso m) => m a () -> m b c -> m (a, b) c
132−a &>> b = a *** b >>^ siSnd
133−
134−(**>) :: (PolyArrow SemiIso m) => m () () -> m a b -> m a b
135−a **> b = turn siSnd ^>> a *** b >>^ siSnd
136−
137−(>>*) :: (PolyArrow SemiIso m, Eq b) => m a b -> m () b -> m a b
138−a >>* b = turn siFst ^>> a $$$ b
139−
140−(>>&) :: (PolyArrow SemiIso m) => m a b -> m () c -> m a (b, c)
141−a >>& b = turn siFst ^>> a *** b
142−
143−(>**) :: (PolyArrow SemiIso m) => m a b -> m () () -> m a b
144−a >** b = turn siFst ^>> a *** b >>^ siFst
145−
146−(<<*) :: (PolyArrow SemiIso m, Eq b) => m a b -> m () b -> m a b
147−a <<* b = turn siSnd ^>> b $$$ a
148−
149−(<<&) :: (PolyArrow SemiIso m) => m a b -> m () c -> m a (b, c)
150−a <<& b = turn siSnd ^>> b *** a >>^ siSwap
151−
152−(<**) :: (PolyArrow SemiIso m) => m a b -> m () () -> m a b
153−a <** b = turn siSnd ^>> b *** a >>^ siSnd
154−
155−(*<<) :: (PolyArrow SemiIso m) => m a () -> m a b -> m a b
156−a *<< b = b &&& a >>^ siFst
157−
158−(&<<) :: (PolyArrow SemiIso m) => m a () -> m b c -> m (a, b) c
159−a &<< b = siSwap ^>> b *** a >>^ siFst
160−
161−(**<) :: (PolyArrow SemiIso m) => m () () -> m a b -> m a b
162−a **< b = turn siFst ^>> b *** a >>^ siFst
163−
164−check :: (s -> Bool) -> SemiIso s s
165−check f = isoCheck f id id
166−
167−siCheck ::
168− (s -> Bool) ->
169− (forall f. AlternativeMonad f => s -> f a) ->
170− (forall f. AlternativeMonad f => a -> f s) ->
171− SemiIso s a
172−siCheck f a b =
173− SI
174− (\c -> guard (f c) >> a c)
175− (b >=> (\c -> guard (f c) >> pure c))
176−
177−isoCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso s a
178−isoCheck f a b = siCheck f (pure . a) (pure . b)
179−
180−isoConst :: s -> a -> SemiIso s a
181−isoConst s a = SI (const $ pure a) (const $ pure s)
182−
183−konst :: Eq x => x -> SemiIso () x
184−konst x = isoConst () x >>> check (== x)
185−
186−assoc :: SemiIso (a, (b, c)) ((a, b), c)
187−assoc = siPure (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))
188−
189−siFst :: SemiIso (a, ()) a
190−siFst = siPure fst (,())
191−
192−siSnd :: SemiIso ((), a) a
193−siSnd = siPure snd ((),)
194−
195−siDouble :: (Eq a) => SemiIso a (a, a)
196−siDouble = siPure (\x -> (x, x)) fst >>> check (uncurry (==))
197−
198−siSwap :: SemiIso (a, b) (b, a)
199−siSwap = siPure swap swap
200−
201−siTranspose2 :: SemiIso ((a, b), (c, d)) ((a, c), (b, d))
202−siTranspose2 =
203− siPure (\((r1, b), (r2, c)) -> ((r1, r2), (b, c))) (\((r1, r2), (b, c)) -> ((r1, b), (r2, c)))
204−
205−siSequenceEither :: SemiIso (r, Either a b) (Either (r, a) (r, b))
206−siSequenceEither = siPure (\(r, e) -> Bi.bimap (r,) (r,) e) (either (Bi.second Left) (Bi.second Right))
src/Control/Tuple/Morph.hsdeleted−486
@@ -1,486 +0,0 @@
1−{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-redundant-constraints #-}
2−
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.hsdeleted−300
@@ -1,300 +0,0 @@
1−{-# OPTIONS_GHC -Wno-redundant-constraints #-}
2−
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.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# OPTIONS_GHC -Wno-orphans #-}
2−
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.hsdeleted−26
@@ -1,26 +0,0 @@
1−module Data.Isoparsec.Char
2− ( unsafeWhiteSpace,
3− unsafeWhiteSpace1,
4− space,
5− number,
6− )
7−where
8−
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.hsdeleted−15
@@ -1,15 +0,0 @@
1−module Data.Isoparsec.Chunks
2− ( Chunk (..),
3− )
4−where
5−
6−import Data.Isoparsec
7−import Data.Proxy
8−import GHC.TypeLits
9−
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.hsdeleted−130
@@ -1,130 +0,0 @@
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.hsdeleted−88
@@ -1,88 +0,0 @@
1−{-# OPTIONS_GHC -Wno-orphans #-}
2−
3−module Data.Isoparsec.Megaparsec
4− ( runMegaparsecParser,
5− ParseErrorBundle (..),
6− MegaparsecParser (..),
7− )
8−where
9−
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.hsdeleted−83
@@ -1,83 +0,0 @@
1−{-# OPTIONS_GHC -Wno-orphans #-}
2−
3−module Data.Isoparsec.Printer
4− ( runMonoidPrinter,
5− MonoidPrinter (..),
6− )
7−where
8−
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.hsdeleted−44
@@ -1,44 +0,0 @@
1−module Data.Isoparsec.ToIsoparsec
2− ( ToIsoparsec (..),
3− )
4−where
5−
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.hsnew file+6
@@ -0,0 +1,6 @@
1+module Lib
2+ ( someFunc
3+ ) where
4+
5+someFunc :: IO ()
6+someFunc = putStrLn "someFunc"
stack.yaml+2−4
@@ -17,7 +17,7 @@
1717#
1818# resolver: ./custom-snapshot.yaml
1919# resolver: https://example.com/snapshots/2018-01-01.yaml
20−resolver: lts-15.8
20+resolver: lts-14.7
2121
2222# User packages to be built.
2323# Various formats can be used as shown in the example below.
@@ -39,6 +39,7 @@ packages:
3939# - git: https://github.com/commercialhaskell/stack.git
4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
4141#
42+# extra-deps: []
4243
4344# Override default flag values for local packages and extra-deps
4445# flags: {}
@@ -63,6 +64,3 @@ packages:
6364#
6465# Allow a newer minor version of GHC than the snapshot specifies
6566# 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+1−57
@@ -1,58 +1,2 @@
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 ()
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− )
2+main = putStrLn "Test suite not yet implemented"
test/Spec/BasicReader.hsdeleted−38
@@ -1,38 +0,0 @@
1−{-# LANGUAGE PartialTypeSignatures #-}
2−{-# LANGUAGE TemplateHaskell #-}
3−
4−module Spec.BasicReader
5− ( spec,
6− )
7−where
8−
9−import Control.Arrow.Extra
10−import Control.Arrow.Reader
11−import Control.Lens.TH
12−import Data.Either
13−import Data.Isoparsec
14−import Data.Isoparsec.Char
15−import Data.Isoparsec.Megaparsec
16−import Test.Hspec
17−import Prelude hiding ((.), id)
18−
19−data ConstSep = ConstSep Integer Integer
20− deriving (Eq, Show)
21−
22−makePrisms ''ConstSep
23−
24−instance ArrowReader String a => ToIsoparsec ConstSep String a where
25− toIsoparsec = _ConstSep <.> (number >** biask chunk') &&& number
26−
27−spec :: Spec
28−spec = do
29− let run (sep :: String) (s :: String) =
30− runMegaparsecParser s . runReaderArrow sep $ (auto @ConstSep)
31− it "deserializes" $ do
32− run "s" "12s31" `shouldBe` Right (ConstSep 12 31)
33− run " " "12 31" `shouldBe` Right (ConstSep 12 31)
34− run "oh no" "12oh no31" `shouldBe` Right (ConstSep 12 31)
35− run "oh no" "12oh no 31" `shouldSatisfy` isLeft
36− run "oh no" "12ohno31" `shouldSatisfy` isLeft
37− run "&" "12 31" `shouldSatisfy` isLeft
38− run "&" "12&31" `shouldBe` Right (ConstSep 12 31)
test/Spec/Helper.hsdeleted−102
@@ -1,102 +0,0 @@
1−module Spec.Helper
2− ( shouldParseBS,
3− roundtrip,
4− parseSatisfyBS,
5− shouldParseS,
6− )
7−where
8−
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.hsdeleted−88
@@ -1,88 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−module Spec.JSON
4− ( quickSpec,
5− spec,
6− )
7−where
8−
9−import Control.Arrow.Extra
10−import Control.Lens.TH
11−import Data.Isoparsec
12−import Data.Isoparsec.Char
13−import Data.Isoparsec.Megaparsec
14−import Data.Isoparsec.Printer
15−import Data.Maybe
16−import Spec.Helper
17−import Test.Hspec
18−import Test.Tasty
19−import Test.Tasty.QuickCheck
20−import Text.Megaparsec.Error
21−import Prelude hiding ((.))
22−
23−data JSON
24− = Object [(String, JSON)]
25− | JString String
26− | Array [JSON]
27− | JInteger Integer
28− deriving (Show, Eq)
29−
30−instance Arbitrary JSON where
31− arbitrary =
32− oneof
33− [ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),
34− JString <$> listOf (elements ['.' .. 'z']),
35− Array <$> listOf (scale (`div` 2) arbitrary),
36− JInteger <$> arbitrary
37− ]
38−
39− shrink (Object a) = Object <$> shrink a
40− shrink (JString a) = JString <$> shrink a
41− shrink (Array a) = Array <$> shrink a
42− shrink (JInteger a) = JInteger <$> shrink a
43−
44−makePrisms ''JSON
45−
46−spec :: Spec
47−spec =
48− it "deserializes" $ do
49− "{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]
50− "{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]
51− "{}" `shouldParseS` Object []
52− "[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]
53− "[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]
54−
55−quickSpec :: TestTree
56−quickSpec =
57− testProperty "roundtrips" $ \x ->
58− let s = fromJust $ runMonoidPrinter @String json x
59− in counterexample s $ case runMegaparsecParser s json of
60− Right y -> property $ x == y
61− Left err -> counterexample (errorBundlePretty err) False
62−
63−instance ToIsoparsec JSON String a where
64− toIsoparsec = json
65−
66−json :: forall m. Isoparsec m String => m () JSON
67−json = 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.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−module Spec.JSONHList
4− ( quickSpec,
5− spec,
6− )
7−where
8−
9−import Control.Arrow.Extra
10−import Control.Lens.TH
11−import Data.Isoparsec
12−import Data.Isoparsec.Char
13−import Data.Isoparsec.Megaparsec
14−import Data.Isoparsec.Printer
15−import Data.Maybe
16−import Spec.Helper
17−import Test.Hspec
18−import Test.Tasty
19−import Test.Tasty.QuickCheck
20−import Text.Megaparsec.Error
21−import Prelude hiding ((.))
22−
23−data JSON
24− = Object [(String, JSON)]
25− | JString String
26− | Array [JSON]
27− | JInteger Integer
28− deriving (Show, Eq)
29−
30−instance Arbitrary JSON where
31− arbitrary =
32− oneof
33− [ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),
34− JString <$> listOf (elements ['.' .. 'z']),
35− Array <$> listOf (scale (`div` 2) arbitrary),
36− JInteger <$> arbitrary
37− ]
38−
39− shrink (Object a) = Object <$> shrink a
40− shrink (JString a) = JString <$> shrink a
41− shrink (Array a) = Array <$> shrink a
42− shrink (JInteger a) = JInteger <$> shrink a
43−
44−makePrisms ''JSON
45−
46−spec :: Spec
47−spec =
48− it "deserializes" $ do
49− "{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]
50− "{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]
51− "{}" `shouldParseS` Object []
52− "[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]
53− "[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]
54−
55−quickSpec :: TestTree
56−quickSpec =
57− testProperty "roundtrips" $ \x ->
58− let s = fromJust $ runMonoidPrinter @String json x
59− in counterexample s $ case runMegaparsecParser s json of
60− Right y -> property $ x == y
61− Left err -> counterexample (errorBundlePretty err) False
62−
63−instance ToIsoparsec JSON String a where
64− toIsoparsec = json
65−
66−json :: forall m. Isoparsec m String => m () JSON
67−json = delist $ string ~| array ~| integer ~| object
68− where
69− string' :: Listed m () String
70− string' = token '"' ~> tokensWhile (/= '"') ~> token '"'
71− string :: Listed m () JSON
72− string = string' ~$> _JString
73− array :: Listed m () JSON
74− array =
75− token '['
76− ~> unsafeWhiteSpace
77− ~> sepByComma json
78− ~> unsafeWhiteSpace
79− ~> token ']'
80− ~$> _Array
81− integer = number ~$> _JInteger
82− object =
83− token '{' ~> unsafeWhiteSpace
84− ~> hmap sepByComma pair
85− ~> unsafeWhiteSpace
86− ~> token '}'
87− ~$> _Object
88− pair =
89− unsafeWhiteSpace ~> string' ~> unsafeWhiteSpace ~> token ':' ~> unsafeWhiteSpace
90− ~& json ~> unsafeWhiteSpace
91− sepByComma :: Eq a => m () a -> m () [a]
92− sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)
test/Spec/Megaparsec/BasicNums.hsdeleted−45
@@ -1,45 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−module Spec.Megaparsec.BasicNums
4− ( spec,
5− quickSpec,
6− )
7−where
8−
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.hsdeleted−30
@@ -1,30 +0,0 @@
1−{-# OPTIONS_GHC -Wno-orphans #-}
2−
3−module Spec.Orphans
4− (
5− )
6−where
7−
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.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−module Spec.Ssh
4− ( spec,
5− quickSpec,
6− )
7−where
8−
9−import Control.Lens.TH
10−import Data.ByteString as BS
11−import qualified Data.Char as C
12−import Data.Either
13−import Data.Isoparsec
14−import Data.Isoparsec.ByteString
15−import 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.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−module Spec.SshHList
4− ( spec,
5− quickSpec,
6− )
7−where
8−
9−import Control.Lens.TH
10−import Data.ByteString as BS
11−import qualified Data.Char as C
12−import Data.Either
13−import Data.Isoparsec
14−import Data.Isoparsec.ByteString
15−import Data.Word
16−import GHC.Generics
17−import Numeric.Natural
18−import Spec.Helper
19−import Spec.Orphans ()
20−import Test.Hspec
21−import Test.Tasty
22−import Test.Tasty.QuickCheck
23−import Prelude as P hiding ((.), id)
24−
25−data MessageNumber
26− = DisconnectMsg
27− | IgnoreMsg
28− | UnimplementedMsg
29− | DebugMsg
30− | ServiceRequestMsg
31− | ServiceAcceptMsg
32− | KextInitMsg
33− | NewKeysMsg
34− deriving (Eq, Show, Ord)
35−
36−instance ToIsoparsec MessageNumber ByteString a where
37− toIsoparsec =
38− delist $
39− anyToken
40− ~> mapIso
41− [ (1 :: Word8, DisconnectMsg),
42− (2, IgnoreMsg),
43− (3, UnimplementedMsg),
44− (4, DebugMsg),
45− (5, ServiceRequestMsg),
46− (6, ServiceAcceptMsg),
47− (20, KextInitMsg),
48− (21, NewKeysMsg)
49− ]
50−
51−newtype DisconnectReasonCode
52− = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}
53− deriving (Eq, Ord, Show, Generic, Arbitrary)
54−
55−instance ToIsoparsec DisconnectReasonCode ByteString a
56−
57−newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}
58− deriving (Eq, Ord, Show, Generic, Arbitrary)
59−
60−instance ToIsoparsec AlwaysDisplay ByteString a
61−
62−newtype PacketSequenceNumber
63− = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}
64− deriving (Eq, Ord, Show, Generic, Arbitrary)
65−
66−instance ToIsoparsec PacketSequenceNumber ByteString a
67−
68−data Payload
69− = VersionPayload String
70− | IgnorePayload ByteString
71− | ServiceRequest SSHString
72− | DebugPayload AlwaysDisplay SSHString
73− | DisconnectPayload DisconnectReasonCode String
74− | ServiceAccept SSHString
75− | UnimplementedPayload PacketSequenceNumber
76− deriving (Show, Eq)
77−
78−instance Arbitrary Payload where
79− arbitrary =
80− oneof
81− [ VersionPayload . P.filter (not . C.isSpace) <$> s,
82− IgnorePayload <$> arbitrary,
83− ServiceRequest . SSHString <$> s,
84− DebugPayload <$> arbitrary <*> (SSHString <$> s),
85− DisconnectPayload <$> arbitrary <*> s,
86− ServiceAccept . SSHString <$> s,
87− UnimplementedPayload <$> arbitrary
88− ]
89− where
90− s = getASCIIString <$> arbitrary
91−
92−makePrisms ''Payload
93−
94−instance ToIsoparsec Payload ByteString a where
95− toIsoparsec =
96− delist $
97− specific DisconnectMsg ~> auto @DisconnectReasonCode
98− ~& tokensWhile (const True)
99− ~>^ utf8
100− ~$> _DisconnectPayload
101− ~| specific ServiceRequestMsg ~> auto @SSHString ~$> _ServiceRequest
102− ~| chunk "SSH-2.0-"
103− ~> tokensWhile (`BS.notElem` " \n\r")
104− ~>^ utf8
105− ~> ( chunk " " ~> takeUntil "\r\n" ~>^ (maskr . turn . konst $ ("" :: ByteString))
106− ~| chunk "\r\n"
107− )
108− ~$> _VersionPayload
109− ~| specific IgnoreMsg ~> tokensWhile (const True) ~$> _IgnorePayload
110− ~| specific DebugMsg ~> auto @AlwaysDisplay
111− ~& auto @SSHString
112− ~$> _DebugPayload
113− ~| specific UnimplementedMsg ~> auto @PacketSequenceNumber ~$> _UnimplementedPayload
114− ~| specific ServiceAcceptMsg ~> auto @SSHString ~$> _ServiceAccept
115−
116−newtype Padding = Padding {unPadding :: ByteString}
117− deriving (Eq, Ord, Show, Generic, Arbitrary)
118−
119−newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
120− deriving (Eq, Ord, Show, Generic, Arbitrary)
121−
122−badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
123−badZeroPadding =
124− delist $
125− throughIntegral
126− ^~> manyTokens
127− ~>^ siPure
128− (ZeroPadding . fromIntegral . BS.length)
129− (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
130−
131−newtype MAC = MAC {unMAC :: ByteString}
132− deriving (Eq, Ord, Show, Generic, Arbitrary)
133−
134−data NoneMAC = NoneMAC
135− deriving (Eq, Ord, Show, Generic)
136−
137−instance ToIsoparsec NoneMAC b a where
138− toIsoparsec = arr $ konst NoneMAC
139−
140−instance Arbitrary NoneMAC where
141− arbitrary = return NoneMAC
142−
143−data Packet mac
144− = Packet Payload ZeroPadding mac
145− deriving (Eq, Show)
146−
147−instance Arbitrary mac => Arbitrary (Packet mac) where
148− arbitrary = Packet <$> arbitrary <*> arbitrary <*> arbitrary
149−
150−makePrisms ''Packet
151−
152−instance ToIsoparsec (Packet NoneMAC) ByteString a where
153− toIsoparsec =
154− delist $
155− ( ( (auto @(Byte32 'BE) ~* anyToken)
156− ~> (arr (throughIntegral @(Byte32 'BE) @Natural) ~* arr (throughIntegral @Byte8 @Natural))
157− ~>^ siPure
158− (\(packetL, paddingL :: Natural) -> (packetL - paddingL - 1 :: Natural, paddingL :: Natural))
159− (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
160− ~> (manyTokens ~* arr (throughIntegral @Natural @Byte8))
161− ~> (tuck (auto @Payload) ~* badZeroPadding)
162− )
163− ~& auto @NoneMAC
164− )
165− ~$> _Packet
166−
167−spec :: Spec
168−spec = do
169− it "deserialize payload" $ do
170− "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"
171− "SSH-2.0-TesT" `parseSatisfyBS` isLeft @_ @Payload
172− "SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"
173− "SSH-2.0-TesT random comment" `parseSatisfyBS` isLeft @_ @Payload
174− "\x2__" `shouldParseBS` IgnorePayload "__"
175− "\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")
176− it "deserialize packet" $ do
177− ("\0\0\0\xd" <> "\x2" <> "\x5\0\0\0\x5henlo" <> "69")
178− `shouldParseBS` Packet (ServiceRequest (SSHString "henlo")) (ZeroPadding 2) NoneMAC
179− ("\0\0\0\xd" <> "\x2" <> "\x2\0\0\0\x5henlo" <> "69")
180− `shouldParseBS` Packet (IgnorePayload "\0\0\0\x5henlo") (ZeroPadding 2) NoneMAC
181− ("\0\0\0\xd" <> "\x3" <> "\x2\0\0henlo!" <> "69a")
182− `shouldParseBS` Packet (IgnorePayload "\0\0henlo!") (ZeroPadding 3) NoneMAC
183− ("\0\0\0\xb" <> "\x3" <> "\x2henlo!" <> "69a")
184− `shouldParseBS` Packet (IgnorePayload "henlo!") (ZeroPadding 3) NoneMAC
185−
186−quickSpec :: TestTree
187−quickSpec =
188− testGroup
189− "roundtrips"
190− [ testProperty "payload" $ roundtrip @Payload @ByteString,
191− testProperty "packet" $ roundtrip @(Packet NoneMAC) @ByteString
192− ]
test/Spec/TwoDigits.hsdeleted−70
@@ -1,70 +0,0 @@
1−module Spec.TwoDigits
2− ( spec,
3− quickSpec,
4− )
5−where
6−
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