git.iko.soy/isoparsec
on master help sign in
swap
04fff3e4 ahead, 1 behind
20 files changed+918−129
since splitsnapshots
unifiedsplit
.hlint.yaml+26−4 package.yaml+1 src/Control/Prism.hs+3−1 src/Control/Tuple/Morph.hs+177−2 src/Data/Isoparsec.hs+238−9 src/Data/Isoparsec/ByteString.hs+3−3 src/Data/Isoparsec/Internal.hs+7−4 src/Data/Isoparsec/Megaparsec.hs+56−26 src/Data/Isoparsec/Printer.hs+62−18 src/Data/Isoparsec/ToIsoparsec.hs−3 stack.yaml+1−1 test/Spec.hs+14 test/Spec/BasicReader.hs+1−1 test/Spec/Helper.hs+17−20 test/Spec/JSON.hs+8−15 test/Spec/JSONHList.hs+92 test/Spec/Megaparsec/BasicNums.hs+5−6 test/Spec/Ssh.hs+6−6 test/Spec/SshHList.hs+192 test/Spec/TwoDigits.hs+9−10
.hlint.yaml+26−4
@@ -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
@@ -134,14 +134,36 @@
134134
135135# hints found in src/Data/Isoparsec.hs
136136- warn: {lhs: "a <+^ konst ()", rhs: "opt a"}
137−- warn: {lhs: "(b >>^ turn (konst a)) <+^ konst ()", rhs: "opt' a b"}
137+- warn: {lhs: "opt (b >>^ turn (konst a))", rhs: "opt' a b"}
138138- 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"}
139141- fixity: "infixl 0 <.>"
140−- warn: {lhs: "(b >>^ morphed) >>^ si a", rhs: "a <.> b"}
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"}
141159- warn: {lhs: "siPure coerce coerce", rhs: "coercing"}
142160- 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"}
143165- warn: {lhs: "auto @x >>^ turn (konst a)", rhs: "specific a"}
144−- warn: {lhs: "arr (siPure fromIntegral fromIntegral)", rhs: "throughIntegral"}
166+- warn: {lhs: "siPure fromIntegral fromIntegral", rhs: "throughIntegral"}
145167
146168# hints found in src/Data/Isoparsec/ByteString.hs
147169- warn: {lhs: "arr (siPure C.unpack C.pack)", rhs: "utf8"}
package.yaml+1
@@ -28,6 +28,7 @@ dependencies:
2828- mtl
2929- profunctors
3030- mono-traversable
31+- split
3132
3233library:
3334 source-dirs: src
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/Tuple/Morph.hs+177−2
@@ -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
@@ -94,8 +105,14 @@ instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where
94105
95106infixl 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+238−9
@@ -4,14 +4,30 @@ module Data.Isoparsec
44 ( module X,
55 (<.>),
66 repeating,
7+ sepBy,
8+ sepBy1,
79 opt,
810 opt',
911 morphed,
12+ fMorphed,
1013 coercing,
1114 mapIso,
1215 auto,
1316 specific,
1417 throughIntegral,
18+ (~>),
19+ (~>^),
20+ (^~>),
21+ (^~>^),
22+ (~|),
23+ (~$>),
24+ (~&),
25+ (~*),
26+ siPrism,
27+ delist,
28+ enlist,
29+ Listed,
30+ hmap,
1531 )
1632where
1733
@@ -34,16 +50,192 @@ opt' a m = opt (m >>^ turn (konst a))
3450repeating :: (PolyArrow SemiIso m, ArrowPlus m, Eq b) => m () b -> m () [b]
3551repeating m = (m &&& (repeating m <+^ konst [])) >>^ siCons
3652
53+sepBy :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]
54+sepBy sep a = sepBy1 sep a <+^ konst []
55+
56+sepBy1 :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]
57+sepBy1 sep a = (a &&& repeating (sep *>> a) <+^ konst []) >>^ siCons
58+
3759infixl 0 <.>
3860
3961(<.>) ::
40− (PolyArrow SemiIso m, TupleMorphable x c, TupleMorphable y c) =>
41− (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) ->
4264 m x' x ->
43− m x' y'
44−b <.> p = (p >>^ morphed) >>^ si b
45− where
46− si p' = withPrism p' $ \x y -> SemiIso (pure . x) (either (const empty) pure . y)
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
47239
48240coercing :: forall b a. Coercible a b => SemiIso a b
49241coercing = siPure coerce coerce
@@ -51,6 +243,43 @@ coercing = siPure coerce coerce
51243morphed :: (TupleMorphable a c, TupleMorphable b c) => SemiIso a b
52244morphed = siPure morphTuples morphTuples
53245
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+
54283mapIso :: (PolyArrow SemiIso m, Ord a, Ord b) => [(a, b)] -> m a b
55284mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)
56285 where
@@ -66,6 +295,6 @@ specific :: forall x s m. (ToIsoparsec x s m, Isoparsec m s, Eq x) => x -> m ()
66295specific x = auto @x >>^ turn (konst x)
67296
68297throughIntegral ::
69− (Integral a, Integral b, Num a, Num b, PolyArrow SemiIso m) =>
70− m a b
71−throughIntegral = arr $ siPure 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+3−3
@@ -20,8 +20,8 @@ import Data.Proxy
2020import Data.Word
2121import Prelude as P hiding ((.))
2222
23−utf8 :: PolyArrow SemiIso m => m ByteString String
24−utf8 = arr $ siPure C.unpack C.pack
23+utf8 :: SemiIso ByteString String
24+utf8 = siPure C.unpack C.pack
2525
2626data Endianness = BE | LE
2727
@@ -88,5 +88,5 @@ instance ToIsoparsec SSHString ByteString m where
8888 >>^ coercing @Word32
8989 >>^ siPure fromIntegral fromIntegral
9090 >>> manyTokens
91− >>> utf8
91+ >>^ utf8
9292 >>^ siPure SSHString unSSHString
src/Data/Isoparsec/Internal.hs+7−4
@@ -6,6 +6,7 @@ module Data.Isoparsec.Internal
66 unroll,
77 arrowsWhile,
88 arrowsUntil,
9+ EffectOnly,
910 )
1011where
1112
@@ -26,22 +27,22 @@ class
2627
2728 anyToken :: m () (Element s)
2829
29− token :: Element s -> m () ()
30− default token :: Eq (Element s) => Element s -> m () ()
30+ token :: Element s -> EffectOnly m
31+ default token :: Eq (Element s) => Element s -> EffectOnly m
3132 token x = anyToken >>^ turn (konst x)
3233
3334 token' :: m (Element s) (Element s)
3435 default token' :: Eq (Element s) => m (Element s) (Element s)
3536 token' = id >>& anyToken >>^ check (uncurry (==)) >>^ siPure fst (\x -> (x, x))
3637
37− tokens :: [Element s] -> m () ()
38+ tokens :: [Element s] -> EffectOnly m
3839 tokens [] = arr $ isoConst () ()
3940 tokens (t : ts) = token t &&& tokens ts >>^ isoConst ((), ()) ()
4041
4142 tokens' :: m [Element s] [Element s]
4243 tokens' = (turn siCons ^>> token' *** tokens' >>^ siCons) <+^ isoConst [] []
4344
44− chunk :: s -> m () ()
45+ chunk :: s -> EffectOnly m
4546 chunk = tokens . otoList
4647
4748 chunk' :: m s s
@@ -91,6 +92,8 @@ class
9192
9293 tuck' :: m a b -> m (a, s) b
9394
95+type EffectOnly m = m () ()
96+
9497arrowsWhile :: (PolyArrow SemiIso m, ArrowPlus m) => m () a -> m () [a]
9598arrowsWhile f = ((f &&& arrowsWhile f) >>^ siCons) <+^ isoConst () []
9699
src/Data/Isoparsec/Megaparsec.hs+56−26
@@ -1,8 +1,9 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
22
33module Data.Isoparsec.Megaparsec
4− ( runMegaparsec,
5− runMegaparsecT,
4+ ( runMegaparsecParser,
5+ ParseErrorBundle (..),
6+ MegaparsecParser (..),
67 )
78where
89
@@ -10,24 +11,30 @@ import Control.Arrow.Extra
1011import Control.Arrow.Extra.Orphans ()
1112import Control.Monad
1213import Data.Functor
13−import Data.Isoparsec.Internal as I
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− s ->
21− Kleisli (Parsec e s) () r ->
22− Either (ParseErrorBundle s e) r
23−runMegaparsec s (Kleisli f) = runParser (f () <* eof) "" s
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
2431
25−runMegaparsecT ::
26− (Ord e, Stream s, Monad m) =>
32+runMegaparsecParser ::
33+ (Stream s) =>
2734 s ->
28− Kleisli (ParsecT e s m) () r ->
29− m (Either (ParseErrorBundle s e) r)
30−runMegaparsecT s (Kleisli f) = runParserT (f () <* eof) "" s
35+ MegaparsecParser s () r ->
36+ Either (ParseErrorBundle s Void) r
37+runMegaparsecParser s (MegaparsecParser (Kleisli f)) = runParser (f () <* eof) "" s
3138
3239instance (MonadParsec e s m) => PolyArrow SemiIso (Kleisli m) where
3340 arr si = Kleisli $ \t -> case embed si t of
@@ -35,24 +42,47 @@ instance (MonadParsec e s m) => PolyArrow SemiIso (Kleisli m) where
3542 Nothing -> M.failure Nothing mempty
3643
3744instance
38− (MonadParsec e s m, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>
39− Isoparsec (Kleisli m) s
45+ (Stream s, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>
46+ Isoparsec (MegaparsecParser s) s
4047 where
41− 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
61+
62+ notToken t = MegaparsecParser . Kleisli . const $ M.anySingleBut t
4263
43− token t = Kleisli . const $ M.single t $> ()
64+ tokenWhere f = MegaparsecParser . Kleisli . const $ satisfy f
4465
45− manyTokens = Kleisli $ takeP Nothing . fromIntegral
66+ manyTokens = MegaparsecParser . Kleisli $ takeP Nothing . fromIntegral
4667
47− tuck' (Kleisli f) = Kleisli $ \(x, sub) -> do
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
4877 sup <- getInput
4978 setInput sub
50− r <- f x <* eof
79+ r <- f () <* eof
5180 setInput sup
5281 return r
5382
54−instance MonadParsec e s m => IsoparsecFail (Kleisli m) e where
55− failure e = Kleisli $ \_ -> customFailure e
56−
57−instance (MonadParsec e s m, M.Token s ~ Element s, s ~ M.Tokens s) => ArrowPlus (Kleisli m) where
58− (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+62−18
@@ -1,39 +1,83 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
22
33module Data.Isoparsec.Printer
4− ( runPrinter,
4+ ( runMonoidPrinter,
5+ MonoidPrinter (..),
56 )
67where
78
89import Control.Cokleisli
910import Control.Monad.Writer.Lazy
11+import Data.Functor
1012import Data.Isoparsec
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 . runCokleisli 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 (Element s), Eq s, IsSequence 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 . singleton $ 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 . singleton
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
3760 return . fromIntegral . olength $ w
3861
39− tuck' (Cokleisli f) = Cokleisli $ lift . (fmap . fmap) getDual . runWriterT . f
62+ takeUntil end = MonoidPrinter . Cokleisli $ \s ->
63+ if length ((split . onSublist $ otoList end) . otoList $ s) > 1
64+ then empty
65+ else do
66+ tell . Dual $ s
67+ tell . Dual $ end
68+
69+ tokensWhile f = MonoidPrinter . Cokleisli $ \s ->
70+ if oall f s
71+ then (tell . Dual) s
72+ else empty
73+
74+ tokensWhile1 f = MonoidPrinter . Cokleisli $ \s ->
75+ if oall f s && not (onull s)
76+ then (tell . Dual) s
77+ else empty
78+
79+ tuck (MonoidPrinter (Cokleisli f)) =
80+ MonoidPrinter . Cokleisli $ lift . fmap getDual . execWriterT . f
81+
82+ tuck' (MonoidPrinter (Cokleisli f)) =
83+ MonoidPrinter . Cokleisli $ lift . (fmap . fmap) getDual . runWriterT . f
src/Data/Isoparsec/ToIsoparsec.hs−3
@@ -42,6 +42,3 @@ instance (GToIsoparsec a s m, GToIsoparsec b s m) => GToIsoparsec (a :+: b) s m
4242 fromL _ = empty
4343 fromR (R1 b) = pure b
4444 fromR _ = empty
45−
46−instance {-# OVERLAPPABLE #-} t ~ Element s => ToIsoparsec t s m where
47− toIsoparsec = anyToken
stack.yaml+1−1
@@ -17,7 +17,7 @@
1717#
1818# resolver: ./custom-snapshot.yaml
1919# resolver: https://example.com/snapshots/2018-01-01.yaml
20−resolver: lts-15.2
20+resolver: lts-15.8
2121
2222# User packages to be built.
2323# Various formats can be used as shown in the example below.
test/Spec.hs+14
@@ -1,7 +1,9 @@
11import qualified Spec.BasicReader as BasicReader
22import qualified Spec.JSON as JSON
3+import qualified Spec.JSONHList as JSONHList
34import qualified Spec.Megaparsec.BasicNums as BasicNums
45import qualified Spec.Ssh as Ssh
6+import qualified Spec.SshHList as SshHList
57import qualified Spec.TwoDigits as TwoDigits
68import Test.Tasty
79import Test.Tasty.Hspec
@@ -11,7 +13,9 @@ main = do
1113 bsicNumSpec <- testSpec "Basic megaparsec test" BasicNums.spec
1214 twoDigitsSpec <- testSpec "Two digits test" TwoDigits.spec
1315 sshSpec <- testSpec "ssh spec" Ssh.spec
16+ sshHListSpec <- testSpec "ssh HList spec" SshHList.spec
1417 jsonSpec <- testSpec "json spec" JSON.spec
18+ jsonHListSpec <- testSpec "json spec" JSONHList.spec
1519 basicReaderSpec <- testSpec "json spec" BasicReader.spec
1620 defaultMain
1721 ( testGroup
@@ -26,6 +30,11 @@ main = do
2630 [ jsonSpec,
2731 JSON.quickSpec
2832 ],
33+ testGroup
34+ "JSONHList"
35+ [ jsonHListSpec,
36+ JSONHList.quickSpec
37+ ],
2938 testGroup
3039 "TwoDigits"
3140 [ twoDigitsSpec,
@@ -36,6 +45,11 @@ main = do
3645 [ sshSpec,
3746 Ssh.quickSpec
3847 ],
48+ testGroup
49+ "ssh HList"
50+ [ sshHListSpec,
51+ SshHList.quickSpec
52+ ],
3953 testGroup
4054 "BasicReader"
4155 [ basicReaderSpec
test/Spec/BasicReader.hs+1−1
@@ -27,7 +27,7 @@ instance ArrowReader String a => ToIsoparsec ConstSep String a where
2727spec :: Spec
2828spec = do
2929 let run (sep :: String) (s :: String) =
30− runMegaparsec @() s . runReaderArrow sep $ (auto @ConstSep)
30+ runMegaparsecParser s . runReaderArrow sep $ (auto @ConstSep)
3131 it "deserializes" $ do
3232 run "s" "12s31" `shouldBe` Right (ConstSep 12 31)
3333 run " " "12 31" `shouldBe` Right (ConstSep 12 31)
test/Spec/Helper.hs+17−20
@@ -6,8 +6,6 @@ module Spec.Helper
66 )
77where
88
9−import Control.Cokleisli
10−import Control.Monad.Writer.Lazy
119import Data.ByteString as BS
1210import Data.Either
1311import Data.Isoparsec as I
@@ -23,23 +21,23 @@ import Prelude as P hiding ((.))
2321
2422parseSatisfy ::
2523 forall x s.
26− ( ToIsoparsec x s (Kleisli (Parsec Void s)),
24+ ( ToIsoparsec x s (MegaparsecParser s),
2725 Stream s,
2826 Show x,
2927 Show (M.Token s),
3028 Show s,
31− Isoparsec (Kleisli (Parsec Void s)) s
29+ Isoparsec (MegaparsecParser s) s
3230 ) =>
3331 s ->
3432 (Either (ParseErrorBundle s Void) x -> Bool) ->
3533 Expectation
36−parseSatisfy s p = runMegaparsec @Void @s s toIsoparsec `shouldSatisfy` p
34+parseSatisfy s p = runMegaparsecParser @s s toIsoparsec `shouldSatisfy` p
3735
3836parseSatisfyBS ::
3937 forall x.
40− ( ToIsoparsec x ByteString (Kleisli (Parsec Void ByteString)),
38+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),
4139 Show x,
42− Isoparsec (Kleisli (Parsec Void ByteString)) ByteString
40+ Isoparsec (MegaparsecParser ByteString) ByteString
4341 ) =>
4442 ByteString ->
4543 (Either (ParseErrorBundle ByteString Void) x -> Bool) ->
@@ -48,25 +46,25 @@ parseSatisfyBS = parseSatisfy
4846
4947shouldParse ::
5048 forall x s.
51− ( ToIsoparsec x s (Kleisli (Parsec Void s)),
49+ ( ToIsoparsec x s (MegaparsecParser s),
5250 Stream s,
5351 Show x,
5452 Eq x,
55− Isoparsec (Kleisli (Parsec Void s)) s
53+ Isoparsec (MegaparsecParser s) s
5654 ) =>
5755 s ->
5856 x ->
5957 Expectation
60−shouldParse s e = case runMegaparsec @Void @s s toIsoparsec of
58+shouldParse s e = case runMegaparsecParser @s s toIsoparsec of
6159 Right e' -> e' `shouldBe` e
6260 Left err -> expectationFailure $ errorBundlePretty err
6361
6462shouldParseBS ::
6563 forall x.
66− ( ToIsoparsec x ByteString (Kleisli (Parsec Void ByteString)),
64+ ( ToIsoparsec x ByteString (MegaparsecParser ByteString),
6765 Show x,
6866 Eq x,
69− Isoparsec (Kleisli (Parsec Void ByteString)) ByteString
67+ Isoparsec (MegaparsecParser ByteString) ByteString
7068 ) =>
7169 ByteString ->
7270 x ->
@@ -75,10 +73,10 @@ shouldParseBS = shouldParse
7573
7674shouldParseS ::
7775 forall x.
78− ( ToIsoparsec x String (Kleisli (Parsec Void String)),
76+ ( ToIsoparsec x String (MegaparsecParser String),
7977 Show x,
8078 Eq x,
81− Isoparsec (Kleisli (Parsec Void String)) String
79+ Isoparsec (MegaparsecParser String) String
8280 ) =>
8381 String ->
8482 x ->
@@ -87,19 +85,18 @@ shouldParseS = shouldParse
8785
8886roundtrip ::
8987 forall x s.
90− ( ToIsoparsec x s (Kleisli (Parsec Void s)),
91− ToIsoparsec x s (Cokleisli (WriterT (Dual s) Maybe)),
88+ ( ToIsoparsec x s (MegaparsecParser s),
89+ ToIsoparsec x s (MonoidPrinter s),
9290 Stream s,
9391 Show s,
9492 I.Element s ~ M.Token s,
9593 Eq x,
96− Eq s,
97− Isoparsec (Kleisli (Parsec Void s)) s
94+ Isoparsec (MegaparsecParser s) s
9895 ) =>
9996 x ->
10097 Property
10198roundtrip x =
102− let s = fromJust $ runPrinter @Maybe @s toIsoparsec x
103− in counterexample (show s) $ case runMegaparsec @Void @s s toIsoparsec of
99+ let s = fromJust $ runMonoidPrinter @s toIsoparsec x
100+ in counterexample (show s) $ case runMegaparsecParser @s s toIsoparsec of
104101 Right y -> property $ x == y
105102 Left err -> counterexample (errorBundlePretty err) False
test/Spec/JSON.hs+8−15
@@ -13,7 +13,6 @@ import Data.Isoparsec.Char
1313import Data.Isoparsec.Megaparsec
1414import Data.Isoparsec.Printer
1515import Data.Maybe
16−import Data.Void
1716import Spec.Helper
1817import Test.Hspec
1918import Test.Tasty
@@ -56,16 +55,16 @@ spec =
5655quickSpec :: TestTree
5756quickSpec =
5857 testProperty "roundtrips" $ \x ->
59− let s = fromJust $ runPrinter @Maybe @String json x
60− in counterexample s $ case runMegaparsec @Void s json of
58+ let s = fromJust $ runMonoidPrinter @String json x
59+ in counterexample s $ case runMegaparsecParser s json of
6160 Right y -> property $ x == y
6261 Left err -> counterexample (errorBundlePretty err) False
6362
6463instance ToIsoparsec JSON String a where
6564 toIsoparsec = json
6665
67−json :: Isoparsec m String => m () JSON
68−json = SI pure pure ^<< (string <+> array <+> integer <+> object)
66+json :: forall m. Isoparsec m String => m () JSON
67+json = string <+> array <+> integer <+> object
6968 where
7069 string' = token '"' **> tokensWhile (/= '"') >** token '"'
7170 string = _JString <.> string'
@@ -73,23 +72,17 @@ json = SI pure pure ^<< (string <+> array <+> integer <+> object)
7372 _Array
7473 <.> token '['
7574 &&& unsafeWhiteSpace
76− &&& ( ( ( (json >** unsafeWhiteSpace)
77− &&& repeating (token ',' *>> unsafeWhiteSpace >>> json) <+^ konst []
78− )
79− >>^ siCons
80− )
81− <+^ konst []
82− )
75+ &&& sepByComma json
8376 &&& unsafeWhiteSpace
8477 &&& token ']'
8578 integer = _JInteger <.> number
8679 object =
8780 _Object <.> token '{' &&& unsafeWhiteSpace
88− &&& ( (pair &&& repeating (token ',' **> unsafeWhiteSpace **> pair) <+^ konst [] >>^ siCons)
89− <+^ konst []
90− )
81+ &&& sepByComma pair
9182 &&& unsafeWhiteSpace
9283 &&& token '}'
9384 pair =
9485 (unsafeWhiteSpace **> string' >** unsafeWhiteSpace >** token ':' >** unsafeWhiteSpace)
9586 &&& (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 @() "12 31" parser `shouldBe` Right (Foo 12 31)
38− runMegaparsec @() "1 33" parser `shouldBe` Right (Foo 1 33)
39− runMegaparsec @() "1562" parser `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 s parser 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/Ssh.hs+6−6
@@ -93,13 +93,13 @@ instance ToIsoparsec Payload ByteString a where
9393 ( _DisconnectPayload
9494 <.> specific DisconnectMsg
9595 &&& auto @DisconnectReasonCode
96− &&& (tokensWhile (const True) >>> utf8)
96+ &&& (tokensWhile (const True) >>^ utf8)
9797 )
9898 <+> ( _ServiceRequest <.> specific ServiceRequestMsg
9999 &&& auto @SSHString
100100 )
101101 <+> ( _VersionPayload <.> chunk "SSH-2.0-"
102− &&& (tokensWhile (`BS.notElem` " \n\r") >>> utf8)
102+ &&& (tokensWhile (`BS.notElem` " \n\r") >>^ utf8)
103103 &&& ( (chunk " " >>> takeUntil "\r\n" >>^ (maskr . turn . konst $ ""))
104104 <+> chunk "\r\n"
105105 )
@@ -125,7 +125,7 @@ newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
125125badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
126126badZeroPadding =
127127 throughIntegral
128− >>> manyTokens
128+ ^>> manyTokens
129129 >>^ siPure
130130 (ZeroPadding . fromIntegral . BS.length)
131131 (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
@@ -153,12 +153,12 @@ makePrisms ''Packet
153153
154154instance ToIsoparsec mac ByteString a => ToIsoparsec (Packet mac) ByteString a where
155155 toIsoparsec =
156− ( auto @(Byte32 'BE) &&& auto @Byte8
157− >>> throughIntegral *** throughIntegral
156+ ( auto @(Byte32 'BE) &&& anyToken
157+ >>^ throughIntegral *** throughIntegral
158158 >>^ siPure
159159 (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))
160160 (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
161− >>> manyTokens *** throughIntegral
161+ >>> manyTokens *** arr throughIntegral
162162 >>> tuck (auto @Payload) *** badZeroPadding
163163 )
164164 &&& auto @mac
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+9−10
@@ -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
@@ -52,18 +51,18 @@ spec :: Spec
5251spec = do
5352 let parser = toIsoparsec @_ @String
5453 it "deserializes" $ do
55− runMegaparsec @() "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))
56− runMegaparsec @() "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))
57− runMegaparsec @() "1253" parser `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))
58− runMegaparsec @() "12538" parser `shouldSatisfy` isLeft
59− runMegaparsec @() "2" parser `shouldSatisfy` isLeft
60− runMegaparsec @() "a" parser `shouldSatisfy` isLeft
61− runMegaparsec @() "1a" parser `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 s parser 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