git.iko.soy/isoparsec
on 4ba121e help sign in
04fff3e
swap
1 ahead, 4 behind
24 files changed+487−918
since splitsnapshots
unifiedsplit
.hlint.yaml+4−26 debugger/Main.hs+142 package.yaml+15−1 src/Control/Prism.hs+1−3 src/Control/Tuple/Morph.hs+2−177 src/Data/Isoparsec.hs+9−238 src/Data/Isoparsec/ByteString.hs+3−3 src/Data/Isoparsec/Debugger.hs+6 src/Data/Isoparsec/Debugger/Internal.hs+75 src/Data/Isoparsec/Debugger/UI.hs+120 src/Data/Isoparsec/Internal.hs+4−7 src/Data/Isoparsec/Megaparsec.hs+26−56 src/Data/Isoparsec/Printer.hs+18−62 src/Data/Isoparsec/ToIsoparsec.hs+3 stack.yaml+1−1 test/Spec.hs−14 test/Spec/BasicReader.hs+1−1 test/Spec/Helper.hs+20−17 test/Spec/JSON.hs+15−8 test/Spec/JSONHList.hs−92 test/Spec/Megaparsec/BasicNums.hs+6−5 test/Spec/Ssh.hs+6−6 test/Spec/SshHList.hs−192 test/Spec/TwoDigits.hs+10−9
.hlint.yaml+4−26
@@ -52,7 +52,7 @@
5252# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
5353
5454
55−# Define some custom fixity operators
55+# Define some custom infix operators
5656# - fixity: infixr 3 ~^#^~
5757
5858
@@ -134,36 +134,14 @@
134134
135135# hints found in src/Data/Isoparsec.hs
136136- warn: {lhs: "a <+^ konst ()", rhs: "opt a"}
137−- warn: {lhs: "opt (b >>^ turn (konst a))", rhs: "opt' a b"}
137+- warn: {lhs: "(b >>^ turn (konst a)) <+^ konst ()", 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"}
141139- fixity: "infixl 0 <.>"
142−- warn: {lhs: "(b >>^ morphed) >>^ siPrism a", rhs: "a <.> b"}
143−- warn: {lhs: "withPrism a\n (\\ x y -> SemiIso (pure . x) (either (const empty) pure . y))", rhs: "siPrism a"}
144−- fixity: "infixl 8 ~>"
145−- fixity: "infixl 8 ~>^"
146−- fixity: "infixl 8 ^~>"
147−- fixity: "infixl 8 ^~>^"
148−- warn: {lhs: "turn siHFst ^>> (enlist a *** enlist b) >>^ siHFst", rhs: "a ~> b"}
149−- warn: {lhs: "siPure fst (, HNil)", rhs: "siHFst"}
150−- fixity: "infixl 5 ~|"
151−- warn: {lhs: "enlist a <+> enlist b", rhs: "a ~| b"}
152−- fixity: "infixl 7 ~&"
153−- warn: {lhs: "(enlist a &&& enlist b) >>^ consHList", rhs: "a ~& b"}
154−- fixity: "infixl 9 ~*"
155−- warn: {lhs: "turn consHList ^>> (enlist a *** enlist b) >>^ consHList", rhs: "a ~* b"}
156−- fixity: "infixl 6 ~$>"
157−- warn: {lhs: "enlist a >>> enlist (arr (siPrism b))", rhs: "a ~$> b"}
158−- warn: {lhs: "turn fMorphed ^>>\n (a (fMorphed ^>> b >>^ turn fMorphed)) >>^ fMorphed", rhs: "hmap a b"}
140+- warn: {lhs: "(b >>^ morphed) >>^ si a", rhs: "a <.> b"}
159141- warn: {lhs: "siPure coerce coerce", rhs: "coercing"}
160142- 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"}
165143- warn: {lhs: "auto @x >>^ turn (konst a)", rhs: "specific a"}
166−- warn: {lhs: "siPure fromIntegral fromIntegral", rhs: "throughIntegral"}
144+- warn: {lhs: "arr (siPure fromIntegral fromIntegral)", rhs: "throughIntegral"}
167145
168146# hints found in src/Data/Isoparsec/ByteString.hs
169147- warn: {lhs: "arr (siPure C.unpack C.pack)", rhs: "utf8"}
debugger/Main.hsnew file+142
@@ -0,0 +1,142 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+
3+module Main
4+ ( main,
5+ )
6+where
7+
8+import Control.Lens.TH
9+import Data.ByteString as BS
10+import qualified Data.Char as C
11+import Data.Isoparsec
12+import Data.Isoparsec.ByteString
13+import Data.Isoparsec.Debugger
14+import GHC.Generics
15+import Prelude as P hiding ((.), id)
16+
17+data MessageNumber
18+ = DisconnectMsg
19+ | IgnoreMsg
20+ | UnimplementedMsg
21+ | DebugMsg
22+ | ServiceRequestMsg
23+ | ServiceAcceptMsg
24+ | KextInitMsg
25+ | NewKeysMsg
26+ deriving (Eq, Show, Ord)
27+
28+instance ToIsoparsec MessageNumber ByteString a where
29+ toIsoparsec =
30+ anyToken
31+ >>> mapIso
32+ [ (1, DisconnectMsg),
33+ (2, IgnoreMsg),
34+ (3, UnimplementedMsg),
35+ (4, DebugMsg),
36+ (5, ServiceRequestMsg),
37+ (6, ServiceAcceptMsg),
38+ (20, KextInitMsg),
39+ (21, NewKeysMsg)
40+ ]
41+
42+newtype DisconnectReasonCode
43+ = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}
44+ deriving (Eq, Ord, Show, Generic)
45+
46+instance ToIsoparsec DisconnectReasonCode ByteString a
47+
48+newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}
49+ deriving (Eq, Ord, Show, Generic)
50+
51+instance ToIsoparsec AlwaysDisplay ByteString a
52+
53+newtype PacketSequenceNumber
54+ = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}
55+ deriving (Eq, Ord, Show, Generic)
56+
57+instance ToIsoparsec PacketSequenceNumber ByteString a
58+
59+data Payload
60+ = VersionPayload String
61+ | IgnorePayload ByteString
62+ | ServiceRequest SSHString
63+ | DebugPayload AlwaysDisplay SSHString
64+ | DisconnectPayload DisconnectReasonCode String
65+ | ServiceAccept SSHString
66+ | UnimplementedPayload PacketSequenceNumber
67+ deriving (Show, Eq)
68+
69+makePrisms ''Payload
70+
71+instance ToIsoparsec Payload ByteString a where
72+ toIsoparsec =
73+ ( _DisconnectPayload
74+ <.> specific DisconnectMsg
75+ &&& auto @DisconnectReasonCode
76+ &&& (tokensWhile (const True) >>> utf8)
77+ )
78+ <+> ( _ServiceRequest <.> specific ServiceRequestMsg
79+ &&& auto @SSHString
80+ )
81+ <+> ( _VersionPayload <.> chunk "SSH-2.0-"
82+ &&& (tokensWhile (`BS.notElem` " \n\r") >>> utf8)
83+ &&& ( (chunk " " >>> takeUntil "\r\n" >>^ (maskr . turn . konst $ ""))
84+ <+> chunk "\r\n"
85+ )
86+ )
87+ <+> (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))
88+ <+> ( _DebugPayload <.> specific DebugMsg
89+ &&& auto @AlwaysDisplay
90+ &&& auto @SSHString
91+ )
92+ <+> ( _UnimplementedPayload <.> specific UnimplementedMsg
93+ &&& auto @PacketSequenceNumber
94+ )
95+ <+> ( _ServiceAccept <.> specific ServiceAcceptMsg
96+ &&& auto @SSHString
97+ )
98+
99+newtype Padding = Padding {unPadding :: ByteString}
100+ deriving (Eq, Ord, Show, Generic)
101+
102+newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
103+ deriving (Eq, Ord, Show, Generic)
104+
105+badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
106+badZeroPadding =
107+ throughIntegral
108+ >>> manyTokens
109+ >>^ siPure
110+ (ZeroPadding . fromIntegral . BS.length)
111+ (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
112+
113+newtype MAC = MAC {unMAC :: ByteString}
114+ deriving (Eq, Ord, Show, Generic)
115+
116+data NoneMAC = NoneMAC
117+ deriving (Eq, Ord, Show, Generic)
118+
119+instance ToIsoparsec NoneMAC b a where
120+ toIsoparsec = arr $ konst NoneMAC
121+
122+data Packet mac
123+ = Packet Payload ZeroPadding mac
124+ deriving (Eq, Show)
125+
126+makePrisms ''Packet
127+
128+instance ToIsoparsec mac ByteString a => ToIsoparsec (Packet mac) ByteString a where
129+ toIsoparsec =
130+ ( auto @(Byte32 'BE) &&& auto @Byte8
131+ >>> throughIntegral *** throughIntegral
132+ >>^ siPure
133+ (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))
134+ (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
135+ >>> manyTokens *** throughIntegral
136+ >>> tuck (auto @Payload) *** badZeroPadding
137+ )
138+ &&& auto @mac
139+ >>^ siPure (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))
140+
141+main :: IO ()
142+main = debug @ByteString (auto @(Packet NoneMAC))
package.yaml+15−1
@@ -28,7 +28,9 @@ dependencies:
2828- mtl
2929- profunctors
3030- mono-traversable
31−- split
31+- brick
32+- vty
33+- word-wrap
3234
3335library:
3436 source-dirs: src
@@ -59,6 +61,7 @@ default-extensions:
5961- TypeOperators
6062- UndecidableInstances
6163- RankNTypes
64+- DeriveFunctor
6265
6366tests:
6467 isoparsec-test:
@@ -79,3 +82,14 @@ tests:
7982 - QuickCheck
8083 - megaparsec
8184 - bytestring
85+
86+executable:
87+ source-dirs: debugger
88+ main: Main.hs
89+ dependencies:
90+ - isoparsec
91+ - lens
92+ ghc-options:
93+ - -threaded
94+ - -rtsopts
95+ - -with-rtsopts=-N
src/Control/Prism.hs+1−3
@@ -1,7 +1,7 @@
11module Control.Prism
22 ( withPrism,
3+ Market,
34 Identity,
4− Prism',
55 )
66where
77
@@ -9,8 +9,6 @@ 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−
1412data Market a b s t = Market (b -> t) (s -> Either t a)
1513
1614instance Functor (Market a b s) where
src/Control/Tuple/Morph.hs+2−177
@@ -7,22 +7,11 @@ 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 (..),
2010 )
2111where
2212
2313import Data.Kind
2414import Data.Proxy
25−import Data.Type.Equality
2615import GHC.Generics
2716import GHC.TypeLits hiding (Nat)
2817
@@ -105,14 +94,8 @@ instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where
10594
10695infixl 4 ++:
10796
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
97+class AppendableList aa bb cc | aa bb -> cc where
98+ (++:) :: HList aa -> HList bb -> HList (aa ++ bb)
11699
117100instance AppendableList '[] bb bb where
118101 HNil ++: bb = bb
@@ -260,33 +243,6 @@ instance
260243 aa = hTake @(Length a) Proxy cc
261244 bb = hDrop @(Length a) Proxy cc
262245
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−
290246-- ## Other
291247
292248type family IsMophableTuple t :: Bool where
@@ -353,134 +309,3 @@ type family IsMophableTuple t :: Bool where
353309 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
354310 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
355311 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+9−238
@@ -4,30 +4,14 @@ module Data.Isoparsec
44 ( module X,
55 (<.>),
66 repeating,
7− sepBy,
8− sepBy1,
97 opt,
108 opt',
119 morphed,
12− fMorphed,
1310 coercing,
1411 mapIso,
1512 auto,
1613 specific,
1714 throughIntegral,
18− (~>),
19− (~>^),
20− (^~>),
21− (^~>^),
22− (~|),
23− (~$>),
24− (~&),
25− (~*),
26− siPrism,
27− delist,
28− enlist,
29− Listed,
30− hmap,
3115 )
3216where
3317
@@ -50,192 +34,16 @@ opt' a m = opt (m >>^ turn (konst a))
5034repeating :: (PolyArrow SemiIso m, ArrowPlus m, Eq b) => m () b -> m () [b]
5135repeating m = (m &&& (repeating m <+^ konst [])) >>^ siCons
5236
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−
5937infixl 0 <.>
6038
6139(<.>) ::
62− (PolyArrow SemiIso m, TupleMorphable x c, TupleMorphable a c) =>
63− (Prism' a b) ->
40+ (PolyArrow SemiIso m, TupleMorphable x c, TupleMorphable y c) =>
41+ (Market y y y (Identity y) -> Market y y y' (Identity y')) ->
6442 m x' x ->
65− m x' b
66−b <.> p = (p >>^ morphed) >>^ siPrism b
67−
68−siPrism ::
69− (Prism' a b) ->
70− SemiIso a b
71−siPrism p = withPrism p $ \x y -> SemiIso (pure . x) (either (const empty) pure . y)
72−
73−type Listed m a b = m (HList (TupleHListContents a)) (HList (TupleHListContents b))
74−
75−infixl 8 ~>, ~>^, ^~>, ^~>^
76−
77−type family If cond t f where
78− If 'True t _ = t
79− If 'False _ f = f
80−
81−type family BothEmpty a b where
82− BothEmpty '[] '[] = 'True
83− BothEmpty _ _ = 'False
84−
85−class BothEmpty c' d' ~ flag => SmartCompose b' c' d' flag | c' d' -> flag where
86− -- | Conceptually an analog to '>>>':
87− --
88− -- > Listed m a b -> Listed m b c -> Listed m a c
89− (~>) ::
90− ( PolyArrow SemiIso m,
91− FlatMorphable a a' fa,
92− FlatMorphable b b' fb,
93− FlatMorphable c c' fc,
94− FlatMorphable d d' fd
95− ) =>
96− m a b ->
97− m c d ->
98− m (HList a') (HList (If flag b' d'))
99−
100−instance SmartCompose b '[] '[] 'True where
101− (~>) lhs rhs = turn siHFst ^>> (enlist lhs *** enlist rhs) >>^ siHFst
102−
103−instance SmartCompose (c ': cc) (c ': cc) d 'False where
104− (~>) lhs rhs = enlist lhs >>> enlist rhs
105−
106−instance SmartCompose '[] '[] (d ': dd) 'False where
107− (~>) lhs rhs = enlist lhs >>> enlist rhs
108−
109−siHFst :: SemiIso (a, HList '[]) a
110−siHFst = siPure fst (,HNil)
111−
112−-- | Conceptually an analog to '>>^':
113−--
114−-- > Listed m a b -> SemiIso b c -> Listed m a c
115−(~>^) ::
116− ( PolyArrow SemiIso m,
117− FlatMorphable a a' fa,
118− FlatMorphable b bc fb,
119− FlatMorphable c bc 'False,
120− FlatMorphable d d' 'False
121− ) =>
122− m a b ->
123− SemiIso c d ->
124− m (HList a') (HList d')
125−lhs ~>^ rhs = enlist lhs >>> enlist (arr rhs)
126−
127−-- | Conceptually an analog to '^>>':
128−--
129−-- > SemiIso a b -> Listed m b c -> Listed m a c
130−(^~>) ::
131− ( PolyArrow SemiIso m,
132− FlatMorphable a a' 'False,
133− FlatMorphable b bc 'False,
134− FlatMorphable c bc fc,
135− FlatMorphable d d' fd
136− ) =>
137− SemiIso a b ->
138− m c d ->
139− m (HList a') (HList d')
140−lhs ^~> rhs = enlist (arr lhs) >>> enlist rhs
141−
142−-- | Conceptually an analog to '^>^':
143−--
144−-- > SemiIso a b -> SemiIso b c -> Listed m a c
145−(^~>^) ::
146− ( PolyArrow SemiIso m,
147− FlatMorphable a a' 'False,
148− FlatMorphable b b' 'False,
149− FlatMorphable d d' 'False
150− ) =>
151− SemiIso a b ->
152− SemiIso b d ->
153− m (HList a') (HList d')
154−lhs ^~>^ rhs = enlist . arr $ lhs >>> rhs
155−
156−infixl 5 ~|
157−
158−-- | Conceptually an analog to '<+>':
159−--
160−-- > Listed m a b -> Listed m a b -> Listed m a b
161−(~|) ::
162− ( PolyArrow SemiIso m,
163− ArrowPlus m,
164− FlatMorphable a ac fa,
165− FlatMorphable c ac fb,
166− FlatMorphable b bd fc,
167− FlatMorphable d bd fd
168− ) =>
169− m a b ->
170− m c d ->
171− m (HList ac) (HList bd)
172−lhs ~| rhs = enlist lhs <+> enlist rhs
173−
174−infixl 7 ~&
175−
176−-- | Conceptually an analog to '&&&':
177−--
178−-- > Listed m a b -> Listed m a c -> Listed m a (b, c)
179−(~&) ::
180− ( PolyArrow SemiIso m,
181− FlatMorphable a ac' fa,
182− FlatMorphable c ac' fc,
183− FlatMorphable b b' fb,
184− FlatMorphable d d' fd,
185− AppendableList b' d' f
186− ) =>
187− m a b ->
188− m c d ->
189− m (HList ac') (HList f)
190−lhs ~& rhs = (enlist lhs &&& enlist rhs) >>^ consHList
191−
192−infixl 9 ~*
193−
194−-- | Conceptually an analog to '***':
195−--
196−-- > Listed m a b -> Listed m c d -> Listed m (a, b) (c, d)
197−(~*) ::
198− ( PolyArrow SemiIso m,
199− FlatMorphable a a' fa,
200− FlatMorphable c c' fc,
201− FlatMorphable b b' fb,
202− FlatMorphable d d' fd,
203− AppendableList a' c' e',
204− AppendableList b' d' f'
205− ) =>
206− m a b ->
207− m c d ->
208− m (HList e') (HList f')
209−lhs ~* rhs = turn consHList ^>> (enlist lhs *** enlist rhs) >>^ consHList
210−
211−infixl 6 ~$>
212−
213−(~$>) ::
214− ( PolyArrow SemiIso m,
215− FlatMorphable a a' fa,
216− FlatMorphable b bc fb,
217− FlatMorphable c bc fc,
218− FlatMorphable d d' fd
219− ) =>
220− m a b ->
221− Prism' c d ->
222− m (HList a') (HList d')
223−lhs ~$> rhs = enlist lhs >>> enlist (arr (siPrism rhs))
224−
225−-- | Conceptually:
226−--
227−-- > (m a b -> m c d) -> Listed m a b -> Listed m c d
228−hmap ::
229− ( FlatMorphable b b' fb,
230− FlatMorphable a a' fa,
231− FlatMorphable d d' fd,
232− FlatMorphable c c' fc,
233− PolyArrow SemiIso m
234− ) =>
235− (m a b -> m c d) ->
236− m (HList a') (HList b') ->
237− m (HList c') (HList d')
238−hmap f m = turn fMorphed ^>> (f $ fMorphed ^>> m >>^ turn fMorphed) >>^ fMorphed
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)
23947
24048coercing :: forall b a. Coercible a b => SemiIso a b
24149coercing = siPure coerce coerce
@@ -243,43 +51,6 @@ coercing = siPure coerce coerce
24351morphed :: (TupleMorphable a c, TupleMorphable b c) => SemiIso a b
24452morphed = siPure morphTuples morphTuples
24553
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−
28354mapIso :: (PolyArrow SemiIso m, Ord a, Ord b) => [(a, b)] -> m a b
28455mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)
28556 where
@@ -295,6 +66,6 @@ specific :: forall x s m. (ToIsoparsec x s m, Isoparsec m s, Eq x) => x -> m ()
29566specific x = auto @x >>^ turn (konst x)
29667
29768throughIntegral ::
298− (Integral a, Integral b, Num a, Num b) =>
299− SemiIso a b
300−throughIntegral = siPure fromIntegral fromIntegral
69+ (Integral a, Integral b, Num a, Num b, PolyArrow SemiIso m) =>
70+ m a b
71+throughIntegral = arr $ 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 :: SemiIso ByteString String
24−utf8 = siPure C.unpack C.pack
23+utf8 :: PolyArrow SemiIso m => m ByteString String
24+utf8 = arr $ 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/Debugger.hsnew file+6
@@ -0,0 +1,6 @@
1+module Data.Isoparsec.Debugger
2+ ( debug,
3+ )
4+where
5+
6+import Data.Isoparsec.Debugger.UI
src/Data/Isoparsec/Debugger/Internal.hsnew file+75
@@ -0,0 +1,75 @@
1+module Data.Isoparsec.Debugger.Internal
2+ ( IsoparsecDebugger (..),
3+ DebuggerAction (..),
4+ DebuggerArrow (..),
5+ )
6+where
7+
8+import Data.Isoparsec
9+import Prelude hiding ((.), id)
10+
11+data IsoparsecDebugger
12+ = DEmpty
13+ | DSeq IsoparsecDebugger IsoparsecDebugger
14+ | DAlt IsoparsecDebugger IsoparsecDebugger
15+ | DAction DebuggerAction
16+ deriving (Show)
17+
18+data DebuggerAction
19+ = AnyToken
20+ | Token String
21+ | Token'
22+ | Tokens String
23+ | Tokens'
24+ | Chunk String
25+ | Chunk'
26+ | NotToken String
27+ | TokenWhere
28+ | ManyTokens
29+ | TakeUntil String
30+ | TokensWhile
31+ | TokensWhile1
32+ | Other String
33+ deriving (Eq, Ord, Show)
34+
35+newtype DebuggerArrow s a b = DebuggerArrow {runDebuggerArrow :: IsoparsecDebugger}
36+
37+instance Category (DebuggerArrow s) where
38+ id = DebuggerArrow DEmpty
39+ (DebuggerArrow a) . (DebuggerArrow b) = DebuggerArrow $ DSeq b a
40+
41+instance BaseArrow (DebuggerArrow s) where
42+ (DebuggerArrow a) *** (DebuggerArrow b) = DebuggerArrow $ DSeq b a
43+ (DebuggerArrow a) &&& (DebuggerArrow b) = DebuggerArrow $ DSeq b a
44+ first (DebuggerArrow a) = DebuggerArrow a
45+ second (DebuggerArrow a) = DebuggerArrow a
46+
47+instance ArrowZero (DebuggerArrow s) where
48+ zeroArrow = DebuggerArrow DEmpty
49+
50+instance ArrowPlus (DebuggerArrow s) where
51+ (DebuggerArrow a) <+> (DebuggerArrow b) = DebuggerArrow $ DAlt b a
52+
53+instance ArrowChoice (DebuggerArrow s) where
54+ (DebuggerArrow a) ||| (DebuggerArrow b) = DebuggerArrow $ DAlt b a
55+ (DebuggerArrow a) +++ (DebuggerArrow b) = DebuggerArrow $ DAlt b a
56+
57+instance PolyArrow p (DebuggerArrow s) where
58+ arr _ = DebuggerArrow DEmpty
59+
60+instance (IsSequence s, Show s) => Isoparsec (DebuggerArrow s) s where
61+ anyToken = DebuggerArrow $ DAction AnyToken
62+ token = DebuggerArrow . DAction . Token . show . singleton @s
63+ token' = DebuggerArrow $ DAction Token'
64+ tokens = DebuggerArrow . DAction . Tokens . show . fromList @s
65+ tokens' = DebuggerArrow $ DAction Tokens'
66+ chunk = DebuggerArrow . DAction . Chunk . show
67+ chunk' = DebuggerArrow $ DAction Chunk'
68+ notToken = DebuggerArrow . DAction . NotToken . show . singleton @s
69+ tokenWhere _ = DebuggerArrow $ DAction TokenWhere
70+ manyTokens = DebuggerArrow $ DAction ManyTokens
71+ takeUntil = DebuggerArrow . DAction . TakeUntil . show
72+ tokensWhile _ = DebuggerArrow $ DAction TokensWhile
73+ tokensWhile1 _ = DebuggerArrow $ DAction TokensWhile1
74+ tuck (DebuggerArrow a) = DebuggerArrow a
75+ tuck' (DebuggerArrow a) = DebuggerArrow a
src/Data/Isoparsec/Debugger/UI.hsnew file+120
@@ -0,0 +1,120 @@
1+module Data.Isoparsec.Debugger.UI
2+ ( debug,
3+ )
4+where
5+
6+import Brick
7+import Brick.Widgets.Border
8+import Brick.Widgets.Center
9+import Control.Monad
10+import Control.Monad.IO.Class
11+import Data.Isoparsec.Debugger.Internal
12+import Graphics.Vty
13+import Text.Wrap
14+
15+debug :: DebuggerArrow s a b -> IO ()
16+debug (DebuggerArrow debugger) = do
17+ putStrLn . take 200 . show . rebalanceState $ debugger
18+ void $
19+ defaultMain
20+ app
21+ DebuggerState
22+ { displayedState = startDisplaying . rebalanceState $ debugger
23+ }
24+
25+app :: App DebuggerState DebuggerEvent DebuggerName
26+app =
27+ App
28+ { appDraw = pure . renderState This . Rendered . displayedState,
29+ appChooseCursor = showFirstCursor,
30+ appHandleEvent = eventHandler,
31+ appStartEvent = \s -> do
32+ vty <- getVtyHandle
33+ let output = outputIface vty
34+ when (supportsMode output Mouse)
35+ $ liftIO
36+ $ setMode output Mouse True
37+ return s,
38+ appAttrMap = const $ attrMap defAttr []
39+ }
40+
41+eventHandler :: DebuggerState -> BrickEvent DebuggerName DebuggerEvent -> EventM DebuggerName (Next DebuggerState)
42+eventHandler s (VtyEvent (EvKey KEsc _)) = halt s
43+eventHandler s (MouseUp n _ _) =
44+ continue $ s {displayedState = unRender $ expand n (Rendered $ displayedState s)}
45+eventHandler s _ = continue s
46+
47+data DebuggerState
48+ = DebuggerState
49+ { displayedState :: DisplayDebuggerState
50+ }
51+
52+data DisplayDebuggerState
53+ = DDSeq (DebugRenderState DisplayDebuggerState) (DebugRenderState DisplayDebuggerState)
54+ | DDAlt (DebugRenderState DisplayDebuggerState) (DebugRenderState DisplayDebuggerState)
55+ | DDAction DebuggerAction
56+ | DDEmpty
57+ deriving (Show)
58+
59+data DebugRenderState a
60+ = Rendered a
61+ | Delayed a
62+ deriving (Show, Functor)
63+
64+unRender :: DebugRenderState a -> a
65+unRender (Rendered a) = a
66+unRender (Delayed a) = a
67+
68+startDisplaying :: IsoparsecDebugger -> DisplayDebuggerState
69+startDisplaying DEmpty = DDEmpty
70+startDisplaying (DAction a) = DDAction a
71+startDisplaying (DSeq a b) =
72+ DDSeq (Rendered $ startDisplaying a) (Delayed $ startDisplaying b)
73+startDisplaying (DAlt a b) =
74+ DDAlt (Rendered $ startDisplaying a) (Delayed $ startDisplaying b)
75+
76+renderState :: DebuggerName -> DebugRenderState DisplayDebuggerState -> Widget DebuggerName
77+renderState n (Delayed _) = clickable n $ renderSmallNode " + "
78+renderState _ (Rendered DDEmpty) = renderSmallNode "*"
79+renderState _ (Rendered (DDAction a)) = renderNode $ show a
80+renderState n (Rendered (DDSeq a b)) = renderState (L n) a <=> renderState (R n) b
81+renderState n (Rendered (DDAlt a b)) = renderState (L n) a <+> renderState (R n) b
82+
83+rebalanceState :: IsoparsecDebugger -> IsoparsecDebugger
84+rebalanceState DEmpty = DEmpty
85+rebalanceState a@(DAction _) = a
86+rebalanceState (DAlt (DAlt a b) c) = rebalanceState $ DAlt (rebalanceState a) (rebalanceState $ DAlt b c)
87+rebalanceState (DAlt a b) = DAlt (rebalanceState a) (rebalanceState b)
88+rebalanceState (DSeq (DSeq a b) c) = rebalanceState $ DSeq (rebalanceState a) (rebalanceState $ DSeq b c)
89+rebalanceState (DSeq DEmpty c) = rebalanceState c
90+rebalanceState (DSeq a b) = DSeq (rebalanceState a) (rebalanceState b)
91+
92+expand ::
93+ DebuggerName ->
94+ DebugRenderState DisplayDebuggerState ->
95+ DebugRenderState DisplayDebuggerState
96+expand This (Delayed s) = Rendered s
97+expand (L n) (Rendered (DDSeq l r)) = Rendered $ DDSeq (expand n l) r
98+expand (L n) (Rendered (DDAlt l r)) = Rendered $ DDAlt (expand n l) r
99+expand (R n) (Rendered (DDAlt l r)) = Rendered $ DDAlt l (expand n r)
100+expand (R n) (Rendered (DDSeq l r)) = Rendered $ DDSeq l (expand n r)
101+expand n (Delayed s) = expand n (Rendered s)
102+expand _ s = s
103+
104+data DebuggerName
105+ = This
106+ | L DebuggerName
107+ | R DebuggerName
108+ deriving (Eq, Ord, Show)
109+
110+data DebuggerEvent = U
111+ deriving (Show)
112+
113+nodeWidth :: Int
114+nodeWidth = 16
115+
116+renderSmallNode :: String -> Widget n
117+renderSmallNode = hLimit nodeWidth . hCenter . border . str
118+
119+renderNode :: String -> Widget n
120+renderNode = hLimit nodeWidth . hCenter . border . strWrapWith (WrapSettings False True)
src/Data/Isoparsec/Internal.hs+4−7
@@ -6,7 +6,6 @@ module Data.Isoparsec.Internal
66 unroll,
77 arrowsWhile,
88 arrowsUntil,
9− EffectOnly,
109 )
1110where
1211
@@ -27,22 +26,22 @@ class
2726
2827 anyToken :: m () (Element s)
2928
30− token :: Element s -> EffectOnly m
31− default token :: Eq (Element s) => Element s -> EffectOnly m
29+ token :: Element s -> m () ()
30+ default token :: Eq (Element s) => Element s -> m () ()
3231 token x = anyToken >>^ turn (konst x)
3332
3433 token' :: m (Element s) (Element s)
3534 default token' :: Eq (Element s) => m (Element s) (Element s)
3635 token' = id >>& anyToken >>^ check (uncurry (==)) >>^ siPure fst (\x -> (x, x))
3736
38− tokens :: [Element s] -> EffectOnly m
37+ tokens :: [Element s] -> m () ()
3938 tokens [] = arr $ isoConst () ()
4039 tokens (t : ts) = token t &&& tokens ts >>^ isoConst ((), ()) ()
4140
4241 tokens' :: m [Element s] [Element s]
4342 tokens' = (turn siCons ^>> token' *** tokens' >>^ siCons) <+^ isoConst [] []
4443
45− chunk :: s -> EffectOnly m
44+ chunk :: s -> m () ()
4645 chunk = tokens . otoList
4746
4847 chunk' :: m s s
@@ -92,8 +91,6 @@ class
9291
9392 tuck' :: m a b -> m (a, s) b
9493
95−type EffectOnly m = m () ()
96−
9794arrowsWhile :: (PolyArrow SemiIso m, ArrowPlus m) => m () a -> m () [a]
9895arrowsWhile f = ((f &&& arrowsWhile f) >>^ siCons) <+^ isoConst () []
9996
src/Data/Isoparsec/Megaparsec.hs+26−56
@@ -1,9 +1,8 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
22
33module Data.Isoparsec.Megaparsec
4− ( runMegaparsecParser,
5− ParseErrorBundle (..),
6− MegaparsecParser (..),
4+ ( runMegaparsec,
5+ runMegaparsecT,
76 )
87where
98
@@ -11,30 +10,24 @@ import Control.Arrow.Extra
1110import Control.Arrow.Extra.Orphans ()
1211import Control.Monad
1312import Data.Functor
14−import Data.Functor.Identity
15−import Data.Isoparsec
16−import Data.Void
13+import Data.Isoparsec.Internal as I
1714import Text.Megaparsec hiding (Token)
1815import qualified Text.Megaparsec as M
1916import Prelude hiding ((.))
2017
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
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
3124
32−runMegaparsecParser ::
33− (Stream s) =>
25+runMegaparsecT ::
26+ (Ord e, Stream s, Monad m) =>
3427 s ->
35− MegaparsecParser s () r ->
36− Either (ParseErrorBundle s Void) r
37−runMegaparsecParser s (MegaparsecParser (Kleisli f)) = runParser (f () <* eof) "" s
28+ Kleisli (ParsecT e s m) () r ->
29+ m (Either (ParseErrorBundle s e) r)
30+runMegaparsecT s (Kleisli f) = runParserT (f () <* eof) "" s
3831
3932instance (MonadParsec e s m) => PolyArrow SemiIso (Kleisli m) where
4033 arr si = Kleisli $ \t -> case embed si t of
@@ -42,47 +35,24 @@ instance (MonadParsec e s m) => PolyArrow SemiIso (Kleisli m) where
4235 Nothing -> M.failure Nothing mempty
4336
4437instance
45− (Stream s, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>
46− Isoparsec (MegaparsecParser s) s
38+ (MonadParsec e s m, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>
39+ Isoparsec (Kleisli m) s
4740 where
48− anyToken = MegaparsecParser . Kleisli $ const anySingle
49−
50− token t = MegaparsecParser . Kleisli . const $ M.single t $> ()
51−
52− token' = MegaparsecParser . Kleisli $ \t -> M.single t $> t
53−
54− tokens ts = MegaparsecParser . Kleisli . const $ M.chunk (fromList ts) $> ()
55−
56− tokens' = MegaparsecParser . Kleisli $ \ts -> M.chunk (fromList ts) $> ts
57−
58− chunk c = MegaparsecParser . Kleisli . const $ M.chunk c $> ()
59−
60− chunk' = MegaparsecParser . Kleisli $ \c -> M.chunk c $> c
61−
62− notToken t = MegaparsecParser . Kleisli . const $ M.anySingleBut t
41+ anyToken = Kleisli $ const anySingle
6342
64− tokenWhere f = MegaparsecParser . Kleisli . const $ satisfy f
43+ token t = Kleisli . const $ M.single t $> ()
6544
66− manyTokens = MegaparsecParser . Kleisli $ takeP Nothing . fromIntegral
45+ manyTokens = Kleisli $ takeP Nothing . fromIntegral
6746
68− takeUntil c = MegaparsecParser . Kleisli $ \() -> do
69− ta <- M.manyTill M.anySingle (M.chunk c)
70− return $ fromList ta
71−
72− tokensWhile f = MegaparsecParser . Kleisli . const $ M.takeWhileP Nothing f
73−
74− tokensWhile1 f = MegaparsecParser . Kleisli . const $ M.takeWhile1P Nothing f
75−
76− tuck (MegaparsecParser (Kleisli f)) = MegaparsecParser . Kleisli $ \sub -> do
77− sup <- getInput
78− setInput sub
79− r <- f () <* eof
80− setInput sup
81− return r
82−
83− tuck' (MegaparsecParser (Kleisli f)) = MegaparsecParser . Kleisli $ \(x, sub) -> do
47+ tuck' (Kleisli f) = Kleisli $ \(x, sub) -> do
8448 sup <- getInput
8549 setInput sub
8650 r <- f x <* eof
8751 setInput sup
8852 return r
53+
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
src/Data/Isoparsec/Printer.hs+18−62
@@ -1,83 +1,39 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
22
33module Data.Isoparsec.Printer
4− ( runMonoidPrinter,
5− MonoidPrinter (..),
4+ ( runPrinter,
65 )
76where
87
98import Control.Cokleisli
109import Control.Monad.Writer.Lazy
11−import Data.Functor
1210import Data.Isoparsec
13−import Data.List.Split
1411import Prelude hiding ((.), id)
1512
16−newtype MonoidPrinter s a b
17− = MonoidPrinter {unMonoidPrinter :: Cokleisli (WriterT (Dual s) Maybe) a b}
18− deriving (Category, BaseArrow, ArrowZero, ArrowPlus, ArrowChoice, PolyArrow SemiIso)
19−
20−runMonoidPrinter ::
21− forall s a.
22− MonoidPrinter s () a ->
13+runPrinter ::
14+ forall m s a.
15+ Monad m =>
16+ Cokleisli (WriterT (Dual s) m) () a ->
2317 a ->
24− Maybe s
25−runMonoidPrinter p = fmap getDual . execWriterT . runCokleisli (unMonoidPrinter p)
18+ m s
19+runPrinter p = fmap getDual . execWriterT . runCokleisli p
20+
21+instance IsoparsecFail (Cokleisli (WriterT s Maybe)) e where
22+ failure _ = Cokleisli . const $ WriterT Nothing
2623
27−instance IsoparsecFail (MonoidPrinter s) e where
28− failure _ = MonoidPrinter . Cokleisli . const $ WriterT Nothing
24+instance IsoparsecFail (Cokleisli (WriterT s (Either e))) e where
25+ failure = Cokleisli . const . WriterT . Left
2926
3027instance
31− (Monoid s, Eq (Element s), IsSequence s) =>
32− Isoparsec (MonoidPrinter s) s
28+ (MonadPlus m, Monoid s, Eq (Element s), Eq s, IsSequence s, Show s) =>
29+ Isoparsec (Cokleisli (WriterT (Dual s) m)) s
3330 where
34− anyToken = MonoidPrinter . Cokleisli $ tell . Dual . singleton
35−
36− token t = MonoidPrinter . Cokleisli $ const $ tell . Dual . singleton $ t
37−
38− token' = MonoidPrinter . Cokleisli $ \t -> (tell . Dual . singleton) t $> t
39−
40− tokens ts = MonoidPrinter . Cokleisli $ const $ tell . Dual . fromList $ ts
41−
42− tokens' = MonoidPrinter . Cokleisli $ \ts -> (tell . Dual . fromList) ts $> ts
43−
44− chunk c = MonoidPrinter . Cokleisli . const $ tell . Dual $ c
31+ token t = Cokleisli $ const $ tell . Dual . singleton $ t
4532
46− chunk' = MonoidPrinter . Cokleisli $ \c -> (tell . Dual) c $> c
33+ anyToken = Cokleisli $ tell . Dual . singleton
4734
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
35+ manyTokens = Cokleisli $ \w -> do
5936 tell $ Dual w
6037 return . fromIntegral . olength $ w
6138
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
39+ tuck' (Cokleisli f) = Cokleisli $ lift . (fmap . fmap) getDual . runWriterT . f
src/Data/Isoparsec/ToIsoparsec.hs+3
@@ -42,3 +42,6 @@ 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.8
20+resolver: lts-15.2
2121
2222# User packages to be built.
2323# Various formats can be used as shown in the example below.
test/Spec.hs−14
@@ -1,9 +1,7 @@
11import qualified Spec.BasicReader as BasicReader
22import qualified Spec.JSON as JSON
3−import qualified Spec.JSONHList as JSONHList
43import qualified Spec.Megaparsec.BasicNums as BasicNums
54import qualified Spec.Ssh as Ssh
6−import qualified Spec.SshHList as SshHList
75import qualified Spec.TwoDigits as TwoDigits
86import Test.Tasty
97import Test.Tasty.Hspec
@@ -13,9 +11,7 @@ main = do
1311 bsicNumSpec <- testSpec "Basic megaparsec test" BasicNums.spec
1412 twoDigitsSpec <- testSpec "Two digits test" TwoDigits.spec
1513 sshSpec <- testSpec "ssh spec" Ssh.spec
16− sshHListSpec <- testSpec "ssh HList spec" SshHList.spec
1714 jsonSpec <- testSpec "json spec" JSON.spec
18− jsonHListSpec <- testSpec "json spec" JSONHList.spec
1915 basicReaderSpec <- testSpec "json spec" BasicReader.spec
2016 defaultMain
2117 ( testGroup
@@ -30,11 +26,6 @@ main = do
3026 [ jsonSpec,
3127 JSON.quickSpec
3228 ],
33− testGroup
34− "JSONHList"
35− [ jsonHListSpec,
36− JSONHList.quickSpec
37− ],
3829 testGroup
3930 "TwoDigits"
4031 [ twoDigitsSpec,
@@ -45,11 +36,6 @@ main = do
4536 [ sshSpec,
4637 Ssh.quickSpec
4738 ],
48− testGroup
49− "ssh HList"
50− [ sshHListSpec,
51− SshHList.quickSpec
52− ],
5339 testGroup
5440 "BasicReader"
5541 [ 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− runMegaparsecParser s . runReaderArrow sep $ (auto @ConstSep)
30+ runMegaparsec @() 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+20−17
@@ -6,6 +6,8 @@ module Spec.Helper
66 )
77where
88
9+import Control.Cokleisli
10+import Control.Monad.Writer.Lazy
911import Data.ByteString as BS
1012import Data.Either
1113import Data.Isoparsec as I
@@ -21,23 +23,23 @@ import Prelude as P hiding ((.))
2123
2224parseSatisfy ::
2325 forall x s.
24− ( ToIsoparsec x s (MegaparsecParser s),
26+ ( ToIsoparsec x s (Kleisli (Parsec Void s)),
2527 Stream s,
2628 Show x,
2729 Show (M.Token s),
2830 Show s,
29− Isoparsec (MegaparsecParser s) s
31+ Isoparsec (Kleisli (Parsec Void s)) s
3032 ) =>
3133 s ->
3234 (Either (ParseErrorBundle s Void) x -> Bool) ->
3335 Expectation
34−parseSatisfy s p = runMegaparsecParser @s s toIsoparsec `shouldSatisfy` p
36+parseSatisfy s p = runMegaparsec @Void @s s toIsoparsec `shouldSatisfy` p
3537
3638parseSatisfyBS ::
3739 forall x.
38− ( ToIsoparsec x ByteString (MegaparsecParser ByteString),
40+ ( ToIsoparsec x ByteString (Kleisli (Parsec Void ByteString)),
3941 Show x,
40− Isoparsec (MegaparsecParser ByteString) ByteString
42+ Isoparsec (Kleisli (Parsec Void ByteString)) ByteString
4143 ) =>
4244 ByteString ->
4345 (Either (ParseErrorBundle ByteString Void) x -> Bool) ->
@@ -46,25 +48,25 @@ parseSatisfyBS = parseSatisfy
4648
4749shouldParse ::
4850 forall x s.
49− ( ToIsoparsec x s (MegaparsecParser s),
51+ ( ToIsoparsec x s (Kleisli (Parsec Void s)),
5052 Stream s,
5153 Show x,
5254 Eq x,
53− Isoparsec (MegaparsecParser s) s
55+ Isoparsec (Kleisli (Parsec Void s)) s
5456 ) =>
5557 s ->
5658 x ->
5759 Expectation
58−shouldParse s e = case runMegaparsecParser @s s toIsoparsec of
60+shouldParse s e = case runMegaparsec @Void @s s toIsoparsec of
5961 Right e' -> e' `shouldBe` e
6062 Left err -> expectationFailure $ errorBundlePretty err
6163
6264shouldParseBS ::
6365 forall x.
64− ( ToIsoparsec x ByteString (MegaparsecParser ByteString),
66+ ( ToIsoparsec x ByteString (Kleisli (Parsec Void ByteString)),
6567 Show x,
6668 Eq x,
67− Isoparsec (MegaparsecParser ByteString) ByteString
69+ Isoparsec (Kleisli (Parsec Void ByteString)) ByteString
6870 ) =>
6971 ByteString ->
7072 x ->
@@ -73,10 +75,10 @@ shouldParseBS = shouldParse
7375
7476shouldParseS ::
7577 forall x.
76− ( ToIsoparsec x String (MegaparsecParser String),
78+ ( ToIsoparsec x String (Kleisli (Parsec Void String)),
7779 Show x,
7880 Eq x,
79− Isoparsec (MegaparsecParser String) String
81+ Isoparsec (Kleisli (Parsec Void String)) String
8082 ) =>
8183 String ->
8284 x ->
@@ -85,18 +87,19 @@ shouldParseS = shouldParse
8587
8688roundtrip ::
8789 forall x s.
88− ( ToIsoparsec x s (MegaparsecParser s),
89− ToIsoparsec x s (MonoidPrinter s),
90+ ( ToIsoparsec x s (Kleisli (Parsec Void s)),
91+ ToIsoparsec x s (Cokleisli (WriterT (Dual s) Maybe)),
9092 Stream s,
9193 Show s,
9294 I.Element s ~ M.Token s,
9395 Eq x,
94− Isoparsec (MegaparsecParser s) s
96+ Eq s,
97+ Isoparsec (Kleisli (Parsec Void s)) s
9598 ) =>
9699 x ->
97100 Property
98101roundtrip x =
99− let s = fromJust $ runMonoidPrinter @s toIsoparsec x
100− in counterexample (show s) $ case runMegaparsecParser @s s toIsoparsec of
102+ let s = fromJust $ runPrinter @Maybe @s toIsoparsec x
103+ in counterexample (show s) $ case runMegaparsec @Void @s s toIsoparsec of
101104 Right y -> property $ x == y
102105 Left err -> counterexample (errorBundlePretty err) False
test/Spec/JSON.hs+15−8
@@ -13,6 +13,7 @@ import Data.Isoparsec.Char
1313import Data.Isoparsec.Megaparsec
1414import Data.Isoparsec.Printer
1515import Data.Maybe
16+import Data.Void
1617import Spec.Helper
1718import Test.Hspec
1819import Test.Tasty
@@ -55,16 +56,16 @@ spec =
5556quickSpec :: TestTree
5657quickSpec =
5758 testProperty "roundtrips" $ \x ->
58− let s = fromJust $ runMonoidPrinter @String json x
59− in counterexample s $ case runMegaparsecParser s json of
59+ let s = fromJust $ runPrinter @Maybe @String json x
60+ in counterexample s $ case runMegaparsec @Void s json of
6061 Right y -> property $ x == y
6162 Left err -> counterexample (errorBundlePretty err) False
6263
6364instance ToIsoparsec JSON String a where
6465 toIsoparsec = json
6566
66−json :: forall m. Isoparsec m String => m () JSON
67−json = string <+> array <+> integer <+> object
67+json :: Isoparsec m String => m () JSON
68+json = SI pure pure ^<< (string <+> array <+> integer <+> object)
6869 where
6970 string' = token '"' **> tokensWhile (/= '"') >** token '"'
7071 string = _JString <.> string'
@@ -72,17 +73,23 @@ json = string <+> array <+> integer <+> object
7273 _Array
7374 <.> token '['
7475 &&& unsafeWhiteSpace
75− &&& sepByComma json
76+ &&& ( ( ( (json >** unsafeWhiteSpace)
77+ &&& repeating (token ',' *>> unsafeWhiteSpace >>> json) <+^ konst []
78+ )
79+ >>^ siCons
80+ )
81+ <+^ konst []
82+ )
7683 &&& unsafeWhiteSpace
7784 &&& token ']'
7885 integer = _JInteger <.> number
7986 object =
8087 _Object <.> token '{' &&& unsafeWhiteSpace
81− &&& sepByComma pair
88+ &&& ( (pair &&& repeating (token ',' **> unsafeWhiteSpace **> pair) <+^ konst [] >>^ siCons)
89+ <+^ konst []
90+ )
8291 &&& unsafeWhiteSpace
8392 &&& token '}'
8493 pair =
8594 (unsafeWhiteSpace **> string' >** unsafeWhiteSpace >** token ':' >** unsafeWhiteSpace)
8695 &&& (json >** unsafeWhiteSpace)
87− sepByComma :: Eq a => m () a -> m () [a]
88− sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)
test/Spec/JSONHList.hsdeleted−92
@@ -1,92 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−module Spec.JSONHList
4− ( quickSpec,
5− spec,
6− )
7−where
8−
9−import Control.Arrow.Extra
10−import Control.Lens.TH
11−import Data.Isoparsec
12−import Data.Isoparsec.Char
13−import Data.Isoparsec.Megaparsec
14−import Data.Isoparsec.Printer
15−import Data.Maybe
16−import Spec.Helper
17−import Test.Hspec
18−import Test.Tasty
19−import Test.Tasty.QuickCheck
20−import Text.Megaparsec.Error
21−import Prelude hiding ((.))
22−
23−data JSON
24− = Object [(String, JSON)]
25− | JString String
26− | Array [JSON]
27− | JInteger Integer
28− deriving (Show, Eq)
29−
30−instance Arbitrary JSON where
31− arbitrary =
32− oneof
33− [ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),
34− JString <$> listOf (elements ['.' .. 'z']),
35− Array <$> listOf (scale (`div` 2) arbitrary),
36− JInteger <$> arbitrary
37− ]
38−
39− shrink (Object a) = Object <$> shrink a
40− shrink (JString a) = JString <$> shrink a
41− shrink (Array a) = Array <$> shrink a
42− shrink (JInteger a) = JInteger <$> shrink a
43−
44−makePrisms ''JSON
45−
46−spec :: Spec
47−spec =
48− it "deserializes" $ do
49− "{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]
50− "{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]
51− "{}" `shouldParseS` Object []
52− "[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]
53− "[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]
54−
55−quickSpec :: TestTree
56−quickSpec =
57− testProperty "roundtrips" $ \x ->
58− let s = fromJust $ runMonoidPrinter @String json x
59− in counterexample s $ case runMegaparsecParser s json of
60− Right y -> property $ x == y
61− Left err -> counterexample (errorBundlePretty err) False
62−
63−instance ToIsoparsec JSON String a where
64− toIsoparsec = json
65−
66−json :: forall m. Isoparsec m String => m () JSON
67−json = delist $ string ~| array ~| integer ~| object
68− where
69− string' :: Listed m () String
70− string' = token '"' ~> tokensWhile (/= '"') ~> token '"'
71− string :: Listed m () JSON
72− string = string' ~$> _JString
73− array :: Listed m () JSON
74− array =
75− token '['
76− ~> unsafeWhiteSpace
77− ~> sepByComma json
78− ~> unsafeWhiteSpace
79− ~> token ']'
80− ~$> _Array
81− integer = number ~$> _JInteger
82− object =
83− token '{' ~> unsafeWhiteSpace
84− ~> hmap sepByComma pair
85− ~> unsafeWhiteSpace
86− ~> token '}'
87− ~$> _Object
88− pair =
89− unsafeWhiteSpace ~> string' ~> unsafeWhiteSpace ~> token ':' ~> unsafeWhiteSpace
90− ~& json ~> unsafeWhiteSpace
91− sepByComma :: Eq a => m () a -> m () [a]
92− sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)
test/Spec/Megaparsec/BasicNums.hs+6−5
@@ -13,6 +13,7 @@ import Data.Isoparsec.Char
1313import Data.Isoparsec.Megaparsec
1414import Data.Isoparsec.Printer
1515import Data.Maybe
16+import Data.Void
1617import Test.Hspec
1718import Test.Tasty
1819import Test.Tasty.QuickCheck
@@ -33,13 +34,13 @@ parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number)
3334spec :: Spec
3435spec =
3536 it "deserializes" $ do
36− runMegaparsecParser "12 31" parser `shouldBe` Right (Foo 12 31)
37− runMegaparsecParser "1 33" parser `shouldBe` Right (Foo 1 33)
38− runMegaparsecParser "1562" parser `shouldSatisfy` isLeft
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
3940
4041quickSpec :: TestTree
4142quickSpec = testProperty "roundtrips" $ \x ->
42− let s = fromJust $ runMonoidPrinter @String parser x
43− in counterexample s $ case runMegaparsecParser s parser of
43+ let s = fromJust $ runPrinter @Maybe @String parser x
44+ in counterexample s $ case runMegaparsec @Void s parser of
4445 Right y -> property $ x == y
4546 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) &&& anyToken
157− >>^ throughIntegral *** throughIntegral
156+ ( auto @(Byte32 'BE) &&& auto @Byte8
157+ >>> throughIntegral *** throughIntegral
158158 >>^ siPure
159159 (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))
160160 (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
161− >>> manyTokens *** arr throughIntegral
161+ >>> manyTokens *** throughIntegral
162162 >>> tuck (auto @Payload) *** badZeroPadding
163163 )
164164 &&& auto @mac
test/Spec/SshHList.hsdeleted−192
@@ -1,192 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−
3−module Spec.SshHList
4− ( spec,
5− quickSpec,
6− )
7−where
8−
9−import Control.Lens.TH
10−import Data.ByteString as BS
11−import qualified Data.Char as C
12−import Data.Either
13−import Data.Isoparsec
14−import Data.Isoparsec.ByteString
15−import Data.Word
16−import GHC.Generics
17−import Numeric.Natural
18−import Spec.Helper
19−import Spec.Orphans ()
20−import Test.Hspec
21−import Test.Tasty
22−import Test.Tasty.QuickCheck
23−import Prelude as P hiding ((.), id)
24−
25−data MessageNumber
26− = DisconnectMsg
27− | IgnoreMsg
28− | UnimplementedMsg
29− | DebugMsg
30− | ServiceRequestMsg
31− | ServiceAcceptMsg
32− | KextInitMsg
33− | NewKeysMsg
34− deriving (Eq, Show, Ord)
35−
36−instance ToIsoparsec MessageNumber ByteString a where
37− toIsoparsec =
38− delist $
39− anyToken
40− ~> mapIso
41− [ (1 :: Word8, DisconnectMsg),
42− (2, IgnoreMsg),
43− (3, UnimplementedMsg),
44− (4, DebugMsg),
45− (5, ServiceRequestMsg),
46− (6, ServiceAcceptMsg),
47− (20, KextInitMsg),
48− (21, NewKeysMsg)
49− ]
50−
51−newtype DisconnectReasonCode
52− = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}
53− deriving (Eq, Ord, Show, Generic, Arbitrary)
54−
55−instance ToIsoparsec DisconnectReasonCode ByteString a
56−
57−newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}
58− deriving (Eq, Ord, Show, Generic, Arbitrary)
59−
60−instance ToIsoparsec AlwaysDisplay ByteString a
61−
62−newtype PacketSequenceNumber
63− = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}
64− deriving (Eq, Ord, Show, Generic, Arbitrary)
65−
66−instance ToIsoparsec PacketSequenceNumber ByteString a
67−
68−data Payload
69− = VersionPayload String
70− | IgnorePayload ByteString
71− | ServiceRequest SSHString
72− | DebugPayload AlwaysDisplay SSHString
73− | DisconnectPayload DisconnectReasonCode String
74− | ServiceAccept SSHString
75− | UnimplementedPayload PacketSequenceNumber
76− deriving (Show, Eq)
77−
78−instance Arbitrary Payload where
79− arbitrary =
80− oneof
81− [ VersionPayload . P.filter (not . C.isSpace) <$> s,
82− IgnorePayload <$> arbitrary,
83− ServiceRequest . SSHString <$> s,
84− DebugPayload <$> arbitrary <*> (SSHString <$> s),
85− DisconnectPayload <$> arbitrary <*> s,
86− ServiceAccept . SSHString <$> s,
87− UnimplementedPayload <$> arbitrary
88− ]
89− where
90− s = getASCIIString <$> arbitrary
91−
92−makePrisms ''Payload
93−
94−instance ToIsoparsec Payload ByteString a where
95− toIsoparsec =
96− delist $
97− specific DisconnectMsg ~> auto @DisconnectReasonCode
98− ~& tokensWhile (const True)
99− ~>^ utf8
100− ~$> _DisconnectPayload
101− ~| specific ServiceRequestMsg ~> auto @SSHString ~$> _ServiceRequest
102− ~| chunk "SSH-2.0-"
103− ~> tokensWhile (`BS.notElem` " \n\r")
104− ~>^ utf8
105− ~> ( chunk " " ~> takeUntil "\r\n" ~>^ (maskr . turn . konst $ ("" :: ByteString))
106− ~| chunk "\r\n"
107− )
108− ~$> _VersionPayload
109− ~| specific IgnoreMsg ~> tokensWhile (const True) ~$> _IgnorePayload
110− ~| specific DebugMsg ~> auto @AlwaysDisplay
111− ~& auto @SSHString
112− ~$> _DebugPayload
113− ~| specific UnimplementedMsg ~> auto @PacketSequenceNumber ~$> _UnimplementedPayload
114− ~| specific ServiceAcceptMsg ~> auto @SSHString ~$> _ServiceAccept
115−
116−newtype Padding = Padding {unPadding :: ByteString}
117− deriving (Eq, Ord, Show, Generic, Arbitrary)
118−
119−newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
120− deriving (Eq, Ord, Show, Generic, Arbitrary)
121−
122−badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
123−badZeroPadding =
124− delist $
125− throughIntegral
126− ^~> manyTokens
127− ~>^ siPure
128− (ZeroPadding . fromIntegral . BS.length)
129− (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
130−
131−newtype MAC = MAC {unMAC :: ByteString}
132− deriving (Eq, Ord, Show, Generic, Arbitrary)
133−
134−data NoneMAC = NoneMAC
135− deriving (Eq, Ord, Show, Generic)
136−
137−instance ToIsoparsec NoneMAC b a where
138− toIsoparsec = arr $ konst NoneMAC
139−
140−instance Arbitrary NoneMAC where
141− arbitrary = return NoneMAC
142−
143−data Packet mac
144− = Packet Payload ZeroPadding mac
145− deriving (Eq, Show)
146−
147−instance Arbitrary mac => Arbitrary (Packet mac) where
148− arbitrary = Packet <$> arbitrary <*> arbitrary <*> arbitrary
149−
150−makePrisms ''Packet
151−
152−instance ToIsoparsec (Packet NoneMAC) ByteString a where
153− toIsoparsec =
154− delist $
155− ( ( (auto @(Byte32 'BE) ~* anyToken)
156− ~> (arr (throughIntegral @(Byte32 'BE) @Natural) ~* arr (throughIntegral @Byte8 @Natural))
157− ~>^ siPure
158− (\(packetL, paddingL :: Natural) -> (packetL - paddingL - 1 :: Natural, paddingL :: Natural))
159− (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
160− ~> (manyTokens ~* arr (throughIntegral @Natural @Byte8))
161− ~> (tuck (auto @Payload) ~* badZeroPadding)
162− )
163− ~& auto @NoneMAC
164− )
165− ~$> _Packet
166−
167−spec :: Spec
168−spec = do
169− it "deserialize payload" $ do
170− "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"
171− "SSH-2.0-TesT" `parseSatisfyBS` isLeft @_ @Payload
172− "SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"
173− "SSH-2.0-TesT random comment" `parseSatisfyBS` isLeft @_ @Payload
174− "\x2__" `shouldParseBS` IgnorePayload "__"
175− "\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")
176− it "deserialize packet" $ do
177− ("\0\0\0\xd" <> "\x2" <> "\x5\0\0\0\x5henlo" <> "69")
178− `shouldParseBS` Packet (ServiceRequest (SSHString "henlo")) (ZeroPadding 2) NoneMAC
179− ("\0\0\0\xd" <> "\x2" <> "\x2\0\0\0\x5henlo" <> "69")
180− `shouldParseBS` Packet (IgnorePayload "\0\0\0\x5henlo") (ZeroPadding 2) NoneMAC
181− ("\0\0\0\xd" <> "\x3" <> "\x2\0\0henlo!" <> "69a")
182− `shouldParseBS` Packet (IgnorePayload "\0\0henlo!") (ZeroPadding 3) NoneMAC
183− ("\0\0\0\xb" <> "\x3" <> "\x2henlo!" <> "69a")
184− `shouldParseBS` Packet (IgnorePayload "henlo!") (ZeroPadding 3) NoneMAC
185−
186−quickSpec :: TestTree
187−quickSpec =
188− testGroup
189− "roundtrips"
190− [ testProperty "payload" $ roundtrip @Payload @ByteString,
191− testProperty "packet" $ roundtrip @(Packet NoneMAC) @ByteString
192− ]
test/Spec/TwoDigits.hs+10−9
@@ -11,6 +11,7 @@ import Data.Isoparsec.Chunks
1111import Data.Isoparsec.Megaparsec
1212import Data.Isoparsec.Printer
1313import Data.Maybe
14+import Data.Void
1415import GHC.Generics
1516import Test.Hspec
1617import Test.Tasty
@@ -51,18 +52,18 @@ spec :: Spec
5152spec = do
5253 let parser = toIsoparsec @_ @String
5354 it "deserializes" $ do
54− runMegaparsecParser "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))
55− runMegaparsecParser "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))
56− runMegaparsecParser "1253" parser `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))
57− runMegaparsecParser "12538" parser `shouldSatisfy` isLeft
58− runMegaparsecParser "2" parser `shouldSatisfy` isLeft
59− runMegaparsecParser "a" parser `shouldSatisfy` isLeft
60− runMegaparsecParser "1a" parser `shouldSatisfy` isLeft
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
6162
6263quickSpec :: TestTree
6364quickSpec = testProperty "roundtrips" $ \x ->
64− let s = fromJust $ runMonoidPrinter @String parser x
65− in counterexample s $ case runMegaparsecParser s parser of
65+ let s = fromJust $ runPrinter @Maybe @String parser x
66+ in counterexample s $ case runMegaparsec @Void s parser of
6667 Right y -> property $ x == y
6768 Left err -> counterexample (errorBundlePretty err) False
6869 where