git.iko.soy/isoparsec
on master help sign in
swap
04fff3e22 ahead, 0 behind
37 files changed+1517−551
since splitsnapshots
unifiedsplit
.github/workflows/haskell.yml+2−2 .gitignore+1 .hlint.yaml+105−1 README.md+6−1 isoparsec.cabal−113 package.yaml+2−1 src/Control/Arrow/Extra.hs+7−7 src/Control/Arrow/Extra/BaseArrow.hs+13−1 src/Control/Arrow/Extra/Orphans.hs+1−1 src/Control/Arrow/Extra/PolyArrow.hs+10−11 src/Control/Arrow/Reader.hs+34 src/Control/Arrow/Trans/Class.hs+9 src/Control/Arrow/Trans/Reader.hs+53 src/Data/Isoparsec/Cokleisli.hs → src/Control/Cokleisli.hs+5−7 src/Control/Prism.hs+3−1 src/Control/SemiIso.hs+122 src/Control/Tuple/Morph.hs+179−4 src/Data/Isoparsec.hs+252−97 src/Data/Isoparsec/ByteString.hs+22−31 src/Data/Isoparsec/Char.hs+7−7 src/Data/Isoparsec/Chunks.hs+2−2 src/Data/Isoparsec/Internal.hs+76−91 src/Data/Isoparsec/Megaparsec.hs+57−20 src/Data/Isoparsec/Printer.hs+64−20 src/Data/Isoparsec/ToIsoparsec.hs+12−17 src/Data/Isoparsec/Tokenable.hs−24 stack.yaml+1−6 test/Spec.hs+23−1 test/Spec/BasicReader.hs+38 test/Spec/Helper.hs+50−10 test/Spec/JSON.hs+27−23 test/Spec/JSONHList.hs+92 test/Spec/Megaparsec/BasicNums.hs+5−6 test/Spec/Orphans.hs+3−3 test/Spec/Ssh.hs+27−27 test/Spec/SshHList.hs+192 test/Spec/TwoDigits.hs+15−16
.github/workflows/haskell.yml+2−2
@@ -9,7 +9,7 @@ jobs:
99
1010 strategy:
1111 matrix:
12− resolver: [lts-13.11, lts-13.19, lts-14, nightly]
12+ resolver: [lts-13.11, lts-13.19, lts-14.27, lts-15, nightly]
1313
1414 steps:
1515 - uses: actions/checkout@v1
@@ -29,6 +29,6 @@ jobs:
2929 stack test --fast --pedantic --ghc-options '-j' --resolver=${{ matrix.resolver }}
3030
3131 - name: Weeder
32− if: matrix.resolver == 'lts-14'
32+ if: matrix.resolver == 'lts-15'
3333 run: |
3434 curl -sSL https://raw.github.com/ndmitchell/weeder/master/misc/run.sh | sh -s . --build
.gitignore+1
@@ -20,3 +20,4 @@ cabal.project.local
2020cabal.project.local~
2121.HTF/
2222.ghc.environment.*
23+*.cabal
.hlint.yaml+105−1
@@ -52,7 +52,7 @@
5252# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
5353
5454
55−# Define some custom infix operators
55+# Define some custom fixity operators
5656# - fixity: infixr 3 ~^#^~
5757
5858
@@ -85,3 +85,107 @@
8585 - -XTypeOperators
8686 - -XUndecidableInstances
8787 - -XRankNTypes
88+
89+# hints found in src/Control/SemiIso.hs
90+- warn: {lhs: "SI (pure . a) (pure . b)", rhs: "siPure a b"}
91+- warn: {lhs: "SemiIso (pure . a) (pure . b)", rhs: "siPure a b"}
92+- warn: {lhs: "SemiIso (const empty) (const empty)", rhs: "zeroArrow"}
93+
94+# hints found in src/Control/Arrow/Extra.hs
95+- fixity: "infixl 5 <+^"
96+- fixity: "infixl 5 ^+>"
97+- fixity: "infixl 5 ^+^"
98+- warn: {lhs: "a <+> arr b", rhs: "a <+^ b"}
99+- warn: {lhs: "arr a <+> b", rhs: "a ^+> b"}
100+- warn: {lhs: "arr a <+> arr b", rhs: "a ^+^ b"}
101+
102+# hints found in src/Control/Arrow/Extra/ArrowChoice.hs
103+- fixity: "infixl 2 +++"
104+- fixity: "infixl 2 |||"
105+
106+# hints found in src/Control/Arrow/Extra/ArrowPlus.hs
107+- fixity: "infixl 5 <+>"
108+
109+# hints found in src/Control/Arrow/Extra/ArrowZero.hs
110+# no hints found
111+
112+# hints found in src/Control/Arrow/Extra/BaseArrow.hs
113+- fixity: "infixl 3 ***"
114+- fixity: "infixl 3 &&&"
115+- fixity: "infixl 1 >>>"
116+- fixity: "infixl 1 <<<"
117+
118+# hints found in src/Control/Arrow/Extra/Orphans.hs
119+# no hints found
120+
121+# hints found in src/Control/Arrow/Extra/PolyArrow.hs
122+- fixity: "infixl 1 ^>>"
123+- fixity: "infixl 1 >>^"
124+- fixity: "infixl 1 ^<<"
125+- fixity: "infixl 1 <<^"
126+- fixity: "infixl 1 ^>^"
127+- fixity: "infixl 1 ^<^"
128+- warn: {lhs: "arr a >>> arr b", rhs: "a ^>^ b"}
129+- warn: {lhs: "arr a <<< arr b", rhs: "a ^<^ b"}
130+- warn: {lhs: "arr a >>> b", rhs: "a ^>> b"}
131+- warn: {lhs: "a >>> arr b", rhs: "a >>^ b"}
132+- warn: {lhs: "a <<< arr b", rhs: "a <<^ b"}
133+- warn: {lhs: "arr a <<< b", rhs: "a ^<< b"}
134+
135+# hints found in src/Data/Isoparsec.hs
136+- warn: {lhs: "a <+^ konst ()", rhs: "opt a"}
137+- warn: {lhs: "opt (b >>^ turn (konst a))", rhs: "opt' a b"}
138+- warn: {lhs: "(a &&& (repeating a <+^ konst [])) >>^ siCons", rhs: "repeating a"}
139+- warn: {lhs: "sepBy1 a b <+^ konst []", rhs: "sepBy a b"}
140+- warn: {lhs: "(b &&& repeating (a *>> b) <+^ konst []) >>^ siCons", rhs: "sepBy1 a b"}
141+- fixity: "infixl 0 <.>"
142+- warn: {lhs: "(b >>^ morphed) >>^ siPrism a", rhs: "a <.> b"}
143+- warn: {lhs: "withPrism a\n (\\ x y -> SemiIso (pure . x) (either (const empty) pure . y))", rhs: "siPrism a"}
144+- fixity: "infixl 8 ~>"
145+- fixity: "infixl 8 ~>^"
146+- fixity: "infixl 8 ^~>"
147+- fixity: "infixl 8 ^~>^"
148+- warn: {lhs: "turn siHFst ^>> (enlist a *** enlist b) >>^ siHFst", rhs: "a ~> b"}
149+- warn: {lhs: "siPure fst (, HNil)", rhs: "siHFst"}
150+- fixity: "infixl 5 ~|"
151+- warn: {lhs: "enlist a <+> enlist b", rhs: "a ~| b"}
152+- fixity: "infixl 7 ~&"
153+- warn: {lhs: "(enlist a &&& enlist b) >>^ consHList", rhs: "a ~& b"}
154+- fixity: "infixl 9 ~*"
155+- warn: {lhs: "turn consHList ^>> (enlist a *** enlist b) >>^ consHList", rhs: "a ~* b"}
156+- fixity: "infixl 6 ~$>"
157+- warn: {lhs: "enlist a >>> enlist (arr (siPrism b))", rhs: "a ~$> b"}
158+- warn: {lhs: "turn fMorphed ^>>\n (a (fMorphed ^>> b >>^ turn fMorphed)) >>^ fMorphed", rhs: "hmap a b"}
159+- warn: {lhs: "siPure coerce coerce", rhs: "coercing"}
160+- warn: {lhs: "siPure morphTuples morphTuples", rhs: "morphed"}
161+- warn: {lhs: "siPure flatUnmorph flatMorph", rhs: "fMorphed"}
162+- warn: {lhs: "turn fMorphed ^>> a >>^ fMorphed", rhs: "enlist a"}
163+- warn: {lhs: "fMorphed ^>> a >>^ turn fMorphed", rhs: "delist a"}
164+- warn: {lhs: "siPure (uncurry (++:))\n (\\ c -> (hTake @(Length a) Proxy c, hDrop @(Length a) Proxy c))", rhs: "consHList"}
165+- warn: {lhs: "auto @x >>^ turn (konst a)", rhs: "specific a"}
166+- warn: {lhs: "siPure fromIntegral fromIntegral", rhs: "throughIntegral"}
167+
168+# hints found in src/Data/Isoparsec/ByteString.hs
169+- warn: {lhs: "arr (siPure C.unpack C.pack)", rhs: "utf8"}
170+- warn: {lhs: "bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte16 e) @Word16", rhs: "toIsoparsec"}
171+- warn: {lhs: "bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte32 e) @Word32", rhs: "toIsoparsec"}
172+- warn: {lhs: "bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte64 e) @Word64", rhs: "toIsoparsec"}
173+- warn: {lhs: "anyToken >>> mapIso [(0, False), (1, True)]", rhs: "toIsoparsec"}
174+
175+# hints found in src/Data/Isoparsec/Char.hs
176+- warn: {lhs: "token ' '", rhs: "space"}
177+- warn: {lhs: "tokensWhile isSpace >>^ ((maskr . turn . konst) mempty)", rhs: "unsafeWhiteSpace"}
178+- warn: {lhs: "tokensWhile1 isSpace >>^ ((maskr . turn . konst) (singleton ' '))", rhs: "unsafeWhiteSpace1"}
179+
180+# hints found in src/Data/Isoparsec/Cokleisli.hs
181+- warn: {lhs: "Cokleisli\n (\\ t ->\n case project a t of\n Just x -> return x\n Nothing -> mzero)", rhs: "arr a"}
182+- warn: {lhs: "Cokleisli (const mzero)", rhs: "zeroArrow"}
183+
184+# hints found in src/Data/Isoparsec/Internal.hs
185+- warn: {lhs: "((a &&& arrowsWhile a) >>^ siCons) <+^ isoConst () []", rhs: "arrowsWhile a"}
186+- warn: {lhs: "siMaybe (pure . uncurry cons) uncons", rhs: "siCons"}
187+- warn: {lhs: "SI (\\ c -> guard (a c) >> b c)\n (c >=> (\\ c -> guard (a c) >> pure c))", rhs: "siCheck a b c"}
188+- warn: {lhs: "siCheck a (pure . b) (pure . c)", rhs: "isoCheck a b c"}
189+- warn: {lhs: "SI (const (pure b)) (const (pure a))", rhs: "isoConst a b"}
190+- warn: {lhs: "isoCheck a id id", rhs: "check a"}
191+- warn: {lhs: "SI (const (pure a)) (const (pure ())) >>> check (== a)", rhs: "konst a"}
README.md+6−1
@@ -1,2 +1,7 @@
1−# isoparsec ![](https://github.com/ilyakooo0/isoparsec/workflows/Haskell%20CI/badge.svg)
1+# 🔄 🔡 isoparsec ![](https://github.com/ilyakooo0/isoparsec/workflows/Haskell%20CI/badge.svg)
2+
23Isomorphic (invertible) parser library
4+
5+### 🚧 Under construction 🚧
6+
7+![](https://media.giphy.com/media/xDQ3Oql1BN54c/giphy.gif)
isoparsec.cabaldeleted−113
@@ -1,113 +0,0 @@
1−cabal-version: 1.12
2−
3−-- This file has been generated from package.yaml by hpack version 0.31.2.
4−--
5−-- see: https://github.com/sol/hpack
6−--
7−-- hash: 2b8bf0f1dd722fe9b761b465eeaa17ff976877aa7a5c517e092915bdc90158d7
8−
9−name: isoparsec
10−version: 0.1.0.0
11−description: Please see the README on GitHub at <https://github.com/ilyakooo0/isoparsec#readme>
12−homepage: https://github.com/ilyakooo0/isoparsec#readme
13−bug-reports: https://github.com/ilyakooo0/isoparsec/issues
14−author: Ilya Kostyuchenko
15−maintainer: ilyakooo0@gmail.com
16−copyright: 2019 Ilya Kostyuchenko
17−license: MIT
18−license-file: LICENSE
19−build-type: Simple
20−extra-source-files:
21− README.md
22− ChangeLog.md
23−
24−source-repository head
25− type: git
26− location: https://github.com/ilyakooo0/isoparsec
27−
28−library
29− exposed-modules:
30− Control.Arrow.Extra
31− Control.Arrow.Extra.ArrowChoice
32− Control.Arrow.Extra.ArrowPlus
33− Control.Arrow.Extra.ArrowZero
34− Control.Arrow.Extra.BaseArrow
35− Control.Arrow.Extra.Orphans
36− Control.Arrow.Extra.PolyArrow
37− Control.SemiIso
38− Control.Tuple.Morph
39− Data.Isoparsec
40− Data.Isoparsec.ByteString
41− Data.Isoparsec.Char
42− Data.Isoparsec.Chunks
43− Data.Isoparsec.Cokleisli
44− Data.Isoparsec.Internal
45− Data.Isoparsec.Megaparsec
46− Data.Isoparsec.Printer
47− Data.Isoparsec.ToIsoparsec
48− Data.Isoparsec.Tokenable
49− other-modules:
50− Control.Prism
51− hs-source-dirs:
52− src
53− default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DefaultSignatures DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances RankNTypes
54− build-depends:
55− base >=4.7 && <5
56− , bytestring
57− , containers
58− , megaparsec
59− , mtl
60− , profunctors
61− default-language: Haskell2010
62−
63−test-suite isoparsec-test
64− type: exitcode-stdio-1.0
65− main-is: Spec.hs
66− other-modules:
67− Spec.Helper
68− Spec.JSON
69− Spec.Megaparsec.BasicNums
70− Spec.Orphans
71− Spec.Ssh
72− Spec.TwoDigits
73− Control.Arrow.Extra
74− Control.Arrow.Extra.ArrowChoice
75− Control.Arrow.Extra.ArrowPlus
76− Control.Arrow.Extra.ArrowZero
77− Control.Arrow.Extra.BaseArrow
78− Control.Arrow.Extra.Orphans
79− Control.Arrow.Extra.PolyArrow
80− Control.Prism
81− Control.SemiIso
82− Control.Tuple.Morph
83− Data.Isoparsec
84− Data.Isoparsec.ByteString
85− Data.Isoparsec.Char
86− Data.Isoparsec.Chunks
87− Data.Isoparsec.Cokleisli
88− Data.Isoparsec.Internal
89− Data.Isoparsec.Megaparsec
90− Data.Isoparsec.Printer
91− Data.Isoparsec.ToIsoparsec
92− Data.Isoparsec.Tokenable
93− Paths_isoparsec
94− hs-source-dirs:
95− test
96− src
97− default-extensions: AllowAmbiguousTypes ConstraintKinds DataKinds DefaultSignatures DeriveGeneric FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses OverloadedStrings PatternSynonyms PolyKinds ScopedTypeVariables StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeOperators UndecidableInstances RankNTypes
98− ghc-options: -threaded -rtsopts -with-rtsopts=-N
99− build-depends:
100− QuickCheck
101− , base >=4.7 && <5
102− , bytestring
103− , containers
104− , hspec
105− , lens
106− , megaparsec
107− , mtl
108− , profunctors
109− , tasty
110− , tasty-hspec
111− , tasty-quickcheck
112− , word8
113− default-language: Haskell2010
package.yaml+2−1
@@ -27,6 +27,8 @@ dependencies:
2727# - text
2828- mtl
2929- profunctors
30+- mono-traversable
31+- split
3032
3133library:
3234 source-dirs: src
@@ -77,4 +79,3 @@ tests:
7779 - QuickCheck
7880 - megaparsec
7981 - bytestring
80− - word8
src/Control/Arrow/Extra.hs+7−7
@@ -14,19 +14,19 @@ import Control.Arrow.Extra.ArrowPlus as X
1414import Control.Arrow.Extra.ArrowZero as X
1515import Control.Arrow.Extra.BaseArrow as X
1616import Control.Arrow.Extra.PolyArrow as X
17−import Control.Category as X
17+import Control.Category as X hiding ((<<<), (>>>))
1818
19−infixr 5 <+^
19+infixl 5 <+^
2020
21−infixr 5 ^+>
21+infixl 5 ^+>
2222
23−infixr 5 ^+^
23+infixl 5 ^+^
2424
25−(<+^) :: (ArrowPlus a, PolyArrow a p) => a b c -> p b c -> a b c
25+(<+^) :: (ArrowPlus a, PolyArrow p a) => a b c -> p b c -> a b c
2626a <+^ b = a <+> arr b
2727
28−(^+>) :: (ArrowPlus a, PolyArrow a p) => p b c -> a b c -> a b c
28+(^+>) :: (ArrowPlus a, PolyArrow p a) => p b c -> a b c -> a b c
2929a ^+> b = arr a <+> b
3030
31−(^+^) :: (ArrowPlus a, PolyArrow a p) => p b c -> p b c -> a b c
31+(^+^) :: (ArrowPlus a, PolyArrow p a) => p b c -> p b c -> a b c
3232a ^+^ b = arr a <+> arr b
src/Control/Arrow/Extra/BaseArrow.hs+13−1
@@ -2,10 +2,12 @@
22
33module Control.Arrow.Extra.BaseArrow
44 ( BaseArrow (..),
5+ (>>>),
6+ (<<<),
57 )
68where
79
8−import Control.Category
10+import Control.Category hiding ((<<<), (>>>))
911
1012infixl 3 ***
1113
@@ -23,3 +25,13 @@ class Category a => BaseArrow a where
2325 (***) :: a b c -> a b' c' -> a (b, b') (c, c')
2426
2527 (&&&) :: a b c -> a b c' -> a b (c, c')
28+
29+infixl 1 >>>
30+
31+(>>>) :: Category cat => cat a b -> cat b c -> cat a c
32+x >>> y = y . x
33+
34+infixl 1 <<<
35+
36+(<<<) :: Category cat => cat b c -> cat a b -> cat a c
37+x <<< y = x . y
src/Control/Arrow/Extra/Orphans.hs+1−1
@@ -29,7 +29,7 @@ instance {-# OVERLAPPABLE #-} (Category a, A.Arrow a) => BaseArrow a where
2929
3030 (&&&) = (A.&&&)
3131
32−instance A.Arrow a => PolyArrow a (->) where
32+instance A.Arrow a => PolyArrow (->) a where
3333 arr = A.arr
3434
3535instance {-# OVERLAPPABLE #-} A.ArrowPlus a => ArrowPlus a where
src/Control/Arrow/Extra/PolyArrow.hs+10−11
@@ -10,31 +10,30 @@ module Control.Arrow.Extra.PolyArrow
1010where
1111
1212import Control.Arrow.Extra.BaseArrow
13−import Control.Category
1413
15−infixr 1 ^>>, >>^
14+infixl 1 ^>>, >>^
1615
17−infixr 1 ^<<, <<^
16+infixl 1 ^<<, <<^
1817
19−infixr 1 ^>^, ^<^
18+infixl 1 ^>^, ^<^
2019
21−class BaseArrow a => PolyArrow a p where
20+class BaseArrow a => PolyArrow p a where
2221 arr :: p b c -> a b c
2322
24−(^>>) :: PolyArrow a p => p b c -> a c d -> a b d
23+(^>>) :: PolyArrow p a => p b c -> a c d -> a b d
2524f ^>> a = arr f >>> a
2625
27−(>>^) :: PolyArrow a p => a b c -> p c d -> a b d
26+(>>^) :: PolyArrow p a => a b c -> p c d -> a b d
2827a >>^ f = a >>> arr f
2928
30−(<<^) :: PolyArrow a p => a c d -> p b c -> a b d
29+(<<^) :: PolyArrow p a => a c d -> p b c -> a b d
3130a <<^ f = a <<< arr f
3231
33−(^<<) :: PolyArrow a p => p c d -> a b c -> a b d
32+(^<<) :: PolyArrow p a => p c d -> a b c -> a b d
3433f ^<< a = arr f <<< a
3534
36−(^>^) :: PolyArrow a p => p b c -> p c d -> a b d
35+(^>^) :: PolyArrow p a => p b c -> p c d -> a b d
3736a ^>^ b = arr a >>> arr b
3837
39−(^<^) :: PolyArrow a p => p c d -> p b c -> a b d
38+(^<^) :: PolyArrow p a => p c d -> p b c -> a b d
4039a ^<^ b = arr a <<< arr b
src/Control/Arrow/Reader.hsnew file+34
@@ -0,0 +1,34 @@
1+module Control.Arrow.Reader
2+ ( ArrowReader (..),
3+ asksr,
4+ asksl,
5+ biask,
6+ biasks,
7+ module Control.Arrow.Trans.Reader,
8+ )
9+where
10+
11+import Control.Arrow.Extra
12+import Control.Arrow.Trans.Reader
13+import Control.SemiIso
14+import Prelude hiding ((.), id)
15+
16+class ArrowReader r a where
17+ askr :: a () r
18+ askl :: a r ()
19+
20+instance (PolyArrow SemiIso a, Eq r) => ArrowReader r (ReaderArrow r a) where
21+ askr = ReaderArrow . arr $ siFst >>> siDouble
22+ askl = ReaderArrow . arr $ turn siDouble >>> turn siFst
23+
24+asksr :: (PolyArrow SemiIso a, ArrowReader r a) => SemiIso r s -> a () s
25+asksr si = askr >>^ si
26+
27+asksl :: (PolyArrow SemiIso a, ArrowReader r a) => SemiIso r s -> a s ()
28+asksl si = turn si ^>> askl
29+
30+biask :: (ArrowReader r a, Category a) => a r r -> a () ()
31+biask a = askr >>> a >>> askl
32+
33+biasks :: (ArrowReader r a, PolyArrow SemiIso a) => SemiIso r s -> a s s -> a () ()
34+biasks si a = asksr si >>> a >>> asksl si
src/Control/Arrow/Trans/Class.hsnew file+9
@@ -0,0 +1,9 @@
1+module Control.Arrow.Trans.Class
2+ ( ArrowTrans (..),
3+ )
4+where
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.hsnew file+53
@@ -0,0 +1,53 @@
1+module Control.Arrow.Trans.Reader
2+ ( ReaderArrow (..),
3+ runReaderArrow,
4+ module Control.Arrow.Trans.Class,
5+ )
6+where
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/Data/Isoparsec/Cokleisli.hs → src/Control/Cokleisli.hsrenamed+5−7
@@ -1,4 +1,4 @@
1−module Data.Isoparsec.Cokleisli
1+module Control.Cokleisli
22 ( Cokleisli (..),
33 )
44where
@@ -6,10 +6,10 @@ where
66import Control.Applicative
77import Control.Arrow.Extra
88import Control.Monad
9−import Data.Isoparsec.Internal
9+import Control.SemiIso
1010import Prelude hiding ((.))
1111
12−newtype Cokleisli m a b = Cokleisli {unCokleisli :: b -> m a}
12+newtype Cokleisli m a b = Cokleisli {runCokleisli :: b -> m a}
1313
1414instance Monad m => Category (Cokleisli m) where
1515 id = Cokleisli return
@@ -26,10 +26,8 @@ instance (Alternative m, Monad m) => BaseArrow (Cokleisli m) where
2626 (Cokleisli cb) &&& (Cokleisli c'b) = Cokleisli $
2727 \(c, c') -> c'b c' >> cb c
2828
29−instance MonadPlus m => PolyArrow (Cokleisli m) SemiIso where
30− arr si = Cokleisli $ \t -> case project si t of
31− Just x -> return x
32− Nothing -> mzero
29+instance (Alternative m, Monad m) => PolyArrow SemiIso (Cokleisli m) where
30+ arr si = Cokleisli $ \t -> project si t
3331
3432instance MonadPlus m => ArrowZero (Cokleisli m) where
3533 zeroArrow = Cokleisli $ const mzero
src/Control/Prism.hs+3−1
@@ -1,7 +1,7 @@
11module Control.Prism
22 ( withPrism,
3− Market,
43 Identity,
4+ Prism',
55 )
66where
77
@@ -9,6 +9,8 @@ import Data.Coerce
99import Data.Functor.Identity
1010import Data.Profunctor
1111
12+type Prism' a b = Market a a a (Identity a) -> Market a a b (Identity b)
13+
1214data Market a b s t = Market (b -> t) (s -> Either t a)
1315
1416instance Functor (Market a b s) where
src/Control/SemiIso.hs+122
@@ -7,13 +7,42 @@ module Control.SemiIso
77 turn,
88 withSemiIso,
99 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,
1037 )
1138where
1239
1340import Control.Applicative as X
1441import Control.Arrow.Extra
1542import Control.Monad as X
43+import qualified Data.Bifunctor as Bi
1644import Data.Bitraversable
45+import Data.Tuple
1746import Prelude hiding ((.), id)
1847
1948type AlternativeMonad m = (Alternative m, Monad m)
@@ -82,3 +111,96 @@ withSemiIso ::
82111 ((a -> f b) -> (b -> f a) -> c) ->
83112 c
84113withSemiIso (SemiIso a b) f = f a b
114+
115+maskr :: SemiIso a () -> SemiIso a ()
116+maskr (SemiIso e p) = SemiIso (\a -> e a <|> pure ()) p
117+
118+maskl :: SemiIso () b -> SemiIso () b
119+maskl (SemiIso e p) = SemiIso e (\b -> p b <|> pure ())
120+
121+infixl 1 *>>, **>, >>*, >**, <<*, <**, *<<, **<
122+
123+infixl 3 $$$
124+
125+($$$) :: (PolyArrow SemiIso m, Eq b) => m a b -> m c b -> m (a, c) b
126+a $$$ c = a *** c >>^ turn siDouble
127+
128+(*>>) :: (PolyArrow SemiIso m) => m a () -> m a b -> m a b
129+a *>> b = a &&& b >>^ siSnd
130+
131+(&>>) :: (PolyArrow SemiIso m) => m a () -> m b c -> m (a, b) c
132+a &>> b = a *** b >>^ siSnd
133+
134+(**>) :: (PolyArrow SemiIso m) => m () () -> m a b -> m a b
135+a **> b = turn siSnd ^>> a *** b >>^ siSnd
136+
137+(>>*) :: (PolyArrow SemiIso m, Eq b) => m a b -> m () b -> m a b
138+a >>* b = turn siFst ^>> a $$$ b
139+
140+(>>&) :: (PolyArrow SemiIso m) => m a b -> m () c -> m a (b, c)
141+a >>& b = turn siFst ^>> a *** b
142+
143+(>**) :: (PolyArrow SemiIso m) => m a b -> m () () -> m a b
144+a >** b = turn siFst ^>> a *** b >>^ siFst
145+
146+(<<*) :: (PolyArrow SemiIso m, Eq b) => m a b -> m () b -> m a b
147+a <<* b = turn siSnd ^>> b $$$ a
148+
149+(<<&) :: (PolyArrow SemiIso m) => m a b -> m () c -> m a (b, c)
150+a <<& b = turn siSnd ^>> b *** a >>^ siSwap
151+
152+(<**) :: (PolyArrow SemiIso m) => m a b -> m () () -> m a b
153+a <** b = turn siSnd ^>> b *** a >>^ siSnd
154+
155+(*<<) :: (PolyArrow SemiIso m) => m a () -> m a b -> m a b
156+a *<< b = b &&& a >>^ siFst
157+
158+(&<<) :: (PolyArrow SemiIso m) => m a () -> m b c -> m (a, b) c
159+a &<< b = siSwap ^>> b *** a >>^ siFst
160+
161+(**<) :: (PolyArrow SemiIso m) => m () () -> m a b -> m a b
162+a **< b = turn siFst ^>> b *** a >>^ siFst
163+
164+check :: (s -> Bool) -> SemiIso s s
165+check f = isoCheck f id id
166+
167+siCheck ::
168+ (s -> Bool) ->
169+ (forall f. AlternativeMonad f => s -> f a) ->
170+ (forall f. AlternativeMonad f => a -> f s) ->
171+ SemiIso s a
172+siCheck f a b =
173+ SI
174+ (\c -> guard (f c) >> a c)
175+ (b >=> (\c -> guard (f c) >> pure c))
176+
177+isoCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso s a
178+isoCheck f a b = siCheck f (pure . a) (pure . b)
179+
180+isoConst :: s -> a -> SemiIso s a
181+isoConst s a = SI (const $ pure a) (const $ pure s)
182+
183+konst :: Eq x => x -> SemiIso () x
184+konst x = isoConst () x >>> check (== x)
185+
186+assoc :: SemiIso (a, (b, c)) ((a, b), c)
187+assoc = siPure (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))
188+
189+siFst :: SemiIso (a, ()) a
190+siFst = siPure fst (,())
191+
192+siSnd :: SemiIso ((), a) a
193+siSnd = siPure snd ((),)
194+
195+siDouble :: (Eq a) => SemiIso a (a, a)
196+siDouble = siPure (\x -> (x, x)) fst >>> check (uncurry (==))
197+
198+siSwap :: SemiIso (a, b) (b, a)
199+siSwap = siPure swap swap
200+
201+siTranspose2 :: SemiIso ((a, b), (c, d)) ((a, c), (b, d))
202+siTranspose2 =
203+ siPure (\((r1, b), (r2, c)) -> ((r1, r2), (b, c))) (\((r1, r2), (b, c)) -> ((r1, b), (r2, c)))
204+
205+siSequenceEither :: SemiIso (r, Either a b) (Either (r, a) (r, b))
206+siSequenceEither = siPure (\(r, e) -> Bi.bimap (r,) (r,) e) (either (Bi.second Left) (Bi.second Right))
src/Control/Tuple/Morph.hs+179−4
@@ -7,11 +7,22 @@ module Control.Tuple.Morph
77 TupleMorphable,
88 CheckListsForTupleIso,
99 ReorderList,
10+ FlatMorphable (..),
11+ TupleHListContents,
12+ HListContentsTuple,
13+ Nat (..),
14+ HList (..),
15+ AppendableList (..),
16+ DroppableList (..),
17+ TakeableList (..),
18+ Length,
19+ Proxy (..),
1020 )
1121where
1222
1323import Data.Kind
1424import Data.Proxy
25+import Data.Type.Equality
1526import GHC.Generics
1627import GHC.TypeLits hiding (Nat)
1728
@@ -60,7 +71,7 @@ data HList (ts :: [*]) where
6071 HCons :: t -> HList tt -> HList (t ': tt)
6172 HNil :: HList '[]
6273
63−infixr 5 :+
74+infixl 5 :+
6475
6576pattern (:+) :: (ts ~ (t : tt)) => t -> HList tt -> HList ts
6677pattern (:+) a b = HCons a b
@@ -92,10 +103,16 @@ instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where
92103
93104-- ## Appending
94105
95−infixr 4 ++:
106+infixl 4 ++:
96107
97−class AppendableList aa bb cc | aa bb -> cc where
98− (++:) :: HList aa -> HList bb -> HList (aa ++ bb)
108+class
109+ ( (aa ++ bb) ~ cc,
110+ DroppableList (Length aa) cc bb,
111+ TakeableList (Length aa) cc aa
112+ ) =>
113+ AppendableList aa bb cc
114+ | aa bb -> cc where
115+ (++:) :: HList aa -> HList bb -> HList cc
99116
100117instance AppendableList '[] bb bb where
101118 HNil ++: bb = bb
@@ -243,6 +260,33 @@ instance
243260 aa = hTake @(Length a) Proxy cc
244261 bb = hDrop @(Length a) Proxy cc
245262
263+-- ## FlatMorphable
264+
265+class
266+ ( TupleHListContents t ~ th,
267+ flag ~ (t == HList th)
268+ ) =>
269+ FlatMorphable t th flag
270+ | t -> th,
271+ th flag -> t where
272+ flatUnmorph :: t -> HList th
273+ flatMorph :: HList th -> t
274+
275+instance
276+ ( TupleMorphable' t th (IsMophableTuple t),
277+ TupleHListContents t ~ th,
278+ HListContentsTuple th ~ t,
279+ (t == HList th) ~ 'False
280+ ) =>
281+ FlatMorphable t th 'False
282+ where
283+ flatUnmorph = unmorph' (Proxy @(IsMophableTuple t))
284+ flatMorph = morph' (Proxy @(IsMophableTuple t))
285+
286+instance (th == th) ~ 'True => FlatMorphable (HList th) th 'True where
287+ flatMorph = id
288+ flatUnmorph = id
289+
246290-- ## Other
247291
248292type family IsMophableTuple t :: Bool where
@@ -309,3 +353,134 @@ type family IsMophableTuple t :: Bool where
309353 IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2) = 'True
310354 IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = 'True
311355 IsMophableTuple c = 'False
356+
357+type family TupleHListContents t :: [*] where
358+ TupleHListContents (HList ts) = ts
359+ TupleHListContents () = '[]
360+ TupleHListContents (a, b) = '[a, b]
361+ TupleHListContents (a, b, c) = '[a, b, c]
362+ TupleHListContents (a, b, c, d) = '[a, b, c, d]
363+ TupleHListContents (a, b, c, d, e) = '[a, b, c, d, e]
364+ TupleHListContents (a, b, c, d, e, f) = '[a, b, c, d, e, f]
365+ TupleHListContents (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]
366+ TupleHListContents (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]
367+ TupleHListContents (a, b, c, d, e, f, g, h, i) = '[a, b, c, d, e, f, g, h, i]
368+ TupleHListContents (a, b, c, d, e, f, g, h, i, j) = '[a, b, c, d, e, f, g, h, i, j]
369+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k) = '[a, b, c, d, e, f, g, h, i, j, k]
370+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l) = '[a, b, c, d, e, f, g, h, i, j, k, l]
371+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m) = '[a, b, c, d, e, f, g, h, i, j, k, l, m]
372+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n]
373+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o]
374+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p]
375+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q]
376+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r]
377+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s]
378+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t]
379+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u]
380+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v]
381+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w]
382+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x]
383+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y]
384+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z]
385+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1]
386+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1]
387+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1]
388+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1]
389+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1]
390+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1]
391+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1]
392+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1]
393+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1]
394+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1]
395+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1]
396+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1]
397+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1]
398+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1]
399+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1]
400+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1]
401+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1]
402+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1]
403+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1]
404+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1]
405+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1]
406+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1]
407+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1]
408+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1]
409+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1]
410+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1]
411+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2]
412+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2]
413+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2]
414+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2]
415+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2]
416+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2]
417+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2]
418+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2]
419+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2]
420+ TupleHListContents (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2]
421+ TupleHListContents a = '[a]
422+
423+type family HListContentsTuple t :: * where
424+ HListContentsTuple '[] = ()
425+ HListContentsTuple '[a] = a
426+ HListContentsTuple '[a, b] = (a, b)
427+ HListContentsTuple '[a, b, c] = (a, b, c)
428+ HListContentsTuple '[a, b, c, d] = (a, b, c, d)
429+ HListContentsTuple '[a, b, c, d, e] = (a, b, c, d, e)
430+ HListContentsTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)
431+ HListContentsTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)
432+ HListContentsTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)
433+ HListContentsTuple '[a, b, c, d, e, f, g, h, i] = (a, b, c, d, e, f, g, h, i)
434+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j] = (a, b, c, d, e, f, g, h, i, j)
435+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k] = (a, b, c, d, e, f, g, h, i, j, k)
436+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l] = (a, b, c, d, e, f, g, h, i, j, k, l)
437+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m] = (a, b, c, d, e, f, g, h, i, j, k, l, m)
438+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
439+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
440+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p)
441+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q)
442+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r)
443+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s)
444+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t)
445+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u)
446+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v)
447+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w)
448+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x)
449+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y)
450+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z)
451+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1)
452+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1)
453+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1)
454+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1)
455+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1)
456+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1)
457+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1)
458+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1)
459+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1)
460+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1)
461+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1)
462+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1)
463+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1)
464+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1)
465+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1)
466+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1)
467+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1)
468+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1)
469+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1)
470+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1)
471+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1)
472+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1)
473+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1)
474+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1)
475+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1)
476+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1)
477+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2)
478+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2)
479+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2)
480+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2)
481+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2)
482+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2)
483+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2)
484+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2)
485+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2)
486+ HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2] = (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2)
src/Data/Isoparsec.hs+252−97
@@ -2,27 +2,32 @@
22
33module Data.Isoparsec
44 ( module X,
5− -- Isoparsec,
6− (%>>),
7− (%>%),
8− (>>%),
9− (%<<),
10− (%<%),
11− (<<%),
12− (<+%),
13− (%+>),
14− (%+%),
155 (<.>),
16− (<^>),
176 repeating,
7+ sepBy,
8+ sepBy1,
189 opt,
1910 opt',
2011 morphed,
12+ fMorphed,
2113 coercing,
2214 mapIso,
2315 auto,
2416 specific,
2517 throughIntegral,
18+ (~>),
19+ (~>^),
20+ (^~>),
21+ (^~>^),
22+ (~|),
23+ (~$>),
24+ (~&),
25+ (~*),
26+ siPrism,
27+ delist,
28+ enlist,
29+ Listed,
30+ hmap,
2631 )
2732where
2833
@@ -33,99 +38,249 @@ import Data.Coerce
3338import Data.Either
3439import Data.Isoparsec.Internal as X
3540import Data.Isoparsec.ToIsoparsec as X
36−import Data.Isoparsec.Tokenable as X
3741import qualified Data.Map as M
3842import Prelude hiding ((.), fail, id)
3943
40−opt :: (ArrowPlus m, PolyArrow m SemiIso) => m () () -> m () ()
41−opt m = m <+> konst ()
44+opt :: (ArrowPlus m, PolyArrow SemiIso m) => m () () -> m () ()
45+opt m = m <+^ konst ()
4246
43−opt' :: (ArrowPlus m, PolyArrow m SemiIso, Eq a) => a -> m () a -> m () ()
44−opt' a m = (m >>> tsnok a) <+> konst ()
47+opt' :: (ArrowPlus m, PolyArrow SemiIso m, Eq a) => a -> m () a -> m () ()
48+opt' a m = opt (m >>^ turn (konst a))
4549
46−repeating :: (PolyArrow m SemiIso, ArrowPlus m, Eq b) => m () b -> m () [b]
47−repeating m = (m &&& (repeating m <+> konst [])) >>^ cons'
50+repeating :: (PolyArrow SemiIso m, ArrowPlus m, Eq b) => m () b -> m () [b]
51+repeating m = (m &&& (repeating m <+^ konst [])) >>^ siCons
4852
49−infixr 1 %>>
53+sepBy :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]
54+sepBy sep a = sepBy1 sep a <+^ konst []
5055
51−(%>>) :: (PolyArrow a SemiIso, ToSemiIso p b c) => p -> a c d -> a b d
52−p %>> a = si p ^>> a
56+sepBy1 :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]
57+sepBy1 sep a = (a &&& repeating (sep *>> a) <+^ konst []) >>^ siCons
5358
54−infixr 1 %>%
55−
56−(%>%) :: (PolyArrow a SemiIso, ToSemiIso p b c, ToSemiIso p' c d) => p -> p' -> a b d
57−p %>% a = si p ^>^ si a
58−
59−infixr 1 >>%
60−
61−(>>%) :: (PolyArrow a SemiIso, ToSemiIso p c d) => a b c -> p -> a b d
62−p >>% a = p >>^ si a
63−
64−infixr 1 %<<
65−
66−(%<<) :: (PolyArrow a SemiIso, ToSemiIso p c d) => p -> a b c -> a b d
67−p %<< a = si p ^<< a
68−
69−infixr 1 %<%
70−
71−(%<%) :: (PolyArrow a SemiIso, ToSemiIso p c d, ToSemiIso p' b c) => p -> p' -> a b d
72−p %<% a = si p ^<^ si a
73−
74−infixr 1 <<%
75−
76−(<<%) :: (PolyArrow a SemiIso, ToSemiIso p b c) => a c d -> p -> a b d
77−p <<% a = p <<^ si a
78−
79−infixr 5 <+%
80−
81−(<+%) :: (PolyArrow a SemiIso, ArrowPlus a, ToSemiIso p b c) => a b c -> p -> a b c
82−a <+% b = a <+^ si b
83−
84−infixr 5 %+>
85−
86−(%+>) :: (PolyArrow a SemiIso, ArrowPlus a, ToSemiIso p b c) => p -> a b c -> a b c
87−a %+> b = si a ^+> b
88−
89−infixr 5 %+%
90−
91−(%+%) :: (PolyArrow a SemiIso, ArrowPlus a, ToSemiIso p b c) => p -> p -> a b c
92−a %+% b = si a ^+^ si b
93−
94−infixr 0 <.>
59+infixl 0 <.>
9560
9661(<.>) ::
97− (PolyArrow m SemiIso, TupleMorphable x c, TupleMorphable y c) =>
98− (Market y y y (Identity y) -> Market y y y' (Identity y')) ->
62+ (PolyArrow SemiIso m, TupleMorphable x c, TupleMorphable a c) =>
63+ (Prism' a b) ->
9964 m x' x ->
100− m x' y'
101−b <.> p = (p >>^ morphed) >>^ si b
102−
103−infixr 0 <^>
104−
105−(<^>) ::
106− (PolyArrow m SemiIso, TupleMorphable x c, TupleMorphable y c, ToSemiIso b y y') =>
107− m x' x ->
108− b ->
109− m x' y'
110−b <^> p = b >>> morphed %>% p
111−
112−coercing :: forall b a m. (Coercible a b, PolyArrow m SemiIso) => m a b
113−coercing = arr $ siJust coerce coerce
114−
115−morphed ::
116− (TupleMorphable a c, TupleMorphable b c) => SemiIso a b
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
117244morphed = siPure morphTuples morphTuples
118245
119−class ToSemiIso x a b | x -> a b where
120− si :: x -> SemiIso a b
121−
122−instance ToSemiIso (Market a a a (Identity a) -> Market a a b (Identity b)) a b where
123− si p = withPrism p $ \x y -> SemiIso (pure . x) (either (const empty) pure . y)
124−
125−instance ToSemiIso (SemiIso a b) a b where
126− si = id
127−
128−mapIso :: (PolyArrow m SemiIso, Ord a, Ord b) => [(a, b)] -> m a b
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
129284mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)
130285 where
131286 n = M.fromListWith (error "mapping not unique") m
@@ -133,13 +288,13 @@ mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)
133288 M.fromListWith (error "mapping not unique") $
134289 (\(a, b) -> (b, a)) <$> m
135290
136−auto :: forall x s m. (ToIsoparsec x s, Isoparsec m s) => m () x
291+auto :: forall x s m. (ToIsoparsec x s m, Isoparsec m s) => m () x
137292auto = toIsoparsec
138293
139−specific :: forall x s m. (ToIsoparsec x s, Isoparsec m s, Eq x, Show x) => x -> m () ()
140−specific x = auto @x >>> check (== x) >>> tsnok x
294+specific :: forall x s m. (ToIsoparsec x s m, Isoparsec m s, Eq x) => x -> m () ()
295+specific x = auto @x >>^ turn (konst x)
141296
142297throughIntegral ::
143− (Integral a, Integral b, Num a, Num b, PolyArrow m SemiIso) =>
144− m a b
145−throughIntegral = arr $ siJust fromIntegral fromIntegral
298+ (Integral a, Integral b, Num a, Num b) =>
299+ SemiIso a b
300+throughIntegral = siPure fromIntegral fromIntegral
src/Data/Isoparsec/ByteString.hs+22−31
@@ -2,7 +2,6 @@
22
33module Data.Isoparsec.ByteString
44 ( utf8,
5− ftu8,
65 ByteString,
76 Endianness (..),
87 Byte8,
@@ -21,11 +20,8 @@ import Data.Proxy
2120import Data.Word
2221import Prelude as P hiding ((.))
2322
24−utf8 :: Isoparsec m ByteString => String -> m () ()
25−utf8 = chunk . C.pack
26−
27−ftu8 :: PolyArrow m SemiIso => m ByteString String
28−ftu8 = arr $ siJust C.unpack C.pack
23+utf8 :: SemiIso ByteString String
24+utf8 = siPure C.unpack C.pack
2925
3026data Endianness = BE | LE
3127
@@ -34,10 +30,10 @@ class BytesToIsoparsec b (e :: Endianness) where
3430
3531instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'BE where
3632 bytesToIsoparsec _ =
37− konst word8s >>> manyTokens
38− >>^ siJust
33+ konst word8s ^>> manyTokens
34+ >>^ siPure
3935 (fromInteger . BS.foldl (\i w -> shiftL i 8 .|. toInteger w) 0)
40− ( liftTokens . snd . P.head
36+ ( fromList . snd . P.head
4137 . P.drop (fromIntegral word8s)
4238 . iterate (\(i, ww) -> (shiftR i 8, fromInteger i : ww))
4339 . (,[])
@@ -48,10 +44,10 @@ instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'BE where
4844
4945instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'LE where
5046 bytesToIsoparsec _ =
51− konst word8s >>> manyTokens
52− >>^ siJust
47+ konst word8s ^>> manyTokens
48+ >>^ siPure
5349 (fromInteger . BS.foldr (\w i -> shiftL i 8 .|. toInteger w) 0)
54− ( liftTokens . P.reverse . snd . P.head
50+ ( fromList . P.reverse . snd . P.head
5551 . P.drop (fromIntegral word8s)
5652 . iterate (\(i, ww) -> (shiftR i 8, fromInteger i : ww))
5753 . (,[])
@@ -71,31 +67,26 @@ newtype Byte32 (e :: Endianness) = Byte32 {unByte32 :: Word32}
7167newtype Byte64 (e :: Endianness) = Byte64 {unByte64 :: Word64}
7268 deriving (Show, Eq, Ord, Enum, Num, Real, Integral, Bounded)
7369
74−instance BytesToIsoparsec Word16 e => ToIsoparsec (Byte16 e) ByteString where
75− toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte16 e) @Word16
70+instance BytesToIsoparsec Word16 e => ToIsoparsec (Byte16 e) ByteString m where
71+ toIsoparsec = bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte16 e) @Word16
7672
77−instance BytesToIsoparsec Word32 e => ToIsoparsec (Byte32 e) ByteString where
78− toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte32 e) @Word32
73+instance BytesToIsoparsec Word32 e => ToIsoparsec (Byte32 e) ByteString m where
74+ toIsoparsec = bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte32 e) @Word32
7975
80−instance BytesToIsoparsec Word64 e => ToIsoparsec (Byte64 e) ByteString where
81− toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte64 e) @Word64
76+instance BytesToIsoparsec Word64 e => ToIsoparsec (Byte64 e) ByteString m where
77+ toIsoparsec = bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte64 e) @Word64
8278
83−instance ToIsoparsec Bool ByteString where
79+instance ToIsoparsec Bool ByteString m where
8480 toIsoparsec = anyToken >>> mapIso [(0, False), (1, True)]
8581
8682newtype SSHString = SSHString {unSSHString :: String}
8783 deriving (Show, Eq, Ord)
8884
89−instance ToIsoparsec SSHString ByteString where
85+instance ToIsoparsec SSHString ByteString m where
9086 toIsoparsec =
91− auto @(Byte32 'BE) >>> coercing @Word32
92− >>> siJust fromIntegral fromIntegral ^>> manyTokens
93− >>> ftu8
94− >>^ siJust SSHString unSSHString
95−
96−instance Tokenable ByteString where
97− type Token ByteString = Word8
98−
99− liftTokens = pack
100−
101− lowerTokens = unpack
87+ auto @(Byte32 'BE)
88+ >>^ coercing @Word32
89+ >>^ siPure fromIntegral fromIntegral
90+ >>> manyTokens
91+ >>^ utf8
92+ >>^ siPure SSHString unSSHString
src/Data/Isoparsec/Char.hs+7−7
@@ -11,16 +11,16 @@ import Data.Isoparsec
1111import Text.Read
1212import Prelude hiding ((.), id)
1313
14−space :: (Isoparsec m s, Token s ~ Char) => m () ()
14+space :: (Isoparsec m s, Element s ~ Char) => m () ()
1515space = token ' '
1616
17−unsafeWhiteSpace :: (Isoparsec m s, Token s ~ Char) => m () ()
18−unsafeWhiteSpace = tokensWhile isSpace >>> badTsnok mempty
17+unsafeWhiteSpace :: (Isoparsec m s, Element s ~ Char, Eq s) => m () ()
18+unsafeWhiteSpace = tokensWhile isSpace >>^ (maskr . turn . konst $ mempty)
1919
20−unsafeWhiteSpace1 :: (Isoparsec m s, Token s ~ Char) => m () ()
21−unsafeWhiteSpace1 = tokensWhile1 isSpace >>> badTsnok (liftToken ' ')
20+unsafeWhiteSpace1 :: (Isoparsec m s, Element s ~ Char, Eq s) => m () ()
21+unsafeWhiteSpace1 = tokensWhile1 isSpace >>^ (maskr . turn . konst $ singleton ' ')
2222
23−number :: (Isoparsec m s, Token s ~ Char) => m () Integer
23+number :: (Isoparsec m s, Element s ~ Char) => m () Integer
2424number =
2525 tokensWhile1 (\c -> isNumber c || c == '+' || c == '-')
26− >>^ siMaybe (readMaybe @Integer . lowerTokens) (Just . liftTokens . show)
26+ >>^ siMaybe (readMaybe @Integer . otoList) (Just . fromList . show)
src/Data/Isoparsec/Chunks.hs+2−2
@@ -10,6 +10,6 @@ import GHC.TypeLits
1010newtype Chunk (n :: Nat) s = Chunk {unChunk :: s}
1111 deriving (Show, Eq, Ord)
1212
13−instance (CmpNat n 0 ~ 'GT, KnownNat n) => ToIsoparsec (Chunk n s) s where
13+instance (CmpNat n 0 ~ 'GT, KnownNat n) => ToIsoparsec (Chunk n s) s m where
1414 toIsoparsec =
15− konst (fromIntegral $ natVal @n Proxy) >>> manyTokens >>> coercing
15+ konst (fromIntegral $ natVal @n Proxy) ^>> manyTokens >>^ coercing
src/Data/Isoparsec/Internal.hs+76−91
@@ -2,76 +2,75 @@ module Data.Isoparsec.Internal
22 ( module X,
33 IsoparsecFail (..),
44 Isoparsec (..),
5− konst,
6− tsnok,
7− cons',
8− siJust,
9− siCheck,
10− siCheck',
11− check,
12− levitate,
13− badKonst,
14− badTsnok,
5+ siCons,
6+ unroll,
7+ arrowsWhile,
8+ arrowsUntil,
9+ EffectOnly,
1510 )
1611where
1712
1813import Control.Arrow.Extra
14+import Control.Arrow.Trans.Reader
1915import Control.Monad
20−import Control.SemiIso as X
21−import Data.Isoparsec.Tokenable
16+import Control.SemiIso as X hiding (filterM, replicateM)
17+import Data.MonoTraversable as X
18+import Data.Sequences as X
2219import Numeric.Natural
2320import Prelude as P hiding ((.), id)
2421
2522class
26− (PolyArrow m SemiIso, ArrowPlus m, ArrowChoice m, Tokenable s) =>
23+ (PolyArrow SemiIso m, ArrowPlus m, ArrowChoice m, IsSequence s) =>
2724 Isoparsec m s
2825 | m -> s where
29− {-# MINIMAL anyToken, manyTokens, tuck #-}
26+ {-# MINIMAL anyToken, manyTokens, tuck' #-}
3027
31− anyToken :: m () (Token s)
28+ anyToken :: m () (Element s)
3229
33− token :: Token s -> m () ()
34− default token :: Eq (Token s) => Token s -> m () ()
35− token x = anyToken >>> tsnok x
30+ token :: Element s -> EffectOnly m
31+ default token :: Eq (Element s) => Element s -> EffectOnly m
32+ token x = anyToken >>^ turn (konst x)
3633
37− tokens :: [Token s] -> m () ()
38− default tokens :: [Token s] -> m () ()
39− tokens [] = arr $ isoConst' () ()
40− tokens (t : ts) = token t &&& tokens ts >>> arr (isoConst' ((), ()) ())
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))
4137
42− chunk :: s -> m () ()
43− chunk = tokens . lowerTokens
38+ tokens :: [Element s] -> EffectOnly m
39+ tokens [] = arr $ isoConst () ()
40+ tokens (t : ts) = token t &&& tokens ts >>^ isoConst ((), ()) ()
4441
45− notToken :: Token s -> m () (Token s)
46− default notToken :: Eq (Token s) => Token s -> m () (Token s)
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)
4755 notToken t = tokenWhere (/= t)
4856
49− tokenWhere :: (Token s -> Bool) -> m () (Token s)
50− tokenWhere f =
51− anyToken >>> check f
57+ tokenWhere :: (Element s -> Bool) -> m () (Element s)
58+ tokenWhere f = anyToken >>^ check f
5259
5360 manyTokens :: m Natural s
5461
55− tokensWhile :: (Token s -> Bool) -> m () s
56−
5762 takeUntil :: s -> m () s
58− default takeUntil :: Eq (Token s) => s -> m () s
59− takeUntil s = takeUntil' s >>^ levitate
60− where
61− takeUntil' s' = (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ cons')
63+ default takeUntil :: Eq s => s -> m () s
64+ takeUntil s = (chunk s >>^ konst mempty) <+> ((anyToken &&& takeUntil s) >>^ siCons)
6265
63− default tokensWhile :: (Token s -> Bool) -> m () s
66+ tokensWhile :: (Element s -> Bool) -> m () s
67+ default tokensWhile :: (Element s -> Bool) -> m () s
6468 tokensWhile f =
65− tokensWhile' f >>> check (P.all f) >>^ levitate
66− where
67− tokensWhile' g =
68− (tokenWhere g &&& tokensWhile' g >>^ cons')
69− <+^ isoConst' () []
69+ (((tokenWhere f >>^ check f) &&& tokensWhile f) >>^ siCons)
70+ <+^ isoConst () mempty
7071
71− tokensWhile1 :: (Token s -> Bool) -> m () s
72− tokensWhile1 f =
73− tokenWhere f &&& tokensWhile f
74− >>^ SI (\(a, aa) -> pure $ liftToken a <> aa) levitateHead
72+ tokensWhile1 :: (Element s -> Bool) -> m () s
73+ tokensWhile1 f = tokenWhere f &&& tokensWhile f >>^ siCons
7574
7675 -- | "tucks" the context of the parser into its input.
7776 -- > ┌─────┐
@@ -89,57 +88,43 @@ class
8988 -- > ──┤ s ├──────────────────────────┤ a ├─▶
9089 -- > └─────┘ └─────┘
9190 tuck :: m () a -> m s a
91+ tuck a = turn siSnd ^>> tuck' a
9292
93−levitateHead :: Alternative f => Tokenable s => s -> f (Token s, s)
94−levitateHead s = case lowerTokens s of
95− (t : tt) -> pure (t, liftTokens tt)
96− [] -> empty
97−
98−cons' :: SemiIso (t, [t]) [t]
99−cons' =
100− SI
101− (pure . uncurry (:))
102− ( \case
103− (t : ts) -> pure (t, ts)
104− _ -> empty
105− )
93+ tuck' :: m a b -> m (a, s) b
10694
107−levitate :: Tokenable s => SemiIso [Token s] s
108−levitate = siJust liftTokens lowerTokens
95+type EffectOnly m = m () ()
10996
110−class IsoparsecFail m e where
111− failure :: e -> m a b
112−
113−siCheck' ::
114− (s -> Bool) ->
115− (forall f. AlternativeMonad f => s -> f a) ->
116− (forall f. AlternativeMonad f => a -> f s) ->
117− SemiIso s a
118−siCheck' f a b =
119− SI
120− (\c -> guard (f c) >> a c)
121− (b >=> (\c -> guard (f c) >> pure c))
122−
123−siCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso s a
124−siCheck f a b = siCheck' f (pure . a) (pure . b)
97+arrowsWhile :: (PolyArrow SemiIso m, ArrowPlus m) => m () a -> m () [a]
98+arrowsWhile f = ((f &&& arrowsWhile f) >>^ siCons) <+^ isoConst () []
12599
126−siJust :: (s -> a) -> (a -> s) -> SemiIso s a
127−siJust a b = SI (pure . a) (pure . b)
100+arrowsUntil :: (ArrowPlus m, Eq a, PolyArrow SemiIso m) => m () a -> m () b -> m () ([a], b)
101+arrowsUntil a b = (arr (konst []) &&& b) <+> (a &&& arrowsUntil a b >>^ (assoc >>> first siCons))
128102
129−isoConst' :: s -> a -> SemiIso s a
130−isoConst' s a = SI (const $ pure a) (const $ pure s)
103+unroll :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => a -> m a (b, a) -> m () [b]
104+unroll a f = (konst a ^>> unroll' f) <+^ isoConst () []
105+ where
106+ unroll' g = (g >>> second (unroll' g)) >>^ siCons
131107
132−konst :: (PolyArrow a SemiIso, Eq x) => x -> a () x
133−konst x = badKonst x >>> check (== x)
108+siCons :: IsSequence s => SemiIso (Element s, s) s
109+siCons =
110+ siMaybe
111+ (pure . uncurry cons)
112+ uncons
134113
135−badKonst :: (PolyArrow a SemiIso) => x -> a () x
136−badKonst x = arr $ SI (const $ pure x) (const $ pure ())
137−
138−tsnok :: (PolyArrow a SemiIso, Eq x) => x -> a x ()
139−tsnok x = check (== x) >>> badTsnok x
140−
141−badTsnok :: (PolyArrow a SemiIso) => x -> a x ()
142−badTsnok x = arr $ SI (const $ pure ()) (const $ pure x)
114+class IsoparsecFail m e where
115+ failure :: e -> m a b
143116
144−check :: PolyArrow a SemiIso => (s -> Bool) -> a s s
145−check f = arr $ siCheck f id id
117+instance (Isoparsec a s, Eq (Element s), Eq r) => Isoparsec (ReaderArrow r a) s where
118+ anyToken = raise anyToken
119+ token' = raise token'
120+ tokens = raise . tokens
121+ tokens' = raise tokens'
122+ chunk = raise . chunk
123+ chunk' = raise chunk'
124+ notToken = raise . notToken
125+ tokenWhere = raise . tokenWhere
126+ manyTokens = raise manyTokens
127+ takeUntil = raise . takeUntil
128+ tokensWhile = raise . tokensWhile
129+ tokensWhile1 = raise . tokensWhile1
130+ tuck' (ReaderArrow a) = ReaderArrow $ assoc ^>> tuck' a
src/Data/Isoparsec/Megaparsec.hs+57−20
@@ -1,7 +1,9 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
22
33module Data.Isoparsec.Megaparsec
4− ( runMegaparsec,
4+ ( runMegaparsecParser,
5+ ParseErrorBundle (..),
6+ MegaparsecParser (..),
57 )
68where
79
@@ -9,43 +11,78 @@ import Control.Arrow.Extra
911import Control.Arrow.Extra.Orphans ()
1012import Control.Monad
1113import Data.Functor
12−import Data.Isoparsec.Internal as I
13−import Data.Isoparsec.Tokenable
14+import Data.Functor.Identity
15+import Data.Isoparsec
16+import Data.Void
1417import Text.Megaparsec hiding (Token)
1518import qualified Text.Megaparsec as M
1619import Prelude hiding ((.))
1720
18−runMegaparsec ::
19− (Ord e, Stream s) =>
20− Kleisli (Parsec e s) () r ->
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) =>
2134 s ->
22− Either (ParseErrorBundle s e) r
23−runMegaparsec (Kleisli f) = runParser (f () <* eof) ""
35+ MegaparsecParser s () r ->
36+ Either (ParseErrorBundle s Void) r
37+runMegaparsecParser s (MegaparsecParser (Kleisli f)) = runParser (f () <* eof) "" s
2438
25−instance (MonadParsec e s m) => PolyArrow (Kleisli m) SemiIso where
39+instance (MonadParsec e s m) => PolyArrow SemiIso (Kleisli m) where
2640 arr si = Kleisli $ \t -> case embed si t of
2741 Just x -> return x
2842 Nothing -> M.failure Nothing mempty
2943
3044instance
31− (MonadParsec e s m, M.Token s ~ Token s, s ~ M.Tokens s, Tokenable s) =>
32− Isoparsec (Kleisli m) s
45+ (Stream s, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>
46+ Isoparsec (MegaparsecParser s) s
3347 where
34− anyToken = Kleisli $ const anySingle
48+ anyToken = MegaparsecParser . Kleisli $ const anySingle
49+
50+ token t = MegaparsecParser . Kleisli . const $ M.single t $> ()
51+
52+ token' = MegaparsecParser . Kleisli $ \t -> M.single t $> t
53+
54+ tokens ts = MegaparsecParser . Kleisli . const $ M.chunk (fromList ts) $> ()
55+
56+ tokens' = MegaparsecParser . Kleisli $ \ts -> M.chunk (fromList ts) $> ts
57+
58+ chunk c = MegaparsecParser . Kleisli . const $ M.chunk c $> ()
59+
60+ chunk' = MegaparsecParser . Kleisli $ \c -> M.chunk c $> c
3561
36− token t = Kleisli . const $ M.single t $> ()
62+ notToken t = MegaparsecParser . Kleisli . const $ M.anySingleBut t
3763
38− manyTokens = Kleisli $ takeP Nothing . fromIntegral
64+ tokenWhere f = MegaparsecParser . Kleisli . const $ satisfy f
3965
40− tuck (Kleisli f) = Kleisli $ \sub -> do
66+ manyTokens = MegaparsecParser . Kleisli $ takeP Nothing . fromIntegral
67+
68+ takeUntil c = MegaparsecParser . Kleisli $ \() -> do
69+ ta <- M.manyTill M.anySingle (M.chunk c)
70+ return $ fromList ta
71+
72+ tokensWhile f = MegaparsecParser . Kleisli . const $ M.takeWhileP Nothing f
73+
74+ tokensWhile1 f = MegaparsecParser . Kleisli . const $ M.takeWhile1P Nothing f
75+
76+ tuck (MegaparsecParser (Kleisli f)) = MegaparsecParser . Kleisli $ \sub -> do
4177 sup <- getInput
4278 setInput sub
4379 r <- f () <* eof
4480 setInput sup
4581 return r
4682
47−instance MonadParsec e s m => IsoparsecFail (Kleisli m) e where
48− failure e = Kleisli $ \_ -> customFailure e
49−
50−instance (MonadParsec e s m, M.Token s ~ Token s, s ~ M.Tokens s) => ArrowPlus (Kleisli m) where
51− (Kleisli lhs) <+> (Kleisli rhs) = Kleisli $ \x -> try (lhs x) <|> rhs x
83+ tuck' (MegaparsecParser (Kleisli f)) = MegaparsecParser . Kleisli $ \(x, sub) -> do
84+ sup <- getInput
85+ setInput sub
86+ r <- f x <* eof
87+ setInput sup
88+ return r
src/Data/Isoparsec/Printer.hs+64−20
@@ -1,39 +1,83 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
22
33module Data.Isoparsec.Printer
4− ( runPrinter,
4+ ( runMonoidPrinter,
5+ MonoidPrinter (..),
56 )
67where
78
9+import Control.Cokleisli
810import Control.Monad.Writer.Lazy
11+import Data.Functor
912import Data.Isoparsec
10−import Data.Isoparsec.Cokleisli
13+import Data.List.Split
1114import Prelude hiding ((.), id)
1215
13−runPrinter ::
14− forall m s a.
15− Monad m =>
16− Cokleisli (WriterT (Dual s) m) () a ->
17− a ->
18− m s
19−runPrinter p = fmap getDual . execWriterT . unCokleisli p
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)
2019
21−instance IsoparsecFail (Cokleisli (WriterT s Maybe)) e where
22− failure _ = Cokleisli . const $ WriterT Nothing
20+runMonoidPrinter ::
21+ forall s a.
22+ MonoidPrinter s () a ->
23+ a ->
24+ Maybe s
25+runMonoidPrinter p = fmap getDual . execWriterT . runCokleisli (unMonoidPrinter p)
2326
24−instance IsoparsecFail (Cokleisli (WriterT s (Either e))) e where
25− failure = Cokleisli . const . WriterT . Left
27+instance IsoparsecFail (MonoidPrinter s) e where
28+ failure _ = MonoidPrinter . Cokleisli . const $ WriterT Nothing
2629
2730instance
28− (MonadPlus m, Monoid s, Eq (Token s), Tokenable s, Show s) =>
29− Isoparsec (Cokleisli (WriterT (Dual s) m)) s
31+ (Monoid s, Eq (Element s), IsSequence s) =>
32+ Isoparsec (MonoidPrinter s) s
3033 where
31− token t = Cokleisli $ const $ tell . Dual . liftToken $ t
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
3245
33− anyToken = Cokleisli $ tell . Dual . liftToken
46+ chunk' = MonoidPrinter . Cokleisli $ \c -> (tell . Dual) c $> c
3447
35− manyTokens = Cokleisli $ \w -> do
48+ notToken nt = MonoidPrinter . Cokleisli $ \t ->
49+ if t == nt
50+ then empty
51+ else (tell . Dual . singleton) t
52+
53+ tokenWhere f = MonoidPrinter . Cokleisli $ \t ->
54+ if f t
55+ then (tell . Dual . singleton) t
56+ else empty
57+
58+ manyTokens = MonoidPrinter . Cokleisli $ \w -> do
3659 tell $ Dual w
37− return . fromIntegral . length . lowerTokens $ w
60+ return . fromIntegral . olength $ w
61+
62+ takeUntil end = MonoidPrinter . Cokleisli $ \s ->
63+ if length ((split . onSublist $ otoList end) . otoList $ s) > 1
64+ then empty
65+ else do
66+ tell . Dual $ s
67+ tell . Dual $ end
68+
69+ tokensWhile f = MonoidPrinter . Cokleisli $ \s ->
70+ if oall f s
71+ then (tell . Dual) s
72+ else empty
73+
74+ tokensWhile1 f = MonoidPrinter . Cokleisli $ \s ->
75+ if oall f s && not (onull s)
76+ then (tell . Dual) s
77+ else empty
78+
79+ tuck (MonoidPrinter (Cokleisli f)) =
80+ MonoidPrinter . Cokleisli $ lift . fmap getDual . execWriterT . f
3881
39− tuck (Cokleisli f) = Cokleisli $ lift . fmap getDual . execWriterT . f
82+ tuck' (MonoidPrinter (Cokleisli f)) =
83+ MonoidPrinter . Cokleisli $ lift . (fmap . fmap) getDual . runWriterT . f
src/Data/Isoparsec/ToIsoparsec.hs+12−17
@@ -5,38 +5,33 @@ where
55
66import Control.Arrow.Extra
77import Data.Isoparsec.Internal
8−import Data.Isoparsec.Tokenable
98import GHC.Generics
109import Prelude hiding ((.))
1110
12−instance {-# OVERLAPPABLE #-} t ~ Token s => ToIsoparsec t s where
13− toIsoparsec = anyToken
14−
15−class ToIsoparsec a s where
16− toIsoparsec :: Isoparsec m s => m () a
17− default toIsoparsec :: (Isoparsec m s, Generic a, GToIsoparsec (Rep a) s) => m () a
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
1814 toIsoparsec = gToIsoparsec >>^ SI (pure . to) (pure . from)
1915
20−class GToIsoparsec a s where
16+class GToIsoparsec a s m where
2117 gToIsoparsec :: Isoparsec m s => m () (a b)
2218
23−instance GToIsoparsec U1 s where
24− gToIsoparsec = konst U1
19+instance GToIsoparsec U1 s m where
20+ gToIsoparsec = arr $ konst U1
2521
26−instance ToIsoparsec c s => GToIsoparsec (K1 i c) s where
27− gToIsoparsec =
28− toIsoparsec >>^ SI (pure . K1) (pure . unK1)
22+instance ToIsoparsec c s m => GToIsoparsec (K1 i c) s m where
23+ gToIsoparsec = toIsoparsec >>^ siPure K1 unK1
2924
30−instance GToIsoparsec c s => GToIsoparsec (M1 i t c) s where
25+instance GToIsoparsec c s m => GToIsoparsec (M1 i t c) s m where
3126 gToIsoparsec =
32− gToIsoparsec >>^ SI (pure . M1) (pure . unM1)
27+ gToIsoparsec >>^ siPure M1 unM1
3328
34−instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :*: b) s where
29+instance (GToIsoparsec a s m, GToIsoparsec b s m) => GToIsoparsec (a :*: b) s m where
3530 gToIsoparsec =
3631 (gToIsoparsec &&& gToIsoparsec)
3732 >>^ SI (\(a, b) -> pure (a :*: b)) (\(a :*: b) -> pure (a, b))
3833
39−instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :+: b) s where
34+instance (GToIsoparsec a s m, GToIsoparsec b s m) => GToIsoparsec (a :+: b) s m where
4035 gToIsoparsec =
4136 ( (gToIsoparsec >>^ SI (pure . Left) (either pure (const empty)))
4237 <+> (gToIsoparsec >>^ SI (pure . Right) (either (const empty) pure))
src/Data/Isoparsec/Tokenable.hsdeleted−24
@@ -1,24 +0,0 @@
1−module Data.Isoparsec.Tokenable
2− ( Tokenable (..),
3− )
4−where
5−
6−class Monoid s => Tokenable s where
7− type Token s
8−
9− {-# MINIMAL (liftTokens | liftToken), lowerTokens #-}
10−
11− liftTokens :: [Token s] -> s
12− liftTokens = mconcat . fmap liftToken
13−
14− liftToken :: Token s -> s
15− liftToken = liftTokens . pure
16−
17− lowerTokens :: s -> [Token s]
18−
19−instance Tokenable [t] where
20− type Token [t] = t
21−
22− liftTokens = id
23−
24− lowerTokens = id
stack.yaml+1−6
@@ -17,7 +17,7 @@
1717#
1818# resolver: ./custom-snapshot.yaml
1919# resolver: https://example.com/snapshots/2018-01-01.yaml
20−resolver: lts-14.23
20+resolver: lts-15.8
2121
2222# User packages to be built.
2323# Various formats can be used as shown in the example below.
@@ -39,11 +39,6 @@ packages:
3939# - git: https://github.com/commercialhaskell/stack.git
4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
4141#
42−extra-deps:
43−- optics-core-0.1
44−- optics-0.1
45−- optics-extra-0.1
46−- optics-th-0.1
4742
4843# Override default flag values for local packages and extra-deps
4944# flags: {}
test/Spec.hs+23−1
@@ -1,6 +1,9 @@
1+import qualified Spec.BasicReader as BasicReader
12import qualified Spec.JSON as JSON
3+import qualified Spec.JSONHList as JSONHList
24import qualified Spec.Megaparsec.BasicNums as BasicNums
35import qualified Spec.Ssh as Ssh
6+import qualified Spec.SshHList as SshHList
47import qualified Spec.TwoDigits as TwoDigits
58import Test.Tasty
69import Test.Tasty.Hspec
@@ -10,6 +13,10 @@ main = do
1013 bsicNumSpec <- testSpec "Basic megaparsec test" BasicNums.spec
1114 twoDigitsSpec <- testSpec "Two digits test" TwoDigits.spec
1215 sshSpec <- testSpec "ssh spec" Ssh.spec
16+ sshHListSpec <- testSpec "ssh HList spec" SshHList.spec
17+ jsonSpec <- testSpec "json spec" JSON.spec
18+ jsonHListSpec <- testSpec "json spec" JSONHList.spec
19+ basicReaderSpec <- testSpec "json spec" BasicReader.spec
1320 defaultMain
1421 ( testGroup
1522 "tests"
@@ -20,7 +27,13 @@ main = do
2027 ],
2128 testGroup
2229 "JSON"
23− [ JSON.quickSpec
30+ [ jsonSpec,
31+ JSON.quickSpec
32+ ],
33+ testGroup
34+ "JSONHList"
35+ [ jsonHListSpec,
36+ JSONHList.quickSpec
2437 ],
2538 testGroup
2639 "TwoDigits"
@@ -31,6 +44,15 @@ main = do
3144 "ssh"
3245 [ sshSpec,
3346 Ssh.quickSpec
47+ ],
48+ testGroup
49+ "ssh HList"
50+ [ sshHListSpec,
51+ SshHList.quickSpec
52+ ],
53+ testGroup
54+ "BasicReader"
55+ [ basicReaderSpec
3456 ]
3557 ]
3658 )
test/Spec/BasicReader.hsnew file+38
@@ -0,0 +1,38 @@
1+{-# LANGUAGE PartialTypeSignatures #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+
4+module Spec.BasicReader
5+ ( spec,
6+ )
7+where
8+
9+import Control.Arrow.Extra
10+import Control.Arrow.Reader
11+import Control.Lens.TH
12+import Data.Either
13+import Data.Isoparsec
14+import Data.Isoparsec.Char
15+import Data.Isoparsec.Megaparsec
16+import Test.Hspec
17+import Prelude hiding ((.), id)
18+
19+data ConstSep = ConstSep Integer Integer
20+ deriving (Eq, Show)
21+
22+makePrisms ''ConstSep
23+
24+instance ArrowReader String a => ToIsoparsec ConstSep String a where
25+ toIsoparsec = _ConstSep <.> (number >** biask chunk') &&& number
26+
27+spec :: Spec
28+spec = do
29+ let run (sep :: String) (s :: String) =
30+ runMegaparsecParser s . runReaderArrow sep $ (auto @ConstSep)
31+ it "deserializes" $ do
32+ run "s" "12s31" `shouldBe` Right (ConstSep 12 31)
33+ run " " "12 31" `shouldBe` Right (ConstSep 12 31)
34+ run "oh no" "12oh no31" `shouldBe` Right (ConstSep 12 31)
35+ run "oh no" "12oh no 31" `shouldSatisfy` isLeft
36+ run "oh no" "12ohno31" `shouldSatisfy` isLeft
37+ run "&" "12 31" `shouldSatisfy` isLeft
38+ run "&" "12&31" `shouldBe` Right (ConstSep 12 31)
test/Spec/Helper.hs+50−10
@@ -1,6 +1,8 @@
11module Spec.Helper
22 ( shouldParseBS,
33 roundtrip,
4+ parseSatisfyBS,
5+ shouldParseS,
46 )
57where
68
@@ -17,46 +19,84 @@ import Test.Tasty.QuickCheck
1719import Text.Megaparsec as M
1820import Prelude as P hiding ((.))
1921
22+parseSatisfy ::
23+ forall x s.
24+ ( ToIsoparsec x s (MegaparsecParser s),
25+ Stream s,
26+ Show x,
27+ Show (M.Token s),
28+ Show s,
29+ Isoparsec (MegaparsecParser s) s
30+ ) =>
31+ s ->
32+ (Either (ParseErrorBundle s Void) x -> Bool) ->
33+ Expectation
34+parseSatisfy s p = runMegaparsecParser @s s toIsoparsec `shouldSatisfy` p
35+
36+parseSatisfyBS ::
37+ forall x.
38+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),
39+ Show x,
40+ Isoparsec (MegaparsecParser ByteString) ByteString
41+ ) =>
42+ ByteString ->
43+ (Either (ParseErrorBundle ByteString Void) x -> Bool) ->
44+ Expectation
45+parseSatisfyBS = parseSatisfy
46+
2047shouldParse ::
2148 forall x s.
22− ( ToIsoparsec x s,
49+ ( ToIsoparsec x s (MegaparsecParser s),
2350 Stream s,
2451 Show x,
2552 Eq x,
26− Isoparsec (Kleisli (Parsec Void s)) s
53+ Isoparsec (MegaparsecParser s) s
2754 ) =>
2855 s ->
2956 x ->
3057 Expectation
31−shouldParse s e = case runMegaparsec @Void @s toIsoparsec s of
58+shouldParse s e = case runMegaparsecParser @s s toIsoparsec of
3259 Right e' -> e' `shouldBe` e
3360 Left err -> expectationFailure $ errorBundlePretty err
3461
3562shouldParseBS ::
3663 forall x.
37− ( ToIsoparsec x ByteString,
64+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),
3865 Show x,
3966 Eq x,
40− Isoparsec (Kleisli (Parsec Void ByteString)) ByteString
67+ Isoparsec (MegaparsecParser ByteString) ByteString
4168 ) =>
4269 ByteString ->
4370 x ->
4471 Expectation
4572shouldParseBS = shouldParse
4673
74+shouldParseS ::
75+ forall x.
76+ ( ToIsoparsec x String (MegaparsecParser String),
77+ Show x,
78+ Eq x,
79+ Isoparsec (MegaparsecParser String) String
80+ ) =>
81+ String ->
82+ x ->
83+ Expectation
84+shouldParseS = shouldParse
85+
4786roundtrip ::
4887 forall x s.
49− ( ToIsoparsec x s,
88+ ( ToIsoparsec x s (MegaparsecParser s),
89+ ToIsoparsec x s (MonoidPrinter s),
5090 Stream s,
5191 Show s,
52− I.Token s ~ M.Token s,
92+ I.Element s ~ M.Token s,
5393 Eq x,
54− Isoparsec (Kleisli (Parsec Void s)) s
94+ Isoparsec (MegaparsecParser s) s
5595 ) =>
5696 x ->
5797 Property
5898roundtrip x =
59− let s = fromJust $ runPrinter @Maybe @s toIsoparsec x
60− in counterexample (show s) $ case runMegaparsec @Void @s toIsoparsec s of
99+ let s = fromJust $ runMonoidPrinter @s toIsoparsec x
100+ in counterexample (show s) $ case runMegaparsecParser @s s toIsoparsec of
61101 Right y -> property $ x == y
62102 Left err -> counterexample (errorBundlePretty err) False
test/Spec/JSON.hs+27−23
@@ -2,6 +2,7 @@
22
33module Spec.JSON
44 ( quickSpec,
5+ spec,
56 )
67where
78
@@ -12,7 +13,8 @@ import Data.Isoparsec.Char
1213import Data.Isoparsec.Megaparsec
1314import Data.Isoparsec.Printer
1415import Data.Maybe
15−import Data.Void
16+import Spec.Helper
17+import Test.Hspec
1618import Test.Tasty
1719import Test.Tasty.QuickCheck
1820import Text.Megaparsec.Error
@@ -41,44 +43,46 @@ instance Arbitrary JSON where
4143
4244makePrisms ''JSON
4345
46+spec :: Spec
47+spec =
48+ it "deserializes" $ do
49+ "{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]
50+ "{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]
51+ "{}" `shouldParseS` Object []
52+ "[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]
53+ "[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]
54+
4455quickSpec :: TestTree
4556quickSpec =
4657 testProperty "roundtrips" $ \x ->
47− let s = fromJust $ runPrinter @Maybe @String json x
48− in counterexample s $ case runMegaparsec @Void json s of
58+ let s = fromJust $ runMonoidPrinter @String json x
59+ in counterexample s $ case runMegaparsecParser s json of
4960 Right y -> property $ x == y
5061 Left err -> counterexample (errorBundlePretty err) False
5162
52−json :: (PolyArrow m SemiIso, Isoparsec m String) => m () JSON
53−json = SI pure pure ^<< (string <+> array <+> integer <+> object)
63+instance ToIsoparsec JSON String a where
64+ toIsoparsec = json
65+
66+json :: forall m. Isoparsec m String => m () JSON
67+json = string <+> array <+> integer <+> object
5468 where
55− string' = token '"' &&& tokensWhile (/= '"') &&& token '"'
69+ string' = token '"' **> tokensWhile (/= '"') >** token '"'
5670 string = _JString <.> string'
5771 array =
5872 _Array
5973 <.> token '['
6074 &&& unsafeWhiteSpace
61− &&& ( ( ( ( json &&& unsafeWhiteSpace
62− &&& repeating
63− ( (token ',' &&& unsafeWhiteSpace &&& json) >>% morphed
64− )
65− <+> konst []
66− )
67− >>% morphed
68− )
69− >>^ cons'
70− )
71− <+> konst []
72− )
75+ &&& sepByComma json
7376 &&& unsafeWhiteSpace
7477 &&& token ']'
7578 integer = _JInteger <.> number
7679 object =
7780 _Object <.> token '{' &&& unsafeWhiteSpace
78− &&& ( ( let pair = (unsafeWhiteSpace &&& string' &&& unsafeWhiteSpace &&& token ':' &&& unsafeWhiteSpace &&& json &&& unsafeWhiteSpace) >>^ morphed
79− in (pair &&& (repeating ((token ',' &&& unsafeWhiteSpace &&& pair) >>^ morphed) <+> konst [])) >>^ cons'
80− )
81− <+> konst []
82− )
81+ &&& sepByComma pair
8382 &&& unsafeWhiteSpace
8483 &&& token '}'
84+ pair =
85+ (unsafeWhiteSpace **> string' >** unsafeWhiteSpace >** token ':' >** unsafeWhiteSpace)
86+ &&& (json >** unsafeWhiteSpace)
87+ sepByComma :: Eq a => m () a -> m () [a]
88+ sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)
test/Spec/JSONHList.hsnew file+92
@@ -0,0 +1,92 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+
3+module Spec.JSONHList
4+ ( quickSpec,
5+ spec,
6+ )
7+where
8+
9+import Control.Arrow.Extra
10+import Control.Lens.TH
11+import Data.Isoparsec
12+import Data.Isoparsec.Char
13+import Data.Isoparsec.Megaparsec
14+import Data.Isoparsec.Printer
15+import Data.Maybe
16+import Spec.Helper
17+import Test.Hspec
18+import Test.Tasty
19+import Test.Tasty.QuickCheck
20+import Text.Megaparsec.Error
21+import Prelude hiding ((.))
22+
23+data JSON
24+ = Object [(String, JSON)]
25+ | JString String
26+ | Array [JSON]
27+ | JInteger Integer
28+ deriving (Show, Eq)
29+
30+instance Arbitrary JSON where
31+ arbitrary =
32+ oneof
33+ [ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),
34+ JString <$> listOf (elements ['.' .. 'z']),
35+ Array <$> listOf (scale (`div` 2) arbitrary),
36+ JInteger <$> arbitrary
37+ ]
38+
39+ shrink (Object a) = Object <$> shrink a
40+ shrink (JString a) = JString <$> shrink a
41+ shrink (Array a) = Array <$> shrink a
42+ shrink (JInteger a) = JInteger <$> shrink a
43+
44+makePrisms ''JSON
45+
46+spec :: Spec
47+spec =
48+ it "deserializes" $ do
49+ "{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]
50+ "{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]
51+ "{}" `shouldParseS` Object []
52+ "[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]
53+ "[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]
54+
55+quickSpec :: TestTree
56+quickSpec =
57+ testProperty "roundtrips" $ \x ->
58+ let s = fromJust $ runMonoidPrinter @String json x
59+ in counterexample s $ case runMegaparsecParser s json of
60+ Right y -> property $ x == y
61+ Left err -> counterexample (errorBundlePretty err) False
62+
63+instance ToIsoparsec JSON String a where
64+ toIsoparsec = json
65+
66+json :: forall m. Isoparsec m String => m () JSON
67+json = delist $ string ~| array ~| integer ~| object
68+ where
69+ string' :: Listed m () String
70+ string' = token '"' ~> tokensWhile (/= '"') ~> token '"'
71+ string :: Listed m () JSON
72+ string = string' ~$> _JString
73+ array :: Listed m () JSON
74+ array =
75+ token '['
76+ ~> unsafeWhiteSpace
77+ ~> sepByComma json
78+ ~> unsafeWhiteSpace
79+ ~> token ']'
80+ ~$> _Array
81+ integer = number ~$> _JInteger
82+ object =
83+ token '{' ~> unsafeWhiteSpace
84+ ~> hmap sepByComma pair
85+ ~> unsafeWhiteSpace
86+ ~> token '}'
87+ ~$> _Object
88+ pair =
89+ unsafeWhiteSpace ~> string' ~> unsafeWhiteSpace ~> token ':' ~> unsafeWhiteSpace
90+ ~& json ~> unsafeWhiteSpace
91+ sepByComma :: Eq a => m () a -> m () [a]
92+ sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)
test/Spec/Megaparsec/BasicNums.hs+5−6
@@ -13,7 +13,6 @@ import Data.Isoparsec.Char
1313import Data.Isoparsec.Megaparsec
1414import Data.Isoparsec.Printer
1515import Data.Maybe
16−import Data.Void
1716import Test.Hspec
1817import Test.Tasty
1918import Test.Tasty.QuickCheck
@@ -34,13 +33,13 @@ parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number)
3433spec :: Spec
3534spec =
3635 it "deserializes" $ do
37− runMegaparsec @() parser "12 31" `shouldBe` (Right $ Foo 12 31)
38− runMegaparsec @() parser "1 33" `shouldBe` (Right $ Foo 1 33)
39− runMegaparsec @() parser "1562" `shouldSatisfy` isLeft
36+ runMegaparsecParser "12 31" parser `shouldBe` Right (Foo 12 31)
37+ runMegaparsecParser "1 33" parser `shouldBe` Right (Foo 1 33)
38+ runMegaparsecParser "1562" parser `shouldSatisfy` isLeft
4039
4140quickSpec :: TestTree
4241quickSpec = testProperty "roundtrips" $ \x ->
43− let s = fromJust $ runPrinter @Maybe @String parser x
44− in counterexample s $ case runMegaparsec @Void parser s of
42+ let s = fromJust $ runMonoidPrinter @String parser x
43+ in counterexample s $ case runMegaparsecParser s parser of
4544 Right y -> property $ x == y
4645 Left err -> counterexample (errorBundlePretty err) False
test/Spec/Orphans.hs+3−3
@@ -15,13 +15,13 @@ import Test.Tasty.QuickCheck
1515import Prelude hiding ((.))
1616
1717instance
18− (CmpNat n 0 ~ 'GT, KnownNat n, Arbitrary (Token s), Tokenable s) =>
18+ (CmpNat n 0 ~ 'GT, KnownNat n, Arbitrary (Element s), IsSequence s) =>
1919 Arbitrary (Chunk n s)
2020 where
21− arbitrary = Chunk . liftTokens <$> vectorOf (fromIntegral $ natVal @n Proxy) arbitrary
21+ arbitrary = Chunk . fromList <$> vectorOf (fromIntegral $ natVal @n Proxy) arbitrary
2222
2323instance Arbitrary ByteString where
24− arbitrary = liftTokens <$> listOf arbitrary
24+ arbitrary = fromList <$> listOf arbitrary
2525
2626deriving instance Arbitrary (Byte16 e)
2727
test/Spec/Ssh.hs+27−27
@@ -9,9 +9,9 @@ where
99import Control.Lens.TH
1010import Data.ByteString as BS
1111import qualified Data.Char as C
12+import Data.Either
1213import Data.Isoparsec
1314import Data.Isoparsec.ByteString
14−import qualified Data.Word8 as W8
1515import GHC.Generics
1616import Spec.Helper
1717import Spec.Orphans ()
@@ -31,7 +31,7 @@ data MessageNumber
3131 | NewKeysMsg
3232 deriving (Eq, Show, Ord)
3333
34−instance ToIsoparsec MessageNumber ByteString where
34+instance ToIsoparsec MessageNumber ByteString a where
3535 toIsoparsec =
3636 anyToken
3737 >>> mapIso
@@ -49,18 +49,18 @@ newtype DisconnectReasonCode
4949 = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}
5050 deriving (Eq, Ord, Show, Generic, Arbitrary)
5151
52−instance ToIsoparsec DisconnectReasonCode ByteString
52+instance ToIsoparsec DisconnectReasonCode ByteString a
5353
5454newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}
5555 deriving (Eq, Ord, Show, Generic, Arbitrary)
5656
57−instance ToIsoparsec AlwaysDisplay ByteString
57+instance ToIsoparsec AlwaysDisplay ByteString a
5858
5959newtype PacketSequenceNumber
6060 = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}
6161 deriving (Eq, Ord, Show, Generic, Arbitrary)
6262
63−instance ToIsoparsec PacketSequenceNumber ByteString
63+instance ToIsoparsec PacketSequenceNumber ByteString a
6464
6565data Payload
6666 = VersionPayload String
@@ -88,21 +88,20 @@ instance Arbitrary Payload where
8888
8989makePrisms ''Payload
9090
91−instance ToIsoparsec Payload ByteString where
91+instance ToIsoparsec Payload ByteString a where
9292 toIsoparsec =
9393 ( _DisconnectPayload
9494 <.> specific DisconnectMsg
9595 &&& auto @DisconnectReasonCode
96− &&& (tokensWhile (const True) >>> ftu8)
96+ &&& (tokensWhile (const True) >>^ utf8)
9797 )
9898 <+> ( _ServiceRequest <.> specific ServiceRequestMsg
9999 &&& auto @SSHString
100100 )
101− <+> ( _VersionPayload <.> utf8 "SSH-2.0-"
102− &&& ( ( (takeUntil "\r\n" >>> check (BS.all (not . W8.isSpace)))
103− <+> ((takeUntil " " &&& (takeUntil "\r\n" >>> badTsnok "")) >>% morphed)
104− )
105− >>> ftu8
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"
106105 )
107106 )
108107 <+> (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))
@@ -126,8 +125,8 @@ newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
126125badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
127126badZeroPadding =
128127 throughIntegral
129− >>> manyTokens
130− >>^ siJust
128+ ^>> manyTokens
129+ >>^ siPure
131130 (ZeroPadding . fromIntegral . BS.length)
132131 (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
133132
@@ -137,8 +136,8 @@ newtype MAC = MAC {unMAC :: ByteString}
137136data NoneMAC = NoneMAC
138137 deriving (Eq, Ord, Show, Generic)
139138
140−instance ToIsoparsec NoneMAC b where
141− toIsoparsec = konst NoneMAC
139+instance ToIsoparsec NoneMAC b a where
140+ toIsoparsec = arr $ konst NoneMAC
142141
143142instance Arbitrary NoneMAC where
144143 arbitrary = return NoneMAC
@@ -152,25 +151,26 @@ instance Arbitrary mac => Arbitrary (Packet mac) where
152151
153152makePrisms ''Packet
154153
155−instance ToIsoparsec mac ByteString => ToIsoparsec (Packet mac) ByteString where
154+instance ToIsoparsec mac ByteString a => ToIsoparsec (Packet mac) ByteString a where
156155 toIsoparsec =
157− ( ( (auto @(Byte32 'BE) &&& auto @Byte8)
158− >>> (throughIntegral *** throughIntegral)
159− >>> siJust
160− (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))
161− (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
162− ^>> (manyTokens *** throughIntegral)
163− >>> (tuck (auto @Payload) *** badZeroPadding)
164− )
165− &&& auto @mac
156+ ( auto @(Byte32 'BE) &&& anyToken
157+ >>^ throughIntegral *** throughIntegral
158+ >>^ siPure
159+ (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))
160+ (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
161+ >>> manyTokens *** arr throughIntegral
162+ >>> tuck (auto @Payload) *** badZeroPadding
166163 )
167− >>^ siJust (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))
164+ &&& auto @mac
165+ >>^ siPure (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))
168166
169167spec :: Spec
170168spec = do
171169 it "deserialize payload" $ do
172170 "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"
171+ "SSH-2.0-TesT" `parseSatisfyBS` isLeft @_ @Payload
173172 "SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"
173+ "SSH-2.0-TesT random comment" `parseSatisfyBS` isLeft @_ @Payload
174174 "\x2__" `shouldParseBS` IgnorePayload "__"
175175 "\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")
176176 it "deserialize packet" $ do
test/Spec/SshHList.hsnew file+192
@@ -0,0 +1,192 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+
3+module Spec.SshHList
4+ ( spec,
5+ quickSpec,
6+ )
7+where
8+
9+import Control.Lens.TH
10+import Data.ByteString as BS
11+import qualified Data.Char as C
12+import Data.Either
13+import Data.Isoparsec
14+import Data.Isoparsec.ByteString
15+import Data.Word
16+import GHC.Generics
17+import Numeric.Natural
18+import Spec.Helper
19+import Spec.Orphans ()
20+import Test.Hspec
21+import Test.Tasty
22+import Test.Tasty.QuickCheck
23+import Prelude as P hiding ((.), id)
24+
25+data MessageNumber
26+ = DisconnectMsg
27+ | IgnoreMsg
28+ | UnimplementedMsg
29+ | DebugMsg
30+ | ServiceRequestMsg
31+ | ServiceAcceptMsg
32+ | KextInitMsg
33+ | NewKeysMsg
34+ deriving (Eq, Show, Ord)
35+
36+instance ToIsoparsec MessageNumber ByteString a where
37+ toIsoparsec =
38+ delist $
39+ anyToken
40+ ~> mapIso
41+ [ (1 :: Word8, DisconnectMsg),
42+ (2, IgnoreMsg),
43+ (3, UnimplementedMsg),
44+ (4, DebugMsg),
45+ (5, ServiceRequestMsg),
46+ (6, ServiceAcceptMsg),
47+ (20, KextInitMsg),
48+ (21, NewKeysMsg)
49+ ]
50+
51+newtype DisconnectReasonCode
52+ = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}
53+ deriving (Eq, Ord, Show, Generic, Arbitrary)
54+
55+instance ToIsoparsec DisconnectReasonCode ByteString a
56+
57+newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}
58+ deriving (Eq, Ord, Show, Generic, Arbitrary)
59+
60+instance ToIsoparsec AlwaysDisplay ByteString a
61+
62+newtype PacketSequenceNumber
63+ = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}
64+ deriving (Eq, Ord, Show, Generic, Arbitrary)
65+
66+instance ToIsoparsec PacketSequenceNumber ByteString a
67+
68+data Payload
69+ = VersionPayload String
70+ | IgnorePayload ByteString
71+ | ServiceRequest SSHString
72+ | DebugPayload AlwaysDisplay SSHString
73+ | DisconnectPayload DisconnectReasonCode String
74+ | ServiceAccept SSHString
75+ | UnimplementedPayload PacketSequenceNumber
76+ deriving (Show, Eq)
77+
78+instance Arbitrary Payload where
79+ arbitrary =
80+ oneof
81+ [ VersionPayload . P.filter (not . C.isSpace) <$> s,
82+ IgnorePayload <$> arbitrary,
83+ ServiceRequest . SSHString <$> s,
84+ DebugPayload <$> arbitrary <*> (SSHString <$> s),
85+ DisconnectPayload <$> arbitrary <*> s,
86+ ServiceAccept . SSHString <$> s,
87+ UnimplementedPayload <$> arbitrary
88+ ]
89+ where
90+ s = getASCIIString <$> arbitrary
91+
92+makePrisms ''Payload
93+
94+instance ToIsoparsec Payload ByteString a where
95+ toIsoparsec =
96+ delist $
97+ specific DisconnectMsg ~> auto @DisconnectReasonCode
98+ ~& tokensWhile (const True)
99+ ~>^ utf8
100+ ~$> _DisconnectPayload
101+ ~| specific ServiceRequestMsg ~> auto @SSHString ~$> _ServiceRequest
102+ ~| chunk "SSH-2.0-"
103+ ~> tokensWhile (`BS.notElem` " \n\r")
104+ ~>^ utf8
105+ ~> ( chunk " " ~> takeUntil "\r\n" ~>^ (maskr . turn . konst $ ("" :: ByteString))
106+ ~| chunk "\r\n"
107+ )
108+ ~$> _VersionPayload
109+ ~| specific IgnoreMsg ~> tokensWhile (const True) ~$> _IgnorePayload
110+ ~| specific DebugMsg ~> auto @AlwaysDisplay
111+ ~& auto @SSHString
112+ ~$> _DebugPayload
113+ ~| specific UnimplementedMsg ~> auto @PacketSequenceNumber ~$> _UnimplementedPayload
114+ ~| specific ServiceAcceptMsg ~> auto @SSHString ~$> _ServiceAccept
115+
116+newtype Padding = Padding {unPadding :: ByteString}
117+ deriving (Eq, Ord, Show, Generic, Arbitrary)
118+
119+newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
120+ deriving (Eq, Ord, Show, Generic, Arbitrary)
121+
122+badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
123+badZeroPadding =
124+ delist $
125+ throughIntegral
126+ ^~> manyTokens
127+ ~>^ siPure
128+ (ZeroPadding . fromIntegral . BS.length)
129+ (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
130+
131+newtype MAC = MAC {unMAC :: ByteString}
132+ deriving (Eq, Ord, Show, Generic, Arbitrary)
133+
134+data NoneMAC = NoneMAC
135+ deriving (Eq, Ord, Show, Generic)
136+
137+instance ToIsoparsec NoneMAC b a where
138+ toIsoparsec = arr $ konst NoneMAC
139+
140+instance Arbitrary NoneMAC where
141+ arbitrary = return NoneMAC
142+
143+data Packet mac
144+ = Packet Payload ZeroPadding mac
145+ deriving (Eq, Show)
146+
147+instance Arbitrary mac => Arbitrary (Packet mac) where
148+ arbitrary = Packet <$> arbitrary <*> arbitrary <*> arbitrary
149+
150+makePrisms ''Packet
151+
152+instance ToIsoparsec (Packet NoneMAC) ByteString a where
153+ toIsoparsec =
154+ delist $
155+ ( ( (auto @(Byte32 'BE) ~* anyToken)
156+ ~> (arr (throughIntegral @(Byte32 'BE) @Natural) ~* arr (throughIntegral @Byte8 @Natural))
157+ ~>^ siPure
158+ (\(packetL, paddingL :: Natural) -> (packetL - paddingL - 1 :: Natural, paddingL :: Natural))
159+ (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
160+ ~> (manyTokens ~* arr (throughIntegral @Natural @Byte8))
161+ ~> (tuck (auto @Payload) ~* badZeroPadding)
162+ )
163+ ~& auto @NoneMAC
164+ )
165+ ~$> _Packet
166+
167+spec :: Spec
168+spec = do
169+ it "deserialize payload" $ do
170+ "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"
171+ "SSH-2.0-TesT" `parseSatisfyBS` isLeft @_ @Payload
172+ "SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"
173+ "SSH-2.0-TesT random comment" `parseSatisfyBS` isLeft @_ @Payload
174+ "\x2__" `shouldParseBS` IgnorePayload "__"
175+ "\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")
176+ it "deserialize packet" $ do
177+ ("\0\0\0\xd" <> "\x2" <> "\x5\0\0\0\x5henlo" <> "69")
178+ `shouldParseBS` Packet (ServiceRequest (SSHString "henlo")) (ZeroPadding 2) NoneMAC
179+ ("\0\0\0\xd" <> "\x2" <> "\x2\0\0\0\x5henlo" <> "69")
180+ `shouldParseBS` Packet (IgnorePayload "\0\0\0\x5henlo") (ZeroPadding 2) NoneMAC
181+ ("\0\0\0\xd" <> "\x3" <> "\x2\0\0henlo!" <> "69a")
182+ `shouldParseBS` Packet (IgnorePayload "\0\0henlo!") (ZeroPadding 3) NoneMAC
183+ ("\0\0\0\xb" <> "\x3" <> "\x2henlo!" <> "69a")
184+ `shouldParseBS` Packet (IgnorePayload "henlo!") (ZeroPadding 3) NoneMAC
185+
186+quickSpec :: TestTree
187+quickSpec =
188+ testGroup
189+ "roundtrips"
190+ [ testProperty "payload" $ roundtrip @Payload @ByteString,
191+ testProperty "packet" $ roundtrip @(Packet NoneMAC) @ByteString
192+ ]
test/Spec/TwoDigits.hs+15−16
@@ -11,7 +11,6 @@ import Data.Isoparsec.Chunks
1111import Data.Isoparsec.Megaparsec
1212import Data.Isoparsec.Printer
1313import Data.Maybe
14−import Data.Void
1514import GHC.Generics
1615import Test.Hspec
1716import Test.Tasty
@@ -22,14 +21,14 @@ import Prelude hiding ((.))
2221newtype SingleDigit = SingleDigit {unSingleDigit :: String}
2322 deriving (Eq, Show, Generic)
2423
25−instance ToIsoparsec SingleDigit String where
24+instance ToIsoparsec SingleDigit String m where
2625 toIsoparsec =
2726 toIsoparsec @(Chunk 1 String)
28− >>> coercing
29− >>> check (all @[] isDigit)
30− >>> coercing
27+ >>^ coercing
28+ >>^ check (all @[] isDigit)
29+ >>^ coercing
3130
32−instance (Arbitrary SingleDigit) where
31+instance Arbitrary SingleDigit where
3332 arbitrary = SingleDigit . pure <$> elements ['0' .. '9']
3433
3534data Digits
@@ -46,24 +45,24 @@ instance Arbitrary Digits where
4645 TwoDigits <$> arbitrary <*> arbitrary
4746 ]
4847
49−instance ToIsoparsec Digits String
48+instance ToIsoparsec Digits String m
5049
5150spec :: Spec
5251spec = do
5352 let parser = toIsoparsec @_ @String
5453 it "deserializes" $ do
55− runMegaparsec @() parser "12" `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))
56− runMegaparsec @() parser "125" `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))
57− runMegaparsec @() parser "1253" `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))
58− runMegaparsec @() parser "12538" `shouldSatisfy` isLeft
59− runMegaparsec @() parser "2" `shouldSatisfy` isLeft
60− runMegaparsec @() parser "a" `shouldSatisfy` isLeft
61− runMegaparsec @() parser "1a" `shouldSatisfy` isLeft
54+ runMegaparsecParser "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))
55+ runMegaparsecParser "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))
56+ runMegaparsecParser "1253" parser `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))
57+ runMegaparsecParser "12538" parser `shouldSatisfy` isLeft
58+ runMegaparsecParser "2" parser `shouldSatisfy` isLeft
59+ runMegaparsecParser "a" parser `shouldSatisfy` isLeft
60+ runMegaparsecParser "1a" parser `shouldSatisfy` isLeft
6261
6362quickSpec :: TestTree
6463quickSpec = testProperty "roundtrips" $ \x ->
65− let s = fromJust $ runPrinter @Maybe @String parser x
66− in counterexample s $ case runMegaparsec @Void parser s of
64+ let s = fromJust $ runMonoidPrinter @String parser x
65+ in counterexample s $ case runMegaparsecParser s parser of
6766 Right y -> property $ x == y
6867 Left err -> counterexample (errorBundlePretty err) False
6968 where