mirror of
https://github.com/ilyakooo0/isoparsec.git
synced 2024-11-22 04:43:48 +03:00
🐛 wiggle wiggle wiggle (#47)
* 🐛 wiggle wiggle wiggle
* Removed Market export
* Made it compile
* Renamed operators
* JSON
* Some renaming
* HLint update
* Revert "HLint update"
This reverts commit 60ab005a08.
* Updated hlint
This commit is contained in:
GitHub
parent
23e8888625
commit
f6a4642235
30
.hlint.yaml
30
.hlint.yaml
@ -52,7 +52,7 @@
|
||||
# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
|
||||
|
||||
|
||||
# Define some custom infix operators
|
||||
# Define some custom fixity operators
|
||||
# - fixity: infixr 3 ~^#^~
|
||||
|
||||
|
||||
@ -134,14 +134,36 @@
|
||||
|
||||
# hints found in src/Data/Isoparsec.hs
|
||||
- warn: {lhs: "a <+^ konst ()", rhs: "opt a"}
|
||||
- warn: {lhs: "(b >>^ turn (konst a)) <+^ konst ()", rhs: "opt' a b"}
|
||||
- warn: {lhs: "opt (b >>^ turn (konst a))", rhs: "opt' a b"}
|
||||
- warn: {lhs: "(a &&& (repeating a <+^ konst [])) >>^ siCons", rhs: "repeating a"}
|
||||
- warn: {lhs: "sepBy1 a b <+^ konst []", rhs: "sepBy a b"}
|
||||
- warn: {lhs: "(b &&& repeating (a *>> b) <+^ konst []) >>^ siCons", rhs: "sepBy1 a b"}
|
||||
- fixity: "infixl 0 <.>"
|
||||
- warn: {lhs: "(b >>^ morphed) >>^ si a", rhs: "a <.> b"}
|
||||
- warn: {lhs: "(b >>^ morphed) >>^ siPrism a", rhs: "a <.> b"}
|
||||
- warn: {lhs: "withPrism a\n (\\ x y -> SemiIso (pure . x) (either (const empty) pure . y))", rhs: "siPrism a"}
|
||||
- fixity: "infixl 8 ~>"
|
||||
- fixity: "infixl 8 ~>^"
|
||||
- fixity: "infixl 8 ^~>"
|
||||
- fixity: "infixl 8 ^~>^"
|
||||
- warn: {lhs: "turn siHFst ^>> (enlist a *** enlist b) >>^ siHFst", rhs: "a ~> b"}
|
||||
- warn: {lhs: "siPure fst (, HNil)", rhs: "siHFst"}
|
||||
- fixity: "infixl 5 ~|"
|
||||
- warn: {lhs: "enlist a <+> enlist b", rhs: "a ~| b"}
|
||||
- fixity: "infixl 7 ~&"
|
||||
- warn: {lhs: "(enlist a &&& enlist b) >>^ consHList", rhs: "a ~& b"}
|
||||
- fixity: "infixl 9 ~*"
|
||||
- warn: {lhs: "turn consHList ^>> (enlist a *** enlist b) >>^ consHList", rhs: "a ~* b"}
|
||||
- fixity: "infixl 6 ~$>"
|
||||
- warn: {lhs: "enlist a >>> enlist (arr (siPrism b))", rhs: "a ~$> b"}
|
||||
- warn: {lhs: "turn fMorphed ^>>\n (a (fMorphed ^>> b >>^ turn fMorphed)) >>^ fMorphed", rhs: "hmap a b"}
|
||||
- warn: {lhs: "siPure coerce coerce", rhs: "coercing"}
|
||||
- warn: {lhs: "siPure morphTuples morphTuples", rhs: "morphed"}
|
||||
- warn: {lhs: "siPure flatUnmorph flatMorph", rhs: "fMorphed"}
|
||||
- warn: {lhs: "turn fMorphed ^>> a >>^ fMorphed", rhs: "enlist a"}
|
||||
- warn: {lhs: "fMorphed ^>> a >>^ turn fMorphed", rhs: "delist a"}
|
||||
- warn: {lhs: "siPure (uncurry (++:))\n (\\ c -> (hTake @(Length a) Proxy c, hDrop @(Length a) Proxy c))", rhs: "consHList"}
|
||||
- warn: {lhs: "auto @x >>^ turn (konst a)", rhs: "specific a"}
|
||||
- warn: {lhs: "arr (siPure fromIntegral fromIntegral)", rhs: "throughIntegral"}
|
||||
- warn: {lhs: "siPure fromIntegral fromIntegral", rhs: "throughIntegral"}
|
||||
|
||||
# hints found in src/Data/Isoparsec/ByteString.hs
|
||||
- warn: {lhs: "arr (siPure C.unpack C.pack)", rhs: "utf8"}
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
module Control.Prism
|
||||
( withPrism,
|
||||
Market,
|
||||
Identity,
|
||||
Prism',
|
||||
)
|
||||
where
|
||||
|
||||
@ -9,6 +9,8 @@ import Data.Coerce
|
||||
import Data.Functor.Identity
|
||||
import Data.Profunctor
|
||||
|
||||
type Prism' a b = Market a a a (Identity a) -> Market a a b (Identity b)
|
||||
|
||||
data Market a b s t = Market (b -> t) (s -> Either t a)
|
||||
|
||||
instance Functor (Market a b s) where
|
||||
|
||||
@ -7,11 +7,22 @@ module Control.Tuple.Morph
|
||||
TupleMorphable,
|
||||
CheckListsForTupleIso,
|
||||
ReorderList,
|
||||
FlatMorphable (..),
|
||||
TupleHListContents,
|
||||
HListContentsTuple,
|
||||
Nat (..),
|
||||
HList (..),
|
||||
AppendableList (..),
|
||||
DroppableList (..),
|
||||
TakeableList (..),
|
||||
Length,
|
||||
Proxy (..),
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Kind
|
||||
import Data.Proxy
|
||||
import Data.Type.Equality
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits hiding (Nat)
|
||||
|
||||
@ -94,8 +105,14 @@ instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where
|
||||
|
||||
infixl 4 ++:
|
||||
|
||||
class AppendableList aa bb cc | aa bb -> cc where
|
||||
(++:) :: HList aa -> HList bb -> HList (aa ++ bb)
|
||||
class
|
||||
( (aa ++ bb) ~ cc,
|
||||
DroppableList (Length aa) cc bb,
|
||||
TakeableList (Length aa) cc aa
|
||||
) =>
|
||||
AppendableList aa bb cc
|
||||
| aa bb -> cc where
|
||||
(++:) :: HList aa -> HList bb -> HList cc
|
||||
|
||||
instance AppendableList '[] bb bb where
|
||||
HNil ++: bb = bb
|
||||
@ -243,6 +260,33 @@ instance
|
||||
aa = hTake @(Length a) Proxy cc
|
||||
bb = hDrop @(Length a) Proxy cc
|
||||
|
||||
-- ## FlatMorphable
|
||||
|
||||
class
|
||||
( TupleHListContents t ~ th,
|
||||
flag ~ (t == HList th)
|
||||
) =>
|
||||
FlatMorphable t th flag
|
||||
| t -> th,
|
||||
th flag -> t where
|
||||
flatUnmorph :: t -> HList th
|
||||
flatMorph :: HList th -> t
|
||||
|
||||
instance
|
||||
( TupleMorphable' t th (IsMophableTuple t),
|
||||
TupleHListContents t ~ th,
|
||||
HListContentsTuple th ~ t,
|
||||
(t == HList th) ~ 'False
|
||||
) =>
|
||||
FlatMorphable t th 'False
|
||||
where
|
||||
flatUnmorph = unmorph' (Proxy @(IsMophableTuple t))
|
||||
flatMorph = morph' (Proxy @(IsMophableTuple t))
|
||||
|
||||
instance (th == th) ~ 'True => FlatMorphable (HList th) th 'True where
|
||||
flatMorph = id
|
||||
flatUnmorph = id
|
||||
|
||||
-- ## Other
|
||||
|
||||
type family IsMophableTuple t :: Bool where
|
||||
@ -309,3 +353,134 @@ type family IsMophableTuple t :: Bool where
|
||||
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
|
||||
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
|
||||
IsMophableTuple c = 'False
|
||||
|
||||
type family TupleHListContents t :: [*] where
|
||||
TupleHListContents (HList ts) = ts
|
||||
TupleHListContents () = '[]
|
||||
TupleHListContents (a, b) = '[a, b]
|
||||
TupleHListContents (a, b, c) = '[a, b, c]
|
||||
TupleHListContents (a, b, c, d) = '[a, b, c, d]
|
||||
TupleHListContents (a, b, c, d, e) = '[a, b, c, d, e]
|
||||
TupleHListContents (a, b, c, d, e, f) = '[a, b, c, d, e, f]
|
||||
TupleHListContents (a, b, c, d, e, f, g) = '[a, b, c, d, e, f, g]
|
||||
TupleHListContents (a, b, c, d, e, f, g, h) = '[a, b, c, d, e, f, g, h]
|
||||
TupleHListContents (a, b, c, d, e, f, g, h, i) = '[a, b, c, d, e, f, g, h, i]
|
||||
TupleHListContents (a, b, c, d, e, f, g, h, i, j) = '[a, b, c, d, e, f, g, h, i, j]
|
||||
TupleHListContents (a, b, c, d, e, f, g, h, i, j, k) = '[a, b, c, d, e, f, g, h, i, j, k]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
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]
|
||||
TupleHListContents a = '[a]
|
||||
|
||||
type family HListContentsTuple t :: * where
|
||||
HListContentsTuple '[] = ()
|
||||
HListContentsTuple '[a] = a
|
||||
HListContentsTuple '[a, b] = (a, b)
|
||||
HListContentsTuple '[a, b, c] = (a, b, c)
|
||||
HListContentsTuple '[a, b, c, d] = (a, b, c, d)
|
||||
HListContentsTuple '[a, b, c, d, e] = (a, b, c, d, e)
|
||||
HListContentsTuple '[a, b, c, d, e, f] = (a, b, c, d, e, f)
|
||||
HListContentsTuple '[a, b, c, d, e, f, g] = (a, b, c, d, e, f, g)
|
||||
HListContentsTuple '[a, b, c, d, e, f, g, h] = (a, b, c, d, e, f, g, h)
|
||||
HListContentsTuple '[a, b, c, d, e, f, g, h, i] = (a, b, c, d, e, f, g, h, i)
|
||||
HListContentsTuple '[a, b, c, d, e, f, g, h, i, j] = (a, b, c, d, e, f, g, h, i, j)
|
||||
HListContentsTuple '[a, b, c, d, e, f, g, h, i, j, k] = (a, b, c, d, e, f, g, h, i, j, k)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
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)
|
||||
|
||||
@ -4,14 +4,30 @@ module Data.Isoparsec
|
||||
( module X,
|
||||
(<.>),
|
||||
repeating,
|
||||
sepBy,
|
||||
sepBy1,
|
||||
opt,
|
||||
opt',
|
||||
morphed,
|
||||
fMorphed,
|
||||
coercing,
|
||||
mapIso,
|
||||
auto,
|
||||
specific,
|
||||
throughIntegral,
|
||||
(~>),
|
||||
(~>^),
|
||||
(^~>),
|
||||
(^~>^),
|
||||
(~|),
|
||||
(~$>),
|
||||
(~&),
|
||||
(~*),
|
||||
siPrism,
|
||||
delist,
|
||||
enlist,
|
||||
Listed,
|
||||
hmap,
|
||||
)
|
||||
where
|
||||
|
||||
@ -34,16 +50,192 @@ opt' a m = opt (m >>^ turn (konst a))
|
||||
repeating :: (PolyArrow SemiIso m, ArrowPlus m, Eq b) => m () b -> m () [b]
|
||||
repeating m = (m &&& (repeating m <+^ konst [])) >>^ siCons
|
||||
|
||||
sepBy :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]
|
||||
sepBy sep a = sepBy1 sep a <+^ konst []
|
||||
|
||||
sepBy1 :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]
|
||||
sepBy1 sep a = (a &&& repeating (sep *>> a) <+^ konst []) >>^ siCons
|
||||
|
||||
infixl 0 <.>
|
||||
|
||||
(<.>) ::
|
||||
(PolyArrow SemiIso m, TupleMorphable x c, TupleMorphable y c) =>
|
||||
(Market y y y (Identity y) -> Market y y y' (Identity y')) ->
|
||||
(PolyArrow SemiIso m, TupleMorphable x c, TupleMorphable a c) =>
|
||||
(Prism' a b) ->
|
||||
m x' x ->
|
||||
m x' y'
|
||||
b <.> p = (p >>^ morphed) >>^ si b
|
||||
where
|
||||
si p' = withPrism p' $ \x y -> SemiIso (pure . x) (either (const empty) pure . y)
|
||||
m x' b
|
||||
b <.> p = (p >>^ morphed) >>^ siPrism b
|
||||
|
||||
siPrism ::
|
||||
(Prism' a b) ->
|
||||
SemiIso a b
|
||||
siPrism p = withPrism p $ \x y -> SemiIso (pure . x) (either (const empty) pure . y)
|
||||
|
||||
type Listed m a b = m (HList (TupleHListContents a)) (HList (TupleHListContents b))
|
||||
|
||||
infixl 8 ~>, ~>^, ^~>, ^~>^
|
||||
|
||||
type family If cond t f where
|
||||
If 'True t _ = t
|
||||
If 'False _ f = f
|
||||
|
||||
type family BothEmpty a b where
|
||||
BothEmpty '[] '[] = 'True
|
||||
BothEmpty _ _ = 'False
|
||||
|
||||
class BothEmpty c' d' ~ flag => SmartCompose b' c' d' flag | c' d' -> flag where
|
||||
-- | Conceptually an analog to '>>>':
|
||||
--
|
||||
-- > Listed m a b -> Listed m b c -> Listed m a c
|
||||
(~>) ::
|
||||
( PolyArrow SemiIso m,
|
||||
FlatMorphable a a' fa,
|
||||
FlatMorphable b b' fb,
|
||||
FlatMorphable c c' fc,
|
||||
FlatMorphable d d' fd
|
||||
) =>
|
||||
m a b ->
|
||||
m c d ->
|
||||
m (HList a') (HList (If flag b' d'))
|
||||
|
||||
instance SmartCompose b '[] '[] 'True where
|
||||
(~>) lhs rhs = turn siHFst ^>> (enlist lhs *** enlist rhs) >>^ siHFst
|
||||
|
||||
instance SmartCompose (c ': cc) (c ': cc) d 'False where
|
||||
(~>) lhs rhs = enlist lhs >>> enlist rhs
|
||||
|
||||
instance SmartCompose '[] '[] (d ': dd) 'False where
|
||||
(~>) lhs rhs = enlist lhs >>> enlist rhs
|
||||
|
||||
siHFst :: SemiIso (a, HList '[]) a
|
||||
siHFst = siPure fst (,HNil)
|
||||
|
||||
-- | Conceptually an analog to '>>^':
|
||||
--
|
||||
-- > Listed m a b -> SemiIso b c -> Listed m a c
|
||||
(~>^) ::
|
||||
( PolyArrow SemiIso m,
|
||||
FlatMorphable a a' fa,
|
||||
FlatMorphable b bc fb,
|
||||
FlatMorphable c bc 'False,
|
||||
FlatMorphable d d' 'False
|
||||
) =>
|
||||
m a b ->
|
||||
SemiIso c d ->
|
||||
m (HList a') (HList d')
|
||||
lhs ~>^ rhs = enlist lhs >>> enlist (arr rhs)
|
||||
|
||||
-- | Conceptually an analog to '^>>':
|
||||
--
|
||||
-- > SemiIso a b -> Listed m b c -> Listed m a c
|
||||
(^~>) ::
|
||||
( PolyArrow SemiIso m,
|
||||
FlatMorphable a a' 'False,
|
||||
FlatMorphable b bc 'False,
|
||||
FlatMorphable c bc fc,
|
||||
FlatMorphable d d' fd
|
||||
) =>
|
||||
SemiIso a b ->
|
||||
m c d ->
|
||||
m (HList a') (HList d')
|
||||
lhs ^~> rhs = enlist (arr lhs) >>> enlist rhs
|
||||
|
||||
-- | Conceptually an analog to '^>^':
|
||||
--
|
||||
-- > SemiIso a b -> SemiIso b c -> Listed m a c
|
||||
(^~>^) ::
|
||||
( PolyArrow SemiIso m,
|
||||
FlatMorphable a a' 'False,
|
||||
FlatMorphable b b' 'False,
|
||||
FlatMorphable d d' 'False
|
||||
) =>
|
||||
SemiIso a b ->
|
||||
SemiIso b d ->
|
||||
m (HList a') (HList d')
|
||||
lhs ^~>^ rhs = enlist . arr $ lhs >>> rhs
|
||||
|
||||
infixl 5 ~|
|
||||
|
||||
-- | Conceptually an analog to '<+>':
|
||||
--
|
||||
-- > Listed m a b -> Listed m a b -> Listed m a b
|
||||
(~|) ::
|
||||
( PolyArrow SemiIso m,
|
||||
ArrowPlus m,
|
||||
FlatMorphable a ac fa,
|
||||
FlatMorphable c ac fb,
|
||||
FlatMorphable b bd fc,
|
||||
FlatMorphable d bd fd
|
||||
) =>
|
||||
m a b ->
|
||||
m c d ->
|
||||
m (HList ac) (HList bd)
|
||||
lhs ~| rhs = enlist lhs <+> enlist rhs
|
||||
|
||||
infixl 7 ~&
|
||||
|
||||
-- | Conceptually an analog to '&&&':
|
||||
--
|
||||
-- > Listed m a b -> Listed m a c -> Listed m a (b, c)
|
||||
(~&) ::
|
||||
( PolyArrow SemiIso m,
|
||||
FlatMorphable a ac' fa,
|
||||
FlatMorphable c ac' fc,
|
||||
FlatMorphable b b' fb,
|
||||
FlatMorphable d d' fd,
|
||||
AppendableList b' d' f
|
||||
) =>
|
||||
m a b ->
|
||||
m c d ->
|
||||
m (HList ac') (HList f)
|
||||
lhs ~& rhs = (enlist lhs &&& enlist rhs) >>^ consHList
|
||||
|
||||
infixl 9 ~*
|
||||
|
||||
-- | Conceptually an analog to '***':
|
||||
--
|
||||
-- > Listed m a b -> Listed m c d -> Listed m (a, b) (c, d)
|
||||
(~*) ::
|
||||
( PolyArrow SemiIso m,
|
||||
FlatMorphable a a' fa,
|
||||
FlatMorphable c c' fc,
|
||||
FlatMorphable b b' fb,
|
||||
FlatMorphable d d' fd,
|
||||
AppendableList a' c' e',
|
||||
AppendableList b' d' f'
|
||||
) =>
|
||||
m a b ->
|
||||
m c d ->
|
||||
m (HList e') (HList f')
|
||||
lhs ~* rhs = turn consHList ^>> (enlist lhs *** enlist rhs) >>^ consHList
|
||||
|
||||
infixl 6 ~$>
|
||||
|
||||
(~$>) ::
|
||||
( PolyArrow SemiIso m,
|
||||
FlatMorphable a a' fa,
|
||||
FlatMorphable b bc fb,
|
||||
FlatMorphable c bc fc,
|
||||
FlatMorphable d d' fd
|
||||
) =>
|
||||
m a b ->
|
||||
Prism' c d ->
|
||||
m (HList a') (HList d')
|
||||
lhs ~$> rhs = enlist lhs >>> enlist (arr (siPrism rhs))
|
||||
|
||||
-- | Conceptually:
|
||||
--
|
||||
-- > (m a b -> m c d) -> Listed m a b -> Listed m c d
|
||||
hmap ::
|
||||
( FlatMorphable b b' fb,
|
||||
FlatMorphable a a' fa,
|
||||
FlatMorphable d d' fd,
|
||||
FlatMorphable c c' fc,
|
||||
PolyArrow SemiIso m
|
||||
) =>
|
||||
(m a b -> m c d) ->
|
||||
m (HList a') (HList b') ->
|
||||
m (HList c') (HList d')
|
||||
hmap f m = turn fMorphed ^>> (f $ fMorphed ^>> m >>^ turn fMorphed) >>^ fMorphed
|
||||
|
||||
coercing :: forall b a. Coercible a b => SemiIso a b
|
||||
coercing = siPure coerce coerce
|
||||
@ -51,6 +243,43 @@ coercing = siPure coerce coerce
|
||||
morphed :: (TupleMorphable a c, TupleMorphable b c) => SemiIso a b
|
||||
morphed = siPure morphTuples morphTuples
|
||||
|
||||
fMorphed :: (FlatMorphable a b fa) => SemiIso a (HList b)
|
||||
fMorphed = siPure flatUnmorph flatMorph
|
||||
|
||||
-- | Conceptually:
|
||||
--
|
||||
-- > m a b -> Listed m a b
|
||||
enlist ::
|
||||
(FlatMorphable a a' fa, FlatMorphable b b' fb, PolyArrow SemiIso m) =>
|
||||
m a b ->
|
||||
m (HList a') (HList b')
|
||||
enlist m = turn fMorphed ^>> m >>^ fMorphed
|
||||
|
||||
-- | Conceptually:
|
||||
--
|
||||
-- > Listed m a b -> m a b
|
||||
delist ::
|
||||
( FlatMorphable a a' 'False,
|
||||
FlatMorphable b b' 'False,
|
||||
PolyArrow SemiIso m,
|
||||
HListContentsTuple a' ~ a,
|
||||
HListContentsTuple b' ~ b,
|
||||
TupleHListContents a ~ a',
|
||||
TupleHListContents b ~ b'
|
||||
) =>
|
||||
m (HList a') (HList b') ->
|
||||
m a b
|
||||
delist m = fMorphed ^>> m >>^ turn fMorphed
|
||||
|
||||
consHList ::
|
||||
forall a b c.
|
||||
AppendableList a b c =>
|
||||
SemiIso (HList a, HList b) (HList c)
|
||||
consHList =
|
||||
siPure
|
||||
(uncurry (++:))
|
||||
(\c -> (hTake @(Length a) Proxy c, hDrop @(Length a) Proxy c))
|
||||
|
||||
mapIso :: (PolyArrow SemiIso m, Ord a, Ord b) => [(a, b)] -> m a b
|
||||
mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)
|
||||
where
|
||||
@ -66,6 +295,6 @@ specific :: forall x s m. (ToIsoparsec x s m, Isoparsec m s, Eq x) => x -> m ()
|
||||
specific x = auto @x >>^ turn (konst x)
|
||||
|
||||
throughIntegral ::
|
||||
(Integral a, Integral b, Num a, Num b, PolyArrow SemiIso m) =>
|
||||
m a b
|
||||
throughIntegral = arr $ siPure fromIntegral fromIntegral
|
||||
(Integral a, Integral b, Num a, Num b) =>
|
||||
SemiIso a b
|
||||
throughIntegral = siPure fromIntegral fromIntegral
|
||||
|
||||
@ -20,8 +20,8 @@ import Data.Proxy
|
||||
import Data.Word
|
||||
import Prelude as P hiding ((.))
|
||||
|
||||
utf8 :: PolyArrow SemiIso m => m ByteString String
|
||||
utf8 = arr $ siPure C.unpack C.pack
|
||||
utf8 :: SemiIso ByteString String
|
||||
utf8 = siPure C.unpack C.pack
|
||||
|
||||
data Endianness = BE | LE
|
||||
|
||||
@ -88,5 +88,5 @@ instance ToIsoparsec SSHString ByteString m where
|
||||
>>^ coercing @Word32
|
||||
>>^ siPure fromIntegral fromIntegral
|
||||
>>> manyTokens
|
||||
>>> utf8
|
||||
>>^ utf8
|
||||
>>^ siPure SSHString unSSHString
|
||||
|
||||
@ -6,6 +6,7 @@ module Data.Isoparsec.Internal
|
||||
unroll,
|
||||
arrowsWhile,
|
||||
arrowsUntil,
|
||||
EffectOnly,
|
||||
)
|
||||
where
|
||||
|
||||
@ -26,22 +27,22 @@ class
|
||||
|
||||
anyToken :: m () (Element s)
|
||||
|
||||
token :: Element s -> m () ()
|
||||
default token :: Eq (Element s) => Element s -> m () ()
|
||||
token :: Element s -> EffectOnly m
|
||||
default token :: Eq (Element s) => Element s -> EffectOnly m
|
||||
token x = anyToken >>^ turn (konst x)
|
||||
|
||||
token' :: m (Element s) (Element s)
|
||||
default token' :: Eq (Element s) => m (Element s) (Element s)
|
||||
token' = id >>& anyToken >>^ check (uncurry (==)) >>^ siPure fst (\x -> (x, x))
|
||||
|
||||
tokens :: [Element s] -> m () ()
|
||||
tokens :: [Element s] -> EffectOnly m
|
||||
tokens [] = arr $ isoConst () ()
|
||||
tokens (t : ts) = token t &&& tokens ts >>^ isoConst ((), ()) ()
|
||||
|
||||
tokens' :: m [Element s] [Element s]
|
||||
tokens' = (turn siCons ^>> token' *** tokens' >>^ siCons) <+^ isoConst [] []
|
||||
|
||||
chunk :: s -> m () ()
|
||||
chunk :: s -> EffectOnly m
|
||||
chunk = tokens . otoList
|
||||
|
||||
chunk' :: m s s
|
||||
@ -91,6 +92,8 @@ class
|
||||
|
||||
tuck' :: m a b -> m (a, s) b
|
||||
|
||||
type EffectOnly m = m () ()
|
||||
|
||||
arrowsWhile :: (PolyArrow SemiIso m, ArrowPlus m) => m () a -> m () [a]
|
||||
arrowsWhile f = ((f &&& arrowsWhile f) >>^ siCons) <+^ isoConst () []
|
||||
|
||||
|
||||
14
test/Spec.hs
14
test/Spec.hs
@ -1,7 +1,9 @@
|
||||
import qualified Spec.BasicReader as BasicReader
|
||||
import qualified Spec.JSON as JSON
|
||||
import qualified Spec.JSONHList as JSONHList
|
||||
import qualified Spec.Megaparsec.BasicNums as BasicNums
|
||||
import qualified Spec.Ssh as Ssh
|
||||
import qualified Spec.SshHList as SshHList
|
||||
import qualified Spec.TwoDigits as TwoDigits
|
||||
import Test.Tasty
|
||||
import Test.Tasty.Hspec
|
||||
@ -11,7 +13,9 @@ main = do
|
||||
bsicNumSpec <- testSpec "Basic megaparsec test" BasicNums.spec
|
||||
twoDigitsSpec <- testSpec "Two digits test" TwoDigits.spec
|
||||
sshSpec <- testSpec "ssh spec" Ssh.spec
|
||||
sshHListSpec <- testSpec "ssh HList spec" SshHList.spec
|
||||
jsonSpec <- testSpec "json spec" JSON.spec
|
||||
jsonHListSpec <- testSpec "json spec" JSONHList.spec
|
||||
basicReaderSpec <- testSpec "json spec" BasicReader.spec
|
||||
defaultMain
|
||||
( testGroup
|
||||
@ -26,6 +30,11 @@ main = do
|
||||
[ jsonSpec,
|
||||
JSON.quickSpec
|
||||
],
|
||||
testGroup
|
||||
"JSONHList"
|
||||
[ jsonHListSpec,
|
||||
JSONHList.quickSpec
|
||||
],
|
||||
testGroup
|
||||
"TwoDigits"
|
||||
[ twoDigitsSpec,
|
||||
@ -36,6 +45,11 @@ main = do
|
||||
[ sshSpec,
|
||||
Ssh.quickSpec
|
||||
],
|
||||
testGroup
|
||||
"ssh HList"
|
||||
[ sshHListSpec,
|
||||
SshHList.quickSpec
|
||||
],
|
||||
testGroup
|
||||
"BasicReader"
|
||||
[ basicReaderSpec
|
||||
|
||||
@ -63,8 +63,8 @@ quickSpec =
|
||||
instance ToIsoparsec JSON String a where
|
||||
toIsoparsec = json
|
||||
|
||||
json :: Isoparsec m String => m () JSON
|
||||
json = SI pure pure ^<< (string <+> array <+> integer <+> object)
|
||||
json :: forall m. Isoparsec m String => m () JSON
|
||||
json = string <+> array <+> integer <+> object
|
||||
where
|
||||
string' = token '"' **> tokensWhile (/= '"') >** token '"'
|
||||
string = _JString <.> string'
|
||||
@ -72,23 +72,17 @@ json = SI pure pure ^<< (string <+> array <+> integer <+> object)
|
||||
_Array
|
||||
<.> token '['
|
||||
&&& unsafeWhiteSpace
|
||||
&&& ( ( ( (json >** unsafeWhiteSpace)
|
||||
&&& repeating (token ',' *>> unsafeWhiteSpace >>> json) <+^ konst []
|
||||
)
|
||||
>>^ siCons
|
||||
)
|
||||
<+^ konst []
|
||||
)
|
||||
&&& sepByComma json
|
||||
&&& unsafeWhiteSpace
|
||||
&&& token ']'
|
||||
integer = _JInteger <.> number
|
||||
object =
|
||||
_Object <.> token '{' &&& unsafeWhiteSpace
|
||||
&&& ( (pair &&& repeating (token ',' **> unsafeWhiteSpace **> pair) <+^ konst [] >>^ siCons)
|
||||
<+^ konst []
|
||||
)
|
||||
&&& sepByComma pair
|
||||
&&& unsafeWhiteSpace
|
||||
&&& token '}'
|
||||
pair =
|
||||
(unsafeWhiteSpace **> string' >** unsafeWhiteSpace >** token ':' >** unsafeWhiteSpace)
|
||||
&&& (json >** unsafeWhiteSpace)
|
||||
sepByComma :: Eq a => m () a -> m () [a]
|
||||
sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)
|
||||
|
||||
92
test/Spec/JSONHList.hs
Normal file
92
test/Spec/JSONHList.hs
Normal file
@ -0,0 +1,92 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Spec.JSONHList
|
||||
( quickSpec,
|
||||
spec,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Arrow.Extra
|
||||
import Control.Lens.TH
|
||||
import Data.Isoparsec
|
||||
import Data.Isoparsec.Char
|
||||
import Data.Isoparsec.Megaparsec
|
||||
import Data.Isoparsec.Printer
|
||||
import Data.Maybe
|
||||
import Spec.Helper
|
||||
import Test.Hspec
|
||||
import Test.Tasty
|
||||
import Test.Tasty.QuickCheck
|
||||
import Text.Megaparsec.Error
|
||||
import Prelude hiding ((.))
|
||||
|
||||
data JSON
|
||||
= Object [(String, JSON)]
|
||||
| JString String
|
||||
| Array [JSON]
|
||||
| JInteger Integer
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Arbitrary JSON where
|
||||
arbitrary =
|
||||
oneof
|
||||
[ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),
|
||||
JString <$> listOf (elements ['.' .. 'z']),
|
||||
Array <$> listOf (scale (`div` 2) arbitrary),
|
||||
JInteger <$> arbitrary
|
||||
]
|
||||
|
||||
shrink (Object a) = Object <$> shrink a
|
||||
shrink (JString a) = JString <$> shrink a
|
||||
shrink (Array a) = Array <$> shrink a
|
||||
shrink (JInteger a) = JInteger <$> shrink a
|
||||
|
||||
makePrisms ''JSON
|
||||
|
||||
spec :: Spec
|
||||
spec =
|
||||
it "deserializes" $ do
|
||||
"{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]
|
||||
"{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]
|
||||
"{}" `shouldParseS` Object []
|
||||
"[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]
|
||||
"[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]
|
||||
|
||||
quickSpec :: TestTree
|
||||
quickSpec =
|
||||
testProperty "roundtrips" $ \x ->
|
||||
let s = fromJust $ runMonoidPrinter @String json x
|
||||
in counterexample s $ case runMegaparsecParser s json of
|
||||
Right y -> property $ x == y
|
||||
Left err -> counterexample (errorBundlePretty err) False
|
||||
|
||||
instance ToIsoparsec JSON String a where
|
||||
toIsoparsec = json
|
||||
|
||||
json :: forall m. Isoparsec m String => m () JSON
|
||||
json = delist $ string ~| array ~| integer ~| object
|
||||
where
|
||||
string' :: Listed m () String
|
||||
string' = token '"' ~> tokensWhile (/= '"') ~> token '"'
|
||||
string :: Listed m () JSON
|
||||
string = string' ~$> _JString
|
||||
array :: Listed m () JSON
|
||||
array =
|
||||
token '['
|
||||
~> unsafeWhiteSpace
|
||||
~> sepByComma json
|
||||
~> unsafeWhiteSpace
|
||||
~> token ']'
|
||||
~$> _Array
|
||||
integer = number ~$> _JInteger
|
||||
object =
|
||||
token '{' ~> unsafeWhiteSpace
|
||||
~> hmap sepByComma pair
|
||||
~> unsafeWhiteSpace
|
||||
~> token '}'
|
||||
~$> _Object
|
||||
pair =
|
||||
unsafeWhiteSpace ~> string' ~> unsafeWhiteSpace ~> token ':' ~> unsafeWhiteSpace
|
||||
~& json ~> unsafeWhiteSpace
|
||||
sepByComma :: Eq a => m () a -> m () [a]
|
||||
sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)
|
||||
@ -93,13 +93,13 @@ instance ToIsoparsec Payload ByteString a where
|
||||
( _DisconnectPayload
|
||||
<.> specific DisconnectMsg
|
||||
&&& auto @DisconnectReasonCode
|
||||
&&& (tokensWhile (const True) >>> utf8)
|
||||
&&& (tokensWhile (const True) >>^ utf8)
|
||||
)
|
||||
<+> ( _ServiceRequest <.> specific ServiceRequestMsg
|
||||
&&& auto @SSHString
|
||||
)
|
||||
<+> ( _VersionPayload <.> chunk "SSH-2.0-"
|
||||
&&& (tokensWhile (`BS.notElem` " \n\r") >>> utf8)
|
||||
&&& (tokensWhile (`BS.notElem` " \n\r") >>^ utf8)
|
||||
&&& ( (chunk " " >>> takeUntil "\r\n" >>^ (maskr . turn . konst $ ""))
|
||||
<+> chunk "\r\n"
|
||||
)
|
||||
@ -125,7 +125,7 @@ newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
|
||||
badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
|
||||
badZeroPadding =
|
||||
throughIntegral
|
||||
>>> manyTokens
|
||||
^>> manyTokens
|
||||
>>^ siPure
|
||||
(ZeroPadding . fromIntegral . BS.length)
|
||||
(flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
|
||||
@ -154,11 +154,11 @@ makePrisms ''Packet
|
||||
instance ToIsoparsec mac ByteString a => ToIsoparsec (Packet mac) ByteString a where
|
||||
toIsoparsec =
|
||||
( auto @(Byte32 'BE) &&& anyToken
|
||||
>>> throughIntegral *** throughIntegral
|
||||
>>^ throughIntegral *** throughIntegral
|
||||
>>^ siPure
|
||||
(\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))
|
||||
(\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
|
||||
>>> manyTokens *** throughIntegral
|
||||
>>> manyTokens *** arr throughIntegral
|
||||
>>> tuck (auto @Payload) *** badZeroPadding
|
||||
)
|
||||
&&& auto @mac
|
||||
|
||||
192
test/Spec/SshHList.hs
Normal file
192
test/Spec/SshHList.hs
Normal file
@ -0,0 +1,192 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Spec.SshHList
|
||||
( spec,
|
||||
quickSpec,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens.TH
|
||||
import Data.ByteString as BS
|
||||
import qualified Data.Char as C
|
||||
import Data.Either
|
||||
import Data.Isoparsec
|
||||
import Data.Isoparsec.ByteString
|
||||
import Data.Word
|
||||
import GHC.Generics
|
||||
import Numeric.Natural
|
||||
import Spec.Helper
|
||||
import Spec.Orphans ()
|
||||
import Test.Hspec
|
||||
import Test.Tasty
|
||||
import Test.Tasty.QuickCheck
|
||||
import Prelude as P hiding ((.), id)
|
||||
|
||||
data MessageNumber
|
||||
= DisconnectMsg
|
||||
| IgnoreMsg
|
||||
| UnimplementedMsg
|
||||
| DebugMsg
|
||||
| ServiceRequestMsg
|
||||
| ServiceAcceptMsg
|
||||
| KextInitMsg
|
||||
| NewKeysMsg
|
||||
deriving (Eq, Show, Ord)
|
||||
|
||||
instance ToIsoparsec MessageNumber ByteString a where
|
||||
toIsoparsec =
|
||||
delist $
|
||||
anyToken
|
||||
~> mapIso
|
||||
[ (1 :: Word8, DisconnectMsg),
|
||||
(2, IgnoreMsg),
|
||||
(3, UnimplementedMsg),
|
||||
(4, DebugMsg),
|
||||
(5, ServiceRequestMsg),
|
||||
(6, ServiceAcceptMsg),
|
||||
(20, KextInitMsg),
|
||||
(21, NewKeysMsg)
|
||||
]
|
||||
|
||||
newtype DisconnectReasonCode
|
||||
= DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}
|
||||
deriving (Eq, Ord, Show, Generic, Arbitrary)
|
||||
|
||||
instance ToIsoparsec DisconnectReasonCode ByteString a
|
||||
|
||||
newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}
|
||||
deriving (Eq, Ord, Show, Generic, Arbitrary)
|
||||
|
||||
instance ToIsoparsec AlwaysDisplay ByteString a
|
||||
|
||||
newtype PacketSequenceNumber
|
||||
= PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}
|
||||
deriving (Eq, Ord, Show, Generic, Arbitrary)
|
||||
|
||||
instance ToIsoparsec PacketSequenceNumber ByteString a
|
||||
|
||||
data Payload
|
||||
= VersionPayload String
|
||||
| IgnorePayload ByteString
|
||||
| ServiceRequest SSHString
|
||||
| DebugPayload AlwaysDisplay SSHString
|
||||
| DisconnectPayload DisconnectReasonCode String
|
||||
| ServiceAccept SSHString
|
||||
| UnimplementedPayload PacketSequenceNumber
|
||||
deriving (Show, Eq)
|
||||
|
||||
instance Arbitrary Payload where
|
||||
arbitrary =
|
||||
oneof
|
||||
[ VersionPayload . P.filter (not . C.isSpace) <$> s,
|
||||
IgnorePayload <$> arbitrary,
|
||||
ServiceRequest . SSHString <$> s,
|
||||
DebugPayload <$> arbitrary <*> (SSHString <$> s),
|
||||
DisconnectPayload <$> arbitrary <*> s,
|
||||
ServiceAccept . SSHString <$> s,
|
||||
UnimplementedPayload <$> arbitrary
|
||||
]
|
||||
where
|
||||
s = getASCIIString <$> arbitrary
|
||||
|
||||
makePrisms ''Payload
|
||||
|
||||
instance ToIsoparsec Payload ByteString a where
|
||||
toIsoparsec =
|
||||
delist $
|
||||
specific DisconnectMsg ~> auto @DisconnectReasonCode
|
||||
~& tokensWhile (const True)
|
||||
~>^ utf8
|
||||
~$> _DisconnectPayload
|
||||
~| specific ServiceRequestMsg ~> auto @SSHString ~$> _ServiceRequest
|
||||
~| chunk "SSH-2.0-"
|
||||
~> tokensWhile (`BS.notElem` " \n\r")
|
||||
~>^ utf8
|
||||
~> ( chunk " " ~> takeUntil "\r\n" ~>^ (maskr . turn . konst $ ("" :: ByteString))
|
||||
~| chunk "\r\n"
|
||||
)
|
||||
~$> _VersionPayload
|
||||
~| specific IgnoreMsg ~> tokensWhile (const True) ~$> _IgnorePayload
|
||||
~| specific DebugMsg ~> auto @AlwaysDisplay
|
||||
~& auto @SSHString
|
||||
~$> _DebugPayload
|
||||
~| specific UnimplementedMsg ~> auto @PacketSequenceNumber ~$> _UnimplementedPayload
|
||||
~| specific ServiceAcceptMsg ~> auto @SSHString ~$> _ServiceAccept
|
||||
|
||||
newtype Padding = Padding {unPadding :: ByteString}
|
||||
deriving (Eq, Ord, Show, Generic, Arbitrary)
|
||||
|
||||
newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
|
||||
deriving (Eq, Ord, Show, Generic, Arbitrary)
|
||||
|
||||
badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
|
||||
badZeroPadding =
|
||||
delist $
|
||||
throughIntegral
|
||||
^~> manyTokens
|
||||
~>^ siPure
|
||||
(ZeroPadding . fromIntegral . BS.length)
|
||||
(flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
|
||||
|
||||
newtype MAC = MAC {unMAC :: ByteString}
|
||||
deriving (Eq, Ord, Show, Generic, Arbitrary)
|
||||
|
||||
data NoneMAC = NoneMAC
|
||||
deriving (Eq, Ord, Show, Generic)
|
||||
|
||||
instance ToIsoparsec NoneMAC b a where
|
||||
toIsoparsec = arr $ konst NoneMAC
|
||||
|
||||
instance Arbitrary NoneMAC where
|
||||
arbitrary = return NoneMAC
|
||||
|
||||
data Packet mac
|
||||
= Packet Payload ZeroPadding mac
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Arbitrary mac => Arbitrary (Packet mac) where
|
||||
arbitrary = Packet <$> arbitrary <*> arbitrary <*> arbitrary
|
||||
|
||||
makePrisms ''Packet
|
||||
|
||||
instance ToIsoparsec (Packet NoneMAC) ByteString a where
|
||||
toIsoparsec =
|
||||
delist $
|
||||
( ( (auto @(Byte32 'BE) ~* anyToken)
|
||||
~> (arr (throughIntegral @(Byte32 'BE) @Natural) ~* arr (throughIntegral @Byte8 @Natural))
|
||||
~>^ siPure
|
||||
(\(packetL, paddingL :: Natural) -> (packetL - paddingL - 1 :: Natural, paddingL :: Natural))
|
||||
(\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
|
||||
~> (manyTokens ~* arr (throughIntegral @Natural @Byte8))
|
||||
~> (tuck (auto @Payload) ~* badZeroPadding)
|
||||
)
|
||||
~& auto @NoneMAC
|
||||
)
|
||||
~$> _Packet
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
it "deserialize payload" $ do
|
||||
"SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"
|
||||
"SSH-2.0-TesT" `parseSatisfyBS` isLeft @_ @Payload
|
||||
"SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"
|
||||
"SSH-2.0-TesT random comment" `parseSatisfyBS` isLeft @_ @Payload
|
||||
"\x2__" `shouldParseBS` IgnorePayload "__"
|
||||
"\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")
|
||||
it "deserialize packet" $ do
|
||||
("\0\0\0\xd" <> "\x2" <> "\x5\0\0\0\x5henlo" <> "69")
|
||||
`shouldParseBS` Packet (ServiceRequest (SSHString "henlo")) (ZeroPadding 2) NoneMAC
|
||||
("\0\0\0\xd" <> "\x2" <> "\x2\0\0\0\x5henlo" <> "69")
|
||||
`shouldParseBS` Packet (IgnorePayload "\0\0\0\x5henlo") (ZeroPadding 2) NoneMAC
|
||||
("\0\0\0\xd" <> "\x3" <> "\x2\0\0henlo!" <> "69a")
|
||||
`shouldParseBS` Packet (IgnorePayload "\0\0henlo!") (ZeroPadding 3) NoneMAC
|
||||
("\0\0\0\xb" <> "\x3" <> "\x2henlo!" <> "69a")
|
||||
`shouldParseBS` Packet (IgnorePayload "henlo!") (ZeroPadding 3) NoneMAC
|
||||
|
||||
quickSpec :: TestTree
|
||||
quickSpec =
|
||||
testGroup
|
||||
"roundtrips"
|
||||
[ testProperty "payload" $ roundtrip @Payload @ByteString,
|
||||
testProperty "packet" $ roundtrip @(Packet NoneMAC) @ByteString
|
||||
]
|
||||
Loading…
Reference in New Issue
Block a user