49556aa · isoparsec · git.iko.soy

git.iko.soy/isoparsec

[WIP] Add Isoparsec (#4)

* Added basics of Isoparsec * Fixed build dependancies * Reformatted, added tasks, added basic megaparsec, added basic tests * Updated actions * Fixed weeder * Added string printer * Added JSON test * Fixed warnings * Revert "Fixed warnings" This reverts commit d25aef4e42cdb3758f10d8c10144c9c53d90eb4a. * Made things compile * Removed redundant dependency * Changed Isoparsec to not be a type family * Added generics and stuff * chunks and stuff * wip added ssh * Proper comment parsing * notes * bumped lts * Added BE LE * added ssh packets * added more ssh tests * fixed test :) * Added zero-padding

commit49556aaab7e9f575d1f8fd0bdb88ffeff443b97e authoriko <ilyakooo0@gmail.com> dateThu 23 Jan 2020, 16:53 (7 years ago) parent1ad141d

32 files changed+1990−80

compare with master

unifiedsplit

.github/workflows/haskell.yml+1−1

@@ -1,6 +1,6 @@

11name: Haskell CI

3−on: [push, pull_request]

3+on: [push]

55jobs:

66 build:

.hlint.yamlnew file+62

@@ -0,0 +1,62 @@

1+# HLint configuration file

2+# https://github.com/ndmitchell/hlint

3+##########################

5+# This file contains a template configuration file, which is typically

6+# placed as .hlint.yaml in the root of your project

9+# Specify additional command line arguments

10+#

11+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]

12+

13+

14+# Control which extensions/flags/modules/functions can be used

15+#

16+# - extensions:

17+# - default: false # all extension are banned by default

18+# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used

19+# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module

20+#

21+# - flags:

22+# - {name: -w, within: []} # -w is allowed nowhere

23+#

24+# - modules:

25+# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'

26+# - {name: Control.Arrow, within: []} # Certain modules are banned entirely

27+#

28+# - functions:

29+# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules

30+

31+

32+# Add custom hints for this project

33+#

34+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"

35+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}

36+

37+

38+# Turn on hints that are off by default

39+#

40+# Ban "module X(module X) where", to require a real export list

41+# - warn: {name: Use explicit module export list}

42+#

43+# Replace a $ b $ c with a . b $ c

44+# - group: {name: dollar, enabled: true}

45+#

46+# Generalise map to fmap, ++ to <>

47+# - group: {name: generalise, enabled: true}

48+

49+

50+# Ignore some builtin hints

51+# - ignore: {name: Use let}

52+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules

53+

54+

55+# Define some custom infix operators

56+# - fixity: infixr 3 ~^#^~

57+

58+

59+# To generate a suitable file for HLint do:

60+# $ hlint --default > .hlint.yaml

61+

62+- ignore: {name: "Use list comprehension"}

.vscode/tasks.jsonnew file+50

@@ -0,0 +1,50 @@

1+{

2+ // See https://go.microsoft.com/fwlink/?LinkId=733558

3+ // for the documentation about the tasks.json format

4+ "version": "2.0.0",

5+ "tasks": [

6+ {

7+ "label": "Stack Build",

8+ "group": {

9+ "kind": "build",

10+ "isDefault": true

11+ },

12+ "type": "shell",

13+ "command": "stack build --fast --no-interleaved-output",

14+ "problemMatcher": {

15+ "owner": "haskell",

16+ "fileLocation": [

17+ "absolute"

18+ ],

19+ "pattern": [

20+ {

21+ "regexp": "^(\\S+\\s+>\\s*)?\\s*(\\S+):(\\d+):(\\d+): (warning|error|info):.*$",

22+ "file": 2,

23+ "line": 3,

24+ "column": 4,

25+ "severity": 5

26+ },

27+ {

28+ "regexp": "^(\\s+•\\s+| \\s*)([^\\d\\W].+)$",

29+ "message": 2

30+ }

31+ ]

32+ },

33+ "presentation": {

34+ "showReuseMessage": false,

35+ "focus": false

36+ }

37+ },

38+ {

39+ "label": "Stack Install",

40+ "type": "shell",

41+ "command": "stack install --fast",

42+ "dependsOn": "Stack Build",

43+ "problemMatcher": [],

44+ "presentation": {

45+ "showReuseMessage": false,

46+ "focus": false

47+ }

48+ }

49+ ]

50+}

app/Main.hs+5−4

@@ -1,6 +1,7 @@

1−module Main (main) where

2−

3−import Lib

1+module Main

2+ ( main,

3+ )

4+where

56main :: IO ()

6−main = someFunc

7+main = putStrLn "henlo."

package.yaml+21−4

@@ -25,6 +25,15 @@ dependencies:

2525library:

2626 source-dirs: src

2727

28+ dependencies:

29+ - optics-core

30+ - megaparsec

31+ - containers

32+ - bytestring

33+ # - text

34+ - mtl

35+

36+

2837executables:

2938 isoparsec-exe:

3039 main: Main.hs

@@ -33,8 +42,7 @@ executables:

3342 - -threaded

3443 - -rtsopts

3544 - -with-rtsopts=-N

36− dependencies:

37− - isoparsec

45+ dependencies: []

3846

3947tests:

4048 isoparsec-test:

@@ -44,5 +52,14 @@ tests:

4452 - -threaded

4553 - -rtsopts

4654 - -with-rtsopts=-N

47− dependencies: []

48− # - isoparsec

55+ dependencies:

56+ - isoparsec

57+ - tasty

58+ - tasty-hspec

59+ - hspec

60+ - optics

61+ - tasty-quickcheck

62+ - QuickCheck

63+ - megaparsec

64+ - bytestring

65+ - word8

random-notes.mdnew file+5

@@ -0,0 +1,5 @@

1+Implied `Isoparse m =>` everywhere

3+`m () a` -- parser produces an `a` out of thin air and printer consumes an `a`.

4+`m a ()` -- printer consumes an `a` and the printer produces an `a`.

5+`a -> m () ()` -- `a` is a global constant used by both the parser and the printer.

src/Control/Arrow/Extra.hs+31−8

@@ -1,9 +1,32 @@

1+{-# LANGUAGE MonoLocalBinds #-}

13module Control.Arrow.Extra

2− ( module X

3− ) where

4−

5−import Control.Arrow.Extra.ArrowChoice as X

6−import Control.Arrow.Extra.ArrowPlus as X

7−import Control.Arrow.Extra.ArrowZero as X

8−import Control.Arrow.Extra.BaseArrow as X

9−import Control.Arrow.Extra.PolyArrow as X

4+ ( module X,

5+ (<+^),

6+ (^+>),

7+ (^+^),

8+ )

9+where

10+

11+import Control.Arrow as X (Kleisli (..))

12+import Control.Arrow.Extra.ArrowChoice as X

13+import Control.Arrow.Extra.ArrowPlus as X

14+import Control.Arrow.Extra.ArrowZero as X

15+import Control.Arrow.Extra.BaseArrow as X

16+import Control.Arrow.Extra.PolyArrow as X

17+import Control.Category as X

18+

19+infixr 5 <+^

20+

21+infixr 5 ^+>

22+

23+infixr 5 ^+^

24+

25+(<+^) :: (ArrowPlus a, PolyArrow a p) => a b c -> p b c -> a b c

26+a <+^ b = a <+> arr b

27+

28+(^+>) :: (ArrowPlus a, PolyArrow a p) => p b c -> a b c -> a b c

29+a ^+> b = arr a <+> b

30+

31+(^+^) :: (ArrowPlus a, PolyArrow a p) => p b c -> p b c -> a b c

32+a ^+^ b = arr a <+> arr b

src/Control/Arrow/Extra/ArrowChoice.hs+14−13

@@ -1,16 +1,23 @@

1−{-# LANGUAGE FlexibleInstances, UndecidableInstances, MonoLocalBinds, NoImplicitPrelude #-}

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MonoLocalBinds #-}

3+{-# LANGUAGE NoImplicitPrelude #-}

4+{-# LANGUAGE UndecidableInstances #-}

36module Control.Arrow.Extra.ArrowChoice

4− ( ArrowChoice(..)

5− ) where

7+ ( ArrowChoice (..),

8+ )

9+where

610

7−import qualified Control.Arrow as A

8−import Control.Arrow.Extra.BaseArrow

9−import Control.Category

10−import Data.Either

11+import Control.Arrow.Extra.BaseArrow

12+import Control.Category

13+import Data.Either

1114

15+infixl 2 +++

16+

17+infixl 2 |||

1218

1319class BaseArrow a => ArrowChoice a where

20+

1421 left :: a b c -> a (Either b d) (Either c d)

1522 left = (+++ id)

1623

@@ -20,9 +27,3 @@ class BaseArrow a => ArrowChoice a where

2027 (+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')

2128

2229 (|||) :: a b d -> a c d -> a (Either b c) d

23−

24−instance A.ArrowChoice a => ArrowChoice a where

25− left = A.left

26− right = A.right

27− (+++) = (A.+++)

28− (|||) = (A.|||)

src/Control/Arrow/Extra/ArrowPlus.hs+9−8

@@ -1,14 +1,15 @@

1−{-# LANGUAGE FlexibleInstances, UndecidableInstances, MonoLocalBinds #-}

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MonoLocalBinds #-}

3+{-# LANGUAGE UndecidableInstances #-}

35module Control.Arrow.Extra.ArrowPlus

4− ( ArrowPlus(..)

5− ) where

6+ ( ArrowPlus (..),

7+ )

8+where

7−import qualified Control.Arrow as A

8−import Control.Arrow.Extra.ArrowZero

10+import Control.Arrow.Extra.ArrowZero

11+

12+infixl 5 <+>

913

1014class ArrowZero a => ArrowPlus a where

1115 (<+>) :: a b c -> a b c -> a b c

12−

13−instance A.ArrowPlus a => ArrowPlus a where

14− (<+>) = (A.<+>)

src/Control/Arrow/Extra/ArrowZero.hs+7−8

@@ -1,14 +1,13 @@

1−{-# LANGUAGE FlexibleInstances, UndecidableInstances, MonoLocalBinds #-}

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MonoLocalBinds #-}

3+{-# LANGUAGE UndecidableInstances #-}

35module Control.Arrow.Extra.ArrowZero

4− ( ArrowZero(..)

5− ) where

6+ ( ArrowZero (..),

7+ )

8+where

7−import qualified Control.Arrow as A

8−import Control.Arrow.Extra.BaseArrow

10+import Control.Arrow.Extra.BaseArrow

911

1012class BaseArrow a => ArrowZero a where

1113 zeroArrow :: a b c

12−

13−instance A.ArrowZero a => ArrowZero a where

14− zeroArrow = A.zeroArrow

src/Control/Arrow/Extra/BaseArrow.hs+16−15

@@ -1,27 +1,28 @@

1−{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, UndecidableInstances #-}

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE NoImplicitPrelude #-}

3+{-# LANGUAGE UndecidableInstances #-}

35module Control.Arrow.Extra.BaseArrow

4− ( BaseArrow(..)

5− ) where

6+ ( BaseArrow (..),

7+ )

8+where

7−import qualified Control.Arrow as A

8−import Control.Category

10+import Control.Category

11+

12+infixl 3 ***

13+

14+infixl 3 &&&

915

1016class Category a => BaseArrow a where

17+

1118 {-# MINIMAL (***), (&&&) #-}

1219

13− first :: a b c -> a (b,d) (c,d)

20+ first :: a b c -> a (b, d) (c, d)

1421 first = (*** id)

1522

16− second :: a b c -> a (d,b) (d,c)

23+ second :: a b c -> a (d, b) (d, c)

1724 second = (id ***)

1825

19− (***) :: a b c -> a b' c' -> a (b,b') (c,c')

20−

21− (&&&) :: a b c -> a b c' -> a b (c,c')

26+ (***) :: a b c -> a b' c' -> a (b, b') (c, c')

2227

23−instance (Category a, A.Arrow a) => BaseArrow a where

24− first = A.first

25− second = A.second

26− (***) = (A.***)

27− (&&&) = (A.&&&)

28+ (&&&) :: a b c -> a b c' -> a b (c, c')

src/Control/Arrow/Extra/Orphans.hsnew file+41

@@ -0,0 +1,41 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE UndecidableInstances #-}

4+{-# OPTIONS_GHC -Wno-orphans #-}

6+module Control.Arrow.Extra.Orphans

7+ (

8+ )

9+where

10+

11+import qualified Control.Arrow as A

12+import Control.Arrow.Extra

13+

14+instance {-# OVERLAPPABLE #-} A.ArrowZero a => ArrowZero a where

15+ zeroArrow = A.zeroArrow

16+

17+instance {-# OVERLAPPABLE #-} A.ArrowChoice a => ArrowChoice a where

18+

19+ left = A.left

20+

21+ right = A.right

22+

23+ (+++) = (A.+++)

24+

25+ (|||) = (A.|||)

26+

27+instance {-# OVERLAPPABLE #-} (Category a, A.Arrow a) => BaseArrow a where

28+

29+ first = A.first

30+

31+ second = A.second

32+

33+ (***) = (A.***)

34+

35+ (&&&) = (A.&&&)

36+

37+instance A.Arrow a => PolyArrow a (->) where

38+ arr = A.arr

39+

40+instance {-# OVERLAPPABLE #-} A.ArrowPlus a => ArrowPlus a where

41+ (<+>) = (A.<+>)

src/Control/Arrow/Extra/PolyArrow.hs+21−16

@@ -1,25 +1,30 @@

1−{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, MonoLocalBinds #-}

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MonoLocalBinds #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

35module Control.Arrow.Extra.PolyArrow

4− ( PolyArrow(..)

5− , (^>>)

6− , (>>^)

7− , (<<^)

8− , (^<<)

9− , (^>^)

10− , (^<^)

11− ) where

12−

13−import qualified Control.Arrow as A

14−import Control.Arrow.Extra.BaseArrow

15−import Control.Category

6+ ( PolyArrow (..),

7+ (^>>),

8+ (>>^),

9+ (<<^),

10+ (^<<),

11+ (^>^),

12+ (^<^),

13+ )

14+where

15+

16+import Control.Arrow.Extra.BaseArrow

17+import Control.Category

18+

19+infixr 1 ^>>, >>^

20+

21+infixr 1 ^<<, <<^

22+

23+infixr 1 ^>^, ^<^

1624

1725class BaseArrow a => PolyArrow a p where

1826 arr :: p b c -> a b c

1927

20−instance A.Arrow a => PolyArrow a (->) where

21− arr = A.arr

22−

2328(^>>) :: PolyArrow a p => p b c -> a c d -> a b d

2429f ^>> a = arr f >>> a

2530

src/Control/Tuple/Morph.hsnew file+336

@@ -0,0 +1,336 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE PatternSynonyms #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeApplications #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE UndecidableInstances #-}

16+{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-redundant-constraints #-}

17+

18+module Control.Tuple.Morph

19+ ( morphTuples,

20+ morphReorderTuples,

21+ morphPickTuples,

22+ TupleMorphable,

23+ CheckListsForTupleIso,

24+ ReorderList,

25+ )

26+where

27+

28+import Data.Kind

29+import Data.Proxy

30+import GHC.Generics

31+import GHC.TypeLits hiding (Nat)

32+

33+morphTuples :: (TupleMorphable a c, TupleMorphable b c) => a -> b

34+morphTuples = morph . unmorph

35+

36+morphPickTuples ::

37+ ( TupleMorphable a b,

38+ TupleMorphable c d,

39+ ReorderList b d

40+ ) =>

41+ a ->

42+ c

43+morphPickTuples = morph . hReorder Proxy . unmorph

44+

45+type CheckListsForTupleIso b d =

46+ EqOrError (Length b) (Length d)

47+ ( 'Text "Not isomorphic tuple contents:"

48+ ':$$: 'Text " " ':<>: 'ShowType b

49+ ':$$: 'Text " " ':<>: 'ShowType d

50+ )

51+

52+morphReorderTuples ::

53+ ( TupleMorphable a b,

54+ TupleMorphable c d,

55+ ReorderList b d,

56+ CheckListsForTupleIso b d

57+ ) =>

58+ a ->

59+ c

60+morphReorderTuples = morph . hReorder Proxy . unmorph

61+

62+type family EqOrError a b e :: Constraint where

63+ EqOrError a a _ = a ~ a

64+ EqOrError _ _ e = TypeError e

65+

66+-- # Nat

67+

68+data Nat where

69+ S :: Nat -> Nat

70+ Z :: Nat

71+

72+-- # HList

73+

74+data HList (ts :: [*]) where

75+ HCons :: t -> HList tt -> HList (t ': tt)

76+ HNil :: HList '[]

77+

78+infixr 5 :+

79+

80+pattern (:+) :: (ts ~ (t : tt)) => t -> HList tt -> HList ts

81+pattern (:+) a b = HCons a b

82+

83+-- ## Taking

84+

85+class TakeableList (n :: Nat) aa bb | n aa -> bb where

86+ hTake :: Proxy n -> HList aa -> HList bb

87+

88+instance TakeableList 'Z a '[] where

89+ hTake _ _ = HNil

90+

91+instance

92+ (TakeableList n aa bb', bb ~ (a ': bb')) =>

93+ TakeableList ('S n) (a ': aa) bb

94+ where

95+ hTake (Proxy :: Proxy ('S n)) (a :+ aa) = a :+ hTake @n Proxy aa

96+

97+-- ## Dropping

98+

99+class DroppableList (n :: Nat) (aa :: [*]) (bb :: [*]) | n aa -> bb where

100+ hDrop :: Proxy n -> HList aa -> HList bb

101+

102+instance DroppableList 'Z aa aa where

103+ hDrop _ aa = aa

104+

105+instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where

106+ hDrop (Proxy :: Proxy ('S n)) (_ :+ aa) = hDrop @n Proxy aa

107+

108+-- ## Appending

109+

110+infixr 4 ++:

111+

112+class AppendableList aa bb cc | aa bb -> cc where

113+ (++:) :: HList aa -> HList bb -> HList (aa ++ bb)

114+

115+instance AppendableList '[] bb bb where

116+ HNil ++: bb = bb

117+

118+instance

119+ ( AppendableList aa bb cc,

120+ cc ~ (aa ++ bb),

121+ ((a ': aa) ++ bb) ~ (a ': cc)

122+ ) =>

123+ AppendableList (a ': aa) bb (a ': cc)

124+ where

125+ (a :+ aa) ++: bb = a :+ (aa ++: bb)

126+

127+-- ## Finding

128+

129+class FindableList ts t where

130+ hFind :: HList ts -> t

131+

132+instance

133+ {-# OVERLAPPING #-}

134+ (NotFindableList ts t) =>

135+ FindableList (t ': ts) t

136+ where

137+ hFind (t :+ _) = t

138+

139+instance

140+ (TEq a t ~ 'False, FindableList ts a) =>

141+ FindableList (t ': ts) a

142+ where

143+ hFind (_ :+ ts) = hFind ts

144+

145+instance

146+ ( TypeError

147+ ('Text "Could not find type " ':<>: 'ShowType a ':<>: 'Text " in tuple.")

148+ ) =>

149+ FindableList '[] a

150+ where

151+ hFind = error "oh no"

152+

153+class NotFindableList ts t

154+

155+instance

156+ {-# OVERLAPPING #-}

157+ ( TypeError

158+ ('Text "Type " ':<>: 'ShowType t ':<>: 'Text " is not unique in tuple.")

159+ ) =>

160+ NotFindableList (t ': ts) t

161+

162+instance (NotFindableList ts a) => NotFindableList (t ': ts) a

163+

164+instance NotFindableList '[] a

165+

166+class ReorderList as bs where

167+ hReorder :: Proxy bs -> HList as -> HList bs

168+

169+instance (FindableList as b, ReorderList as bs) => ReorderList as (b ': bs) where

170+ hReorder _ as = hFind as :+ hReorder (Proxy @bs) as

171+

172+instance ReorderList as '[] where

173+ hReorder _ _ = HNil

174+

175+type family TEq a b :: Bool where

176+ TEq a a = 'True

177+ TEq a b = 'False

178+

179+-- ## Other

180+

181+type family (++) (as :: [k]) (bs :: [k]) :: [k] where

182+ (++) '[] b = b

183+ (++) (a ': as) bs = a ': (as ++ bs)

184+

185+type family Length (aa :: [k]) :: Nat where

186+ Length '[] = 'Z

187+ Length (a ': aa) = 'S (Length aa)

188+

189+-- # Morphing

190+

191+class TupleMorphable t th | t -> th where

192+

193+ unmorph :: t -> HList th

194+

195+ morph :: HList th -> t

196+

197+instance (IsMophableTuple t ~ flag, TupleMorphable' t th flag) => TupleMorphable t th where

198+

199+ unmorph = unmorph' (Proxy @flag)

200+

201+ morph = morph' (Proxy @flag)

202+

203+-- ## Implementation

204+

205+class TupleMorphable' t th (flag :: Bool) | t flag -> th where

206+

207+ unmorph' :: Proxy flag -> t -> HList th

208+

209+ morph' :: Proxy flag -> HList th -> t

210+

211+instance TupleMorphable' t '[t] 'False where

212+

213+ unmorph' _ t = t :+ HNil

214+

215+ morph' _ (t :+ HNil) = t

216+

217+instance (GenericTupleMorphable (Rep t) th, Generic t) => TupleMorphable' t th 'True where

218+

219+ unmorph' _ = genericUnmorph . from

220+

221+ morph' _ = to . genericMorph

222+

223+-- ### Generics

224+

225+class GenericTupleMorphable f th | f -> th where

226+

227+ genericUnmorph :: f p -> HList th

228+

229+ genericMorph :: HList th -> f p

230+

231+instance (GenericTupleMorphable f t) => GenericTupleMorphable (M1 i c f) t where

232+

233+ genericUnmorph = genericUnmorph . unM1

234+

235+ genericMorph = M1 . genericMorph

236+

237+instance (TupleMorphable c t) => GenericTupleMorphable (K1 i c) t where

238+

239+ genericUnmorph = unmorph . unK1

240+

241+ genericMorph = K1 . morph

242+

243+instance GenericTupleMorphable U1 '[] where

244+

245+ genericUnmorph _ = HNil

246+

247+ genericMorph _ = U1

248+

249+type CanTakeDrop a b c =

250+ ( TakeableList (Length a) c a,

251+ DroppableList (Length a) c b,

252+ c ~ (a ++ b)

253+ )

254+

255+instance

256+ ( GenericTupleMorphable f a,

257+ GenericTupleMorphable g b,

258+ AppendableList a b c,

259+ CanTakeDrop a b c

260+ ) =>

261+ GenericTupleMorphable (f :*: g) c

262+ where

263+

264+ genericUnmorph (a :*: b) = genericUnmorph a ++: genericUnmorph b

265+

266+ genericMorph cc = genericMorph aa :*: genericMorph bb

267+ where

268+ aa = hTake @(Length a) Proxy cc

269+ bb = hDrop @(Length a) Proxy cc

270+

271+-- ## Other

272+

273+type family IsMophableTuple t :: Bool where

274+ IsMophableTuple () = 'True

275+ IsMophableTuple (a, b) = 'True

276+ IsMophableTuple (a, b, c) = 'True

277+ IsMophableTuple (a, b, c, d) = 'True

278+ IsMophableTuple (a, b, c, d, e) = 'True

279+ IsMophableTuple (a, b, c, d, e, f) = 'True

280+ IsMophableTuple (a, b, c, d, e, f, g) = 'True

281+ IsMophableTuple (a, b, c, d, e, f, g, h) = 'True

282+ IsMophableTuple (a, b, c, d, e, f, g, h, i) = 'True

283+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j) = 'True

284+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k) = 'True

285+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l) = 'True

286+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m) = 'True

287+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = 'True

288+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = 'True

289+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = 'True

290+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = 'True

291+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = 'True

292+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = 'True

293+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = 'True

294+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = 'True

295+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = 'True

296+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = 'True

297+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = 'True

298+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = 'True

299+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) = 'True

300+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1) = 'True

301+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1) = 'True

302+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1) = 'True

303+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1) = 'True

304+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1) = 'True

305+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1) = 'True

306+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1) = 'True

307+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1) = 'True

308+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1) = 'True

309+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) = 'True

310+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) = 'True

311+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) = 'True

312+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) = 'True

313+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) = 'True

314+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) = 'True

315+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) = 'True

316+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1) = 'True

317+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1) = 'True

318+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1) = 'True

319+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1) = 'True

320+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1) = 'True

321+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1) = 'True

322+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1) = 'True

323+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1) = 'True

324+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1) = 'True

325+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1) = 'True

326+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2) = 'True

327+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2) = 'True

328+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2) = 'True

329+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2) = 'True

330+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2) = 'True

331+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2) = 'True

332+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2) = 'True

333+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2) = 'True

334+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2) = 'True

335+ IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = 'True

336+ IsMophableTuple c = 'False

src/Data/Isoparsec.hsnew file+166

@@ -0,0 +1,166 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ExistentialQuantification #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeOperators #-}

12+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

13+

14+module Data.Isoparsec

15+ ( module X,

16+ -- Isoparsec,

17+ (%>>),

18+ (%>%),

19+ (>>%),

20+ (%<<),

21+ (%<%),

22+ (<<%),

23+ (<?>),

24+ (<+%),

25+ (%+>),

26+ (%+%),

27+ (<.>),

28+ (<^>),

29+ repeating,

30+ opt,

31+ opt',

32+ morphed,

33+ coercing,

34+ mapIso,

35+ auto,

36+ specific,

37+ throughIntegral,

38+ )

39+where

40+

41+import Control.Arrow.Extra as X

42+import Control.Tuple.Morph

43+import Data.Coerce

44+import Data.Isoparsec.Internal as X

45+import Data.Isoparsec.ToIsoparsec as X

46+import Data.Isoparsec.Tokenable as X

47+import qualified Data.Map as M

48+import Optics.Iso

49+import Optics.Optic

50+import Optics.Prism

51+import Prelude hiding ((.), fail, id)

52+

53+opt :: (ArrowPlus m, IsoparsecTry m, PolyArrow m SemiIso') => m () () -> m () ()

54+opt m = try m <+> konst ()

55+

56+opt' :: (ArrowPlus m, IsoparsecTry m, PolyArrow m SemiIso', Eq a) => a -> m () a -> m () ()

57+opt' a m = (try m >>> tsnok a) <+> konst ()

58+

59+repeating :: (PolyArrow m SemiIso', IsoparsecTry m, ArrowPlus m, Eq b) => m () b -> m () [b]

60+repeating m = (try m &&& (try (repeating m) <+> konst [])) >>^ cons'

61+

62+infix 0 <?>

63+

64+(<?>) :: IsoparsecLabel m l => m a b -> l -> m a b

65+thing <?> msg = label msg thing

66+

67+infixr 1 %>>

68+

69+(%>>) :: (PolyArrow a SemiIso', ToSemiIso p b c) => p -> a c d -> a b d

70+p %>> a = si p ^>> a

71+

72+infixr 1 %>%

73+

74+(%>%) :: (PolyArrow a SemiIso', ToSemiIso p b c, ToSemiIso p' c d) => p -> p' -> a b d

75+p %>% a = si p ^>^ si a

76+

77+infixr 1 >>%

78+

79+(>>%) :: (PolyArrow a SemiIso', ToSemiIso p c d) => a b c -> p -> a b d

80+p >>% a = p >>^ si a

81+

82+infixr 1 %<<

83+

84+(%<<) :: (PolyArrow a SemiIso', ToSemiIso p c d) => p -> a b c -> a b d

85+p %<< a = si p ^<< a

86+

87+infixr 1 %<%

88+

89+(%<%) :: (PolyArrow a SemiIso', ToSemiIso p c d, ToSemiIso p' b c) => p -> p' -> a b d

90+p %<% a = si p ^<^ si a

91+

92+infixr 1 <<%

93+

94+(<<%) :: (PolyArrow a SemiIso', ToSemiIso p b c) => a c d -> p -> a b d

95+p <<% a = p <<^ si a

96+

97+infixr 5 <+%

98+

99+(<+%) :: (PolyArrow a SemiIso', ArrowPlus a, ToSemiIso p b c) => a b c -> p -> a b c

100+a <+% b = a <+^ si b

101+

102+infixr 5 %+>

103+

104+(%+>) :: (PolyArrow a SemiIso', ArrowPlus a, ToSemiIso p b c) => p -> a b c -> a b c

105+a %+> b = si a ^+> b

106+

107+infixr 5 %+%

108+

109+(%+%) :: (PolyArrow a SemiIso', ArrowPlus a, ToSemiIso p b c) => p -> p -> a b c

110+a %+% b = si a ^+^ si b

111+

112+infixr 0 <.>

113+

114+(<.>) ::

115+ (PolyArrow m SemiIso', TupleMorphable x c, TupleMorphable y c, ToSemiIso b y y') =>

116+ b ->

117+ m x' x ->

118+ m x' y'

119+b <.> p = (p >>% morphed) >>% b

120+

121+infixr 0 <^>

122+

123+(<^>) ::

124+ (PolyArrow m SemiIso', TupleMorphable x c, TupleMorphable y c, ToSemiIso b y y') =>

125+ m x' x ->

126+ b ->

127+ m x' y'

128+b <^> p = b >>> morphed %>% p

129+

130+coercing :: forall b a m. (Coercible a b, PolyArrow m SemiIso') => m a b

131+coercing = arr $ siJust coerce coerce

132+

133+morphed ::

134+ (TupleMorphable a c, TupleMorphable b c) =>

135+ Iso' a b

136+morphed = iso morphTuples morphTuples

137+

138+class ToSemiIso x a b | x -> a b where

139+ si :: x -> SemiIso' a b

140+

141+instance (k `Is` A_Prism) => ToSemiIso (Optic' k NoIx b a) a b where

142+ si p = si' (Just . n) (either (const Nothing) Just . u)

143+ where

144+ (n, u) = withPrism p (,)

145+

146+instance ToSemiIso (SemiIso' a b) a b where

147+ si = id

148+

149+mapIso :: (PolyArrow m SemiIso', Ord a, Ord b) => [(a, b)] -> m a b

150+mapIso m = arr $ si' (`M.lookup` n) (`M.lookup` u)

151+ where

152+ n = M.fromListWith (error "mapping not unique") m

153+ u =

154+ M.fromListWith (error "mapping not unique") $

155+ (\(a, b) -> (b, a)) <$> m

156+

157+auto :: forall x s m. (ToIsoparsec x s, Isoparsec m s) => m () x

158+auto = toIsoparsec

159+

160+specific :: forall x s m. (ToIsoparsec x s, Isoparsec m s, Eq x, Show x) => x -> m () ()

161+specific x = auto @x >>> check (== x) >>> tsnok x

162+

163+throughIntegral ::

164+ (Integral a, Integral b, Num a, Num b, PolyArrow m SemiIso') =>

165+ m a b

166+throughIntegral = arr $ siJust fromIntegral fromIntegral

src/Data/Isoparsec/ByteString.hsnew file+111

@@ -0,0 +1,111 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TupleSections #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# OPTIONS_GHC -Wno-orphans #-}

11+

12+module Data.Isoparsec.ByteString

13+ ( utf8,

14+ ftu8,

15+ ByteString,

16+ Endianness (..),

17+ Byte8,

18+ Byte16 (..),

19+ Byte32 (..),

20+ Byte64 (..),

21+ SSHString (..),

22+ )

23+where

24+

25+import Data.Bits

26+import Data.ByteString as BS

27+import qualified Data.ByteString.Char8 as C

28+import Data.Isoparsec

29+import Data.Proxy

30+import Data.Word

31+import Prelude as P hiding ((.))

32+

33+utf8 :: Isoparsec m ByteString => String -> m () ()

34+utf8 = chunk . C.pack

35+

36+ftu8 :: PolyArrow m SemiIso' => m ByteString String

37+ftu8 = arr $ siJust C.unpack C.pack

38+

39+data Endianness = BE | LE

40+

41+class BytesToIsoparsec b (e :: Endianness) where

42+ bytesToIsoparsec :: (Isoparsec m ByteString) => Proxy e -> m () b

43+

44+instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'BE where

45+ bytesToIsoparsec _ =

46+ konst word8s >>> manyTokens

47+ >>^ siJust

48+ (fromInteger . BS.foldl (\i w -> shiftL i 8 .|. toInteger w) 0)

49+ ( liftTokens . snd . P.head

50+ . P.drop (fromIntegral word8s)

51+ . iterate (\(i, ww) -> (shiftR i 8, fromInteger i : ww))

52+ . (,[])

53+ . toInteger

54+ )

55+ where

56+ word8s = fromIntegral $ finiteBitSize (undefined :: b) `div` 8

57+

58+instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'LE where

59+ bytesToIsoparsec _ =

60+ konst word8s >>> manyTokens

61+ >>^ siJust

62+ (fromInteger . BS.foldr (\w i -> shiftL i 8 .|. toInteger w) 0)

63+ ( liftTokens . P.reverse . snd . P.head

64+ . P.drop (fromIntegral word8s)

65+ . iterate (\(i, ww) -> (shiftR i 8, fromInteger i : ww))

66+ . (,[])

67+ . toInteger

68+ )

69+ where

70+ word8s = fromIntegral $ finiteBitSize (undefined :: b) `div` 8

71+

72+type Byte8 = Word8

73+

74+newtype Byte16 (e :: Endianness) = Byte16 {unByte16 :: Word16}

75+ deriving (Show, Eq, Ord, Enum, Num, Real, Integral, Bounded)

76+

77+newtype Byte32 (e :: Endianness) = Byte32 {unByte32 :: Word32}

78+ deriving (Show, Eq, Ord, Enum, Num, Real, Integral, Bounded)

79+

80+newtype Byte64 (e :: Endianness) = Byte64 {unByte64 :: Word64}

81+ deriving (Show, Eq, Ord, Enum, Num, Real, Integral, Bounded)

82+

83+instance BytesToIsoparsec Word16 e => ToIsoparsec (Byte16 e) ByteString where

84+ toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte16 e) @Word16

85+

86+instance BytesToIsoparsec Word32 e => ToIsoparsec (Byte32 e) ByteString where

87+ toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte32 e) @Word32

88+

89+instance BytesToIsoparsec Word64 e => ToIsoparsec (Byte64 e) ByteString where

90+ toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte64 e) @Word64

91+

92+instance ToIsoparsec Bool ByteString where

93+ toIsoparsec = anyToken >>> mapIso [(0, False), (1, True)]

94+

95+newtype SSHString = SSHString {unSSHString :: String}

96+ deriving (Show, Eq, Ord)

97+

98+instance ToIsoparsec SSHString ByteString where

99+ toIsoparsec =

100+ auto @(Byte32 'BE) >>> coercing @Word32

101+ >>> siJust fromIntegral fromIntegral ^>> manyTokens

102+ >>> ftu8

103+ >>^ siJust SSHString unSSHString

104+

105+instance Tokenable ByteString where

106+

107+ type Token ByteString = Word8

108+

109+ liftTokens = pack

110+

111+ lowerTokens = unpack

src/Data/Isoparsec/Char.hsnew file+33

@@ -0,0 +1,33 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE TypeFamilies #-}

8+module Data.Isoparsec.Char

9+ ( unsafeWhiteSpace,

10+ unsafeWhiteSpace1,

11+ space,

12+ number,

13+ )

14+where

15+

16+import Data.Char

17+import Data.Isoparsec

18+import Text.Read

19+import Prelude hiding ((.), id)

20+

21+space :: (Isoparsec m s, Token s ~ Char) => m () ()

22+space = token ' '

23+

24+unsafeWhiteSpace :: (Isoparsec m s, Token s ~ Char) => m () ()

25+unsafeWhiteSpace = tokensWhile isSpace >>> badTsnok mempty

26+

27+unsafeWhiteSpace1 :: (Isoparsec m s, Token s ~ Char) => m () ()

28+unsafeWhiteSpace1 = tokensWhile1 isSpace >>> badTsnok (liftToken ' ')

29+

30+number :: (Isoparsec m s, Token s ~ Char) => m () Integer

31+number =

32+ tokensWhile1 (\c -> isNumber c || c == '+' || c == '-')

33+ >>^ si' (readMaybe @Integer . lowerTokens) (Just . liftTokens . show)

src/Data/Isoparsec/Chunks.hsnew file+22

@@ -0,0 +1,22 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE TypeFamilies #-}

8+module Data.Isoparsec.Chunks

9+ ( Chunk (..),

10+ )

11+where

12+

13+import Data.Isoparsec

14+import Data.Proxy

15+import GHC.TypeLits

16+

17+newtype Chunk (n :: Nat) s = Chunk {unChunk :: s}

18+ deriving (Show, Eq, Ord)

19+

20+instance (CmpNat n 0 ~ 'GT, KnownNat n) => ToIsoparsec (Chunk n s) s where

21+ toIsoparsec =

22+ konst (fromIntegral $ natVal @n Proxy) >>> manyTokens >>> coercing

src/Data/Isoparsec/Cokleisli.hsnew file+61

@@ -0,0 +1,61 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

4+module Data.Isoparsec.Cokleisli

5+ ( Cokleisli (..),

6+ )

7+where

9+import Control.Applicative

10+import Control.Arrow.Extra

11+import Control.Monad

12+import Data.Isoparsec.Internal

13+import Optics.Iso

14+import Prelude hiding ((.))

15+

16+newtype Cokleisli m a b = Cokleisli {unCokleisli :: b -> m a}

17+

18+instance Monad m => Category (Cokleisli m) where

19+

20+ id = Cokleisli return

21+

22+ (Cokleisli cb) . (Cokleisli ba) = Cokleisli $ cb >=> ba

23+

24+instance (Alternative m, Monad m) => BaseArrow (Cokleisli m) where

25+

26+ (Cokleisli cb) *** (Cokleisli c'b') = Cokleisli $

27+ \(c, c') -> do

28+ b' <- c'b' c'

29+ b <- cb c

30+ return (b, b')

31+

32+ (Cokleisli cb) &&& (Cokleisli c'b) = Cokleisli $

33+ \(c, c') -> c'b c' >> cb c

34+

35+instance MonadPlus m => PolyArrow (Cokleisli m) SemiIso' where

36+ arr (SemiIso' si) = Cokleisli $ \t -> case withIso si (flip const) t of

37+ Just x -> return x

38+ Nothing -> mzero

39+

40+instance MonadPlus m => ArrowZero (Cokleisli m) where

41+ zeroArrow = Cokleisli $ const mzero

42+

43+instance MonadPlus m => ArrowPlus (Cokleisli m) where

44+ (Cokleisli lhs) <+> (Cokleisli rhs) = Cokleisli $ \x -> lhs x `mplus` rhs x

45+

46+instance (Alternative m, Monad m) => ArrowChoice (Cokleisli m) where

47+

48+ left (Cokleisli cb) = Cokleisli $ \case

49+ Left c -> Left <$> cb c

50+ Right d -> return $ Right d

51+

52+ right (Cokleisli cb) = Cokleisli $ \case

53+ Left d -> return $ Left d

54+ Right c -> Right <$> cb c

55+

56+ (Cokleisli cb) +++ (Cokleisli c'b') = Cokleisli $ \case

57+ Left c -> Left <$> cb c

58+ Right c' -> Right <$> c'b' c'

59+

60+ (Cokleisli db) ||| (Cokleisli dc) = Cokleisli $ \d ->

61+ (Left <$> db d) <|> (Right <$> dc d)

src/Data/Isoparsec/Internal.hsnew file+179

@@ -0,0 +1,179 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DefaultSignatures #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE LiberalTypeSynonyms #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeOperators #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+

13+module Data.Isoparsec.Internal

14+ ( SemiIso' (..),

15+ SemiIso,

16+ si',

17+ IsoparsecFail (..),

18+ Isoparsec (..),

19+ IsoparsecTry (..),

20+ IsoparsecLabel (..),

21+ konst,

22+ tsnok,

23+ cons',

24+ siJust,

25+ siCheck,

26+ siCheck',

27+ check,

28+ levitate,

29+ siDecompose,

30+ badKonst,

31+ badTsnok,

32+ )

33+where

34+

35+import Control.Arrow.Extra

36+import Control.Monad

37+import Data.Isoparsec.Tokenable

38+import Numeric.Natural

39+import Optics.Iso

40+import Prelude as P hiding ((.), id)

41+

42+class

43+ (PolyArrow m SemiIso', ArrowPlus m, ArrowChoice m, IsoparsecTry m, Tokenable s) =>

44+ Isoparsec m s

45+ | m -> s where

46+

47+ {-# MINIMAL anyToken, manyTokens, tuck #-}

48+

49+ anyToken :: m () (Token s)

50+

51+ token :: Token s -> m () ()

52+

53+ default token :: Eq (Token s) => Token s -> m () ()

54+ token x = anyToken >>> tsnok x

55+

56+ tokens :: [Token s] -> m () ()

57+

58+ default tokens :: [Token s] -> m () ()

59+ tokens [] = arr $ isoConst' () ()

60+ tokens (t : ts) = token t &&& tokens ts >>> arr (isoConst' ((), ()) ())

61+

62+ chunk :: s -> m () ()

63+ chunk = tokens . lowerTokens

64+

65+ notToken :: Token s -> m () (Token s)

66+

67+ default notToken :: Eq (Token s) => Token s -> m () (Token s)

68+ notToken t = tokenWhere (/= t)

69+

70+ tokenWhere :: (Token s -> Bool) -> m () (Token s)

71+ tokenWhere f =

72+ anyToken >>> check f

73+

74+ manyTokens :: m Natural s

75+

76+ tokensWhile :: (Token s -> Bool) -> m () s

77+

78+ takeUntil :: s -> m () s

79+

80+ default takeUntil :: Eq (Token s) => s -> m () s

81+ takeUntil s = takeUntil' s >>^ levitate

82+ where

83+ takeUntil' s' = try (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ cons')

84+

85+ default tokensWhile :: (Token s -> Bool) -> m () s

86+ tokensWhile f =

87+ tokensWhile' f >>> check (P.all f) >>^ levitate

88+ where

89+ tokensWhile' g =

90+ try (tokenWhere g &&& tokensWhile' g >>^ cons')

91+ <+^ isoConst' () []

92+

93+ tokensWhile1 :: (Token s -> Bool) -> m () s

94+ tokensWhile1 f =

95+ tokenWhere f &&& tokensWhile f

96+ >>^ si' (\(a, aa) -> Just $ liftToken a <> aa) levitateHead

97+

98+ -- | "tucks" the context of the parser into its input.

99+ -- > ┌─────┐

100+ -- > │ s ├───────┐

101+ -- > └─────┘ │

102+ -- > ┌────┐ │ ┌─────┐

103+ -- > ───┤ () ├────▶ └──────┤ a ├▶

104+ -- > └────┘ └─────┘

105+ -- > │

106+ -- > ┌────┴─────┐

107+ -- > │ tuck │

108+ -- > └────┬─────┘

109+ -- > ▼

110+ -- > ┌─────┐ ┌─────┐

111+ -- > ──┤ s ├──────────────────────────┤ a ├─▶

112+ -- > └─────┘ └─────┘

113+ tuck :: m () a -> m s a

114+

115+class IsoparsecLabel m l where

116+ label :: l -> m a b -> m a b

117+

118+levitateHead :: Tokenable s => s -> Maybe (Token s, s)

119+levitateHead s = case lowerTokens s of

120+ (t : tt) -> Just (t, liftTokens tt)

121+ [] -> Nothing

122+

123+cons' :: SemiIso' (t, [t]) [t]

124+cons' =

125+ si'

126+ (Just . uncurry (:))

127+ ( \case

128+ (t : ts) -> Just (t, ts)

129+ _ -> Nothing

130+ )

131+

132+levitate :: Tokenable s => SemiIso' [Token s] s

133+levitate = siJust liftTokens lowerTokens

134+

135+class IsoparsecTry m where

136+ try :: m a b -> m a b

137+

138+class IsoparsecFail m e where

139+ fail :: e -> m a b

140+

141+newtype SemiIso' s a = SemiIso' (SemiIso s s a a)

142+

143+siDecompose :: SemiIso' a b -> (a -> Maybe b, b -> Maybe a)

144+siDecompose (SemiIso' s) = withIso s (,)

145+

146+type SemiIso s t a b = Iso s (Maybe t) (Maybe a) b

147+

148+si' :: (s -> Maybe a) -> (a -> Maybe s) -> SemiIso' s a

149+si' n u = SemiIso' $ iso n u

150+

151+siCheck' :: (s -> Bool) -> (s -> Maybe a) -> (a -> Maybe s) -> SemiIso' s a

152+siCheck' f a b =

153+ si'

154+ (\c -> guard (f c) >> a c)

155+ (b >=> (\c -> guard (f c) >> pure c))

156+

157+siCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso' s a

158+siCheck f a b = siCheck' f (Just . a) (Just . b)

159+

160+siJust :: (s -> a) -> (a -> s) -> SemiIso' s a

161+siJust a b = si' (Just . a) (Just . b)

162+

163+isoConst' :: s -> a -> SemiIso' s a

164+isoConst' s a = si' (const $ Just a) (const $ Just s)

165+

166+konst :: (PolyArrow a SemiIso', Eq x) => x -> a () x

167+konst x = badKonst x >>> check (== x)

168+

169+badKonst :: (PolyArrow a SemiIso') => x -> a () x

170+badKonst x = arr $ si' (const $ Just x) (const $ Just ())

171+

172+tsnok :: (PolyArrow a SemiIso', Eq x) => x -> a x ()

173+tsnok x = check (== x) >>> badTsnok x

174+

175+badTsnok :: (PolyArrow a SemiIso') => x -> a x ()

176+badTsnok x = arr $ si' (const $ Just ()) (const $ Just x)

177+

178+check :: PolyArrow a SemiIso' => (s -> Bool) -> a s s

179+check f = arr $ siCheck f id id

src/Data/Isoparsec/Megaparsec.hsnew file+66

@@ -0,0 +1,66 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE QuantifiedConstraints #-}

5+{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+{-# OPTIONS_GHC -Wno-orphans #-}

11+

12+module Data.Isoparsec.Megaparsec

13+ ( runMegaparsec,

14+ )

15+where

16+

17+import Control.Arrow.Extra

18+import Control.Arrow.Extra.Orphans ()

19+import Control.Monad

20+import Data.Functor

21+import Data.Isoparsec.Internal as I

22+import Data.Isoparsec.Tokenable

23+import Optics.Getter

24+import Optics.ReadOnly

25+import Text.Megaparsec hiding (Token)

26+import qualified Text.Megaparsec as M

27+import Prelude hiding ((.))

28+

29+runMegaparsec ::

30+ (Ord e, Stream s) =>

31+ Kleisli (Parsec e s) () r ->

32+ s ->

33+ Either (ParseErrorBundle s e) r

34+runMegaparsec (Kleisli f) = runParser (f () <* eof) ""

35+

36+instance (MonadParsec e s m) => IsoparsecTry (Kleisli m) where

37+ try (Kleisli f) = Kleisli $ \a -> M.try (f a)

38+

39+instance (MonadParsec e s m) => PolyArrow (Kleisli m) SemiIso' where

40+ arr (SemiIso' si) = Kleisli $ \t -> case view (getting si) t of

41+ Just x -> return x

42+ Nothing -> failure Nothing mempty

43+

44+instance

45+ (MonadParsec e s m, M.Token s ~ Token s, s ~ M.Tokens s, Tokenable s) =>

46+ Isoparsec (Kleisli m) s

47+ where

48+

49+ anyToken = Kleisli $ const anySingle

50+

51+ token t = Kleisli . const $ M.single t $> ()

52+

53+ manyTokens = Kleisli $ takeP Nothing . fromIntegral

54+

55+ tuck (Kleisli f) = Kleisli $ \sub -> do

56+ sup <- getInput

57+ setInput sub

58+ r <- f () <* eof

59+ setInput sup

60+ return r

61+

62+instance MonadParsec e s m => IsoparsecFail (Kleisli m) e where

63+ fail e = Kleisli $ \_ -> customFailure e

64+

65+instance MonadParsec e s m => IsoparsecLabel (Kleisli m) String where

66+ label s (Kleisli m) = Kleisli $ \x -> M.label s (m x)

src/Data/Isoparsec/Printer.hsnew file+54

@@ -0,0 +1,54 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE UndecidableInstances #-}

6+{-# OPTIONS_GHC -Wno-orphans #-}

8+module Data.Isoparsec.Printer

9+ ( runPrinter,

10+ )

11+where

12+

13+import Control.Monad.Writer.Lazy

14+import Data.Isoparsec

15+import Data.Isoparsec.Cokleisli

16+import Prelude hiding ((.), id)

17+

18+runPrinter ::

19+ forall m s a.

20+ Monad m =>

21+ Cokleisli (WriterT (Dual s) m) () a ->

22+ a ->

23+ m s

24+runPrinter p = fmap getDual . execWriterT . unCokleisli p

25+

26+instance IsoparsecFail (Cokleisli (WriterT s Maybe)) e where

27+ fail _ = Cokleisli . const $ WriterT Nothing

28+

29+instance IsoparsecFail (Cokleisli (WriterT s (Either e))) e where

30+ fail = Cokleisli . const . WriterT . Left

31+

32+instance IsoparsecLabel (Cokleisli (WriterT s Maybe)) e where

33+ label _ = id

34+

35+instance IsoparsecLabel (Cokleisli (WriterT s (Either e))) y where

36+ label _ = id

37+

38+instance IsoparsecTry (Cokleisli (WriterT (Dual s) m)) where

39+ try = id

40+

41+instance

42+ (MonadPlus m, Monoid s, Eq (Token s), Tokenable s, Show s) =>

43+ Isoparsec (Cokleisli (WriterT (Dual s) m)) s

44+ where

45+

46+ token t = Cokleisli $ const $ tell . Dual . liftToken $ t

47+

48+ anyToken = Cokleisli $ tell . Dual . liftToken

49+

50+ manyTokens = Cokleisli $ \w -> do

51+ tell $ Dual w

52+ return . fromIntegral . length . lowerTokens $ w

53+

54+ tuck (Cokleisli f) = Cokleisli $ lift . fmap getDual . execWriterT . f

src/Data/Isoparsec/ToIsoparsec.hsnew file+60

@@ -0,0 +1,60 @@

1+{-# LANGUAGE DefaultSignatures #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE UndecidableInstances #-}

10+module Data.Isoparsec.ToIsoparsec

11+ ( ToIsoparsec (..),

12+ )

13+where

14+

15+import Control.Arrow.Extra

16+import Data.Isoparsec.Internal

17+import Data.Isoparsec.Tokenable

18+import GHC.Generics

19+import Prelude hiding ((.))

20+

21+instance {-# OVERLAPPABLE #-} t ~ Token s => ToIsoparsec t s where

22+ toIsoparsec = anyToken

23+

24+class ToIsoparsec a s where

25+

26+ toIsoparsec :: Isoparsec m s => m () a

27+

28+ default toIsoparsec :: (Isoparsec m s, Generic a, GToIsoparsec (Rep a) s) => m () a

29+ toIsoparsec = gToIsoparsec >>^ si' (Just . to) (Just . from)

30+

31+class GToIsoparsec a s where

32+ gToIsoparsec :: Isoparsec m s => m () (a b)

33+

34+instance GToIsoparsec U1 s where

35+ gToIsoparsec = konst U1

36+

37+instance ToIsoparsec c s => GToIsoparsec (K1 i c) s where

38+ gToIsoparsec =

39+ toIsoparsec >>^ si' (Just . K1) (Just . unK1)

40+

41+instance GToIsoparsec c s => GToIsoparsec (M1 i t c) s where

42+ gToIsoparsec =

43+ gToIsoparsec >>^ si' (Just . M1) (Just . unM1)

44+

45+instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :*: b) s where

46+ gToIsoparsec =

47+ (gToIsoparsec &&& gToIsoparsec)

48+ >>^ si' (\(a, b) -> Just (a :*: b)) (\(a :*: b) -> Just (a, b))

49+

50+instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :+: b) s where

51+ gToIsoparsec =

52+ ( try (gToIsoparsec >>^ si' (Just . Left) (either Just (const Nothing)))

53+ <+> (gToIsoparsec >>^ si' (Just . Right) (either (const Nothing) Just))

54+ )

55+ >>> (arr (si' (Just . L1) fromL) ||| arr (si' (Just . R1) fromR))

56+ where

57+ fromL (L1 a) = Just a

58+ fromL _ = Nothing

59+ fromR (R1 b) = Just b

60+ fromR _ = Nothing

src/Data/Isoparsec/Tokenable.hsnew file+28

@@ -0,0 +1,28 @@

1+{-# LANGUAGE TypeFamilies #-}

3+module Data.Isoparsec.Tokenable

4+ ( Tokenable (..),

5+ )

6+where

8+class Monoid s => Tokenable s where

10+ type Token s

11+

12+ {-# MINIMAL (liftTokens | liftToken), lowerTokens #-}

13+

14+ liftTokens :: [Token s] -> s

15+ liftTokens = mconcat . fmap liftToken

16+

17+ liftToken :: Token s -> s

18+ liftToken = liftTokens . pure

19+

20+ lowerTokens :: s -> [Token s]

21+

22+instance Tokenable [t] where

23+

24+ type Token [t] = t

25+

26+ liftTokens = id

27+

28+ lowerTokens = id

stack.yaml+6−2

@@ -17,7 +17,7 @@

1717#

1818# resolver: ./custom-snapshot.yaml

1919# resolver: https://example.com/snapshots/2018-01-01.yaml

20−resolver: lts-14.7

20+resolver: lts-14.15

2121

2222# User packages to be built.

2323# Various formats can be used as shown in the example below.

@@ -39,7 +39,11 @@ packages:

3939# - git: https://github.com/commercialhaskell/stack.git

4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

4141#

42−# extra-deps: []

42+extra-deps:

43+- optics-core-0.1

44+- optics-0.1

45+- optics-extra-0.1

46+- optics-th-0.1

4347

4448# Override default flag values for local packages and extra-deps

4549# flags: {}

test/Spec.hs+35−1

@@ -1,2 +1,36 @@

1+import qualified Spec.JSON as JSON

2+import qualified Spec.Megaparsec.BasicNums as BasicNums

3+import qualified Spec.Ssh as Ssh

4+import qualified Spec.TwoDigits as TwoDigits

5+import Test.Tasty

6+import Test.Tasty.Hspec

18main :: IO ()

2−main = putStrLn "Test suite not yet implemented"

9+main = do

10+ bsicNumSpec <- testSpec "Basic megaparsec test" BasicNums.spec

11+ twoDigitsSpec <- testSpec "Two digits test" TwoDigits.spec

12+ sshSpec <- testSpec "ssh spec" Ssh.spec

13+ defaultMain

14+ ( testGroup

15+ "tests"

16+ [ testGroup

17+ "Basic number test"

18+ [ bsicNumSpec,

19+ BasicNums.quickSpec

20+ ],

21+ testGroup

22+ "JSON"

23+ [ JSON.quickSpec

24+ ],

25+ testGroup

26+ "TwoDigits"

27+ [ twoDigitsSpec,

28+ TwoDigits.quickSpec

29+ ],

30+ testGroup

31+ "ssh"

32+ [ sshSpec,

33+ Ssh.quickSpec

34+ ]

35+ ]

36+ )

test/Spec/Helper.hsnew file+68

@@ -0,0 +1,68 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TypeApplications #-}

5+{-# LANGUAGE TypeFamilies #-}

7+module Spec.Helper

8+ ( shouldParseBS,

9+ roundtrip,

10+ )

11+where

12+

13+import Data.ByteString as BS

14+import Data.Either

15+import Data.Isoparsec as I

16+import Data.Isoparsec.Megaparsec

17+import Data.Isoparsec.Printer

18+import Data.Maybe

19+import Data.Void

20+import Spec.Orphans ()

21+import Test.Hspec

22+import Test.Tasty.QuickCheck

23+import Text.Megaparsec as M

24+import Prelude as P hiding ((.))

25+

26+shouldParse ::

27+ forall x s.

28+ ( ToIsoparsec x s,

29+ Stream s,

30+ Show x,

31+ Eq x,

32+ Isoparsec (Kleisli (Parsec Void s)) s

33+ ) =>

34+ s ->

35+ x ->

36+ Expectation

37+shouldParse s e = case runMegaparsec @Void @s toIsoparsec s of

38+ Right e' -> e' `shouldBe` e

39+ Left err -> expectationFailure $ errorBundlePretty err

40+

41+shouldParseBS ::

42+ forall x.

43+ ( ToIsoparsec x ByteString,

44+ Show x,

45+ Eq x,

46+ Isoparsec (Kleisli (Parsec Void ByteString)) ByteString

47+ ) =>

48+ ByteString ->

49+ x ->

50+ Expectation

51+shouldParseBS = shouldParse

52+

53+roundtrip ::

54+ forall x s.

55+ ( ToIsoparsec x s,

56+ Stream s,

57+ Show s,

58+ I.Token s ~ M.Token s,

59+ Eq x,

60+ Isoparsec (Kleisli (Parsec Void s)) s

61+ ) =>

62+ x ->

63+ Property

64+roundtrip x =

65+ let s = fromJust $ runPrinter @Maybe @s toIsoparsec x

66+ in counterexample (show s) $ case runMegaparsec @Void @s toIsoparsec s of

67+ Right y -> property $ x == y

68+ Left err -> counterexample (errorBundlePretty err) False

test/Spec/JSON.hsnew file+99

@@ -0,0 +1,99 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ExistentialQuantification #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE TemplateHaskell #-}

9+{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeOperators #-}

12+

13+module Spec.JSON

14+ ( quickSpec,

15+ )

16+where

17+

18+import Control.Arrow.Extra

19+import Data.Isoparsec

20+import Data.Isoparsec.Char

21+import Data.Isoparsec.Megaparsec

22+import Data.Isoparsec.Printer

23+import Data.Maybe

24+import Data.Void

25+import Optics hiding (elements)

26+import Test.Tasty

27+import Test.Tasty.QuickCheck

28+import Text.Megaparsec.Error

29+import Prelude hiding ((.))

30+

31+data JSON

32+ = Object [(String, JSON)]

33+ | JString String

34+ | Array [JSON]

35+ | JInteger Integer

36+ deriving (Show, Eq)

37+

38+instance Arbitrary JSON where

39+

40+ arbitrary =

41+ oneof

42+ [ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),

43+ JString <$> listOf (elements ['.' .. 'z']),

44+ Array <$> listOf (scale (`div` 2) arbitrary),

45+ JInteger <$> arbitrary

46+ ]

47+

48+ shrink (Object a) = Object <$> shrink a

49+ shrink (JString a) = JString <$> shrink a

50+ shrink (Array a) = Array <$> shrink a

51+ shrink (JInteger a) = JInteger <$> shrink a

52+

53+makePrisms ''JSON

54+

55+quickSpec :: TestTree

56+quickSpec =

57+ testProperty "roundtrips" $ \x ->

58+ let s = fromJust $ runPrinter @Maybe @String json x

59+ in counterexample s $ case runMegaparsec @Void json s of

60+ Right y -> property $ x == y

61+ Left err -> counterexample (errorBundlePretty err) False

62+

63+json :: (PolyArrow m SemiIso', Isoparsec m String) => m () JSON

64+json = si' Just Just ^<< (try string <+> try array <+> try integer <+> object)

65+ where

66+ string' = token '"' &&& tokensWhile (/= '"') &&& token '"'

67+ string = _JString <.> string'

68+ array =

69+ _Array

70+ <.> token '['

71+ &&& unsafeWhiteSpace

72+ &&& ( try

73+ ( ( ( json &&& unsafeWhiteSpace

74+ &&& try

75+ ( repeating

76+ ( (token ',' &&& unsafeWhiteSpace &&& json) >>% morphed

77+ )

78+ )

79+ <+> konst []

80+ )

81+ >>% morphed

82+ )

83+ >>^ cons'

84+ )

85+ <+> konst []

86+ )

87+ &&& unsafeWhiteSpace

88+ &&& token ']'

89+ integer = _JInteger <.> number

90+ object =

91+ _Object <.> token '{' &&& unsafeWhiteSpace

92+ &&& ( try

93+ ( let pair = (unsafeWhiteSpace &&& string' &&& unsafeWhiteSpace &&& token ':' &&& unsafeWhiteSpace &&& json &&& unsafeWhiteSpace) >>% morphed

94+ in (pair &&& try (repeating ((token ',' &&& unsafeWhiteSpace &&& pair) >>% morphed) <+> konst [])) >>^ cons'

95+ )

96+ <+> konst []

97+ )

98+ &&& unsafeWhiteSpace

99+ &&& token '}'

test/Spec/Megaparsec/BasicNums.hsnew file+51

@@ -0,0 +1,51 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE RankNTypes #-}

4+{-# LANGUAGE TemplateHaskell #-}

5+{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE TypeFamilies #-}

8+module Spec.Megaparsec.BasicNums

9+ ( spec,

10+ quickSpec,

11+ )

12+where

13+

14+import Data.Either

15+import Data.Isoparsec

16+import Data.Isoparsec.Char

17+import Data.Isoparsec.Megaparsec

18+import Data.Isoparsec.Printer

19+import Data.Maybe

20+import Data.Void

21+import Optics

22+import Test.Hspec

23+import Test.Tasty

24+import Test.Tasty.QuickCheck

25+import Text.Megaparsec.Error

26+import Prelude hiding ((.), fail)

27+

28+data Foo = Foo Integer Integer

29+ deriving (Show, Eq)

30+

31+instance Arbitrary Foo where

32+ arbitrary = Foo <$> arbitrary <*> arbitrary

33+

34+makePrisms ''Foo

35+

36+parser :: (Isoparsec m s, Token s ~ Char, IsoparsecLabel m String) => m () Foo

37+parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number <?> "oh no")

38+

39+spec :: Spec

40+spec =

41+ it "deserializes" $ do

42+ runMegaparsec @() parser "12 31" `shouldBe` (Right $ Foo 12 31)

43+ runMegaparsec @() parser "1 33" `shouldBe` (Right $ Foo 1 33)

44+ runMegaparsec @() parser "1562" `shouldSatisfy` isLeft

45+

46+quickSpec :: TestTree

47+quickSpec = testProperty "roundtrips" $ \x ->

48+ let s = fromJust $ runPrinter @Maybe @String parser x

49+ in counterexample s $ case runMegaparsec @Void parser s of

50+ Right y -> property $ x == y

51+ Left err -> counterexample (errorBundlePretty err) False

test/Spec/Orphans.hsnew file+39

@@ -0,0 +1,39 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE ExistentialQuantification #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE StandaloneDeriving #-}

7+{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+{-# OPTIONS_GHC -Wno-orphans #-}

11+

12+module Spec.Orphans

13+ (

14+ )

15+where

16+

17+import Data.ByteString

18+import Data.Isoparsec

19+import Data.Isoparsec.ByteString

20+import Data.Isoparsec.Chunks

21+import Data.Proxy

22+import GHC.TypeLits

23+import Test.Tasty.QuickCheck

24+import Prelude hiding ((.))

25+

26+instance

27+ (CmpNat n 0 ~ 'GT, KnownNat n, Arbitrary (Token s), Tokenable s) =>

28+ Arbitrary (Chunk n s)

29+ where

30+ arbitrary = Chunk . liftTokens <$> vectorOf (fromIntegral $ natVal @n Proxy) arbitrary

31+

32+instance Arbitrary ByteString where

33+ arbitrary = liftTokens <$> listOf arbitrary

34+

35+deriving instance Arbitrary (Byte16 e)

36+

37+deriving instance Arbitrary (Byte32 e)

38+

39+deriving instance Arbitrary (Byte64 e)

test/Spec/Ssh.hsnew file+212

@@ -0,0 +1,212 @@

1+{-# LANGUAGE BinaryLiterals #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE DerivingStrategies #-}

6+{-# LANGUAGE FlexibleContexts #-}

7+{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE OverloadedStrings #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE StandaloneDeriving #-}

13+{-# LANGUAGE TemplateHaskell #-}

14+{-# LANGUAGE TypeApplications #-}

15+{-# LANGUAGE TypeFamilies #-}

16+

17+module Spec.Ssh

18+ ( spec,

19+ quickSpec,

20+ )

21+where

22+

23+import Data.ByteString as BS

24+import qualified Data.Char as C

25+import Data.Isoparsec

26+import Data.Isoparsec.ByteString

27+import qualified Data.Word8 as W8

28+import GHC.Generics

29+import Optics

30+import Spec.Helper

31+import Spec.Orphans ()

32+import Test.Hspec

33+import Test.Tasty

34+import Test.Tasty.QuickCheck

35+import Prelude as P hiding ((.), id)

36+

37+data MessageNumber

38+ = DisconnectMsg

39+ | IgnoreMsg

40+ | UnimplementedMsg

41+ | DebugMsg

42+ | ServiceRequestMsg

43+ | ServiceAcceptMsg

44+ | KextInitMsg

45+ | NewKeysMsg

46+ deriving (Eq, Show, Ord)

47+

48+instance ToIsoparsec MessageNumber ByteString where

49+ toIsoparsec =

50+ anyToken

51+ >>> mapIso

52+ [ (1, DisconnectMsg),

53+ (2, IgnoreMsg),

54+ (3, UnimplementedMsg),

55+ (4, DebugMsg),

56+ (5, ServiceRequestMsg),

57+ (6, ServiceAcceptMsg),

58+ (20, KextInitMsg),

59+ (21, NewKeysMsg)

60+ ]

61+

62+newtype DisconnectReasonCode

63+ = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}

64+ deriving (Eq, Ord, Show, Generic, Arbitrary)

65+

66+instance ToIsoparsec DisconnectReasonCode ByteString

67+

68+newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}

69+ deriving (Eq, Ord, Show, Generic, Arbitrary)

70+

71+instance ToIsoparsec AlwaysDisplay ByteString

72+

73+newtype PacketSequenceNumber

74+ = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}

75+ deriving (Eq, Ord, Show, Generic, Arbitrary)

76+

77+instance ToIsoparsec PacketSequenceNumber ByteString

78+

79+data Payload

80+ = VersionPayload String

81+ | IgnorePayload ByteString

82+ | ServiceRequest SSHString

83+ | DebugPayload AlwaysDisplay SSHString

84+ | DisconnectPayload DisconnectReasonCode String

85+ | ServiceAccept SSHString

86+ | UnimplementedPayload PacketSequenceNumber

87+ deriving (Show, Eq)

88+

89+instance Arbitrary Payload where

90+ arbitrary =

91+ oneof

92+ [ VersionPayload . P.filter (not . C.isSpace) <$> s,

93+ IgnorePayload <$> arbitrary,

94+ ServiceRequest . SSHString <$> s,

95+ DebugPayload <$> arbitrary <*> (SSHString <$> s),

96+ DisconnectPayload <$> arbitrary <*> s,

97+ ServiceAccept . SSHString <$> s,

98+ UnimplementedPayload <$> arbitrary

99+ ]

100+ where

101+ s = getASCIIString <$> arbitrary

102+

103+makePrisms ''Payload

104+

105+instance ToIsoparsec Payload ByteString where

106+ toIsoparsec =

107+ try

108+ ( _DisconnectPayload

109+ <.> specific DisconnectMsg

110+ &&& auto @DisconnectReasonCode

111+ &&& (tokensWhile (const True) >>> ftu8)

112+ )

113+ <+> try

114+ ( _ServiceRequest <.> specific ServiceRequestMsg

115+ &&& auto @SSHString

116+ )

117+ <+> try

118+ ( _VersionPayload <.> utf8 "SSH-2.0-"

119+ &&& ( ( try (takeUntil "\r\n" >>> check (BS.all (not . W8.isSpace)))

120+ <+> ((takeUntil " " &&& (takeUntil "\r\n" >>> badTsnok "")) >>% morphed)

121+ )

122+ >>> ftu8

123+ )

124+ )

125+ <+> try (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))

126+ <+> try

127+ ( _DebugPayload <.> specific DebugMsg

128+ &&& auto @AlwaysDisplay

129+ &&& auto @SSHString

130+ )

131+ <+> try

132+ ( _UnimplementedPayload <.> specific UnimplementedMsg

133+ &&& auto @PacketSequenceNumber

134+ )

135+ <+> try

136+ ( _ServiceAccept <.> specific ServiceAcceptMsg

137+ &&& auto @SSHString

138+ )

139+

140+newtype Padding = Padding {unPadding :: ByteString}

141+ deriving (Eq, Ord, Show, Generic, Arbitrary)

142+

143+newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}

144+ deriving (Eq, Ord, Show, Generic, Arbitrary)

145+

146+badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding

147+badZeroPadding =

148+ throughIntegral

149+ >>> manyTokens

150+ >>^ siJust

151+ (ZeroPadding . fromIntegral . BS.length)

152+ (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)

153+

154+newtype MAC = MAC {unMAC :: ByteString}

155+ deriving (Eq, Ord, Show, Generic, Arbitrary)

156+

157+data NoneMAC = NoneMAC

158+ deriving (Eq, Ord, Show, Generic)

159+

160+instance ToIsoparsec NoneMAC b where

161+ toIsoparsec = konst NoneMAC

162+

163+instance Arbitrary NoneMAC where

164+ arbitrary = return NoneMAC

165+

166+data Packet mac

167+ = Packet Payload ZeroPadding mac

168+ deriving (Eq, Show)

169+

170+instance Arbitrary mac => Arbitrary (Packet mac) where

171+ arbitrary = Packet <$> arbitrary <*> arbitrary <*> arbitrary

172+

173+makePrisms ''Packet

174+

175+instance ToIsoparsec mac ByteString => ToIsoparsec (Packet mac) ByteString where

176+ toIsoparsec =

177+ ( ( (auto @(Byte32 'BE) &&& auto @Byte8)

178+ >>> (throughIntegral *** throughIntegral)

179+ >>> siJust

180+ (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))

181+ (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))

182+ ^>> (manyTokens *** throughIntegral)

183+ >>> (tuck (auto @Payload) *** badZeroPadding)

184+ )

185+ &&& auto @mac

186+ )

187+ >>^ siJust (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))

188+

189+spec :: Spec

190+spec = do

191+ it "deserialize payload" $ do

192+ "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"

193+ "SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"

194+ "\x2__" `shouldParseBS` IgnorePayload "__"

195+ "\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")

196+ it "deserialize packet" $ do

197+ ("\0\0\0\xd" <> "\x2" <> "\x5\0\0\0\x5henlo" <> "69")

198+ `shouldParseBS` Packet (ServiceRequest (SSHString "henlo")) (ZeroPadding 2) NoneMAC

199+ ("\0\0\0\xd" <> "\x2" <> "\x2\0\0\0\x5henlo" <> "69")

200+ `shouldParseBS` Packet (IgnorePayload "\0\0\0\x5henlo") (ZeroPadding 2) NoneMAC

201+ ("\0\0\0\xd" <> "\x3" <> "\x2\0\0henlo!" <> "69a")

202+ `shouldParseBS` Packet (IgnorePayload "\0\0henlo!") (ZeroPadding 3) NoneMAC

203+ ("\0\0\0\xb" <> "\x3" <> "\x2henlo!" <> "69a")

204+ `shouldParseBS` Packet (IgnorePayload "henlo!") (ZeroPadding 3) NoneMAC

205+

206+quickSpec :: TestTree

207+quickSpec =

208+ testGroup

209+ "roundtrips"

210+ [ testProperty "payload" $ roundtrip @Payload @ByteString,

211+ testProperty "packet" $ roundtrip @(Packet NoneMAC) @ByteString

212+ ]

test/Spec/TwoDigits.hsnew file+81

@@ -0,0 +1,81 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DerivingVia #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE TypeFamilies #-}

10+

11+module Spec.TwoDigits

12+ ( spec,

13+ quickSpec,

14+ )

15+where

16+

17+import Data.Char

18+import Data.Either

19+import Data.Isoparsec

20+import Data.Isoparsec.Chunks

21+import Data.Isoparsec.Megaparsec

22+import Data.Isoparsec.Printer

23+import Data.Maybe

24+import Data.Void

25+import GHC.Generics

26+import Test.Hspec

27+import Test.Tasty

28+import Test.Tasty.QuickCheck

29+import Text.Megaparsec.Error

30+import Prelude hiding ((.))

31+

32+newtype SingleDigit = SingleDigit {unSingleDigit :: String}

33+ deriving (Eq, Show, Generic)

34+

35+instance ToIsoparsec SingleDigit String where

36+ toIsoparsec =

37+ toIsoparsec @(Chunk 1 String)

38+ >>> coercing

39+ >>> check (all @[] isDigit)

40+ >>> coercing

41+

42+instance (Arbitrary SingleDigit) where

43+ arbitrary = SingleDigit . pure <$> elements ['0' .. '9']

44+

45+data Digits

46+ = FourDigits SingleDigit SingleDigit SingleDigit SingleDigit

47+ | ThreeDigits SingleDigit SingleDigit SingleDigit

48+ | TwoDigits SingleDigit SingleDigit

49+ deriving (Generic, Show, Eq)

50+

51+instance Arbitrary Digits where

52+ arbitrary =

53+ oneof

54+ [ FourDigits <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary,

55+ ThreeDigits <$> arbitrary <*> arbitrary <*> arbitrary,

56+ TwoDigits <$> arbitrary <*> arbitrary

57+ ]

58+

59+instance ToIsoparsec Digits String

60+

61+spec :: Spec

62+spec = do

63+ let parser = toIsoparsec

64+ it "deserializes" $ do

65+ runMegaparsec @() parser "12" `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))

66+ runMegaparsec @() parser "125" `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))

67+ runMegaparsec @() parser "1253" `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))

68+ runMegaparsec @() parser "12538" `shouldSatisfy` isLeft

69+ runMegaparsec @() parser "2" `shouldSatisfy` isLeft

70+ runMegaparsec @() parser "a" `shouldSatisfy` isLeft

71+ runMegaparsec @() parser "1a" `shouldSatisfy` isLeft

72+

73+quickSpec :: TestTree

74+quickSpec = testProperty "roundtrips" $ \x ->

75+ let s = fromJust $ runPrinter @Maybe @String parser x

76+ in counterexample s $ case runMegaparsec @Void parser s of

77+ Right y -> property $ x == y

78+ Left err -> counterexample (errorBundlePretty err) False

79+ where

80+ parser :: Isoparsec m String => m () Digits

81+ parser = toIsoparsec