master..49556aa · isoparsec

git.iko.soy/isoparsec

42 files changed+754−1752

unifiedsplit

.github/workflows/haskell.yml+3−14

@@ -7,28 +7,17 @@ jobs:

88 runs-on: ubuntu-latest

10− strategy:

11− matrix:

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

13−

1410 steps:

1511 - uses: actions/checkout@v1

1612

17− - name: Cache

18− uses: actions/cache@v1

19− with:

20− path: ~/.stack

21− key: ${{ runner.os }}-stack-${{ matrix.resolver }}

22−

2313 - name: Build

2414 run: |

25− stack build --fast --pedantic --ghc-options '-j -ddump-to-file -ddump-hi' --test --no-run-tests --bench --no-run-benchmarks --resolver=${{ matrix.resolver }}

15+ stack build --fast --pedantic --ghc-options '-j' --test --no-run-tests --bench --no-run-benchmarks

2616

2717 - name: Test

2818 run: |

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

19+ stack test --fast --pedantic --ghc-options '-j'

3020

3121 - name: Weeder

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

3322 run: |

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

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

.hlint.yaml+1−130

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

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

5353

5454

55−# Define some custom fixity operators

55+# Define some custom infix operators

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

5757

5858

@@ -60,132 +60,3 @@

6060# $ hlint --default > .hlint.yaml

6161

6262- ignore: {name: "Use list comprehension"}

63−

64−- arguments:

65− - -XAllowAmbiguousTypes

66− - -XConstraintKinds

67− - -XDataKinds

68− - -XDefaultSignatures

69− - -XDeriveGeneric

70− - -XFlexibleContexts

71− - -XFlexibleInstances

72− - -XFunctionalDependencies

73− - -XGADTs

74− - -XGeneralizedNewtypeDeriving

75− - -XLambdaCase

76− - -XMultiParamTypeClasses

77− - -XOverloadedStrings

78− - -XPatternSynonyms

79− - -XPolyKinds

80− - -XScopedTypeVariables

81− - -XStandaloneDeriving

82− - -XTupleSections

83− - -XTypeApplications

84− - -XTypeFamilies

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"}

.weeder.yamldeleted−1

@@ -1 +0,0 @@

1−- message: Module reused between components

README.md+1−6

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

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

2−

1+# isoparsec

32Isomorphic (invertible) parser library

4−

5−### 🚧 Under construction 🚧

6−

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

app/Main.hsnew file+7

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

1+module Main

2+ ( main,

3+ )

4+where

6+main :: IO ()

7+main = putStrLn "henlo."

hie.yamldeleted−4

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

1−cradle:

2− stack:

3− - path: "."

4− component: "isoparsec:test:isoparsec-test"

package.yaml+22−38

@@ -21,61 +21,45 @@ description: Please see the README on GitHub at <https://github.com/ilya

2121

2222dependencies:

2323- base >= 4.7 && < 5

24−- containers

25−- megaparsec

26−- bytestring

27−# - text

28−- mtl

29−- profunctors

30−- mono-traversable

31−- split

3224

3325library:

3426 source-dirs: src

35− other-modules: Control.Prism

36− dependencies: []

3727

38−default-extensions:

39−- AllowAmbiguousTypes

40−- ConstraintKinds

41−- DataKinds

42−- DefaultSignatures

43−- DeriveGeneric

44−- FlexibleContexts

45−- FlexibleInstances

46−- FunctionalDependencies

47−- GADTs

48−- GeneralizedNewtypeDeriving

49−- LambdaCase

50−- MultiParamTypeClasses

51−- OverloadedStrings

52−- PatternSynonyms

53−- PolyKinds

54−- ScopedTypeVariables

55−- StandaloneDeriving

56−- TupleSections

57−- TypeApplications

58−- TypeFamilies

59−- TypeOperators

60−- UndecidableInstances

61−- RankNTypes

28+ dependencies:

29+ - optics-core

30+ - megaparsec

31+ - containers

32+ - bytestring

33+ # - text

34+ - mtl

35+

36+

37+executables:

38+ isoparsec-exe:

39+ main: Main.hs

40+ source-dirs: app

41+ ghc-options:

42+ - -threaded

43+ - -rtsopts

44+ - -with-rtsopts=-N

45+ dependencies: []

6246

6347tests:

6448 isoparsec-test:

6549 main: Spec.hs

66− source-dirs:

67− - test

68− - src

50+ source-dirs: test

6951 ghc-options:

7052 - -threaded

7153 - -rtsopts

7254 - -with-rtsopts=-N

7355 dependencies:

56+ - isoparsec

7457 - tasty

7558 - tasty-hspec

7659 - hspec

77− - lens

60+ - optics

7861 - tasty-quickcheck

7962 - QuickCheck

8063 - megaparsec

8164 - bytestring

65+ - word8

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

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

1414import Control.Arrow.Extra.ArrowZero as X

1515import Control.Arrow.Extra.BaseArrow as X

1616import Control.Arrow.Extra.PolyArrow as X

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

17+import Control.Category as X

1818

19−infixl 5 <+^

19+infixr 5 <+^

2020

21−infixl 5 ^+>

21+infixr 5 ^+>

2222

23−infixl 5 ^+^

23+infixr 5 ^+^

2424

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

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

2727

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

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

3030

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

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

src/Control/Arrow/Extra/ArrowChoice.hs+4

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

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MonoLocalBinds #-}

13{-# LANGUAGE NoImplicitPrelude #-}

4+{-# LANGUAGE UndecidableInstances #-}

36module Control.Arrow.Extra.ArrowChoice

47 ( ArrowChoice (..),

@@ -14,6 +17,7 @@ infixl 2 +++

1417infixl 2 |||

1518

1619class BaseArrow a => ArrowChoice a where

20+

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

1822 left = (+++ id)

1923

src/Control/Arrow/Extra/ArrowPlus.hs+4

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

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MonoLocalBinds #-}

3+{-# LANGUAGE UndecidableInstances #-}

15module Control.Arrow.Extra.ArrowPlus

26 ( ArrowPlus (..),

37 )

src/Control/Arrow/Extra/ArrowZero.hs+4

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

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MonoLocalBinds #-}

3+{-# LANGUAGE UndecidableInstances #-}

15module Control.Arrow.Extra.ArrowZero

26 ( ArrowZero (..),

37 )

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

@@ -1,19 +1,20 @@

1+{-# LANGUAGE FlexibleInstances #-}

12{-# LANGUAGE NoImplicitPrelude #-}

3+{-# LANGUAGE UndecidableInstances #-}

35module Control.Arrow.Extra.BaseArrow

46 ( BaseArrow (..),

5− (>>>),

6− (<<<),

77 )

88where

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

10+import Control.Category

1111

1212infixl 3 ***

1313

1414infixl 3 &&&

1515

1616class Category a => BaseArrow a where

17+

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

1819

1920 first :: a b c -> a (b, d) (c, d)

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

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

2627

2728 (&&&) :: 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+6−1

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

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

3+{-# LANGUAGE UndecidableInstances #-}

14{-# OPTIONS_GHC -Wno-orphans #-}

36module Control.Arrow.Extra.Orphans

@@ -12,6 +15,7 @@ instance {-# OVERLAPPABLE #-} A.ArrowZero a => ArrowZero a where

1215 zeroArrow = A.zeroArrow

1316

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

18+

1519 left = A.left

1620

1721 right = A.right

@@ -21,6 +25,7 @@ instance {-# OVERLAPPABLE #-} A.ArrowChoice a => ArrowChoice a where

2125 (|||) = (A.|||)

2226

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

28+

2429 first = A.first

2530

2631 second = A.second

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

2934

3035 (&&&) = (A.&&&)

3136

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

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

3338 arr = A.arr

3439

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

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

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

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE MonoLocalBinds #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

15module Control.Arrow.Extra.PolyArrow

26 ( PolyArrow (..),

37 (^>>),

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

1014where

1115

1216import Control.Arrow.Extra.BaseArrow

17+import Control.Category

1318

14−infixl 1 ^>>, >>^

19+infixr 1 ^>>, >>^

1520

16−infixl 1 ^<<, <<^

21+infixr 1 ^<<, <<^

1722

18−infixl 1 ^>^, ^<^

23+infixr 1 ^>^, ^<^

1924

20−class BaseArrow a => PolyArrow p a where

25+class BaseArrow a => PolyArrow a p where

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

2227

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

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

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

2530

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

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

2732a >>^ f = a >>> arr f

2833

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

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

3035a <<^ f = a <<< arr f

3136

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

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

3338f ^<< a = arr f <<< a

3439

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

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

3641a ^>^ b = arr a >>> arr b

3742

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

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

3944a ^<^ 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.hsdeleted−40

@@ -1,40 +0,0 @@

1−module Control.Prism

2− ( withPrism,

3− Identity,

4− Prism',

5− )

6−where

7−

8−import Data.Coerce

9−import Data.Functor.Identity

10−import Data.Profunctor

11−

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

13−

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

15−

16−instance Functor (Market a b s) where

17− fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)

18−

19−instance Profunctor (Market a b) where

20− dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)

21− lmap f (Market bt seta) = Market bt (seta . f)

22− rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)

23−

24−instance Choice (Market a b) where

25− left' (Market bt seta) = Market (Left . bt) $ \case

26− Left s -> case seta s of

27− Left t -> Left (Left t)

28− Right a -> Right a

29− Right c -> Left (Right c)

30− right' (Market bt seta) = Market (Right . bt) $ \case

31− Left c -> Left (Left c)

32− Right s -> case seta s of

33− Left t -> Left (Right t)

34− Right a -> Right a

35−

36−type APrism b a = Market a a a (Identity a) -> Market a a b (Identity b)

37−

38−withPrism :: APrism b a -> ((a -> b) -> (b -> Either b a) -> r) -> r

39−withPrism k f = case coerce (k (Market Identity Right)) of

40− Market bt seta -> f bt seta

src/Control/SemiIso.hsdeleted−206

@@ -1,206 +0,0 @@

1−module Control.SemiIso

2− ( module X,

3− SemiIso (..),

4− pattern SI,

5− siMaybe,

6− siPure,

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− )

38−where

39−

40−import Control.Applicative as X

41−import Control.Arrow.Extra

42−import Control.Monad as X

43−import qualified Data.Bifunctor as Bi

44−import Data.Bitraversable

45−import Data.Tuple

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

47−

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

49−

50−data SemiIso a b

51− = SemiIso

52− { embed :: forall f. AlternativeMonad f => a -> f b,

53− project :: forall f. AlternativeMonad f => b -> f a

54− }

55−

56−pattern SI ::

57− forall a b.

58− (forall f. AlternativeMonad f => a -> f b) ->

59− (forall f. AlternativeMonad f => b -> f a) ->

60− SemiIso a b

61−pattern SI a b = SemiIso a b

62−

63−siMaybe :: (a -> Maybe b) -> (b -> Maybe a) -> SemiIso a b

64−siMaybe a b = SI (maybeToAlternative . a) (maybeToAlternative . b)

65− where

66− maybeToAlternative :: Alternative f => Maybe a -> f a

67− maybeToAlternative (Just x) = pure x

68− maybeToAlternative Nothing = empty

69−

70−siPure :: (a -> b) -> (b -> a) -> SemiIso a b

71−siPure a b = SI (pure . a) (pure . b)

72−

73−instance Category SemiIso where

74− id = SemiIso pure pure

75− (SemiIso a1 b1) . (SemiIso a2 b2) = SemiIso (a1 <=< a2) (b2 <=< b1)

76−

77−instance BaseArrow SemiIso where

78− (SemiIso a1 b1) *** (SemiIso a2 b2) =

79− SemiIso

80− (\(x, y) -> (,) <$> a1 x <*> a2 y)

81− (\(x, y) -> (,) <$> b1 x <*> b2 y)

82− (SemiIso a1 b1) &&& (SemiIso a2 b2) =

83− SemiIso

84− (\x -> (,) <$> a1 x <*> a2 x)

85− (\(x, y) -> b1 x <|> b2 y)

86−

87−instance ArrowChoice SemiIso where

88− (SemiIso a1 b1) +++ (SemiIso a2 b2) =

89− SemiIso (bitraverse a1 a2) (bitraverse b1 b2)

90− (SemiIso a1 b1) ||| (SemiIso a2 b2) =

91− SemiIso

92− (either a1 a2)

93− (\x -> (Left <$> b1 x) <|> (Right <$> b2 x))

94−

95−instance ArrowZero SemiIso where

96− zeroArrow = SemiIso (const empty) (const empty)

97−

98−instance ArrowPlus SemiIso where

99− (SemiIso a1 b1) <+> (SemiIso a2 b2) =

100− SemiIso

101− (\x -> a1 x <|> a2 x)

102− (\x -> b1 x <|> b2 x)

103−

104−-- | prop> turn . turn = id

105−turn :: SemiIso a b -> SemiIso b a

106−turn (SemiIso a b) = SemiIso b a

107−

108−withSemiIso ::

109− AlternativeMonad f =>

110− SemiIso a b ->

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

112− c

113−withSemiIso (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+29−179

@@ -1,3 +1,18 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE PatternSynonyms #-}

9+{-# LANGUAGE PolyKinds #-}

10+{-# LANGUAGE RankNTypes #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE TypeApplications #-}

13+{-# LANGUAGE TypeFamilies #-}

14+{-# LANGUAGE TypeOperators #-}

15+{-# LANGUAGE UndecidableInstances #-}

116{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-redundant-constraints #-}

217

318module Control.Tuple.Morph

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

722 TupleMorphable,

823 CheckListsForTupleIso,

924 ReorderList,

10− FlatMorphable (..),

11− TupleHListContents,

12− HListContentsTuple,

13− Nat (..),

14− HList (..),

15− AppendableList (..),

16− DroppableList (..),

17− TakeableList (..),

18− Length,

19− Proxy (..),

2025 )

2126where

2227

2328import Data.Kind

2429import Data.Proxy

25−import Data.Type.Equality

2630import GHC.Generics

2731import GHC.TypeLits hiding (Nat)

2832

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

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

7276 HNil :: HList '[]

7377

74−infixl 5 :+

78+infixr 5 :+

7579

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

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

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

103107

104108-- ## Appending

105109

106−infixl 4 ++:

110+infixr 4 ++:

107111

108−class

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

110− DroppableList (Length aa) cc bb,

111− TakeableList (Length aa) cc aa

112− ) =>

113− AppendableList aa bb cc

114− | aa bb -> cc where

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

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

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

116114

117115instance AppendableList '[] bb bb where

118116 HNil ++: bb = bb

@@ -191,11 +189,13 @@ type family Length (aa :: [k]) :: Nat where

191189-- # Morphing

192190

193191class TupleMorphable t th | t -> th where

192+

194193 unmorph :: t -> HList th

195194

196195 morph :: HList th -> t

197196

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

198+

199199 unmorph = unmorph' (Proxy @flag)

200200

201201 morph = morph' (Proxy @flag)

@@ -203,16 +203,19 @@ instance (IsMophableTuple t ~ flag, TupleMorphable' t th flag) => TupleMorphable

203203-- ## Implementation

204204

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

206+

206207 unmorph' :: Proxy flag -> t -> HList th

207208

208209 morph' :: Proxy flag -> HList th -> t

209210

210211instance TupleMorphable' t '[t] 'False where

212+

211213 unmorph' _ t = t :+ HNil

212214

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

214216

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

218+

216219 unmorph' _ = genericUnmorph . from

217220

218221 morph' _ = to . genericMorph

@@ -220,21 +223,25 @@ instance (GenericTupleMorphable (Rep t) th, Generic t) => TupleMorphable' t th '

220223-- ### Generics

221224

222225class GenericTupleMorphable f th | f -> th where

226+

223227 genericUnmorph :: f p -> HList th

224228

225229 genericMorph :: HList th -> f p

226230

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

232+

228233 genericUnmorph = genericUnmorph . unM1

229234

230235 genericMorph = M1 . genericMorph

231236

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

238+

233239 genericUnmorph = unmorph . unK1

234240

235241 genericMorph = K1 . morph

236242

237243instance GenericTupleMorphable U1 '[] where

244+

238245 genericUnmorph _ = HNil

239246

240247 genericMorph _ = U1

@@ -253,6 +260,7 @@ instance

253260 ) =>

254261 GenericTupleMorphable (f :*: g) c

255262 where

263+

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

257265

258266 genericMorph cc = genericMorph aa :*: genericMorph bb

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

260268 aa = hTake @(Length a) Proxy cc

261269 bb = hDrop @(Length a) Proxy cc

262270

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−

290271-- ## Other

291272

292273type family IsMophableTuple t :: Bool where

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

353334 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

354335 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

355336 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+123−257

@@ -1,300 +1,166 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ExistentialQuantification #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE PolyKinds #-}

8+{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeOperators #-}

112{-# OPTIONS_GHC -Wno-redundant-constraints #-}

213

314module Data.Isoparsec

415 ( module X,

16+ -- Isoparsec,

17+ (%>>),

18+ (%>%),

19+ (>>%),

20+ (%<<),

21+ (%<%),

22+ (<<%),

23+ (<?>),

24+ (<+%),

25+ (%+>),

26+ (%+%),

527 (<.>),

28+ (<^>),

629 repeating,

7− sepBy,

8− sepBy1,

930 opt,

1031 opt',

1132 morphed,

12− fMorphed,

1333 coercing,

1434 mapIso,

1535 auto,

1636 specific,

1737 throughIntegral,

18− (~>),

19− (~>^),

20− (^~>),

21− (^~>^),

22− (~|),

23− (~$>),

24− (~&),

25− (~*),

26− siPrism,

27− delist,

28− enlist,

29− Listed,

30− hmap,

3138 )

3239where

3340

3441import Control.Arrow.Extra as X

35−import Control.Prism

3642import Control.Tuple.Morph

3743import Data.Coerce

38−import Data.Either

3944import Data.Isoparsec.Internal as X

4045import Data.Isoparsec.ToIsoparsec as X

46+import Data.Isoparsec.Tokenable as X

4147import qualified Data.Map as M

48+import Optics.Iso

49+import Optics.Optic

50+import Optics.Prism

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

4352

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

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

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

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

4655

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

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

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

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

4958

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

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

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

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

5261

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

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

62+infix 0 <?>

5563

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

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

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

65+thing <?> msg = label msg thing

5866

59−infixl 0 <.>

67+infixr 1 %>>

68+

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

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

71+

72+infixr 1 %>%

73+

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

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

76+

77+infixr 1 >>%

78+

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

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

81+

82+infixr 1 %<<

83+

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

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

86+

87+infixr 1 %<%

88+

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

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

91+

92+infixr 1 <<%

93+

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

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

96+

97+infixr 5 <+%

98+

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

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

101+

102+infixr 5 %+>

103+

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

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

106+

107+infixr 5 %+%

108+

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

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

111+

112+infixr 0 <.>

60113

61114(<.>) ::

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

63− (Prism' a b) ->

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

116+ b ->

64117 m x' x ->

65− m x' b

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

67−

68−siPrism ::

69− (Prism' a b) ->

70− SemiIso a b

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

72−

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

74−

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

76−

77−type family If cond t f where

78− If 'True t _ = t

79− If 'False _ f = f

80−

81−type family BothEmpty a b where

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

83− BothEmpty _ _ = 'False

84−

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

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

87− --

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

89− (~>) ::

90− ( PolyArrow SemiIso m,

91− FlatMorphable a a' fa,

92− FlatMorphable b b' fb,

93− FlatMorphable c c' fc,

94− FlatMorphable d d' fd

95− ) =>

96− m a b ->

97− m c d ->

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

99−

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

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

102−

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

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

105−

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

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

108−

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

110−siHFst = siPure fst (,HNil)

111−

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

113−--

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

115−(~>^) ::

116− ( PolyArrow SemiIso m,

117− FlatMorphable a a' fa,

118− FlatMorphable b bc fb,

119− FlatMorphable c bc 'False,

120− FlatMorphable d d' 'False

121− ) =>

122− m a b ->

123− SemiIso c d ->

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

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

126−

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

128−--

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

130−(^~>) ::

131− ( PolyArrow SemiIso m,

132− FlatMorphable a a' 'False,

133− FlatMorphable b bc 'False,

134− FlatMorphable c bc fc,

135− FlatMorphable d d' fd

136− ) =>

137− SemiIso a b ->

138− m c d ->

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

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

141−

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

143−--

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

145−(^~>^) ::

146− ( PolyArrow SemiIso m,

147− FlatMorphable a a' 'False,

148− FlatMorphable b b' 'False,

149− FlatMorphable d d' 'False

150− ) =>

151− SemiIso a b ->

152− SemiIso b d ->

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

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

155−

156−infixl 5 ~|

157−

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

159−--

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

161−(~|) ::

162− ( PolyArrow SemiIso m,

163− ArrowPlus m,

164− FlatMorphable a ac fa,

165− FlatMorphable c ac fb,

166− FlatMorphable b bd fc,

167− FlatMorphable d bd fd

168− ) =>

169− m a b ->

170− m c d ->

171− m (HList ac) (HList bd)

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

173−

174−infixl 7 ~&

175−

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

177−--

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

179−(~&) ::

180− ( PolyArrow SemiIso m,

181− FlatMorphable a ac' fa,

182− FlatMorphable c ac' fc,

183− FlatMorphable b b' fb,

184− FlatMorphable d d' fd,

185− AppendableList b' d' f

186− ) =>

187− m a b ->

188− m c d ->

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

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

191−

192−infixl 9 ~*

193−

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

195−--

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

197−(~*) ::

198− ( PolyArrow SemiIso m,

199− FlatMorphable a a' fa,

200− FlatMorphable c c' fc,

201− FlatMorphable b b' fb,

202− FlatMorphable d d' fd,

203− AppendableList a' c' e',

204− AppendableList b' d' f'

205− ) =>

206− m a b ->

207− m c d ->

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

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

210−

211−infixl 6 ~$>

212−

213−(~$>) ::

214− ( PolyArrow SemiIso m,

215− FlatMorphable a a' fa,

216− FlatMorphable b bc fb,

217− FlatMorphable c bc fc,

218− FlatMorphable d d' fd

219− ) =>

220− m a b ->

221− Prism' c d ->

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

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

224−

225−-- | Conceptually:

226−--

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

228−hmap ::

229− ( FlatMorphable b b' fb,

230− FlatMorphable a a' fa,

231− FlatMorphable d d' fd,

232− FlatMorphable c c' fc,

233− PolyArrow SemiIso m

234− ) =>

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

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

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

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

239−

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

241−coercing = siPure coerce coerce

242−

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

244−morphed = siPure morphTuples morphTuples

245−

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

247−fMorphed = siPure flatUnmorph flatMorph

248−

249−-- | Conceptually:

250−--

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

252−enlist ::

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

254− m a b ->

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

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

257−

258−-- | Conceptually:

259−--

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

261−delist ::

262− ( FlatMorphable a a' 'False,

263− FlatMorphable b b' 'False,

264− PolyArrow SemiIso m,

265− HListContentsTuple a' ~ a,

266− HListContentsTuple b' ~ b,

267− TupleHListContents a ~ a',

268− TupleHListContents b ~ b'

269− ) =>

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

271− m a b

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

273−

274−consHList ::

275− forall a b c.

276− AppendableList a b c =>

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

278−consHList =

279− siPure

280− (uncurry (++:))

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

282−

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

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

118+ m x' y'

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

120+

121+infixr 0 <^>

122+

123+(<^>) ::

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

125+ m x' x ->

126+ b ->

127+ m x' y'

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

129+

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

131+coercing = arr $ siJust coerce coerce

132+

133+morphed ::

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

135+ Iso' a b

136+morphed = iso morphTuples morphTuples

137+

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

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

140+

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

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

143+ where

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

145+

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

147+ si = id

148+

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

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

285151 where

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

287153 u =

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

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

290156

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

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

292158auto = toIsoparsec

293159

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

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

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

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

296162

297163throughIntegral ::

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

299− SemiIso a b

300−throughIntegral = siPure fromIntegral fromIntegral

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

165+ m a b

166+throughIntegral = arr $ siJust fromIntegral fromIntegral

src/Data/Isoparsec/ByteString.hs+41−22

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TupleSections #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE TypeFamilies #-}

110{-# OPTIONS_GHC -Wno-orphans #-}

211

312module Data.Isoparsec.ByteString

413 ( utf8,

14+ ftu8,

515 ByteString,

616 Endianness (..),

717 Byte8,

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

2030import Data.Word

2131import Prelude as P hiding ((.))

2232

23−utf8 :: SemiIso ByteString String

24−utf8 = siPure C.unpack C.pack

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

34+utf8 = chunk . C.pack

35+

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

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

2538

2639data Endianness = BE | LE

2740

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

3043

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

3245 bytesToIsoparsec _ =

33− konst word8s ^>> manyTokens

34− >>^ siPure

46+ konst word8s >>> manyTokens

47+ >>^ siJust

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

36− ( fromList . snd . P.head

49+ ( liftTokens . snd . P.head

3750 . P.drop (fromIntegral word8s)

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

3952 . (,[])

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

4457

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

4659 bytesToIsoparsec _ =

47− konst word8s ^>> manyTokens

48− >>^ siPure

60+ konst word8s >>> manyTokens

61+ >>^ siJust

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

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

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

5164 . P.drop (fromIntegral word8s)

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

5366 . (,[])

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

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

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

6982

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

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

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

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

7285

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

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

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

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

7588

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

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

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

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

7891

79−instance ToIsoparsec Bool ByteString m where

92+instance ToIsoparsec Bool ByteString where

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

8194

8295newtype SSHString = SSHString {unSSHString :: String}

8396 deriving (Show, Eq, Ord)

8497

85−instance ToIsoparsec SSHString ByteString m where

98+instance ToIsoparsec SSHString ByteString where

8699 toIsoparsec =

87− auto @(Byte32 'BE)

88− >>^ coercing @Word32

89− >>^ siPure fromIntegral fromIntegral

90− >>> manyTokens

91− >>^ utf8

92− >>^ siPure SSHString unSSHString

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

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

102+ >>> ftu8

103+ >>^ siJust SSHString unSSHString

104+

105+instance Tokenable ByteString where

106+

107+ type Token ByteString = Word8

108+

109+ liftTokens = pack

110+

111+ lowerTokens = unpack

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

@@ -1,3 +1,10 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE TypeFamilies #-}

18module Data.Isoparsec.Char

29 ( unsafeWhiteSpace,

310 unsafeWhiteSpace1,

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

1118import Text.Read

1219import Prelude hiding ((.), id)

1320

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

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

1522space = token ' '

1623

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

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

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

25+unsafeWhiteSpace = tokensWhile isSpace >>> badTsnok mempty

1926

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

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

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

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

2229

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

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

2431number =

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

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

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

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

@@ -1,3 +1,10 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE TypeFamilies #-}

18module Data.Isoparsec.Chunks

29 ( Chunk (..),

310 )

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

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

1118 deriving (Show, Eq, Ord)

1219

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

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

1421 toIsoparsec =

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

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

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

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

1−module Control.Cokleisli

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE MultiParamTypeClasses #-}

4+module Data.Isoparsec.Cokleisli

25 ( Cokleisli (..),

36 )

47where

@@ -6,17 +9,20 @@ where

69import Control.Applicative

710import Control.Arrow.Extra

811import Control.Monad

9−import Control.SemiIso

12+import Data.Isoparsec.Internal

13+import Optics.Iso

1014import Prelude hiding ((.))

1115

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

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

1317

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

19+

1520 id = Cokleisli return

1621

1722 (Cokleisli cb) . (Cokleisli ba) = Cokleisli $ cb >=> ba

1823

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

25+

2026 (Cokleisli cb) *** (Cokleisli c'b') = Cokleisli $

2127 \(c, c') -> do

2228 b' <- c'b' c'

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

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

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

2834

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

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

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

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

37+ Just x -> return x

38+ Nothing -> mzero

3139

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

3341 zeroArrow = Cokleisli $ const mzero

@@ -36,6 +44,7 @@ instance MonadPlus m => ArrowPlus (Cokleisli m) where

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

3745

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

47+

3948 left (Cokleisli cb) = Cokleisli $ \case

4049 Left c -> Left <$> cb c

4150 Right d -> return $ Right d

src/Data/Isoparsec/Internal.hs+124−75

@@ -1,76 +1,99 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE DefaultSignatures #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE LambdaCase #-}

8+{-# LANGUAGE LiberalTypeSynonyms #-}

9+{-# LANGUAGE TypeFamilies #-}

10+{-# LANGUAGE TypeOperators #-}

11+{-# LANGUAGE UndecidableInstances #-}

12+

113module Data.Isoparsec.Internal

2− ( module X,

14+ ( SemiIso' (..),

15+ SemiIso,

16+ si',

317 IsoparsecFail (..),

418 Isoparsec (..),

5− siCons,

6− unroll,

7− arrowsWhile,

8− arrowsUntil,

9− EffectOnly,

19+ IsoparsecTry (..),

20+ IsoparsecLabel (..),

21+ konst,

22+ tsnok,

23+ cons',

24+ siJust,

25+ siCheck,

26+ siCheck',

27+ check,

28+ levitate,

29+ siDecompose,

30+ badKonst,

31+ badTsnok,

1032 )

1133where

1234

1335import Control.Arrow.Extra

14−import Control.Arrow.Trans.Reader

1536import Control.Monad

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

17−import Data.MonoTraversable as X

18−import Data.Sequences as X

37+import Data.Isoparsec.Tokenable

1938import Numeric.Natural

39+import Optics.Iso

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

2141

2242class

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

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

2444 Isoparsec m s

2545 | m -> s where

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

2746

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

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

2948

30− token :: Element s -> EffectOnly m

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

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

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

3350

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

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

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

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

3752

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

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

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

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

54+ token x = anyToken >>> tsnok x

4155

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

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

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

4457

45− chunk :: s -> EffectOnly m

46− chunk = tokens . otoList

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

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

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

4761

48− chunk' :: m s s

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

50− where

51− list = siPure otoList fromList

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

63+ chunk = tokens . lowerTokens

64+

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

5266

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

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

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

5568 notToken t = tokenWhere (/= t)

5669

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

58− tokenWhere f = anyToken >>^ check f

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

71+ tokenWhere f =

72+ anyToken >>> check f

5973

6074 manyTokens :: m Natural s

6175

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

77+

6278 takeUntil :: s -> m () s

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

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

6579

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

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

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

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

82+ where

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

84+

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

6886 tokensWhile f =

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

70− <+^ isoConst () mempty

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

88+ where

89+ tokensWhile' g =

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

91+ <+^ isoConst' () []

7192

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

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

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

94+ tokensWhile1 f =

95+ tokenWhere f &&& tokensWhile f

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

7497

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

7699 -- > ┌─────┐

@@ -88,43 +111,69 @@ class

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

89112 -- > └─────┘ └─────┘

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

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

92−

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

94114

95−type EffectOnly m = m () ()

115+class IsoparsecLabel m l where

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

96117

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

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

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

119+levitateHead s = case lowerTokens s of

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

121+ [] -> Nothing

99122

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

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

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

124+cons' =

125+ si'

126+ (Just . uncurry (:))

127+ ( \case

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

129+ _ -> Nothing

130+ )

102131

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 () []

105− where

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

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

133+levitate = siJust liftTokens lowerTokens

107134

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

109−siCons =

110− siMaybe

111− (pure . uncurry cons)

112− uncons

135+class IsoparsecTry m where

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

113137

114138class IsoparsecFail m e where

115− failure :: e -> m a b

116−

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

118− anyToken = raise anyToken

119− token' = raise token'

120− tokens = raise . tokens

121− tokens' = raise tokens'

122− chunk = raise . chunk

123− chunk' = raise chunk'

124− notToken = raise . notToken

125− tokenWhere = raise . tokenWhere

126− manyTokens = raise manyTokens

127− takeUntil = raise . takeUntil

128− tokensWhile = raise . tokensWhile

129− tokensWhile1 = raise . tokensWhile1

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

139+ fail :: e -> m a b

140+

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

142+

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

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

145+

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

147+

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

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

150+

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

152+siCheck' f a b =

153+ si'

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

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

156+

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

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

159+

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

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

162+

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

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

165+

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

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

168+

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

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

171+

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

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

174+

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

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

177+

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

179+check f = arr $ siCheck f id id

src/Data/Isoparsec/Megaparsec.hs+36−58

@@ -1,9 +1,16 @@

1+{-# LANGUAGE FlexibleInstances #-}

2+{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE QuantifiedConstraints #-}

5+{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE ScopedTypeVariables #-}

7+{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE UndecidableInstances #-}

110{-# OPTIONS_GHC -Wno-orphans #-}

211

312module Data.Isoparsec.Megaparsec

4− ( runMegaparsecParser,

5− ParseErrorBundle (..),

6− MegaparsecParser (..),

13+ ( runMegaparsec,

714 )

815where

916

@@ -11,78 +18,49 @@ import Control.Arrow.Extra

1118import Control.Arrow.Extra.Orphans ()

1219import Control.Monad

1320import Data.Functor

14−import Data.Functor.Identity

15−import Data.Isoparsec

16−import Data.Void

21+import Data.Isoparsec.Internal as I

22+import Data.Isoparsec.Tokenable

23+import Optics.Getter

24+import Optics.ReadOnly

1725import Text.Megaparsec hiding (Token)

1826import qualified Text.Megaparsec as M

1927import Prelude hiding ((.))

2028

21−newtype MegaparsecParser s a b

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

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

24−

25−instance

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

27− ArrowPlus (MegaparsecParser s)

28− where

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

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

31−

32−runMegaparsecParser ::

33− (Stream s) =>

29+runMegaparsec ::

30+ (Ord e, Stream s) =>

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

3432 s ->

35− MegaparsecParser s () r ->

36− Either (ParseErrorBundle s Void) r

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

33+ Either (ParseErrorBundle s e) r

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

35+

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

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

3838

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

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

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

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

4141 Just x -> return x

42− Nothing -> M.failure Nothing mempty

42+ Nothing -> failure Nothing mempty

4343

4444instance

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

46− Isoparsec (MegaparsecParser s) s

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

46+ Isoparsec (Kleisli m) s

4747 where

48− anyToken = MegaparsecParser . Kleisli $ const anySingle

49−

50− token t = MegaparsecParser . Kleisli . const $ M.single t $> ()

51−

52− token' = MegaparsecParser . Kleisli $ \t -> M.single t $> t

53−

54− tokens ts = MegaparsecParser . Kleisli . const $ M.chunk (fromList ts) $> ()

55−

56− tokens' = MegaparsecParser . Kleisli $ \ts -> M.chunk (fromList ts) $> ts

57−

58− chunk c = MegaparsecParser . Kleisli . const $ M.chunk c $> ()

5948

60− chunk' = MegaparsecParser . Kleisli $ \c -> M.chunk c $> c

49+ anyToken = Kleisli $ const anySingle

6150

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

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

6352

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

53+ manyTokens = Kleisli $ takeP Nothing . fromIntegral

6554

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

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

7756 sup <- getInput

7857 setInput sub

7958 r <- f () <* eof

8059 setInput sup

8160 return r

8261

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

84− sup <- getInput

85− setInput sub

86− r <- f x <* eof

87− setInput sup

88− return r

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

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

64+

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

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

src/Data/Isoparsec/Printer.hs+32−61

@@ -1,83 +1,54 @@

1+{-# LANGUAGE FlexibleContexts #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE MultiParamTypeClasses #-}

4+{-# LANGUAGE RankNTypes #-}

5+{-# LANGUAGE UndecidableInstances #-}

16{-# OPTIONS_GHC -Wno-orphans #-}

38module Data.Isoparsec.Printer

4− ( runMonoidPrinter,

5− MonoidPrinter (..),

9+ ( runPrinter,

610 )

711where

812

9−import Control.Cokleisli

1013import Control.Monad.Writer.Lazy

11−import Data.Functor

1214import Data.Isoparsec

13−import Data.List.Split

15+import Data.Isoparsec.Cokleisli

1416import Prelude hiding ((.), id)

1517

16−newtype MonoidPrinter s a b

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

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

19−

20−runMonoidPrinter ::

21− forall s a.

22− MonoidPrinter s () a ->

18+runPrinter ::

19+ forall m s a.

20+ Monad m =>

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

2322 a ->

24− Maybe s

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

26−

27−instance IsoparsecFail (MonoidPrinter s) e where

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

29−

30−instance

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

32− Isoparsec (MonoidPrinter s) s

33− where

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

23+ m s

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

3525

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

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

27+ fail _ = Cokleisli . const $ WriterT Nothing

3728

38− token' = MonoidPrinter . Cokleisli $ \t -> (tell . Dual . singleton) t $> t

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

30+ fail = Cokleisli . const . WriterT . Left

3931

40− tokens ts = MonoidPrinter . Cokleisli $ const $ tell . Dual . fromList $ ts

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

33+ label _ = id

4134

42− tokens' = MonoidPrinter . Cokleisli $ \ts -> (tell . Dual . fromList) ts $> ts

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

36+ label _ = id

4337

44− chunk c = MonoidPrinter . Cokleisli . const $ tell . Dual $ c

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

39+ try = id

4540

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

41+instance

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

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

44+ where

4745

48− notToken nt = MonoidPrinter . Cokleisli $ \t ->

49− if t == nt

50− then empty

51− else (tell . Dual . singleton) t

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

5247

53− tokenWhere f = MonoidPrinter . Cokleisli $ \t ->

54− if f t

55− then (tell . Dual . singleton) t

56− else empty

48+ anyToken = Cokleisli $ tell . Dual . liftToken

5749

58− manyTokens = MonoidPrinter . Cokleisli $ \w -> do

50+ manyTokens = Cokleisli $ \w -> do

5951 tell $ Dual w

60− return . fromIntegral . olength $ 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

52+ return . fromIntegral . length . lowerTokens $ w

8153

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

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

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

src/Data/Isoparsec/ToIsoparsec.hs+37−21

@@ -1,3 +1,12 @@

1+{-# LANGUAGE DefaultSignatures #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE FlexibleInstances #-}

4+{-# LANGUAGE MultiParamTypeClasses #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE TypeFamilies #-}

7+{-# LANGUAGE TypeOperators #-}

8+{-# LANGUAGE UndecidableInstances #-}

110module Data.Isoparsec.ToIsoparsec

211 ( ToIsoparsec (..),

312 )

@@ -5,40 +14,47 @@ where

514

615import Control.Arrow.Extra

716import Data.Isoparsec.Internal

17+import Data.Isoparsec.Tokenable

818import GHC.Generics

919import Prelude hiding ((.))

1020

11−class ToIsoparsec a s m where

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

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

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

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

22+ toIsoparsec = anyToken

23+

24+class ToIsoparsec a s where

25+

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

1527

16−class GToIsoparsec a s m where

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

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

30+

31+class GToIsoparsec a s where

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

1833

19−instance GToIsoparsec U1 s m where

20− gToIsoparsec = arr $ konst U1

34+instance GToIsoparsec U1 s where

35+ gToIsoparsec = konst U1

2136

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

23− gToIsoparsec = toIsoparsec >>^ siPure K1 unK1

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

38+ gToIsoparsec =

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

2440

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

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

2642 gToIsoparsec =

27− gToIsoparsec >>^ siPure M1 unM1

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

2844

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

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

3046 gToIsoparsec =

3147 (gToIsoparsec &&& gToIsoparsec)

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

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

3349

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

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

3551 gToIsoparsec =

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

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

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

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

3854 )

39− >>> (arr (SI (pure . L1) fromL) ||| arr (SI (pure . R1) fromR))

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

4056 where

41− fromL (L1 a) = pure a

42− fromL _ = empty

43− fromR (R1 b) = pure b

44− fromR _ = empty

57+ fromL (L1 a) = Just a

58+ fromL _ = Nothing

59+ fromR (R1 b) = Just b

60+ fromR _ = Nothing

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

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

1+{-# LANGUAGE TypeFamilies #-}

3+module Data.Isoparsec.Tokenable

4+ ( Tokenable (..),

5+ )

6+where

8+class Monoid s => Tokenable s where

10+ type Token s

11+

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

13+

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

15+ liftTokens = mconcat . fmap liftToken

16+

17+ liftToken :: Token s -> s

18+ liftToken = liftTokens . pure

19+

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

21+

22+instance Tokenable [t] where

23+

24+ type Token [t] = t

25+

26+ liftTokens = id

27+

28+ lowerTokens = id

src/Lib.hsnew file+6

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

1+module Lib

2+ ( someFunc

3+ ) where

5+someFunc :: IO ()

6+someFunc = putStrLn "someFunc"

stack.yaml+7−2

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

1717#

1818# resolver: ./custom-snapshot.yaml

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

20−resolver: lts-15.8

20+resolver: lts-14.15

2121

2222# User packages to be built.

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

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

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

4040# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

4141#

42+extra-deps:

43+- optics-core-0.1

44+- optics-0.1

45+- optics-extra-0.1

46+- optics-th-0.1

4247

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

4449# flags: {}

@@ -65,4 +70,4 @@ packages:

6570# compiler-check: newer-minor

6671

6772ghc-options:

68− "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists -Wunused-imports

73+ "$locals": -ddump-to-file -ddump-hi -fwarn-unused-binds -fwarn-unused-imports -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Werror=missing-home-modules -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists

test/Spec.hs+1−23

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

1−import qualified Spec.BasicReader as BasicReader

21import qualified Spec.JSON as JSON

3−import qualified Spec.JSONHList as JSONHList

42import qualified Spec.Megaparsec.BasicNums as BasicNums

53import qualified Spec.Ssh as Ssh

6−import qualified Spec.SshHList as SshHList

74import qualified Spec.TwoDigits as TwoDigits

85import Test.Tasty

96import Test.Tasty.Hspec

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

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

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

1512 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

2013 defaultMain

2114 ( testGroup

2215 "tests"

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

2720 ],

2821 testGroup

2922 "JSON"

30− [ jsonSpec,

31− JSON.quickSpec

32− ],

33− testGroup

34− "JSONHList"

35− [ jsonHListSpec,

36− JSONHList.quickSpec

23+ [ JSON.quickSpec

3724 ],

3825 testGroup

3926 "TwoDigits"

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

4431 "ssh"

4532 [ sshSpec,

4633 Ssh.quickSpec

47− ],

48− testGroup

49− "ssh HList"

50− [ sshHListSpec,

51− SshHList.quickSpec

52− ],

53− testGroup

54− "BasicReader"

55− [ basicReaderSpec

5634 ]

5735 ]

5836 )

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

@@ -1,8 +1,12 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TypeApplications #-}

5+{-# LANGUAGE TypeFamilies #-}

17module Spec.Helper

28 ( shouldParseBS,

39 roundtrip,

4− parseSatisfyBS,

5− shouldParseS,

610 )

711where

812

@@ -19,84 +23,46 @@ import Test.Tasty.QuickCheck

1923import Text.Megaparsec as M

2024import Prelude as P hiding ((.))

2125

22−parseSatisfy ::

23− forall x s.

24− ( ToIsoparsec x s (MegaparsecParser s),

25− Stream s,

26− Show x,

27− Show (M.Token s),

28− Show s,

29− Isoparsec (MegaparsecParser s) s

30− ) =>

31− s ->

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

33− Expectation

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

35−

36−parseSatisfyBS ::

37− forall x.

38− ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

39− Show x,

40− Isoparsec (MegaparsecParser ByteString) ByteString

41− ) =>

42− ByteString ->

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

44− Expectation

45−parseSatisfyBS = parseSatisfy

46−

4726shouldParse ::

4827 forall x s.

49− ( ToIsoparsec x s (MegaparsecParser s),

28+ ( ToIsoparsec x s,

5029 Stream s,

5130 Show x,

5231 Eq x,

53− Isoparsec (MegaparsecParser s) s

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

5433 ) =>

5534 s ->

5635 x ->

5736 Expectation

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

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

5938 Right e' -> e' `shouldBe` e

6039 Left err -> expectationFailure $ errorBundlePretty err

6140

6241shouldParseBS ::

6342 forall x.

64− ( ToIsoparsec x ByteString (MegaparsecParser ByteString),

43+ ( ToIsoparsec x ByteString,

6544 Show x,

6645 Eq x,

67− Isoparsec (MegaparsecParser ByteString) ByteString

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

6847 ) =>

6948 ByteString ->

7049 x ->

7150 Expectation

7251shouldParseBS = shouldParse

7352

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−

8653roundtrip ::

8754 forall x s.

88− ( ToIsoparsec x s (MegaparsecParser s),

89− ToIsoparsec x s (MonoidPrinter s),

55+ ( ToIsoparsec x s,

9056 Stream s,

9157 Show s,

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

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

9359 Eq x,

94− Isoparsec (MegaparsecParser s) s

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

9561 ) =>

9662 x ->

9763 Property

9864roundtrip x =

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

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

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

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

10167 Right y -> property $ x == y

10268 Left err -> counterexample (errorBundlePretty err) False

test/Spec/JSON.hs+39−28

@@ -1,20 +1,28 @@

1+{-# LANGUAGE AllowAmbiguousTypes #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE ExistentialQuantification #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE PolyKinds #-}

18{-# LANGUAGE TemplateHaskell #-}

9+{-# LANGUAGE TypeApplications #-}

10+{-# LANGUAGE TypeFamilies #-}

11+{-# LANGUAGE TypeOperators #-}

212

313module Spec.JSON

414 ( quickSpec,

5− spec,

615 )

716where

817

918import Control.Arrow.Extra

10−import Control.Lens.TH

1119import Data.Isoparsec

1220import Data.Isoparsec.Char

1321import Data.Isoparsec.Megaparsec

1422import Data.Isoparsec.Printer

1523import Data.Maybe

16−import Spec.Helper

17−import Test.Hspec

24+import Data.Void

25+import Optics hiding (elements)

1826import Test.Tasty

1927import Test.Tasty.QuickCheck

2028import Text.Megaparsec.Error

@@ -28,6 +36,7 @@ data JSON

2836 deriving (Show, Eq)

2937

3038instance Arbitrary JSON where

39+

3140 arbitrary =

3241 oneof

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

@@ -43,46 +52,48 @@ instance Arbitrary JSON where

4352

4453makePrisms ''JSON

4554

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−

5555quickSpec :: TestTree

5656quickSpec =

5757 testProperty "roundtrips" $ \x ->

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

59− in counterexample s $ case runMegaparsecParser s json of

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

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

6060 Right y -> property $ x == y

6161 Left err -> counterexample (errorBundlePretty err) False

6262

63−instance ToIsoparsec JSON String a where

64− toIsoparsec = json

65−

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

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

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

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

6865 where

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

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

7067 string = _JString <.> string'

7168 array =

7269 _Array

7370 <.> token '['

7471 &&& unsafeWhiteSpace

75− &&& sepByComma json

72+ &&& ( try

73+ ( ( ( json &&& unsafeWhiteSpace

74+ &&& try

75+ ( repeating

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

77+ )

78+ )

79+ <+> konst []

80+ )

81+ >>% morphed

82+ )

83+ >>^ cons'

84+ )

85+ <+> konst []

86+ )

7687 &&& unsafeWhiteSpace

7788 &&& token ']'

7889 integer = _JInteger <.> number

7990 object =

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

81− &&& sepByComma pair

92+ &&& ( try

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

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

95+ )

96+ <+> konst []

97+ )

8298 &&& unsafeWhiteSpace

8399 &&& 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+14−8

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

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE RankNTypes #-}

14{-# LANGUAGE TemplateHaskell #-}

5+{-# LANGUAGE TypeApplications #-}

6+{-# LANGUAGE TypeFamilies #-}

38module Spec.Megaparsec.BasicNums

49 ( spec,

@@ -6,13 +11,14 @@ module Spec.Megaparsec.BasicNums

611 )

712where

813

9−import Control.Lens.TH

1014import Data.Either

1115import Data.Isoparsec

1216import Data.Isoparsec.Char

1317import Data.Isoparsec.Megaparsec

1418import Data.Isoparsec.Printer

1519import Data.Maybe

20+import Data.Void

21+import Optics

1622import Test.Hspec

1723import Test.Tasty

1824import Test.Tasty.QuickCheck

@@ -27,19 +33,19 @@ instance Arbitrary Foo where

2733

2834makePrisms ''Foo

2935

30−parser :: (Isoparsec m String) => m () Foo

31−parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number)

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

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

3238

3339spec :: Spec

3440spec =

3541 it "deserializes" $ do

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

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

38− runMegaparsecParser "1562" parser `shouldSatisfy` isLeft

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

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

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

3945

4046quickSpec :: TestTree

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

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

43− in counterexample s $ case runMegaparsecParser s parser of

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

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

4450 Right y -> property $ x == y

4551 Left err -> counterexample (errorBundlePretty err) False

test/Spec/Orphans.hs+12−3

@@ -1,3 +1,12 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE ExistentialQuantification #-}

3+{-# LANGUAGE FlexibleContexts #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE ScopedTypeVariables #-}

6+{-# LANGUAGE StandaloneDeriving #-}

7+{-# LANGUAGE TypeApplications #-}

8+{-# LANGUAGE TypeFamilies #-}

9+{-# LANGUAGE UndecidableInstances #-}

110{-# OPTIONS_GHC -Wno-orphans #-}

211

312module Spec.Orphans

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

1524import Prelude hiding ((.))

1625

1726instance

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

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

1928 Arbitrary (Chunk n s)

2029 where

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

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

2231

2332instance Arbitrary ByteString where

24− arbitrary = fromList <$> listOf arbitrary

33+ arbitrary = liftTokens <$> listOf arbitrary

2534

2635deriving instance Arbitrary (Byte16 e)

2736

test/Spec/Ssh.hs+67−47

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

1+{-# LANGUAGE BinaryLiterals #-}

2+{-# LANGUAGE ConstraintKinds #-}

3+{-# LANGUAGE DataKinds #-}

4+{-# LANGUAGE DeriveGeneric #-}

5+{-# LANGUAGE DerivingStrategies #-}

6+{-# LANGUAGE FlexibleContexts #-}

7+{-# LANGUAGE FlexibleInstances #-}

8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9+{-# LANGUAGE MultiParamTypeClasses #-}

10+{-# LANGUAGE OverloadedStrings #-}

11+{-# LANGUAGE ScopedTypeVariables #-}

12+{-# LANGUAGE StandaloneDeriving #-}

113{-# LANGUAGE TemplateHaskell #-}

14+{-# LANGUAGE TypeApplications #-}

15+{-# LANGUAGE TypeFamilies #-}

216

317module Spec.Ssh

418 ( spec,

@@ -6,13 +20,13 @@ module Spec.Ssh

620 )

721where

822

9−import Control.Lens.TH

1023import Data.ByteString as BS

1124import qualified Data.Char as C

12−import Data.Either

1325import Data.Isoparsec

1426import Data.Isoparsec.ByteString

27+import qualified Data.Word8 as W8

1528import GHC.Generics

29+import Optics

1630import Spec.Helper

1731import Spec.Orphans ()

1832import Test.Hspec

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

3145 | NewKeysMsg

3246 deriving (Eq, Show, Ord)

3347

34−instance ToIsoparsec MessageNumber ByteString a where

48+instance ToIsoparsec MessageNumber ByteString where

3549 toIsoparsec =

3650 anyToken

3751 >>> mapIso

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

4963 = DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}

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

5165

52−instance ToIsoparsec DisconnectReasonCode ByteString a

66+instance ToIsoparsec DisconnectReasonCode ByteString

5367

5468newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}

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

5670

57−instance ToIsoparsec AlwaysDisplay ByteString a

71+instance ToIsoparsec AlwaysDisplay ByteString

5872

5973newtype PacketSequenceNumber

6074 = PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}

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

6276

63−instance ToIsoparsec PacketSequenceNumber ByteString a

77+instance ToIsoparsec PacketSequenceNumber ByteString

6478

6579data Payload

6680 = VersionPayload String

@@ -88,33 +102,40 @@ instance Arbitrary Payload where

88102

89103makePrisms ''Payload

90104

91−instance ToIsoparsec Payload ByteString a where

105+instance ToIsoparsec Payload ByteString where

92106 toIsoparsec =

93− ( _DisconnectPayload

94− <.> specific DisconnectMsg

95− &&& auto @DisconnectReasonCode

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)

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

104− <+> chunk "\r\n"

107+ try

108+ ( _DisconnectPayload

109+ <.> specific DisconnectMsg

110+ &&& auto @DisconnectReasonCode

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

112+ )

113+ <+> try

114+ ( _ServiceRequest <.> specific ServiceRequestMsg

115+ &&& auto @SSHString

116+ )

117+ <+> try

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

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

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

105121 )

106− )

107− <+> (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))

108− <+> ( _DebugPayload <.> specific DebugMsg

109− &&& auto @AlwaysDisplay

110− &&& auto @SSHString

111− )

112− <+> ( _UnimplementedPayload <.> specific UnimplementedMsg

113− &&& auto @PacketSequenceNumber

114− )

115− <+> ( _ServiceAccept <.> specific ServiceAcceptMsg

116− &&& auto @SSHString

117− )

122+ >>> ftu8

123+ )

124+ )

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

126+ <+> try

127+ ( _DebugPayload <.> specific DebugMsg

128+ &&& auto @AlwaysDisplay

129+ &&& auto @SSHString

130+ )

131+ <+> try

132+ ( _UnimplementedPayload <.> specific UnimplementedMsg

133+ &&& auto @PacketSequenceNumber

134+ )

135+ <+> try

136+ ( _ServiceAccept <.> specific ServiceAcceptMsg

137+ &&& auto @SSHString

138+ )

118139

119140newtype Padding = Padding {unPadding :: ByteString}

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

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

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

126147badZeroPadding =

127148 throughIntegral

128− ^>> manyTokens

129− >>^ siPure

149+ >>> manyTokens

150+ >>^ siJust

130151 (ZeroPadding . fromIntegral . BS.length)

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

132153

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

136157data NoneMAC = NoneMAC

137158 deriving (Eq, Ord, Show, Generic)

138159

139−instance ToIsoparsec NoneMAC b a where

140− toIsoparsec = arr $ konst NoneMAC

160+instance ToIsoparsec NoneMAC b where

161+ toIsoparsec = konst NoneMAC

141162

142163instance Arbitrary NoneMAC where

143164 arbitrary = return NoneMAC

@@ -151,26 +172,25 @@ instance Arbitrary mac => Arbitrary (Packet mac) where

151172

152173makePrisms ''Packet

153174

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

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

155176 toIsoparsec =

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

157− >>^ throughIntegral *** throughIntegral

158− >>^ siPure

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

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

161− >>> manyTokens *** arr throughIntegral

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

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

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

179+ >>> siJust

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

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

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

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

184+ )

185+ &&& auto @mac

163186 )

164− &&& auto @mac

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

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

166188

167189spec :: Spec

168190spec = do

169191 it "deserialize payload" $ do

170192 "SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"

171− "SSH-2.0-TesT" `parseSatisfyBS` isLeft @_ @Payload

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

173− "SSH-2.0-TesT random comment" `parseSatisfyBS` isLeft @_ @Payload

174194 "\x2__" `shouldParseBS` IgnorePayload "__"

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

176196 it "deserialize packet" $ do

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

@@ -1,3 +1,13 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE DeriveGeneric #-}

3+{-# LANGUAGE DerivingVia #-}

4+{-# LANGUAGE FlexibleContexts #-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TypeApplications #-}

9+{-# LANGUAGE TypeFamilies #-}

10+

111module Spec.TwoDigits

212 ( spec,

313 quickSpec,

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

1121import Data.Isoparsec.Megaparsec

1222import Data.Isoparsec.Printer

1323import Data.Maybe

24+import Data.Void

1425import GHC.Generics

1526import Test.Hspec

1627import Test.Tasty

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

2132newtype SingleDigit = SingleDigit {unSingleDigit :: String}

2233 deriving (Eq, Show, Generic)

2334

24−instance ToIsoparsec SingleDigit String m where

35+instance ToIsoparsec SingleDigit String where

2536 toIsoparsec =

2637 toIsoparsec @(Chunk 1 String)

27− >>^ coercing

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

29− >>^ coercing

38+ >>> coercing

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

40+ >>> coercing

3041

31−instance Arbitrary SingleDigit where

42+instance (Arbitrary SingleDigit) where

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

3344

3445data Digits

@@ -45,24 +56,24 @@ instance Arbitrary Digits where

4556 TwoDigits <$> arbitrary <*> arbitrary

4657 ]

4758

48−instance ToIsoparsec Digits String m

59+instance ToIsoparsec Digits String

4960

5061spec :: Spec

5162spec = do

52− let parser = toIsoparsec @_ @String

63+ let parser = toIsoparsec

5364 it "deserializes" $ do

54− runMegaparsecParser "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))

55− runMegaparsecParser "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))

56− runMegaparsecParser "1253" parser `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))

57− runMegaparsecParser "12538" parser `shouldSatisfy` isLeft

58− runMegaparsecParser "2" parser `shouldSatisfy` isLeft

59− runMegaparsecParser "a" parser `shouldSatisfy` isLeft

60− runMegaparsecParser "1a" parser `shouldSatisfy` isLeft

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

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

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

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

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

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

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

6172

6273quickSpec :: TestTree

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

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

65− in counterexample s $ case runMegaparsecParser s parser of

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

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

6677 Right y -> property $ x == y

6778 Left err -> counterexample (errorBundlePretty err) False

6879 where