master..1ffcdf0 · isoparsec

git.iko.soy/isoparsec

on 1ffcdf0 help sign in

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

since splitsnapshots

unifiedsplit

@@ -9,7 +9,7 @@ jobs:

10 strategy:

11 matrix:

12− resolver: [lts-13.11, lts-13.19, lts-14.27, lts-15, nightly]

12+ resolver: [lts-13.11, lts-13.19, lts-14, nightly]

14 steps:

15 - uses: actions/checkout@v1

@@ -29,6 +29,6 @@ jobs:

29 stack test --fast --pedantic --ghc-options '-j' --resolver=${{ matrix.resolver }}

31 - name: Weeder

32− if: matrix.resolver == 'lts-15'

32+ if: matrix.resolver == 'lts-14'

33 run: |

34 curl -sSL https://raw.github.com/ndmitchell/weeder/master/misc/run.sh | sh -s . --build

.hlint.yaml+1−105

@@ -52,7 +52,7 @@

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

55−# Define some custom fixity operators

55+# Define some custom infix operators

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

@@ -85,107 +85,3 @@

85 - -XTypeOperators

86 - -XUndecidableInstances

87 - -XRankNTypes

88−

89−# hints found in src/Control/SemiIso.hs

90−- warn: {lhs: "SI (pure . a) (pure . b)", rhs: "siPure a b"}

91−- warn: {lhs: "SemiIso (pure . a) (pure . b)", rhs: "siPure a b"}

92−- warn: {lhs: "SemiIso (const empty) (const empty)", rhs: "zeroArrow"}

93−

94−# hints found in src/Control/Arrow/Extra.hs

95−- fixity: "infixl 5 <+^"

96−- fixity: "infixl 5 ^+>"

97−- fixity: "infixl 5 ^+^"

98−- warn: {lhs: "a <+> arr b", rhs: "a <+^ b"}

99−- warn: {lhs: "arr a <+> b", rhs: "a ^+> b"}

100−- warn: {lhs: "arr a <+> arr b", rhs: "a ^+^ b"}

101−

102−# hints found in src/Control/Arrow/Extra/ArrowChoice.hs

103−- fixity: "infixl 2 +++"

104−- fixity: "infixl 2 |||"

105−

106−# hints found in src/Control/Arrow/Extra/ArrowPlus.hs

107−- fixity: "infixl 5 <+>"

108−

109−# hints found in src/Control/Arrow/Extra/ArrowZero.hs

110−# no hints found

111−

112−# hints found in src/Control/Arrow/Extra/BaseArrow.hs

113−- fixity: "infixl 3 ***"

114−- fixity: "infixl 3 &&&"

115−- fixity: "infixl 1 >>>"

116−- fixity: "infixl 1 <<<"

117−

118−# hints found in src/Control/Arrow/Extra/Orphans.hs

119−# no hints found

120−

121−# hints found in src/Control/Arrow/Extra/PolyArrow.hs

122−- fixity: "infixl 1 ^>>"

123−- fixity: "infixl 1 >>^"

124−- fixity: "infixl 1 ^<<"

125−- fixity: "infixl 1 <<^"

126−- fixity: "infixl 1 ^>^"

127−- fixity: "infixl 1 ^<^"

128−- warn: {lhs: "arr a >>> arr b", rhs: "a ^>^ b"}

129−- warn: {lhs: "arr a <<< arr b", rhs: "a ^<^ b"}

130−- warn: {lhs: "arr a >>> b", rhs: "a ^>> b"}

131−- warn: {lhs: "a >>> arr b", rhs: "a >>^ b"}

132−- warn: {lhs: "a <<< arr b", rhs: "a <<^ b"}

133−- warn: {lhs: "arr a <<< b", rhs: "a ^<< b"}

134−

135−# hints found in src/Data/Isoparsec.hs

136−- warn: {lhs: "a <+^ konst ()", rhs: "opt a"}

137−- warn: {lhs: "opt (b >>^ turn (konst a))", rhs: "opt' a b"}

138−- warn: {lhs: "(a &&& (repeating a <+^ konst [])) >>^ siCons", rhs: "repeating a"}

139−- warn: {lhs: "sepBy1 a b <+^ konst []", rhs: "sepBy a b"}

140−- warn: {lhs: "(b &&& repeating (a *>> b) <+^ konst []) >>^ siCons", rhs: "sepBy1 a b"}

141−- fixity: "infixl 0 <.>"

142−- warn: {lhs: "(b >>^ morphed) >>^ siPrism a", rhs: "a <.> b"}

143−- warn: {lhs: "withPrism a\n (\\ x y -> SemiIso (pure . x) (either (const empty) pure . y))", rhs: "siPrism a"}

144−- fixity: "infixl 8 ~>"

145−- fixity: "infixl 8 ~>^"

146−- fixity: "infixl 8 ^~>"

147−- fixity: "infixl 8 ^~>^"

148−- warn: {lhs: "turn siHFst ^>> (enlist a *** enlist b) >>^ siHFst", rhs: "a ~> b"}

149−- warn: {lhs: "siPure fst (, HNil)", rhs: "siHFst"}

150−- fixity: "infixl 5 ~|"

151−- warn: {lhs: "enlist a <+> enlist b", rhs: "a ~| b"}

152−- fixity: "infixl 7 ~&"

153−- warn: {lhs: "(enlist a &&& enlist b) >>^ consHList", rhs: "a ~& b"}

154−- fixity: "infixl 9 ~*"

155−- warn: {lhs: "turn consHList ^>> (enlist a *** enlist b) >>^ consHList", rhs: "a ~* b"}

156−- fixity: "infixl 6 ~$>"

157−- warn: {lhs: "enlist a >>> enlist (arr (siPrism b))", rhs: "a ~$> b"}

158−- warn: {lhs: "turn fMorphed ^>>\n (a (fMorphed ^>> b >>^ turn fMorphed)) >>^ fMorphed", rhs: "hmap a b"}

159−- warn: {lhs: "siPure coerce coerce", rhs: "coercing"}

160−- warn: {lhs: "siPure morphTuples morphTuples", rhs: "morphed"}

161−- warn: {lhs: "siPure flatUnmorph flatMorph", rhs: "fMorphed"}

162−- warn: {lhs: "turn fMorphed ^>> a >>^ fMorphed", rhs: "enlist a"}

163−- warn: {lhs: "fMorphed ^>> a >>^ turn fMorphed", rhs: "delist a"}

164−- warn: {lhs: "siPure (uncurry (++:))\n (\\ c -> (hTake @(Length a) Proxy c, hDrop @(Length a) Proxy c))", rhs: "consHList"}

165−- warn: {lhs: "auto @x >>^ turn (konst a)", rhs: "specific a"}

166−- warn: {lhs: "siPure fromIntegral fromIntegral", rhs: "throughIntegral"}

167−

168−# hints found in src/Data/Isoparsec/ByteString.hs

169−- warn: {lhs: "arr (siPure C.unpack C.pack)", rhs: "utf8"}

170−- warn: {lhs: "bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte16 e) @Word16", rhs: "toIsoparsec"}

171−- warn: {lhs: "bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte32 e) @Word32", rhs: "toIsoparsec"}

172−- warn: {lhs: "bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte64 e) @Word64", rhs: "toIsoparsec"}

173−- warn: {lhs: "anyToken >>> mapIso [(0, False), (1, True)]", rhs: "toIsoparsec"}

174−

175−# hints found in src/Data/Isoparsec/Char.hs

176−- warn: {lhs: "token ' '", rhs: "space"}

177−- warn: {lhs: "tokensWhile isSpace >>^ ((maskr . turn . konst) mempty)", rhs: "unsafeWhiteSpace"}

178−- warn: {lhs: "tokensWhile1 isSpace >>^ ((maskr . turn . konst) (singleton ' '))", rhs: "unsafeWhiteSpace1"}

179−

180−# hints found in src/Data/Isoparsec/Cokleisli.hs

181−- warn: {lhs: "Cokleisli\n (\\ t ->\n case project a t of\n Just x -> return x\n Nothing -> mzero)", rhs: "arr a"}

182−- warn: {lhs: "Cokleisli (const mzero)", rhs: "zeroArrow"}

183−

184−# hints found in src/Data/Isoparsec/Internal.hs

185−- warn: {lhs: "((a &&& arrowsWhile a) >>^ siCons) <+^ isoConst () []", rhs: "arrowsWhile a"}

186−- warn: {lhs: "siMaybe (pure . uncurry cons) uncons", rhs: "siCons"}

187−- warn: {lhs: "SI (\\ c -> guard (a c) >> b c)\n (c >=> (\\ c -> guard (a c) >> pure c))", rhs: "siCheck a b c"}

188−- warn: {lhs: "siCheck a (pure . b) (pure . c)", rhs: "isoCheck a b c"}

189−- warn: {lhs: "SI (const (pure b)) (const (pure a))", rhs: "isoConst a b"}

190−- warn: {lhs: "isoCheck a id id", rhs: "check a"}

191−- warn: {lhs: "SI (const (pure a)) (const (pure ())) >>> check (== a)", rhs: "konst a"}

README.md+1−4

@@ -1,7 +1,4 @@

1−# 🔄 🔡 isoparsec ![](https://github.com/ilyakooo0/isoparsec/workflows/Haskell%20CI/badge.svg)

1+# isoparsec ![](https://github.com/ilyakooo0/isoparsec/workflows/Haskell%20CI/badge.svg)

2−

3Isomorphic (invertible) parser library

2Isomorphic (invertible) parser library

5−### 🚧 Under construction 🚧

6−

7![](https://media.giphy.com/media/xDQ3Oql1BN54c/giphy.gif)

4![](https://media.giphy.com/media/xDQ3Oql1BN54c/giphy.gif)

package.yaml−2

@@ -27,8 +27,6 @@ dependencies:

27# - text

28- mtl

29- profunctors

30−- mono-traversable

31−- split

33library:

31library:

34 source-dirs: src

32 source-dirs: src

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

@@ -14,19 +14,19 @@ import Control.Arrow.Extra.ArrowPlus as X

14import Control.Arrow.Extra.ArrowZero as X

15import Control.Arrow.Extra.BaseArrow as X

16import Control.Arrow.Extra.PolyArrow as X

17−import Control.Category as X hiding ((<<<), (>>>))

17+import Control.Category as X

19−infixl 5 <+^

19+infixr 5 <+^

21−infixl 5 ^+>

21+infixr 5 ^+>

23−infixl 5 ^+^

23+infixr 5 ^+^

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

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

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

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

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

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

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

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

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

src/Control/Arrow/Extra/BaseArrow.hs+1−13

@@ -2,12 +2,10 @@

3module Control.Arrow.Extra.BaseArrow

4 ( BaseArrow (..),

5− (>>>),

6− (<<<),

7 )

5 )

8where

6where

10−import Control.Category hiding ((<<<), (>>>))

8+import Control.Category

12infixl 3 ***

10infixl 3 ***

@@ -25,13 +23,3 @@ class Category a => BaseArrow a where

25 (***) :: a b c -> a b' c' -> a (b, b') (c, c')

23 (***) :: a b c -> a b' c' -> a (b, b') (c, c')

27 (&&&) :: a b c -> a b c' -> a b (c, c')

25 (&&&) :: a b c -> a b c' -> a b (c, c')

28−

29−infixl 1 >>>

30−

31−(>>>) :: Category cat => cat a b -> cat b c -> cat a c

32−x >>> y = y . x

33−

34−infixl 1 <<<

35−

36−(<<<) :: Category cat => cat b c -> cat a b -> cat a c

37−x <<< y = x . y

src/Control/Arrow/Extra/Orphans.hs+1−1

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

30 (&&&) = (A.&&&)

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

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

33 arr = A.arr

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

src/Control/Arrow/Extra/PolyArrow.hs+11−10

@@ -10,30 +10,31 @@ module Control.Arrow.Extra.PolyArrow

10where

12import Control.Arrow.Extra.BaseArrow

13+import Control.Category

14−infixl 1 ^>>, >>^

15+infixr 1 ^>>, >>^

16−infixl 1 ^<<, <<^

17+infixr 1 ^<<, <<^

18−infixl 1 ^>^, ^<^

19+infixr 1 ^>^, ^<^

20−class BaseArrow a => PolyArrow p a where

21+class BaseArrow a => PolyArrow a p where

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

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

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

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

24f ^>> a = arr f >>> a

25f ^>> a = arr f >>> a

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

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

27a >>^ f = a >>> arr f

28a >>^ f = a >>> arr f

29−(<<^) :: PolyArrow p a => a c d -> p b c -> a b d

30+(<<^) :: PolyArrow a p => a c d -> p b c -> a b d

30a <<^ f = a <<< arr f

31a <<^ f = a <<< arr f

32−(^<<) :: PolyArrow p a => p c d -> a b c -> a b d

33+(^<<) :: PolyArrow a p => p c d -> a b c -> a b d

33f ^<< a = arr f <<< a

34f ^<< a = arr f <<< a

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

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

36a ^>^ b = arr a >>> arr b

37a ^>^ b = arr a >>> arr b

38−(^<^) :: PolyArrow p a => p c d -> p b c -> a b d

39+(^<^) :: PolyArrow a p => p c d -> p b c -> a b d

39a ^<^ b = arr a <<< arr b

40a ^<^ b = arr a <<< arr b

src/Control/Arrow/Reader.hsdeleted−34

@@ -1,34 +0,0 @@

1−module Control.Arrow.Reader

2− ( ArrowReader (..),

3− asksr,

4− asksl,

5− biask,

6− biasks,

7− module Control.Arrow.Trans.Reader,

8− )

9−where

10−

11−import Control.Arrow.Extra

12−import Control.Arrow.Trans.Reader

13−import Control.SemiIso

14−import Prelude hiding ((.), id)

15−

16−class ArrowReader r a where

17− askr :: a () r

18− askl :: a r ()

19−

20−instance (PolyArrow SemiIso a, Eq r) => ArrowReader r (ReaderArrow r a) where

21− askr = ReaderArrow . arr $ siFst >>> siDouble

22− askl = ReaderArrow . arr $ turn siDouble >>> turn siFst

23−

24−asksr :: (PolyArrow SemiIso a, ArrowReader r a) => SemiIso r s -> a () s

25−asksr si = askr >>^ si

26−

27−asksl :: (PolyArrow SemiIso a, ArrowReader r a) => SemiIso r s -> a s ()

28−asksl si = turn si ^>> askl

29−

30−biask :: (ArrowReader r a, Category a) => a r r -> a () ()

31−biask a = askr >>> a >>> askl

32−

33−biasks :: (ArrowReader r a, PolyArrow SemiIso a) => SemiIso r s -> a s s -> a () ()

34−biasks si a = asksr si >>> a >>> asksl si

src/Control/Arrow/Trans/Class.hsdeleted−9

@@ -1,9 +0,0 @@

1−module Control.Arrow.Trans.Class

2− ( ArrowTrans (..),

3− )

4−where

5−

6−import Control.Arrow.Extra

7−

8−class ArrowTrans s where

9− raise :: BaseArrow a => a b c -> s a b c

src/Control/Arrow/Trans/Reader.hsdeleted−53

@@ -1,53 +0,0 @@

1−module Control.Arrow.Trans.Reader

2− ( ReaderArrow (..),

3− runReaderArrow,

4− module Control.Arrow.Trans.Class,

5− )

6−where

7−

8−import Control.Arrow.Extra

9−import Control.Arrow.Trans.Class

10−import Control.SemiIso

11−import Prelude hiding ((.), fail, id)

12−

13−newtype ReaderArrow r s a b

14− = ReaderArrow {unReaderArrow :: s (r, a) (r, b)}

15−

16−instance BaseArrow a => Category (ReaderArrow r a) where

17− id = ReaderArrow . second $ id

18− (ReaderArrow lhs) . (ReaderArrow rhs) = ReaderArrow $ lhs . rhs

19−

20−instance (PolyArrow p a, PolyArrow SemiIso a, Eq r) => PolyArrow p (ReaderArrow r a) where

21− arr = ReaderArrow . second . arr

22−

23−instance (BaseArrow a, PolyArrow SemiIso a, Eq r) => BaseArrow (ReaderArrow r a) where

24− (ReaderArrow lhs) *** (ReaderArrow rhs) =

25− ReaderArrow $

26− siDouble *** id

27− ^>^ turn siTranspose2

28− >>> lhs *** rhs

29− >>^ siTranspose2

30− >>^ turn siDouble *** id

31− (ReaderArrow lhs) &&& (ReaderArrow rhs) =

32− ReaderArrow $

33− lhs &&& rhs

34− >>^ siTranspose2

35− >>^ turn siDouble *** id

36−

37−instance (ArrowZero a, BaseArrow (ReaderArrow r a)) => ArrowZero (ReaderArrow r a) where

38− zeroArrow = ReaderArrow $ id *** zeroArrow

39−

40−instance (ArrowPlus a, ArrowZero (ReaderArrow r a)) => ArrowPlus (ReaderArrow r a) where

41− (ReaderArrow lhs) <+> (ReaderArrow rhs) = ReaderArrow $ lhs <+> rhs

42−

43−instance (ArrowChoice a, PolyArrow SemiIso a, Eq r) => ArrowChoice (ReaderArrow r a) where

44− (ReaderArrow lhs) ||| (ReaderArrow rhs) = ReaderArrow $ siSequenceEither ^>> lhs ||| rhs

45− (ReaderArrow lhs) +++ (ReaderArrow rhs) =

46− ReaderArrow $ siSequenceEither ^>> lhs +++ rhs >>^ turn siSequenceEither

47−

48−runReaderArrow :: (PolyArrow SemiIso s, Eq r) => r -> ReaderArrow r s a b -> s a b

49−runReaderArrow r a =

50− turn siSnd >>> first (konst r) ^>> unReaderArrow a >>^ (first . turn $ konst r) >>^ siSnd

51−

52−instance ArrowTrans (ReaderArrow r) where

53− raise = ReaderArrow . second

src/Control/Prism.hs+1−3

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

1module Control.Prism

2 ( withPrism,

3+ Market,

3 Identity,

4 Identity,

4− Prism',

5 )

6where

@@ -9,8 +9,6 @@ import Data.Coerce

9import Data.Functor.Identity

10import Data.Profunctor

12−type Prism' a b = Market a a a (Identity a) -> Market a a b (Identity b)

13−

14data Market a b s t = Market (b -> t) (s -> Either t a)

12data Market a b s t = Market (b -> t) (s -> Either t a)

16instance Functor (Market a b s) where

14instance Functor (Market a b s) where

src/Control/SemiIso.hs−122

@@ -7,42 +7,13 @@ module Control.SemiIso

7 turn,

8 withSemiIso,

9 AlternativeMonad,

10− maskr,

11− maskl,

12− isoCheck,

13− siCheck,

14− check,

15− konst,

16− isoConst,

17− assoc,

18− ($$$),

19− (*>>),

20− (&>>),

21− (**>),

22− (>>*),

23− (>>&),

24− (>**),

25− (<<*),

26− (<<&),

27− (<**),

28− (*<<),

29− (&<<),

30− (**<),

31− siFst,

32− siSnd,

33− siDouble,

34− siSwap,

35− siTranspose2,

36− siSequenceEither,

37 )

10 )

38where

11where

40import Control.Applicative as X

13import Control.Applicative as X

41import Control.Arrow.Extra

14import Control.Arrow.Extra

42import Control.Monad as X

15import Control.Monad as X

43−import qualified Data.Bifunctor as Bi

44import Data.Bitraversable

16import Data.Bitraversable

45−import Data.Tuple

46import Prelude hiding ((.), id)

17import Prelude hiding ((.), id)

48type AlternativeMonad m = (Alternative m, Monad m)

19type AlternativeMonad m = (Alternative m, Monad m)

@@ -111,96 +82,3 @@ withSemiIso ::

111 ((a -> f b) -> (b -> f a) -> c) ->

82 ((a -> f b) -> (b -> f a) -> c) ->

112 c

83 c

113withSemiIso (SemiIso a b) f = f a b

84withSemiIso (SemiIso a b) f = f a b

114−

115−maskr :: SemiIso a () -> SemiIso a ()

116−maskr (SemiIso e p) = SemiIso (\a -> e a <|> pure ()) p

117−

118−maskl :: SemiIso () b -> SemiIso () b

119−maskl (SemiIso e p) = SemiIso e (\b -> p b <|> pure ())

120−

121−infixl 1 *>>, **>, >>*, >**, <<*, <**, *<<, **<

122−

123−infixl 3 $$$

124−

125−($$$) :: (PolyArrow SemiIso m, Eq b) => m a b -> m c b -> m (a, c) b

126−a $$$ c = a *** c >>^ turn siDouble

127−

128−(*>>) :: (PolyArrow SemiIso m) => m a () -> m a b -> m a b

129−a *>> b = a &&& b >>^ siSnd

130−

131−(&>>) :: (PolyArrow SemiIso m) => m a () -> m b c -> m (a, b) c

132−a &>> b = a *** b >>^ siSnd

133−

134−(**>) :: (PolyArrow SemiIso m) => m () () -> m a b -> m a b

135−a **> b = turn siSnd ^>> a *** b >>^ siSnd

136−

137−(>>*) :: (PolyArrow SemiIso m, Eq b) => m a b -> m () b -> m a b

138−a >>* b = turn siFst ^>> a $$$ b

139−

140−(>>&) :: (PolyArrow SemiIso m) => m a b -> m () c -> m a (b, c)

141−a >>& b = turn siFst ^>> a *** b

142−

143−(>**) :: (PolyArrow SemiIso m) => m a b -> m () () -> m a b

144−a >** b = turn siFst ^>> a *** b >>^ siFst

145−

146−(<<*) :: (PolyArrow SemiIso m, Eq b) => m a b -> m () b -> m a b

147−a <<* b = turn siSnd ^>> b $$$ a

148−

149−(<<&) :: (PolyArrow SemiIso m) => m a b -> m () c -> m a (b, c)

150−a <<& b = turn siSnd ^>> b *** a >>^ siSwap

151−

152−(<**) :: (PolyArrow SemiIso m) => m a b -> m () () -> m a b

153−a <** b = turn siSnd ^>> b *** a >>^ siSnd

154−

155−(*<<) :: (PolyArrow SemiIso m) => m a () -> m a b -> m a b

156−a *<< b = b &&& a >>^ siFst

157−

158−(&<<) :: (PolyArrow SemiIso m) => m a () -> m b c -> m (a, b) c

159−a &<< b = siSwap ^>> b *** a >>^ siFst

160−

161−(**<) :: (PolyArrow SemiIso m) => m () () -> m a b -> m a b

162−a **< b = turn siFst ^>> b *** a >>^ siFst

163−

164−check :: (s -> Bool) -> SemiIso s s

165−check f = isoCheck f id id

166−

167−siCheck ::

168− (s -> Bool) ->

169− (forall f. AlternativeMonad f => s -> f a) ->

170− (forall f. AlternativeMonad f => a -> f s) ->

171− SemiIso s a

172−siCheck f a b =

173− SI

174− (\c -> guard (f c) >> a c)

175− (b >=> (\c -> guard (f c) >> pure c))

176−

177−isoCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso s a

178−isoCheck f a b = siCheck f (pure . a) (pure . b)

179−

180−isoConst :: s -> a -> SemiIso s a

181−isoConst s a = SI (const $ pure a) (const $ pure s)

182−

183−konst :: Eq x => x -> SemiIso () x

184−konst x = isoConst () x >>> check (== x)

185−

186−assoc :: SemiIso (a, (b, c)) ((a, b), c)

187−assoc = siPure (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))

188−

189−siFst :: SemiIso (a, ()) a

190−siFst = siPure fst (,())

191−

192−siSnd :: SemiIso ((), a) a

193−siSnd = siPure snd ((),)

194−

195−siDouble :: (Eq a) => SemiIso a (a, a)

196−siDouble = siPure (\x -> (x, x)) fst >>> check (uncurry (==))

197−

198−siSwap :: SemiIso (a, b) (b, a)

199−siSwap = siPure swap swap

200−

201−siTranspose2 :: SemiIso ((a, b), (c, d)) ((a, c), (b, d))

202−siTranspose2 =

203− siPure (\((r1, b), (r2, c)) -> ((r1, r2), (b, c))) (\((r1, r2), (b, c)) -> ((r1, b), (r2, c)))

204−

205−siSequenceEither :: SemiIso (r, Either a b) (Either (r, a) (r, b))

206−siSequenceEither = siPure (\(r, e) -> Bi.bimap (r,) (r,) e) (either (Bi.second Left) (Bi.second Right))

src/Control/Tuple/Morph.hs+4−179

@@ -7,22 +7,11 @@ module Control.Tuple.Morph

7 TupleMorphable,

8 CheckListsForTupleIso,

9 ReorderList,

10− FlatMorphable (..),

11− TupleHListContents,

12− HListContentsTuple,

13− Nat (..),

14− HList (..),

15− AppendableList (..),

16− DroppableList (..),

17− TakeableList (..),

18− Length,

19− Proxy (..),

20 )

10 )

21where

11where

23import Data.Kind

13import Data.Kind

24import Data.Proxy

14import Data.Proxy

25−import Data.Type.Equality

26import GHC.Generics

15import GHC.Generics

27import GHC.TypeLits hiding (Nat)

16import GHC.TypeLits hiding (Nat)

@@ -71,7 +60,7 @@ data HList (ts :: [*]) where

71 HCons :: t -> HList tt -> HList (t ': tt)

60 HCons :: t -> HList tt -> HList (t ': tt)

72 HNil :: HList '[]

61 HNil :: HList '[]

74−infixl 5 :+

63+infixr 5 :+

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

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

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

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

@@ -103,16 +92,10 @@ instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where

103

104-- ## Appending

93-- ## Appending

105

106−infixl 4 ++:

95+infixr 4 ++:

107

108−class

109− ( (aa ++ bb) ~ cc,

110− DroppableList (Length aa) cc bb,

111− TakeableList (Length aa) cc aa

112− ) =>

113− AppendableList aa bb cc

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

114− | aa bb -> cc where

115− (++:) :: HList aa -> HList bb -> HList cc

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

116

117instance AppendableList '[] bb bb where

100instance AppendableList '[] bb bb where

118 HNil ++: bb = bb

101 HNil ++: bb = bb

@@ -260,33 +243,6 @@ instance

260 aa = hTake @(Length a) Proxy cc

243 aa = hTake @(Length a) Proxy cc

261 bb = hDrop @(Length a) Proxy cc

244 bb = hDrop @(Length a) Proxy cc

262

245

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−

290-- ## Other

246-- ## Other

291

247

292type family IsMophableTuple t :: Bool where

248type family IsMophableTuple t :: Bool where

@@ -353,134 +309,3 @@ type family IsMophableTuple t :: Bool where

353 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

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, 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

354 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

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, 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

355 IsMophableTuple c = 'False

311 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+97−252

@@ -2,32 +2,27 @@

3module Data.Isoparsec

4 ( module X,

5+ -- Isoparsec,

6+ (%>>),

7+ (%>%),

8+ (>>%),

9+ (%<<),

10+ (%<%),

11+ (<<%),

12+ (<+%),

13+ (%+>),

14+ (%+%),

5 (<.>),

15 (<.>),

16+ (<^>),

6 repeating,

17 repeating,

7− sepBy,

8− sepBy1,

9 opt,

18 opt,

10 opt',

19 opt',

11 morphed,

20 morphed,

12− fMorphed,

13 coercing,

21 coercing,

14 mapIso,

22 mapIso,

15 auto,

23 auto,

16 specific,

24 specific,

17 throughIntegral,

25 throughIntegral,

18− (~>),

19− (~>^),

20− (^~>),

21− (^~>^),

22− (~|),

23− (~$>),

24− (~&),

25− (~*),

26− siPrism,

27− delist,

28− enlist,

29− Listed,

30− hmap,

31 )

26 )

32where

27where

@@ -38,249 +33,99 @@ import Data.Coerce

38import Data.Either

33import Data.Either

39import Data.Isoparsec.Internal as X

34import Data.Isoparsec.Internal as X

40import Data.Isoparsec.ToIsoparsec as X

35import Data.Isoparsec.ToIsoparsec as X

36+import Data.Isoparsec.Tokenable as X

41import qualified Data.Map as M

37import qualified Data.Map as M

42import Prelude hiding ((.), fail, id)

38import Prelude hiding ((.), fail, id)

44−opt :: (ArrowPlus m, PolyArrow SemiIso m) => m () () -> m () ()

40+opt :: (ArrowPlus m, PolyArrow m SemiIso) => m () () -> m () ()

45−opt m = m <+^ konst ()

41+opt m = m <+> konst ()

47−opt' :: (ArrowPlus m, PolyArrow SemiIso m, Eq a) => a -> m () a -> m () ()

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

48−opt' a m = opt (m >>^ turn (konst a))

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

50−repeating :: (PolyArrow SemiIso m, ArrowPlus m, Eq b) => m () b -> m () [b]

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

51−repeating m = (m &&& (repeating m <+^ konst [])) >>^ siCons

47+repeating m = (m &&& (repeating m <+> konst [])) >>^ siCons

53−sepBy :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]

49+infixr 1 %>>

54−sepBy sep a = sepBy1 sep a <+^ konst []

56−sepBy1 :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => m () () -> m () a -> m () [a]

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

57−sepBy1 sep a = (a &&& repeating (sep *>> a) <+^ konst []) >>^ siCons

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

59−infixl 0 <.>

54+infixr 1 %>%

55+

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

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

58+

59+infixr 1 >>%

60+

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

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

63+

64+infixr 1 %<<

65+

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

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

68+

69+infixr 1 %<%

70+

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

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

73+

74+infixr 1 <<%

75+

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

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

78+

79+infixr 5 <+%

80+

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

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

83+

84+infixr 5 %+>

85+

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

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

88+

89+infixr 5 %+%

90+

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

92+a %+% b = si a ^+^ si b

93+

94+infixr 0 <.>

61(<.>) ::

96(<.>) ::

62− (PolyArrow SemiIso m, TupleMorphable x c, TupleMorphable a c) =>

97+ (PolyArrow m SemiIso, TupleMorphable x c, TupleMorphable y c) =>

63− (Prism' a b) ->

98+ (Market y y y (Identity y) -> Market y y y' (Identity y')) ->

64 m x' x ->

99 m x' x ->

65− m x' b

100+ m x' y'

66−b <.> p = (p >>^ morphed) >>^ siPrism b

101+b <.> p = (p >>^ morphed) >>^ si b

67−

102+

68−siPrism ::

103+infixr 0 <^>

69− (Prism' a b) ->

104+

70− SemiIso a b

105+(<^>) ::

71−siPrism p = withPrism p $ \x y -> SemiIso (pure . x) (either (const empty) pure . y)

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

72−

107+ m x' x ->

73−type Listed m a b = m (HList (TupleHListContents a)) (HList (TupleHListContents b))

108+ b ->

74−

109+ m x' y'

75−infixl 8 ~>, ~>^, ^~>, ^~>^

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

76−

111+

77−type family If cond t f where

78− If 'True t _ = t

79− If 'False _ f = f

80−

81−type family BothEmpty a b where

82− BothEmpty '[] '[] = 'True

83− BothEmpty _ _ = 'False

84−

85−class BothEmpty c' d' ~ flag => SmartCompose b' c' d' flag | c' d' -> flag where

86− -- | Conceptually an analog to '>>>':

87− --

88− -- > Listed m a b -> Listed m b c -> Listed m a c

89− (~>) ::

90− ( PolyArrow SemiIso m,

91− FlatMorphable a a' fa,

92− FlatMorphable b b' fb,

93− FlatMorphable c c' fc,

94− FlatMorphable d d' fd

95− ) =>

96− m a b ->

97− m c d ->

98− m (HList a') (HList (If flag b' d'))

99−

100−instance SmartCompose b '[] '[] 'True where

101− (~>) lhs rhs = turn siHFst ^>> (enlist lhs *** enlist rhs) >>^ siHFst

102−

103−instance SmartCompose (c ': cc) (c ': cc) d 'False where

104− (~>) lhs rhs = enlist lhs >>> enlist rhs

105−

106−instance SmartCompose '[] '[] (d ': dd) 'False where

107− (~>) lhs rhs = enlist lhs >>> enlist rhs

108−

109−siHFst :: SemiIso (a, HList '[]) a

110−siHFst = siPure fst (,HNil)

111−

112−-- | Conceptually an analog to '>>^':

113−--

114−-- > Listed m a b -> SemiIso b c -> Listed m a c

115−(~>^) ::

116− ( PolyArrow SemiIso m,

117− FlatMorphable a a' fa,

118− FlatMorphable b bc fb,

119− FlatMorphable c bc 'False,

120− FlatMorphable d d' 'False

121− ) =>

122− m a b ->

123− SemiIso c d ->

124− m (HList a') (HList d')

125−lhs ~>^ rhs = enlist lhs >>> enlist (arr rhs)

126−

127−-- | Conceptually an analog to '^>>':

128−--

129−-- > SemiIso a b -> Listed m b c -> Listed m a c

130−(^~>) ::

131− ( PolyArrow SemiIso m,

132− FlatMorphable a a' 'False,

133− FlatMorphable b bc 'False,

134− FlatMorphable c bc fc,

135− FlatMorphable d d' fd

136− ) =>

137− SemiIso a b ->

138− m c d ->

139− m (HList a') (HList d')

140−lhs ^~> rhs = enlist (arr lhs) >>> enlist rhs

141−

142−-- | Conceptually an analog to '^>^':

143−--

144−-- > SemiIso a b -> SemiIso b c -> Listed m a c

145−(^~>^) ::

146− ( PolyArrow SemiIso m,

147− FlatMorphable a a' 'False,

148− FlatMorphable b b' 'False,

149− FlatMorphable d d' 'False

150− ) =>

151− SemiIso a b ->

152− SemiIso b d ->

153− m (HList a') (HList d')

154−lhs ^~>^ rhs = enlist . arr $ lhs >>> rhs

155−

156−infixl 5 ~|

157−

158−-- | Conceptually an analog to '<+>':

159−--

160−-- > Listed m a b -> Listed m a b -> Listed m a b

161−(~|) ::

162− ( PolyArrow SemiIso m,

163− ArrowPlus m,

164− FlatMorphable a ac fa,

165− FlatMorphable c ac fb,

166− FlatMorphable b bd fc,

167− FlatMorphable d bd fd

168− ) =>

169− m a b ->

170− m c d ->

171− m (HList ac) (HList bd)

172−lhs ~| rhs = enlist lhs <+> enlist rhs

173−

174−infixl 7 ~&

175−

176−-- | Conceptually an analog to '&&&':

177−--

178−-- > Listed m a b -> Listed m a c -> Listed m a (b, c)

179−(~&) ::

180− ( PolyArrow SemiIso m,

181− FlatMorphable a ac' fa,

182− FlatMorphable c ac' fc,

183− FlatMorphable b b' fb,

184− FlatMorphable d d' fd,

185− AppendableList b' d' f

186− ) =>

187− m a b ->

188− m c d ->

189− m (HList ac') (HList f)

190−lhs ~& rhs = (enlist lhs &&& enlist rhs) >>^ consHList

191−

192−infixl 9 ~*

193−

194−-- | Conceptually an analog to '***':

195−--

196−-- > Listed m a b -> Listed m c d -> Listed m (a, b) (c, d)

197−(~*) ::

198− ( PolyArrow SemiIso m,

199− FlatMorphable a a' fa,

200− FlatMorphable c c' fc,

201− FlatMorphable b b' fb,

202− FlatMorphable d d' fd,

203− AppendableList a' c' e',

204− AppendableList b' d' f'

205− ) =>

206− m a b ->

207− m c d ->

208− m (HList e') (HList f')

209−lhs ~* rhs = turn consHList ^>> (enlist lhs *** enlist rhs) >>^ consHList

210−

211−infixl 6 ~$>

212−

213−(~$>) ::

214− ( PolyArrow SemiIso m,

215− FlatMorphable a a' fa,

216− FlatMorphable b bc fb,

217− FlatMorphable c bc fc,

218− FlatMorphable d d' fd

219− ) =>

220− m a b ->

221− Prism' c d ->

222− m (HList a') (HList d')

223−lhs ~$> rhs = enlist lhs >>> enlist (arr (siPrism rhs))

224−

225−-- | Conceptually:

226−--

227−-- > (m a b -> m c d) -> Listed m a b -> Listed m c d

228−hmap ::

229− ( FlatMorphable b b' fb,

230− FlatMorphable a a' fa,

231− FlatMorphable d d' fd,

232− FlatMorphable c c' fc,

233− PolyArrow SemiIso m

234− ) =>

235− (m a b -> m c d) ->

236− m (HList a') (HList b') ->

237− m (HList c') (HList d')

238−hmap f m = turn fMorphed ^>> (f $ fMorphed ^>> m >>^ turn fMorphed) >>^ fMorphed

239−

240−coercing :: forall b a. Coercible a b => SemiIso a b

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

241−coercing = siPure coerce coerce

113+coercing = arr $ siPure coerce coerce

242−

114+

115+morphed ::

243−morphed :: (TupleMorphable a c, TupleMorphable b c) => SemiIso a b

116+ (TupleMorphable a c, TupleMorphable b c) => SemiIso a b

244morphed = siPure morphTuples morphTuples

117morphed = siPure morphTuples morphTuples

245

118

246−fMorphed :: (FlatMorphable a b fa) => SemiIso a (HList b)

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

247−fMorphed = siPure flatUnmorph flatMorph

120+ si :: x -> SemiIso a b

248−

121+

249−-- | Conceptually:

122+instance ToSemiIso (Market a a a (Identity a) -> Market a a b (Identity b)) a b where

250−--

123+ si p = withPrism p $ \x y -> SemiIso (pure . x) (either (const empty) pure . y)

251−-- > m a b -> Listed m a b

124+

252−enlist ::

125+instance ToSemiIso (SemiIso a b) a b where

253− (FlatMorphable a a' fa, FlatMorphable b b' fb, PolyArrow SemiIso m) =>

126+ si = id

254− m a b ->

127+

255− m (HList a') (HList b')

256−enlist m = turn fMorphed ^>> m >>^ fMorphed

257−

258−-- | Conceptually:

259−--

260−-- > Listed m a b -> m a b

261−delist ::

262− ( FlatMorphable a a' 'False,

263− FlatMorphable b b' 'False,

264− PolyArrow SemiIso m,

265− HListContentsTuple a' ~ a,

266− HListContentsTuple b' ~ b,

267− TupleHListContents a ~ a',

268− TupleHListContents b ~ b'

269− ) =>

270− m (HList a') (HList b') ->

271− m a b

272−delist m = fMorphed ^>> m >>^ turn fMorphed

273−

274−consHList ::

275− forall a b c.

276− AppendableList a b c =>

277− SemiIso (HList a, HList b) (HList c)

278−consHList =

279− siPure

280− (uncurry (++:))

281− (\c -> (hTake @(Length a) Proxy c, hDrop @(Length a) Proxy c))

282−

283−mapIso :: (PolyArrow SemiIso m, Ord a, Ord b) => [(a, b)] -> m a b

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

284mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)

129mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)

285 where

130 where

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

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

@@ -288,13 +133,13 @@ mapIso m = arr $ siMaybe (`M.lookup` n) (`M.lookup` u)

288 M.fromListWith (error "mapping not unique") $

133 M.fromListWith (error "mapping not unique") $

289 (\(a, b) -> (b, a)) <$> m

134 (\(a, b) -> (b, a)) <$> m

290

135

291−auto :: forall x s m. (ToIsoparsec x s m, Isoparsec m s) => m () x

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

292auto = toIsoparsec

137auto = toIsoparsec

293

138

294−specific :: forall x s m. (ToIsoparsec x s m, Isoparsec m s, Eq x) => x -> m () ()

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

295−specific x = auto @x >>^ turn (konst x)

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

296

141

297throughIntegral ::

142throughIntegral ::

298− (Integral a, Integral b, Num a, Num b) =>

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

299− SemiIso a b

144+ m a b

300−throughIntegral = siPure fromIntegral fromIntegral

145+throughIntegral = arr $ siPure fromIntegral fromIntegral

src/Data/Isoparsec/ByteString.hs+24−19

@@ -20,8 +20,8 @@ import Data.Proxy

20import Data.Word

21import Prelude as P hiding ((.))

23−utf8 :: SemiIso ByteString String

23+utf8 :: PolyArrow m SemiIso => m ByteString String

24−utf8 = siPure C.unpack C.pack

24+utf8 = arr $ siPure C.unpack C.pack

26data Endianness = BE | LE

@@ -30,10 +30,10 @@ class BytesToIsoparsec b (e :: Endianness) where

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

32 bytesToIsoparsec _ =

33− konst word8s ^>> manyTokens

33+ konst word8s >>> manyTokens

34 >>^ siPure

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

36− ( fromList . snd . P.head

36+ ( liftTokens . snd . P.head

37 . P.drop (fromIntegral word8s)

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

39 . (,[])

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

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

46 bytesToIsoparsec _ =

47− konst word8s ^>> manyTokens

47+ konst word8s >>> manyTokens

48 >>^ siPure

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

50− ( fromList . P.reverse . snd . P.head

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

51 . P.drop (fromIntegral word8s)

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

53 . (,[])

@@ -67,26 +67,31 @@ newtype Byte32 (e :: Endianness) = Byte32 {unByte32 :: Word32}

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

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

70−instance BytesToIsoparsec Word16 e => ToIsoparsec (Byte16 e) ByteString m where

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

71− toIsoparsec = bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte16 e) @Word16

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

73−instance BytesToIsoparsec Word32 e => ToIsoparsec (Byte32 e) ByteString m where

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

74− toIsoparsec = bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte32 e) @Word32

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

76−instance BytesToIsoparsec Word64 e => ToIsoparsec (Byte64 e) ByteString m where

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

77− toIsoparsec = bytesToIsoparsec (Proxy @e) >>^ coercing @(Byte64 e) @Word64

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

79−instance ToIsoparsec Bool ByteString m where

79+instance ToIsoparsec Bool ByteString where

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

82newtype SSHString = SSHString {unSSHString :: String}

83 deriving (Show, Eq, Ord)

85−instance ToIsoparsec SSHString ByteString m where

85+instance ToIsoparsec SSHString ByteString where

86 toIsoparsec =

87− auto @(Byte32 'BE)

88− >>^ coercing @Word32

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

89− >>^ siPure fromIntegral fromIntegral

88+ >>> siPure fromIntegral fromIntegral ^>> manyTokens

90− >>> manyTokens

91− >>^ utf8

89+ >>> utf8

92 >>^ siPure SSHString unSSHString

90 >>^ siPure SSHString unSSHString

91+

92+instance Tokenable ByteString where

93+ type Token ByteString = Word8

94+

95+ liftTokens = pack

96+

97+ lowerTokens = unpack

src/Data/Isoparsec/Char.hs+7−7

@@ -11,16 +11,16 @@ import Data.Isoparsec

11import Text.Read

12import Prelude hiding ((.), id)

14−space :: (Isoparsec m s, Element s ~ Char) => m () ()

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

15space = token ' '

17−unsafeWhiteSpace :: (Isoparsec m s, Element s ~ Char, Eq s) => m () ()

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

18−unsafeWhiteSpace = tokensWhile isSpace >>^ (maskr . turn . konst $ mempty)

18+unsafeWhiteSpace = tokensWhile isSpace >>> badTsnok mempty

20−unsafeWhiteSpace1 :: (Isoparsec m s, Element s ~ Char, Eq s) => m () ()

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

21−unsafeWhiteSpace1 = tokensWhile1 isSpace >>^ (maskr . turn . konst $ singleton ' ')

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

23−number :: (Isoparsec m s, Element s ~ Char) => m () Integer

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

24number =

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

26− >>^ siMaybe (readMaybe @Integer . otoList) (Just . fromList . show)

26+ >>^ siMaybe (readMaybe @Integer . lowerTokens) (Just . liftTokens . show)

src/Data/Isoparsec/Chunks.hs+2−2

@@ -10,6 +10,6 @@ import GHC.TypeLits

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

11 deriving (Show, Eq, Ord)

13−instance (CmpNat n 0 ~ 'GT, KnownNat n) => ToIsoparsec (Chunk n s) s m where

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

14 toIsoparsec =

15− konst (fromIntegral $ natVal @n Proxy) ^>> manyTokens >>^ coercing

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

src/Control/Cokleisli.hs → src/Data/Isoparsec/Cokleisli.hsrenamed+7−5

@@ -1,4 +1,4 @@

1−module Control.Cokleisli

1+module Data.Isoparsec.Cokleisli

2 ( Cokleisli (..),

3 )

4where

@@ -6,10 +6,10 @@ where

6import Control.Applicative

7import Control.Arrow.Extra

8import Control.Monad

9−import Control.SemiIso

9+import Data.Isoparsec.Internal

10import Prelude hiding ((.))

12−newtype Cokleisli m a b = Cokleisli {runCokleisli :: b -> m a}

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

14instance Monad m => Category (Cokleisli m) where

15 id = Cokleisli return

@@ -26,8 +26,10 @@ instance (Alternative m, Monad m) => BaseArrow (Cokleisli m) where

26 (Cokleisli cb) &&& (Cokleisli c'b) = Cokleisli $

27 \(c, c') -> c'b c' >> cb c

29−instance (Alternative m, Monad m) => PolyArrow SemiIso (Cokleisli m) where

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

30− arr si = Cokleisli $ \t -> project si t

30+ arr si = Cokleisli $ \t -> case project si t of

31+ Just x -> return x

32+ Nothing -> mzero

32instance MonadPlus m => ArrowZero (Cokleisli m) where

34instance MonadPlus m => ArrowZero (Cokleisli m) where

33 zeroArrow = Cokleisli $ const mzero

35 zeroArrow = Cokleisli $ const mzero

src/Data/Isoparsec/Internal.hs+90−69

@@ -2,75 +2,77 @@ module Data.Isoparsec.Internal

2 ( module X,

3 IsoparsecFail (..),

4 Isoparsec (..),

5+ konst,

6+ tsnok,

5 siCons,

7 siCons,

8+ isoCheck,

9+ siCheck,

10+ check,

11+ levitate,

12+ badKonst,

13+ badTsnok,

6 unroll,

14 unroll,

7 arrowsWhile,

15 arrowsWhile,

8− arrowsUntil,

9− EffectOnly,

10 )

16 )

11where

17where

13import Control.Arrow.Extra

19import Control.Arrow.Extra

14−import Control.Arrow.Trans.Reader

15import Control.Monad

20import Control.Monad

16−import Control.SemiIso as X hiding (filterM, replicateM)

21+import Control.SemiIso as X

17−import Data.MonoTraversable as X

22+import Data.Isoparsec.Tokenable

18−import Data.Sequences as X

19import Numeric.Natural

23import Numeric.Natural

20import Prelude as P hiding ((.), id)

24import Prelude as P hiding ((.), id)

22class

26class

23− (PolyArrow SemiIso m, ArrowPlus m, ArrowChoice m, IsSequence s) =>

27+ (PolyArrow m SemiIso, ArrowPlus m, ArrowChoice m, Tokenable s) =>

24 Isoparsec m s

28 Isoparsec m s

25 | m -> s where

29 | m -> s where

26− {-# MINIMAL anyToken, manyTokens, tuck' #-}

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

28− anyToken :: m () (Element s)

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

30− token :: Element s -> EffectOnly m

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

31− default token :: Eq (Element s) => Element s -> EffectOnly m

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

32− token x = anyToken >>^ turn (konst x)

36+ token x = anyToken >>> tsnok x

34− token' :: m (Element s) (Element s)

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

35− default token' :: Eq (Element s) => m (Element s) (Element s)

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

36− token' = id >>& anyToken >>^ check (uncurry (==)) >>^ siPure fst (\x -> (x, x))

37−

38− tokens :: [Element s] -> EffectOnly m

39 tokens [] = arr $ isoConst () ()

40 tokens [] = arr $ isoConst () ()

40− tokens (t : ts) = token t &&& tokens ts >>^ isoConst ((), ()) ()

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

41−

42− tokens' :: m [Element s] [Element s]

43− tokens' = (turn siCons ^>> token' *** tokens' >>^ siCons) <+^ isoConst [] []

45− chunk :: s -> EffectOnly m

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

46− chunk = tokens . otoList

44+ chunk = tokens . lowerTokens

48− chunk' :: m s s

49− chunk' = list ^>> tokens' >>^ turn list

50− where

51− list = siPure otoList fromList

52−

53− notToken :: Element s -> m () (Element s)

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

54− default notToken :: Eq (Element s) => Element s -> m () (Element s)

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

55 notToken t = tokenWhere (/= t)

48 notToken t = tokenWhere (/= t)

57− tokenWhere :: (Element s -> Bool) -> m () (Element s)

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

51+ tokenWhere f =

58− tokenWhere f = anyToken >>^ check f

52+ anyToken >>> check f

60 manyTokens :: m Natural s

54 manyTokens :: m Natural s

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

57+

62 takeUntil :: s -> m () s

58 takeUntil :: s -> m () s

63− default takeUntil :: Eq s => s -> m () s

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

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

61+ where

64− takeUntil s = (chunk s >>^ konst mempty) <+> ((anyToken &&& takeUntil s) >>^ siCons)

62+ takeUntil' s' = (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ siCons)

66− tokensWhile :: (Element s -> Bool) -> m () s

67− default tokensWhile :: (Element s -> Bool) -> m () s

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

68 tokensWhile f =

65 tokensWhile f =

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

67+ where

68+ tokensWhile' g =

69− (((tokenWhere f >>^ check f) &&& tokensWhile f) >>^ siCons)

69+ (tokenWhere g &&& tokensWhile' g >>^ siCons)

70− <+^ isoConst () mempty

70+ <+^ isoConst () []

72− tokensWhile1 :: (Element s -> Bool) -> m () s

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

73+ tokensWhile1 f =

73− tokensWhile1 f = tokenWhere f &&& tokensWhile f >>^ siCons

74+ tokenWhere f &&& tokensWhile f

75+ >>^ SI (\(a, aa) -> pure $ liftToken a <> aa) levitateHead

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

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

76 -- > ┌─────┐

78 -- > ┌─────┐

@@ -88,43 +90,62 @@ class

88 -- > ──┤ s ├──────────────────────────┤ a ├─▶

90 -- > ──┤ s ├──────────────────────────┤ a ├─▶

89 -- > └─────┘ └─────┘

91 -- > └─────┘ └─────┘

90 tuck :: m () a -> m s a

92 tuck :: m () a -> m s a

91− tuck a = turn siSnd ^>> tuck' a

92−

93− tuck' :: m a b -> m (a, s) b

95−type EffectOnly m = m () ()

96−

97−arrowsWhile :: (PolyArrow SemiIso m, ArrowPlus m) => m () a -> m () [a]

94+arrowsWhile :: (PolyArrow m SemiIso, ArrowPlus m) => m () a -> m () [a]

98arrowsWhile f = ((f &&& arrowsWhile f) >>^ siCons) <+^ isoConst () []

95arrowsWhile f = ((f &&& arrowsWhile f) >>^ siCons) <+^ isoConst () []

100−arrowsUntil :: (ArrowPlus m, Eq a, PolyArrow SemiIso m) => m () a -> m () b -> m () ([a], b)

97+unroll :: (PolyArrow m SemiIso, ArrowPlus m, Eq a) => a -> m a (b, a) -> m () [b]

101−arrowsUntil a b = (arr (konst []) &&& b) <+> (a &&& arrowsUntil a b >>^ (assoc >>> first siCons))

102−

103−unroll :: (PolyArrow SemiIso m, ArrowPlus m, Eq a) => a -> m a (b, a) -> m () [b]

104−unroll a f = (konst a ^>> unroll' f) <+^ isoConst () []

98+unroll a f = (konst a >>> unroll' f) <+^ isoConst () []

105 where

99 where

106 unroll' g = (g >>> second (unroll' g)) >>^ siCons

100 unroll' g = (g >>> second (unroll' g)) >>^ siCons

107

101

102+levitateHead :: Alternative f => Tokenable s => s -> f (Token s, s)

103+levitateHead s = case lowerTokens s of

104+ (t : tt) -> pure (t, liftTokens tt)

105+ [] -> empty

106+

108−siCons :: IsSequence s => SemiIso (Element s, s) s

107+siCons :: SemiIso (t, [t]) [t]

109siCons =

108siCons =

110− siMaybe

109+ SI

111− (pure . uncurry cons)

110+ (pure . uncurry (:))

112− uncons

111+ ( \case

112+ (t : ts) -> pure (t, ts)

113+ _ -> empty

114+ )

115+

116+levitate :: Tokenable s => SemiIso [Token s] s

117+levitate = siPure liftTokens lowerTokens

113

118

114class IsoparsecFail m e where

119class IsoparsecFail m e where

115 failure :: e -> m a b

120 failure :: e -> m a b

116

121

117−instance (Isoparsec a s, Eq (Element s), Eq r) => Isoparsec (ReaderArrow r a) s where

122+siCheck ::

118− anyToken = raise anyToken

123+ (s -> Bool) ->

119− token' = raise token'

124+ (forall f. AlternativeMonad f => s -> f a) ->

120− tokens = raise . tokens

125+ (forall f. AlternativeMonad f => a -> f s) ->

121− tokens' = raise tokens'

126+ SemiIso s a

122− chunk = raise . chunk

127+siCheck f a b =

123− chunk' = raise chunk'

128+ SI

124− notToken = raise . notToken

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

125− tokenWhere = raise . tokenWhere

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

126− manyTokens = raise manyTokens

131+

127− takeUntil = raise . takeUntil

132+isoCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso s a

128− tokensWhile = raise . tokensWhile

133+isoCheck f a b = siCheck f (pure . a) (pure . b)

129− tokensWhile1 = raise . tokensWhile1

134+

130− tuck' (ReaderArrow a) = ReaderArrow $ assoc ^>> tuck' a

135+isoConst :: s -> a -> SemiIso s a

136+isoConst s a = SI (const $ pure a) (const $ pure s)

137+

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

139+konst x = badKonst x ^>> check (== x)

140+

141+badKonst :: x -> SemiIso () x

142+badKonst x = SI (const $ pure x) (const $ pure ())

143+

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

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

146+

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

148+badTsnok x = arr $ SI (const $ pure ()) (const $ pure x)

149+

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

151+check f = arr $ isoCheck f id id

src/Data/Isoparsec/Megaparsec.hs+20−57

@@ -1,9 +1,7 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

3module Data.Isoparsec.Megaparsec

4− ( runMegaparsecParser,

4+ ( runMegaparsec,

5− ParseErrorBundle (..),

6− MegaparsecParser (..),

7 )

5 )

8where

6where

@@ -11,78 +9,43 @@ import Control.Arrow.Extra

11import Control.Arrow.Extra.Orphans ()

9import Control.Arrow.Extra.Orphans ()

12import Control.Monad

10import Control.Monad

13import Data.Functor

11import Data.Functor

14−import Data.Functor.Identity

12+import Data.Isoparsec.Internal as I

15−import Data.Isoparsec

13+import Data.Isoparsec.Tokenable

16−import Data.Void

17import Text.Megaparsec hiding (Token)

14import Text.Megaparsec hiding (Token)

18import qualified Text.Megaparsec as M

15import qualified Text.Megaparsec as M

19import Prelude hiding ((.))

16import Prelude hiding ((.))

21−newtype MegaparsecParser s a b

18+runMegaparsec ::

22− = MegaparsecParser {unMegaparsecParser :: Kleisli (ParsecT Void s Identity) a b}

19+ (Ord e, Stream s) =>

23− deriving (Category, BaseArrow, ArrowZero, ArrowChoice, PolyArrow SemiIso)

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

24−

25−instance

26− (Stream s, s ~ M.Tokens s, Element s ~ M.Token s) =>

27− ArrowPlus (MegaparsecParser s)

28− where

29− (MegaparsecParser (Kleisli lhs)) <+> (MegaparsecParser (Kleisli rhs)) =

30− MegaparsecParser . Kleisli $ \x -> try (lhs x) <|> rhs x

31−

32−runMegaparsecParser ::

33− (Stream s) =>

34 s ->

21 s ->

35− MegaparsecParser s () r ->

36− Either (ParseErrorBundle s Void) r

22+ Either (ParseErrorBundle s e) r

37−runMegaparsecParser s (MegaparsecParser (Kleisli f)) = runParser (f () <* eof) "" s

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

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

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

40 arr si = Kleisli $ \t -> case embed si t of

26 arr si = Kleisli $ \t -> case embed si t of

41 Just x -> return x

27 Just x -> return x

42 Nothing -> M.failure Nothing mempty

28 Nothing -> M.failure Nothing mempty

44instance

30instance

45− (Stream s, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>

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

46− Isoparsec (MegaparsecParser s) s

32+ Isoparsec (Kleisli m) s

47 where

33 where

48− anyToken = MegaparsecParser . Kleisli $ const anySingle

34+ anyToken = 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

62− notToken t = MegaparsecParser . Kleisli . const $ M.anySingleBut t

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

64− tokenWhere f = MegaparsecParser . Kleisli . const $ satisfy f

38+ manyTokens = Kleisli $ takeP Nothing . fromIntegral

66− manyTokens = MegaparsecParser . Kleisli $ takeP Nothing . fromIntegral

67−

68− takeUntil c = MegaparsecParser . Kleisli $ \() -> do

69− ta <- M.manyTill M.anySingle (M.chunk c)

70− return $ fromList ta

71−

72− tokensWhile f = MegaparsecParser . Kleisli . const $ M.takeWhileP Nothing f

73−

74− tokensWhile1 f = MegaparsecParser . Kleisli . const $ M.takeWhile1P Nothing f

75−

76− tuck (MegaparsecParser (Kleisli f)) = MegaparsecParser . Kleisli $ \sub -> do

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

77 sup <- getInput

41 sup <- getInput

78 setInput sub

42 setInput sub

79 r <- f () <* eof

43 r <- f () <* eof

80 setInput sup

44 setInput sup

81 return r

45 return r

83− tuck' (MegaparsecParser (Kleisli f)) = MegaparsecParser . Kleisli $ \(x, sub) -> do

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

84− sup <- getInput

48+ failure e = Kleisli $ \_ -> customFailure e

85− setInput sub

49+

86− r <- f x <* eof

50+instance (MonadParsec e s m, M.Token s ~ Token s, s ~ M.Tokens s) => ArrowPlus (Kleisli m) where

87− setInput sup

51+ (Kleisli lhs) <+> (Kleisli rhs) = Kleisli $ \x -> try (lhs x) <|> rhs x

88− return r

src/Data/Isoparsec/Printer.hs+20−64

@@ -1,83 +1,39 @@

1{-# OPTIONS_GHC -Wno-orphans #-}

3module Data.Isoparsec.Printer

4− ( runMonoidPrinter,

4+ ( runPrinter,

5− MonoidPrinter (..),

6 )

5 )

7where

6where

9−import Control.Cokleisli

10import Control.Monad.Writer.Lazy

8import Control.Monad.Writer.Lazy

11−import Data.Functor

12import Data.Isoparsec

9import Data.Isoparsec

13−import Data.List.Split

10+import Data.Isoparsec.Cokleisli

14import Prelude hiding ((.), id)

11import Prelude hiding ((.), id)

16−newtype MonoidPrinter s a b

13+runPrinter ::

14+ forall m s a.

15+ Monad m =>

17− = MonoidPrinter {unMonoidPrinter :: Cokleisli (WriterT (Dual s) Maybe) a b}

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

18− deriving (Category, BaseArrow, ArrowZero, ArrowPlus, ArrowChoice, PolyArrow SemiIso)

19−

20−runMonoidPrinter ::

21− forall s a.

22− MonoidPrinter s () a ->

23 a ->

17 a ->

24− Maybe s

18+ m s

25−runMonoidPrinter p = fmap getDual . execWriterT . runCokleisli (unMonoidPrinter p)

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

20+

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

22+ failure _ = Cokleisli . const $ WriterT Nothing

27−instance IsoparsecFail (MonoidPrinter s) e where

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

28− failure _ = MonoidPrinter . Cokleisli . const $ WriterT Nothing

25+ failure = Cokleisli . const . WriterT . Left

30instance

27instance

31− (Monoid s, Eq (Element s), IsSequence s) =>

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

32− Isoparsec (MonoidPrinter s) s

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

33 where

30 where

34− anyToken = MonoidPrinter . Cokleisli $ tell . Dual . singleton

35−

36− token t = MonoidPrinter . Cokleisli $ const $ tell . Dual . singleton $ t

31+ token t = Cokleisli $ const $ tell . Dual . liftToken $ 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

46− chunk' = MonoidPrinter . Cokleisli $ \c -> (tell . Dual) c $> c

33+ anyToken = Cokleisli $ tell . Dual . liftToken

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

59 tell $ Dual w

36 tell $ Dual w

60− return . fromIntegral . olength $ w

37+ return . fromIntegral . length . lowerTokens $ w

61−

62− takeUntil end = MonoidPrinter . Cokleisli $ \s ->

63− if length ((split . onSublist $ otoList end) . otoList $ s) > 1

64− then empty

65− else do

66− tell . Dual $ s

67− tell . Dual $ end

68−

69− tokensWhile f = MonoidPrinter . Cokleisli $ \s ->

70− if oall f s

71− then (tell . Dual) s

72− else empty

73−

74− tokensWhile1 f = MonoidPrinter . Cokleisli $ \s ->

75− if oall f s && not (onull s)

76− then (tell . Dual) s

77− else empty

78−

79− tuck (MonoidPrinter (Cokleisli f)) =

80− MonoidPrinter . Cokleisli $ lift . fmap getDual . execWriterT . f

82− tuck' (MonoidPrinter (Cokleisli f)) =

83− MonoidPrinter . Cokleisli $ lift . (fmap . fmap) getDual . runWriterT . f

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

src/Data/Isoparsec/ToIsoparsec.hs+17−12

@@ -5,33 +5,38 @@ where

6import Control.Arrow.Extra

7import Data.Isoparsec.Internal

8+import Data.Isoparsec.Tokenable

8import GHC.Generics

9import GHC.Generics

9import Prelude hiding ((.))

10import Prelude hiding ((.))

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

13+ toIsoparsec = anyToken

14+

11−class ToIsoparsec a s m where

15+class ToIsoparsec a s where

12− toIsoparsec :: (Isoparsec m s) => m () a

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

13− default toIsoparsec :: (Isoparsec m s, Generic a, GToIsoparsec (Rep a) s m) => m () a

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

14 toIsoparsec = gToIsoparsec >>^ SI (pure . to) (pure . from)

18 toIsoparsec = gToIsoparsec >>^ SI (pure . to) (pure . from)

16−class GToIsoparsec a s m where

20+class GToIsoparsec a s where

17 gToIsoparsec :: Isoparsec m s => m () (a b)

21 gToIsoparsec :: Isoparsec m s => m () (a b)

19−instance GToIsoparsec U1 s m where

23+instance GToIsoparsec U1 s where

20− gToIsoparsec = arr $ konst U1

24+ gToIsoparsec = konst U1

22−instance ToIsoparsec c s m => GToIsoparsec (K1 i c) s m where

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

27+ gToIsoparsec =

23− gToIsoparsec = toIsoparsec >>^ siPure K1 unK1

28+ toIsoparsec >>^ SI (pure . K1) (pure . unK1)

25−instance GToIsoparsec c s m => GToIsoparsec (M1 i t c) s m where

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

26 gToIsoparsec =

31 gToIsoparsec =

27− gToIsoparsec >>^ siPure M1 unM1

32+ gToIsoparsec >>^ SI (pure . M1) (pure . unM1)

29−instance (GToIsoparsec a s m, GToIsoparsec b s m) => GToIsoparsec (a :*: b) s m where

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

30 gToIsoparsec =

35 gToIsoparsec =

31 (gToIsoparsec &&& gToIsoparsec)

36 (gToIsoparsec &&& gToIsoparsec)

32 >>^ SI (\(a, b) -> pure (a :*: b)) (\(a :*: b) -> pure (a, b))

37 >>^ SI (\(a, b) -> pure (a :*: b)) (\(a :*: b) -> pure (a, b))

34−instance (GToIsoparsec a s m, GToIsoparsec b s m) => GToIsoparsec (a :+: b) s m where

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

35 gToIsoparsec =

40 gToIsoparsec =

36 ( (gToIsoparsec >>^ SI (pure . Left) (either pure (const empty)))

41 ( (gToIsoparsec >>^ SI (pure . Left) (either pure (const empty)))

37 <+> (gToIsoparsec >>^ SI (pure . Right) (either (const empty) pure))

42 <+> (gToIsoparsec >>^ SI (pure . Right) (either (const empty) pure))

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

@@ -0,0 +1,24 @@

1+module Data.Isoparsec.Tokenable

2+ ( Tokenable (..),

3+ )

4+where

6+class Monoid s => Tokenable s where

7+ type Token s

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

10+

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

12+ liftTokens = mconcat . fmap liftToken

13+

14+ liftToken :: Token s -> s

15+ liftToken = liftTokens . pure

16+

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

18+

19+instance Tokenable [t] where

20+ type Token [t] = t

21+

22+ liftTokens = id

23+

24+ lowerTokens = id

stack.yaml+6−1

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

17#

18# resolver: ./custom-snapshot.yaml

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

20−resolver: lts-15.8

20+resolver: lts-14.25

22# User packages to be built.

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

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

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

40# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

41#

42+extra-deps:

43+- optics-core-0.1

44+- optics-0.1

45+- optics-extra-0.1

46+- optics-th-0.1

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

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

44# flags: {}

49# flags: {}

test/Spec.hs+1−23

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

1−import qualified Spec.BasicReader as BasicReader

2import qualified Spec.JSON as JSON

1import qualified Spec.JSON as JSON

3−import qualified Spec.JSONHList as JSONHList

4import qualified Spec.Megaparsec.BasicNums as BasicNums

2import qualified Spec.Megaparsec.BasicNums as BasicNums

5import qualified Spec.Ssh as Ssh

3import qualified Spec.Ssh as Ssh

6−import qualified Spec.SshHList as SshHList

7import qualified Spec.TwoDigits as TwoDigits

4import qualified Spec.TwoDigits as TwoDigits

8import Test.Tasty

5import Test.Tasty

9import Test.Tasty.Hspec

6import Test.Tasty.Hspec

@@ -13,10 +10,6 @@ main = do

13 bsicNumSpec <- testSpec "Basic megaparsec test" BasicNums.spec

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

14 twoDigitsSpec <- testSpec "Two digits test" TwoDigits.spec

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

15 sshSpec <- testSpec "ssh spec" Ssh.spec

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

16− sshHListSpec <- testSpec "ssh HList spec" SshHList.spec

17− jsonSpec <- testSpec "json spec" JSON.spec

18− jsonHListSpec <- testSpec "json spec" JSONHList.spec

19− basicReaderSpec <- testSpec "json spec" BasicReader.spec

20 defaultMain

13 defaultMain

21 ( testGroup

14 ( testGroup

22 "tests"

15 "tests"

@@ -27,13 +20,7 @@ main = do

27 ],

20 ],

28 testGroup

21 testGroup

29 "JSON"

22 "JSON"

30− [ jsonSpec,

31− JSON.quickSpec

32− ],

33− testGroup

34− "JSONHList"

35− [ jsonHListSpec,

36− JSONHList.quickSpec

23+ [ JSON.quickSpec

37 ],

24 ],

38 testGroup

25 testGroup

39 "TwoDigits"

26 "TwoDigits"

@@ -44,15 +31,6 @@ main = do

44 "ssh"

31 "ssh"

45 [ sshSpec,

32 [ sshSpec,

46 Ssh.quickSpec

33 Ssh.quickSpec

47− ],

48− testGroup

49− "ssh HList"

50− [ sshHListSpec,

51− SshHList.quickSpec

52− ],

53− testGroup

54− "BasicReader"

55− [ basicReaderSpec

56 ]

34 ]

57 ]

35 ]

58 )

36 )

test/Spec/BasicReader.hsdeleted−38

@@ -1,38 +0,0 @@

1−{-# LANGUAGE PartialTypeSignatures #-}

2−{-# LANGUAGE TemplateHaskell #-}

3−

4−module Spec.BasicReader

5− ( spec,

6− )

7−where

8−

9−import Control.Arrow.Extra

10−import Control.Arrow.Reader

11−import Control.Lens.TH

12−import Data.Either

13−import Data.Isoparsec

14−import Data.Isoparsec.Char

15−import Data.Isoparsec.Megaparsec

16−import Test.Hspec

17−import Prelude hiding ((.), id)

18−

19−data ConstSep = ConstSep Integer Integer

20− deriving (Eq, Show)

21−

22−makePrisms ''ConstSep

23−

24−instance ArrowReader String a => ToIsoparsec ConstSep String a where

25− toIsoparsec = _ConstSep <.> (number >** biask chunk') &&& number

26−

27−spec :: Spec

28−spec = do

29− let run (sep :: String) (s :: String) =

30− runMegaparsecParser s . runReaderArrow sep $ (auto @ConstSep)

31− it "deserializes" $ do

32− run "s" "12s31" `shouldBe` Right (ConstSep 12 31)

33− run " " "12 31" `shouldBe` Right (ConstSep 12 31)

34− run "oh no" "12oh no31" `shouldBe` Right (ConstSep 12 31)

35− run "oh no" "12oh no 31" `shouldSatisfy` isLeft

36− run "oh no" "12ohno31" `shouldSatisfy` isLeft

37− run "&" "12 31" `shouldSatisfy` isLeft

38− run "&" "12&31" `shouldBe` Right (ConstSep 12 31)

test/Spec/Helper.hs+15−29

@@ -2,7 +2,6 @@ module Spec.Helper

2 ( shouldParseBS,

3 roundtrip,

4 parseSatisfyBS,

5− shouldParseS,

6 )

5 )

7where

6where

@@ -21,23 +20,23 @@ import Prelude as P hiding ((.))

22parseSatisfy ::

21parseSatisfy ::

23 forall x s.

22 forall x s.

24− ( ToIsoparsec x s (MegaparsecParser s),

23+ ( ToIsoparsec x s,

25 Stream s,

24 Stream s,

26 Show x,

25 Show x,

27 Show (M.Token s),

26 Show (M.Token s),

28 Show s,

27 Show s,

29− Isoparsec (MegaparsecParser s) s

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

30 ) =>

29 ) =>

31 s ->

30 s ->

32 (Either (ParseErrorBundle s Void) x -> Bool) ->

31 (Either (ParseErrorBundle s Void) x -> Bool) ->

33 Expectation

32 Expectation

34−parseSatisfy s p = runMegaparsecParser @s s toIsoparsec `shouldSatisfy` p

33+parseSatisfy s p = runMegaparsec @Void @s toIsoparsec s `shouldSatisfy` p

36parseSatisfyBS ::

35parseSatisfyBS ::

37 forall x.

36 forall x.

38− ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

37+ ( ToIsoparsec x ByteString,

39 Show x,

38 Show x,

40− Isoparsec (MegaparsecParser ByteString) ByteString

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

41 ) =>

40 ) =>

42 ByteString ->

41 ByteString ->

43 (Either (ParseErrorBundle ByteString Void) x -> Bool) ->

42 (Either (ParseErrorBundle ByteString Void) x -> Bool) ->

@@ -46,57 +45,44 @@ parseSatisfyBS = parseSatisfy

47shouldParse ::

46shouldParse ::

48 forall x s.

47 forall x s.

49− ( ToIsoparsec x s (MegaparsecParser s),

48+ ( ToIsoparsec x s,

50 Stream s,

49 Stream s,

51 Show x,

50 Show x,

52 Eq x,

51 Eq x,

53− Isoparsec (MegaparsecParser s) s

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

54 ) =>

53 ) =>

55 s ->

54 s ->

56 x ->

55 x ->

57 Expectation

56 Expectation

58−shouldParse s e = case runMegaparsecParser @s s toIsoparsec of

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

59 Right e' -> e' `shouldBe` e

58 Right e' -> e' `shouldBe` e

60 Left err -> expectationFailure $ errorBundlePretty err

59 Left err -> expectationFailure $ errorBundlePretty err

62shouldParseBS ::

61shouldParseBS ::

63 forall x.

62 forall x.

64− ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

63+ ( ToIsoparsec x ByteString,

65 Show x,

64 Show x,

66 Eq x,

65 Eq x,

67− Isoparsec (MegaparsecParser ByteString) ByteString

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

68 ) =>

67 ) =>

69 ByteString ->

68 ByteString ->

70 x ->

69 x ->

71 Expectation

70 Expectation

72shouldParseBS = shouldParse

71shouldParseBS = shouldParse

74−shouldParseS ::

75− forall x.

76− ( ToIsoparsec x String (MegaparsecParser String),

77− Show x,

78− Eq x,

79− Isoparsec (MegaparsecParser String) String

80− ) =>

81− String ->

82− x ->

83− Expectation

84−shouldParseS = shouldParse

85−

86roundtrip ::

73roundtrip ::

87 forall x s.

74 forall x s.

88− ( ToIsoparsec x s (MegaparsecParser s),

75+ ( ToIsoparsec x s,

89− ToIsoparsec x s (MonoidPrinter s),

90 Stream s,

76 Stream s,

91 Show s,

77 Show s,

92− I.Element s ~ M.Token s,

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

93 Eq x,

79 Eq x,

94− Isoparsec (MegaparsecParser s) s

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

95 ) =>

81 ) =>

96 x ->

82 x ->

97 Property

83 Property

98roundtrip x =

84roundtrip x =

99− let s = fromJust $ runMonoidPrinter @s toIsoparsec x

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

100− in counterexample (show s) $ case runMegaparsecParser @s s toIsoparsec of

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

101 Right y -> property $ x == y

87 Right y -> property $ x == y

102 Left err -> counterexample (errorBundlePretty err) False

88 Left err -> counterexample (errorBundlePretty err) False

test/Spec/JSON.hs+23−27

@@ -2,7 +2,6 @@

3module Spec.JSON

4 ( quickSpec,

5− spec,

6 )

5 )

7where

6where

@@ -13,8 +12,7 @@ import Data.Isoparsec.Char

13import Data.Isoparsec.Megaparsec

12import Data.Isoparsec.Megaparsec

14import Data.Isoparsec.Printer

13import Data.Isoparsec.Printer

15import Data.Maybe

14import Data.Maybe

16−import Spec.Helper

15+import Data.Void

17−import Test.Hspec

18import Test.Tasty

16import Test.Tasty

19import Test.Tasty.QuickCheck

17import Test.Tasty.QuickCheck

20import Text.Megaparsec.Error

18import Text.Megaparsec.Error

@@ -43,46 +41,44 @@ instance Arbitrary JSON where

44makePrisms ''JSON

42makePrisms ''JSON

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−

55quickSpec :: TestTree

44quickSpec :: TestTree

56quickSpec =

45quickSpec =

57 testProperty "roundtrips" $ \x ->

46 testProperty "roundtrips" $ \x ->

58− let s = fromJust $ runMonoidPrinter @String json x

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

59− in counterexample s $ case runMegaparsecParser s json of

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

60 Right y -> property $ x == y

49 Right y -> property $ x == y

61 Left err -> counterexample (errorBundlePretty err) False

50 Left err -> counterexample (errorBundlePretty err) False

63−instance ToIsoparsec JSON String a where

64− toIsoparsec = json

65−

66−json :: forall m. Isoparsec m String => m () JSON

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

67−json = string <+> array <+> integer <+> object

53+json = SI pure pure ^<< (string <+> array <+> integer <+> object)

68 where

54 where

69− string' = token '"' **> tokensWhile (/= '"') >** token '"'

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

70 string = _JString <.> string'

56 string = _JString <.> string'

71 array =

57 array =

72 _Array

58 _Array

73 <.> token '['

59 <.> token '['

74 &&& unsafeWhiteSpace

60 &&& unsafeWhiteSpace

75− &&& sepByComma json

61+ &&& ( ( ( ( json &&& unsafeWhiteSpace

62+ &&& repeating

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

64+ )

65+ <+> konst []

66+ )

67+ >>% morphed

68+ )

69+ >>^ siCons

70+ )

71+ <+> konst []

72+ )

76 &&& unsafeWhiteSpace

73 &&& unsafeWhiteSpace

77 &&& token ']'

74 &&& token ']'

78 integer = _JInteger <.> number

75 integer = _JInteger <.> number

79 object =

76 object =

80 _Object <.> token '{' &&& unsafeWhiteSpace

77 _Object <.> token '{' &&& unsafeWhiteSpace

81− &&& sepByComma pair

78+ &&& ( ( let pair = (unsafeWhiteSpace &&& string' &&& unsafeWhiteSpace &&& token ':' &&& unsafeWhiteSpace &&& json &&& unsafeWhiteSpace) >>^ morphed

79+ in (pair &&& (repeating ((token ',' &&& unsafeWhiteSpace &&& pair) >>^ morphed) <+> konst [])) >>^ siCons

80+ )

81+ <+> konst []

82+ )

82 &&& unsafeWhiteSpace

83 &&& unsafeWhiteSpace

83 &&& token '}'

84 &&& token '}'

84− pair =

85− (unsafeWhiteSpace **> string' >** unsafeWhiteSpace >** token ':' >** unsafeWhiteSpace)

86− &&& (json >** unsafeWhiteSpace)

87− sepByComma :: Eq a => m () a -> m () [a]

88− sepByComma = sepBy (unsafeWhiteSpace >>> token ',' >>> unsafeWhiteSpace)

test/Spec/JSONHList.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

13import Data.Isoparsec.Megaparsec

14import Data.Isoparsec.Printer

15import Data.Maybe

16+import Data.Void

16import Test.Hspec

17import Test.Hspec

17import Test.Tasty

18import Test.Tasty

18import Test.Tasty.QuickCheck

19import Test.Tasty.QuickCheck

@@ -33,13 +34,13 @@ parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number)

33spec :: Spec

34spec :: Spec

34spec =

35spec =

35 it "deserializes" $ do

36 it "deserializes" $ do

36− runMegaparsecParser "12 31" parser `shouldBe` Right (Foo 12 31)

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

37− runMegaparsecParser "1 33" parser `shouldBe` Right (Foo 1 33)

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

38− runMegaparsecParser "1562" parser `shouldSatisfy` isLeft

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

40quickSpec :: TestTree

41quickSpec :: TestTree

41quickSpec = testProperty "roundtrips" $ \x ->

42quickSpec = testProperty "roundtrips" $ \x ->

42− let s = fromJust $ runMonoidPrinter @String parser x

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

43− in counterexample s $ case runMegaparsecParser s parser of

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

44 Right y -> property $ x == y

45 Right y -> property $ x == y

45 Left err -> counterexample (errorBundlePretty err) False

46 Left err -> counterexample (errorBundlePretty err) False

test/Spec/Orphans.hs+3−3

@@ -15,13 +15,13 @@ import Test.Tasty.QuickCheck

15import Prelude hiding ((.))

17instance

18− (CmpNat n 0 ~ 'GT, KnownNat n, Arbitrary (Element s), IsSequence s) =>

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

19 Arbitrary (Chunk n s)

20 where

21− arbitrary = Chunk . fromList <$> vectorOf (fromIntegral $ natVal @n Proxy) arbitrary

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

23instance Arbitrary ByteString where

24− arbitrary = fromList <$> listOf arbitrary

24+ arbitrary = liftTokens <$> listOf arbitrary

26deriving instance Arbitrary (Byte16 e)

test/Spec/Ssh.hs+21−20

@@ -31,7 +31,7 @@ data MessageNumber

31 | NewKeysMsg

32 deriving (Eq, Show, Ord)

34−instance ToIsoparsec MessageNumber ByteString a where

34+instance ToIsoparsec MessageNumber ByteString where

35 toIsoparsec =

36 anyToken

37 >>> mapIso

@@ -49,18 +49,18 @@ newtype DisconnectReasonCode

49 = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}

50 deriving (Eq, Ord, Show, Generic, Arbitrary)

52−instance ToIsoparsec DisconnectReasonCode ByteString a

52+instance ToIsoparsec DisconnectReasonCode ByteString

54newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}

55 deriving (Eq, Ord, Show, Generic, Arbitrary)

57−instance ToIsoparsec AlwaysDisplay ByteString a

57+instance ToIsoparsec AlwaysDisplay ByteString

59newtype PacketSequenceNumber

60 = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}

61 deriving (Eq, Ord, Show, Generic, Arbitrary)

63−instance ToIsoparsec PacketSequenceNumber ByteString a

63+instance ToIsoparsec PacketSequenceNumber ByteString

65data Payload

66 = VersionPayload String

@@ -88,19 +88,19 @@ instance Arbitrary Payload where

89makePrisms ''Payload

91−instance ToIsoparsec Payload ByteString a where

91+instance ToIsoparsec Payload ByteString where

92 toIsoparsec =

93 ( _DisconnectPayload

94 <.> specific DisconnectMsg

95 &&& auto @DisconnectReasonCode

96− &&& (tokensWhile (const True) >>^ utf8)

96+ &&& (tokensWhile (const True) >>> utf8)

97 )

98 <+> ( _ServiceRequest <.> specific ServiceRequestMsg

99 &&& auto @SSHString

100 )

101 <+> ( _VersionPayload <.> chunk "SSH-2.0-"

102− &&& (tokensWhile (`BS.notElem` " \n\r") >>^ utf8)

102+ &&& (tokensWhile (`BS.notElem` " \n\r") >>> utf8)

103− &&& ( (chunk " " >>> takeUntil "\r\n" >>^ (maskr . turn . konst $ ""))

103+ &&& ( (chunk " " >>> takeUntil "\r\n" >>^ turn (badKonst ""))

104 <+> chunk "\r\n"

105 )

106 )

@@ -125,7 +125,7 @@ newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}

125badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding

126badZeroPadding =

127 throughIntegral

128− ^>> manyTokens

128+ >>> manyTokens

129 >>^ siPure

130 (ZeroPadding . fromIntegral . BS.length)

131 (flip BS.replicate 0 . fromIntegral . zeroPaddingLength)

@@ -136,8 +136,8 @@ newtype MAC = MAC {unMAC :: ByteString}

136data NoneMAC = NoneMAC

137 deriving (Eq, Ord, Show, Generic)

138

139−instance ToIsoparsec NoneMAC b a where

139+instance ToIsoparsec NoneMAC b where

140− toIsoparsec = arr $ konst NoneMAC

140+ toIsoparsec = konst NoneMAC

141

142instance Arbitrary NoneMAC where

143 arbitrary = return NoneMAC

@@ -151,17 +151,18 @@ instance Arbitrary mac => Arbitrary (Packet mac) where

151

152makePrisms ''Packet

153

154−instance ToIsoparsec mac ByteString a => ToIsoparsec (Packet mac) ByteString a where

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

155 toIsoparsec =

156− ( auto @(Byte32 'BE) &&& anyToken

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

157− >>^ throughIntegral *** throughIntegral

157+ >>> (throughIntegral *** throughIntegral)

158− >>^ siPure

158+ >>> siPure

159− (\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))

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

160− (\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))

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

161− >>> manyTokens *** arr throughIntegral

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

162− >>> tuck (auto @Payload) *** badZeroPadding

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

163+ )

164+ &&& auto @mac

163 )

165 )

164− &&& auto @mac

165 >>^ siPure (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))

166 >>^ siPure (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))

166

167

167spec :: Spec

168spec :: Spec

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+16−15

@@ -11,6 +11,7 @@ import Data.Isoparsec.Chunks

11import Data.Isoparsec.Megaparsec

12import Data.Isoparsec.Printer

13import Data.Maybe

14+import Data.Void

14import GHC.Generics

15import GHC.Generics

15import Test.Hspec

16import Test.Hspec

16import Test.Tasty

17import Test.Tasty

@@ -21,14 +22,14 @@ import Prelude hiding ((.))

21newtype SingleDigit = SingleDigit {unSingleDigit :: String}

22newtype SingleDigit = SingleDigit {unSingleDigit :: String}

22 deriving (Eq, Show, Generic)

23 deriving (Eq, Show, Generic)

24−instance ToIsoparsec SingleDigit String m where

25+instance ToIsoparsec SingleDigit String where

25 toIsoparsec =

26 toIsoparsec =

26 toIsoparsec @(Chunk 1 String)

27 toIsoparsec @(Chunk 1 String)

27− >>^ coercing

28+ >>> coercing

28− >>^ check (all @[] isDigit)

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

29− >>^ coercing

30+ >>> coercing

31−instance Arbitrary SingleDigit where

32+instance (Arbitrary SingleDigit) where

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

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

34data Digits

35data Digits

@@ -45,24 +46,24 @@ instance Arbitrary Digits where

45 TwoDigits <$> arbitrary <*> arbitrary

46 TwoDigits <$> arbitrary <*> arbitrary

46 ]

47 ]

48−instance ToIsoparsec Digits String m

49+instance ToIsoparsec Digits String

50spec :: Spec

51spec :: Spec

51spec = do

52spec = do

52 let parser = toIsoparsec @_ @String

53 let parser = toIsoparsec @_ @String

53 it "deserializes" $ do

54 it "deserializes" $ do

54− runMegaparsecParser "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))

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

55− runMegaparsecParser "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))

56+ runMegaparsec @() parser "125" `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+ runMegaparsec @() parser "1253" `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))

57− runMegaparsecParser "12538" parser `shouldSatisfy` isLeft

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

58− runMegaparsecParser "2" parser `shouldSatisfy` isLeft

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

59− runMegaparsecParser "a" parser `shouldSatisfy` isLeft

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

60− runMegaparsecParser "1a" parser `shouldSatisfy` isLeft

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

62quickSpec :: TestTree

63quickSpec :: TestTree

63quickSpec = testProperty "roundtrips" $ \x ->

64quickSpec = testProperty "roundtrips" $ \x ->

64− let s = fromJust $ runMonoidPrinter @String parser x

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

65− in counterexample s $ case runMegaparsecParser s parser of

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

66 Right y -> property $ x == y

67 Right y -> property $ x == y

67 Left err -> counterexample (errorBundlePretty err) False

68 Left err -> counterexample (errorBundlePretty err) False

68 where

69 where