ilyakooo0/isoparsec
1
0
Fork 0
mirror of https://github.com/ilyakooo0/isoparsec.git synced 2024-11-22 04:43:48 +03:00
Code Issues Projects Releases Wiki Activity

[WIP] Add Isoparsec (#4)

Browse Source 
* Added basics of Isoparsec

* Fixed build dependancies

* Reformatted, added tasks, added basic megaparsec, added basic tests

* Updated actions

* Fixed weeder

* Added string printer

* Added JSON test

* Fixed warnings

* Revert "Fixed warnings"

This reverts commit d25aef4e42.

* Made things compile

* Removed redundant dependency

* Changed Isoparsec to not be a type family

* Added generics and stuff

* chunks and stuff

* wip added ssh

* Proper comment parsing

* notes

* bumped lts

* Added BE LE

* added ssh packets

* added more ssh tests

* fixed test :)

* Added zero-padding
This commit is contained in:
iko 2020-01-23 16:53:59 +03:00 committed by GitHub
parent 1ad141d1b5
commit 49556aaab7
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
32 changed files with 1989 additions and 79 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/workflows/haskell.yml vendored
View File

@ -1,6 +1,6 @@
name: Haskell CI
on: [push, pull_request]
on: [push]
jobs:
build:

62
.hlint.yaml Normal file
View File

@ -0,0 +1,62 @@
# HLint configuration file
# https://github.com/ndmitchell/hlint
##########################
# This file contains a template configuration file, which is typically
# placed as .hlint.yaml in the root of your project
# Specify additional command line arguments
#
# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
# Control which extensions/flags/modules/functions can be used
#
# - extensions:
# - default: false # all extension are banned by default
# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
#
# - flags:
# - {name: -w, within: []} # -w is allowed nowhere
#
# - modules:
# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
# - {name: Control.Arrow, within: []} # Certain modules are banned entirely
#
# - functions:
# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
# Add custom hints for this project
#
# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
# Turn on hints that are off by default
#
# Ban "module X(module X) where", to require a real export list
# - warn: {name: Use explicit module export list}
#
# Replace a $ b $ c with a . b $ c
# - group: {name: dollar, enabled: true}
#
# Generalise map to fmap, ++ to <>
# - group: {name: generalise, enabled: true}
# Ignore some builtin hints
# - ignore: {name: Use let}
# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
# Define some custom infix operators
# - fixity: infixr 3 ~^#^~
# To generate a suitable file for HLint do:
# $ hlint --default > .hlint.yaml
- ignore: {name: "Use list comprehension"}

50
.vscode/tasks.json vendored Normal file
View File

@ -0,0 +1,50 @@
{
// See https://go.microsoft.com/fwlink/?LinkId=733558
// for the documentation about the tasks.json format
"version": "2.0.0",
"tasks": [
{
"label": "Stack Build",
"group": {
"kind": "build",
"isDefault": true
},
"type": "shell",
"command": "stack build --fast --no-interleaved-output",
"problemMatcher": {
"owner": "haskell",
"fileLocation": [
"absolute"
],
"pattern": [
{
"regexp": "^(\\S+\\s+>\\s*)?\\s*(\\S+):(\\d+):(\\d+): (warning|error|info):.*$",
"file": 2,
"line": 3,
"column": 4,
"severity": 5
},
{
"regexp": "^(\\s+•\\s+| \\s*)([^\\d\\W].+)$",
"message": 2
}
]
},
"presentation": {
"showReuseMessage": false,
"focus": false
}
},
{
"label": "Stack Install",
"type": "shell",
"command": "stack install --fast",
"dependsOn": "Stack Build",
"problemMatcher": [],
"presentation": {
"showReuseMessage": false,
"focus": false
}
}
]
}

9
app/Main.hs
View File

@ -1,6 +1,7 @@
module Main (main) where
import Lib
module Main
( main,
)
where
main :: IO ()
main = someFunc
main = putStrLn "henlo."

25
package.yaml
View File

@ -25,6 +25,15 @@ dependencies:
library:
source-dirs: src
dependencies:
- optics-core
- megaparsec
- containers
- bytestring
# - text
- mtl
executables:
isoparsec-exe:
main: Main.hs
@ -33,8 +42,7 @@ executables:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- isoparsec
dependencies: []
tests:
isoparsec-test:
@ -44,5 +52,14 @@ tests:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies: []
# - isoparsec
dependencies:
- isoparsec
- tasty
- tasty-hspec
- hspec
- optics
- tasty-quickcheck
- QuickCheck
- megaparsec
- bytestring
- word8

5
random-notes.md Normal file
View File

@ -0,0 +1,5 @@
Implied `Isoparse m =>` everywhere
`m () a` -- parser produces an `a` out of thin air and printer consumes an `a`.
`m a ()` -- printer consumes an `a` and the printer produces an `a`.
`a -> m () ()` -- `a` is a global constant used by both the parser and the printer.

39
src/Control/Arrow/Extra.hs
View File

@ -1,9 +1,32 @@
module Control.Arrow.Extra
( module X
) where
{-# LANGUAGE MonoLocalBinds #-}
import Control.Arrow.Extra.ArrowChoice as X
import Control.Arrow.Extra.ArrowPlus as X
import Control.Arrow.Extra.ArrowZero as X
import Control.Arrow.Extra.BaseArrow as X
import Control.Arrow.Extra.PolyArrow as X
module Control.Arrow.Extra
( module X,
(<+^),
(^+>),
(^+^),
)
where
import Control.Arrow as X (Kleisli (..))
import Control.Arrow.Extra.ArrowChoice as X
import Control.Arrow.Extra.ArrowPlus as X
import Control.Arrow.Extra.ArrowZero as X
import Control.Arrow.Extra.BaseArrow as X
import Control.Arrow.Extra.PolyArrow as X
import Control.Category as X
infixr 5 <+^
infixr 5 ^+>
infixr 5 ^+^
(<+^) :: (ArrowPlus a, PolyArrow a p) => a b c -> p b c -> a b c
a <+^ b = a <+> arr b
(^+>) :: (ArrowPlus a, PolyArrow a p) => p b c -> a b c -> a b c
a ^+> b = arr a <+> b
(^+^) :: (ArrowPlus a, PolyArrow a p) => p b c -> p b c -> a b c
a ^+^ b = arr a <+> arr b

27
src/Control/Arrow/Extra/ArrowChoice.hs
View File

@ -1,16 +1,23 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances, MonoLocalBinds, NoImplicitPrelude #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Extra.ArrowChoice
( ArrowChoice(..)
) where
( ArrowChoice (..),
)
where
import qualified Control.Arrow as A
import Control.Arrow.Extra.BaseArrow
import Control.Category
import Data.Either
import Control.Arrow.Extra.BaseArrow
import Control.Category
import Data.Either
infixl 2 +++
infixl 2 |||
class BaseArrow a => ArrowChoice a where
left :: a b c -> a (Either b d) (Either c d)
left = (+++ id)
@ -20,9 +27,3 @@ class BaseArrow a => ArrowChoice a where
(+++) :: a b c -> a b' c' -> a (Either b b') (Either c c')
(|||) :: a b d -> a c d -> a (Either b c) d
instance A.ArrowChoice a => ArrowChoice a where
left = A.left
right = A.right
(+++) = (A.+++)
(|||) = (A.|||)

17
src/Control/Arrow/Extra/ArrowPlus.hs
View File

@ -1,14 +1,15 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances, MonoLocalBinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Extra.ArrowPlus
( ArrowPlus(..)
) where
( ArrowPlus (..),
)
where
import qualified Control.Arrow as A
import Control.Arrow.Extra.ArrowZero
import Control.Arrow.Extra.ArrowZero
infixl 5 <+>
class ArrowZero a => ArrowPlus a where
(<+>) :: a b c -> a b c -> a b c
instance A.ArrowPlus a => ArrowPlus a where
(<+>) = (A.<+>)

15
src/Control/Arrow/Extra/ArrowZero.hs
View File

@ -1,14 +1,13 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances, MonoLocalBinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Extra.ArrowZero
( ArrowZero(..)
) where
( ArrowZero (..),
)
where
import qualified Control.Arrow as A
import Control.Arrow.Extra.BaseArrow
import Control.Arrow.Extra.BaseArrow
class BaseArrow a => ArrowZero a where
zeroArrow :: a b c
instance A.ArrowZero a => ArrowZero a where
zeroArrow = A.zeroArrow

31
src/Control/Arrow/Extra/BaseArrow.hs
View File

@ -1,27 +1,28 @@
{-# LANGUAGE NoImplicitPrelude, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Arrow.Extra.BaseArrow
( BaseArrow(..)
) where
( BaseArrow (..),
)
where
import qualified Control.Arrow as A
import Control.Category
import Control.Category
infixl 3 ***
infixl 3 &&&
class Category a => BaseArrow a where
{-# MINIMAL (***), (&&&) #-}
first :: a b c -> a (b,d) (c,d)
first :: a b c -> a (b, d) (c, d)
first = (*** id)
second :: a b c -> a (d,b) (d,c)
second :: a b c -> a (d, b) (d, c)
second = (id ***)
(***) :: a b c -> a b' c' -> a (b,b') (c,c')
(***) :: a b c -> a b' c' -> a (b, b') (c, c')
(&&&) :: a b c -> a b c' -> a b (c,c')
instance (Category a, A.Arrow a) => BaseArrow a where
first = A.first
second = A.second
(***) = (A.***)
(&&&) = (A.&&&)
(&&&) :: a b c -> a b c' -> a b (c, c')

41
src/Control/Arrow/Extra/Orphans.hs Normal file
View File

@ -0,0 +1,41 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Control.Arrow.Extra.Orphans
(
)
where
import qualified Control.Arrow as A
import Control.Arrow.Extra
instance {-# OVERLAPPABLE #-} A.ArrowZero a => ArrowZero a where
zeroArrow = A.zeroArrow
instance {-# OVERLAPPABLE #-} A.ArrowChoice a => ArrowChoice a where
left = A.left
right = A.right
(+++) = (A.+++)
(|||) = (A.|||)
instance {-# OVERLAPPABLE #-} (Category a, A.Arrow a) => BaseArrow a where
first = A.first
second = A.second
(***) = (A.***)
(&&&) = (A.&&&)
instance A.Arrow a => PolyArrow a (->) where
arr = A.arr
instance {-# OVERLAPPABLE #-} A.ArrowPlus a => ArrowPlus a where
(<+>) = (A.<+>)

35
src/Control/Arrow/Extra/PolyArrow.hs
View File

@ -1,25 +1,30 @@
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, MonoLocalBinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Arrow.Extra.PolyArrow
( PolyArrow(..)
, (^>>)
, (>>^)
, (<<^)
, (^<<)
, (^>^)
, (^<^)
) where
( PolyArrow (..),
(^>>),
(>>^),
(<<^),
(^<<),
(^>^),
(^<^),
)
where
import qualified Control.Arrow as A
import Control.Arrow.Extra.BaseArrow
import Control.Category
import Control.Arrow.Extra.BaseArrow
import Control.Category
infixr 1 ^>>, >>^
infixr 1 ^<<, <<^
infixr 1 ^>^, ^<^
class BaseArrow a => PolyArrow a p where
arr :: p b c -> a b c
instance A.Arrow a => PolyArrow a (->) where
arr = A.arr
(^>>) :: PolyArrow a p => p b c -> a c d -> a b d
f ^>> a = arr f >>> a

336
src/Control/Tuple/Morph.hs Normal file
View File

@ -0,0 +1,336 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns -Wno-redundant-constraints #-}
module Control.Tuple.Morph
( morphTuples,
morphReorderTuples,
morphPickTuples,
TupleMorphable,
CheckListsForTupleIso,
ReorderList,
)
where
import Data.Kind
import Data.Proxy
import GHC.Generics
import GHC.TypeLits hiding (Nat)
morphTuples :: (TupleMorphable a c, TupleMorphable b c) => a -> b
morphTuples = morph . unmorph
morphPickTuples ::
( TupleMorphable a b,
TupleMorphable c d,
ReorderList b d
) =>
a ->
c
morphPickTuples = morph . hReorder Proxy . unmorph
type CheckListsForTupleIso b d =
EqOrError (Length b) (Length d)
( 'Text "Not isomorphic tuple contents:"
':$$: 'Text " " ':<>: 'ShowType b
':$$: 'Text " " ':<>: 'ShowType d
)
morphReorderTuples ::
( TupleMorphable a b,
TupleMorphable c d,
ReorderList b d,
CheckListsForTupleIso b d
) =>
a ->
c
morphReorderTuples = morph . hReorder Proxy . unmorph
type family EqOrError a b e :: Constraint where
EqOrError a a _ = a ~ a
EqOrError _ _ e = TypeError e
-- # Nat
data Nat where
S :: Nat -> Nat
Z :: Nat
-- # HList
data HList (ts :: [*]) where
HCons :: t -> HList tt -> HList (t ': tt)
HNil :: HList '[]
infixr 5 :+
pattern (:+) :: (ts ~ (t : tt)) => t -> HList tt -> HList ts
pattern (:+) a b = HCons a b
-- ## Taking
class TakeableList (n :: Nat) aa bb | n aa -> bb where
hTake :: Proxy n -> HList aa -> HList bb
instance TakeableList 'Z a '[] where
hTake _ _ = HNil
instance
(TakeableList n aa bb', bb ~ (a ': bb')) =>
TakeableList ('S n) (a ': aa) bb
where
hTake (Proxy :: Proxy ('S n)) (a :+ aa) = a :+ hTake @n Proxy aa
-- ## Dropping
class DroppableList (n :: Nat) (aa :: [*]) (bb :: [*]) | n aa -> bb where
hDrop :: Proxy n -> HList aa -> HList bb
instance DroppableList 'Z aa aa where
hDrop _ aa = aa
instance (DroppableList n aa bb) => DroppableList ('S n) (a ': aa) bb where
hDrop (Proxy :: Proxy ('S n)) (_ :+ aa) = hDrop @n Proxy aa
-- ## Appending
infixr 4 ++:
class AppendableList aa bb cc | aa bb -> cc where
(++:) :: HList aa -> HList bb -> HList (aa ++ bb)
instance AppendableList '[] bb bb where
HNil ++: bb = bb
instance
( AppendableList aa bb cc,
cc ~ (aa ++ bb),
((a ': aa) ++ bb) ~ (a ': cc)
) =>
AppendableList (a ': aa) bb (a ': cc)
where
(a :+ aa) ++: bb = a :+ (aa ++: bb)
-- ## Finding
class FindableList ts t where
hFind :: HList ts -> t
instance
{-# OVERLAPPING #-}
(NotFindableList ts t) =>
FindableList (t ': ts) t
where
hFind (t :+ _) = t
instance
(TEq a t ~ 'False, FindableList ts a) =>
FindableList (t ': ts) a
where
hFind (_ :+ ts) = hFind ts
instance
( TypeError
('Text "Could not find type " ':<>: 'ShowType a ':<>: 'Text " in tuple.")
) =>
FindableList '[] a
where
hFind = error "oh no"
class NotFindableList ts t
instance
{-# OVERLAPPING #-}
( TypeError
('Text "Type " ':<>: 'ShowType t ':<>: 'Text " is not unique in tuple.")
) =>
NotFindableList (t ': ts) t
instance (NotFindableList ts a) => NotFindableList (t ': ts) a
instance NotFindableList '[] a
class ReorderList as bs where
hReorder :: Proxy bs -> HList as -> HList bs
instance (FindableList as b, ReorderList as bs) => ReorderList as (b ': bs) where
hReorder _ as = hFind as :+ hReorder (Proxy @bs) as
instance ReorderList as '[] where
hReorder _ _ = HNil
type family TEq a b :: Bool where
TEq a a = 'True
TEq a b = 'False
-- ## Other
type family (++) (as :: [k]) (bs :: [k]) :: [k] where
(++) '[] b = b
(++) (a ': as) bs = a ': (as ++ bs)
type family Length (aa :: [k]) :: Nat where
Length '[] = 'Z
Length (a ': aa) = 'S (Length aa)
-- # Morphing
class TupleMorphable t th | t -> th where
unmorph :: t -> HList th
morph :: HList th -> t
instance (IsMophableTuple t ~ flag, TupleMorphable' t th flag) => TupleMorphable t th where
unmorph = unmorph' (Proxy @flag)
morph = morph' (Proxy @flag)
-- ## Implementation
class TupleMorphable' t th (flag :: Bool) | t flag -> th where
unmorph' :: Proxy flag -> t -> HList th
morph' :: Proxy flag -> HList th -> t
instance TupleMorphable' t '[t] 'False where
unmorph' _ t = t :+ HNil
morph' _ (t :+ HNil) = t
instance (GenericTupleMorphable (Rep t) th, Generic t) => TupleMorphable' t th 'True where
unmorph' _ = genericUnmorph . from
morph' _ = to . genericMorph
-- ### Generics
class GenericTupleMorphable f th | f -> th where
genericUnmorph :: f p -> HList th
genericMorph :: HList th -> f p
instance (GenericTupleMorphable f t) => GenericTupleMorphable (M1 i c f) t where
genericUnmorph = genericUnmorph . unM1
genericMorph = M1 . genericMorph
instance (TupleMorphable c t) => GenericTupleMorphable (K1 i c) t where
genericUnmorph = unmorph . unK1
genericMorph = K1 . morph
instance GenericTupleMorphable U1 '[] where
genericUnmorph _ = HNil
genericMorph _ = U1
type CanTakeDrop a b c =
( TakeableList (Length a) c a,
DroppableList (Length a) c b,
c ~ (a ++ b)
)
instance
( GenericTupleMorphable f a,
GenericTupleMorphable g b,
AppendableList a b c,
CanTakeDrop a b c
) =>
GenericTupleMorphable (f :*: g) c
where
genericUnmorph (a :*: b) = genericUnmorph a ++: genericUnmorph b
genericMorph cc = genericMorph aa :*: genericMorph bb
where
aa = hTake @(Length a) Proxy cc
bb = hDrop @(Length a) Proxy cc
-- ## Other
type family IsMophableTuple t :: Bool where
IsMophableTuple () = 'True
IsMophableTuple (a, b) = 'True
IsMophableTuple (a, b, c) = 'True
IsMophableTuple (a, b, c, d) = 'True
IsMophableTuple (a, b, c, d, e) = 'True
IsMophableTuple (a, b, c, d, e, f) = 'True
IsMophableTuple (a, b, c, d, e, f, g) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2) = 'True
IsMophableTuple (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p, q, r, s, t, u, v, w, x, y, z, a1, b1, c1, d1, e1, f1, g1, h1, i1, j1, k1, l1, m1, n1, o1, p1, q1, r1, s1, t1, u1, v1, w1, x1, y1, z1, a2, b2, c2, d2, e2, f2, g2, h2, i2, j2) = 'True
IsMophableTuple c = 'False

166
src/Data/Isoparsec.hs Normal file
View File

@ -0,0 +1,166 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
module Data.Isoparsec
( module X,
-- Isoparsec,
(%>>),
(%>%),
(>>%),
(%<<),
(%<%),
(<<%),
(<?>),
(<+%),
(%+>),
(%+%),
(<.>),
(<^>),
repeating,
opt,
opt',
morphed,
coercing,
mapIso,
auto,
specific,
throughIntegral,
)
where
import Control.Arrow.Extra as X
import Control.Tuple.Morph
import Data.Coerce
import Data.Isoparsec.Internal as X
import Data.Isoparsec.ToIsoparsec as X
import Data.Isoparsec.Tokenable as X
import qualified Data.Map as M
import Optics.Iso
import Optics.Optic
import Optics.Prism
import Prelude hiding ((.), fail, id)
opt :: (ArrowPlus m, IsoparsecTry m, PolyArrow m SemiIso') => m () () -> m () ()
opt m = try m <+> konst ()
opt' :: (ArrowPlus m, IsoparsecTry m, PolyArrow m SemiIso', Eq a) => a -> m () a -> m () ()
opt' a m = (try m >>> tsnok a) <+> konst ()
repeating :: (PolyArrow m SemiIso', IsoparsecTry m, ArrowPlus m, Eq b) => m () b -> m () [b]
repeating m = (try m &&& (try (repeating m) <+> konst [])) >>^ cons'
infix 0 <?>
(<?>) :: IsoparsecLabel m l => m a b -> l -> m a b
thing <?> msg = label msg thing
infixr 1 %>>
(%>>) :: (PolyArrow a SemiIso', ToSemiIso p b c) => p -> a c d -> a b d
p %>> a = si p ^>> a
infixr 1 %>%
(%>%) :: (PolyArrow a SemiIso', ToSemiIso p b c, ToSemiIso p' c d) => p -> p' -> a b d
p %>% a = si p ^>^ si a
infixr 1 >>%
(>>%) :: (PolyArrow a SemiIso', ToSemiIso p c d) => a b c -> p -> a b d
p >>% a = p >>^ si a
infixr 1 %<<
(%<<) :: (PolyArrow a SemiIso', ToSemiIso p c d) => p -> a b c -> a b d
p %<< a = si p ^<< a
infixr 1 %<%
(%<%) :: (PolyArrow a SemiIso', ToSemiIso p c d, ToSemiIso p' b c) => p -> p' -> a b d
p %<% a = si p ^<^ si a
infixr 1 <<%
(<<%) :: (PolyArrow a SemiIso', ToSemiIso p b c) => a c d -> p -> a b d
p <<% a = p <<^ si a
infixr 5 <+%
(<+%) :: (PolyArrow a SemiIso', ArrowPlus a, ToSemiIso p b c) => a b c -> p -> a b c
a <+% b = a <+^ si b
infixr 5 %+>
(%+>) :: (PolyArrow a SemiIso', ArrowPlus a, ToSemiIso p b c) => p -> a b c -> a b c
a %+> b = si a ^+> b
infixr 5 %+%
(%+%) :: (PolyArrow a SemiIso', ArrowPlus a, ToSemiIso p b c) => p -> p -> a b c
a %+% b = si a ^+^ si b
infixr 0 <.>
(<.>) ::
(PolyArrow m SemiIso', TupleMorphable x c, TupleMorphable y c, ToSemiIso b y y') =>
b ->
m x' x ->
m x' y'
b <.> p = (p >>% morphed) >>% b
infixr 0 <^>
(<^>) ::
(PolyArrow m SemiIso', TupleMorphable x c, TupleMorphable y c, ToSemiIso b y y') =>
m x' x ->
b ->
m x' y'
b <^> p = b >>> morphed %>% p
coercing :: forall b a m. (Coercible a b, PolyArrow m SemiIso') => m a b
coercing = arr $ siJust coerce coerce
morphed ::
(TupleMorphable a c, TupleMorphable b c) =>
Iso' a b
morphed = iso morphTuples morphTuples
class ToSemiIso x a b | x -> a b where
si :: x -> SemiIso' a b
instance (k `Is` A_Prism) => ToSemiIso (Optic' k NoIx b a) a b where
si p = si' (Just . n) (either (const Nothing) Just . u)
where
(n, u) = withPrism p (,)
instance ToSemiIso (SemiIso' a b) a b where
si = id
mapIso :: (PolyArrow m SemiIso', Ord a, Ord b) => [(a, b)] -> m a b
mapIso m = arr $ si' (`M.lookup` n) (`M.lookup` u)
where
n = M.fromListWith (error "mapping not unique") m
u =
M.fromListWith (error "mapping not unique") $
(\(a, b) -> (b, a)) <$> m
auto :: forall x s m. (ToIsoparsec x s, Isoparsec m s) => m () x
auto = toIsoparsec
specific :: forall x s m. (ToIsoparsec x s, Isoparsec m s, Eq x, Show x) => x -> m () ()
specific x = auto @x >>> check (== x) >>> tsnok x
throughIntegral ::
(Integral a, Integral b, Num a, Num b, PolyArrow m SemiIso') =>
m a b
throughIntegral = arr $ siJust fromIntegral fromIntegral

111
src/Data/Isoparsec/ByteString.hs Normal file
View File

@ -0,0 +1,111 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Data.Isoparsec.ByteString
( utf8,
ftu8,
ByteString,
Endianness (..),
Byte8,
Byte16 (..),
Byte32 (..),
Byte64 (..),
SSHString (..),
)
where
import Data.Bits
import Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import Data.Isoparsec
import Data.Proxy
import Data.Word
import Prelude as P hiding ((.))
utf8 :: Isoparsec m ByteString => String -> m () ()
utf8 = chunk . C.pack
ftu8 :: PolyArrow m SemiIso' => m ByteString String
ftu8 = arr $ siJust C.unpack C.pack
data Endianness = BE | LE
class BytesToIsoparsec b (e :: Endianness) where
bytesToIsoparsec :: (Isoparsec m ByteString) => Proxy e -> m () b
instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'BE where
bytesToIsoparsec _ =
konst word8s >>> manyTokens
>>^ siJust
(fromInteger . BS.foldl (\i w -> shiftL i 8 .|. toInteger w) 0)
( liftTokens . snd . P.head
. P.drop (fromIntegral word8s)
. iterate (\(i, ww) -> (shiftR i 8, fromInteger i : ww))
. (,[])
. toInteger
)
where
word8s = fromIntegral $ finiteBitSize (undefined :: b) `div` 8
instance (FiniteBits b, Integral b) => BytesToIsoparsec b 'LE where
bytesToIsoparsec _ =
konst word8s >>> manyTokens
>>^ siJust
(fromInteger . BS.foldr (\w i -> shiftL i 8 .|. toInteger w) 0)
( liftTokens . P.reverse . snd . P.head
. P.drop (fromIntegral word8s)
. iterate (\(i, ww) -> (shiftR i 8, fromInteger i : ww))
. (,[])
. toInteger
)
where
word8s = fromIntegral $ finiteBitSize (undefined :: b) `div` 8
type Byte8 = Word8
newtype Byte16 (e :: Endianness) = Byte16 {unByte16 :: Word16}
deriving (Show, Eq, Ord, Enum, Num, Real, Integral, Bounded)
newtype Byte32 (e :: Endianness) = Byte32 {unByte32 :: Word32}
deriving (Show, Eq, Ord, Enum, Num, Real, Integral, Bounded)
newtype Byte64 (e :: Endianness) = Byte64 {unByte64 :: Word64}
deriving (Show, Eq, Ord, Enum, Num, Real, Integral, Bounded)
instance BytesToIsoparsec Word16 e => ToIsoparsec (Byte16 e) ByteString where
toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte16 e) @Word16
instance BytesToIsoparsec Word32 e => ToIsoparsec (Byte32 e) ByteString where
toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte32 e) @Word32
instance BytesToIsoparsec Word64 e => ToIsoparsec (Byte64 e) ByteString where
toIsoparsec = bytesToIsoparsec (Proxy @e) >>> coercing @(Byte64 e) @Word64
instance ToIsoparsec Bool ByteString where
toIsoparsec = anyToken >>> mapIso [(0, False), (1, True)]
newtype SSHString = SSHString {unSSHString :: String}
deriving (Show, Eq, Ord)
instance ToIsoparsec SSHString ByteString where
toIsoparsec =
auto @(Byte32 'BE) >>> coercing @Word32
>>> siJust fromIntegral fromIntegral ^>> manyTokens
>>> ftu8
>>^ siJust SSHString unSSHString
instance Tokenable ByteString where
type Token ByteString = Word8
liftTokens = pack
lowerTokens = unpack

33
src/Data/Isoparsec/Char.hs Normal file
View File

@ -0,0 +1,33 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Isoparsec.Char
( unsafeWhiteSpace,
unsafeWhiteSpace1,
space,
number,
)
where
import Data.Char
import Data.Isoparsec
import Text.Read
import Prelude hiding ((.), id)
space :: (Isoparsec m s, Token s ~ Char) => m () ()
space = token ' '
unsafeWhiteSpace :: (Isoparsec m s, Token s ~ Char) => m () ()
unsafeWhiteSpace = tokensWhile isSpace >>> badTsnok mempty
unsafeWhiteSpace1 :: (Isoparsec m s, Token s ~ Char) => m () ()
unsafeWhiteSpace1 = tokensWhile1 isSpace >>> badTsnok (liftToken ' ')
number :: (Isoparsec m s, Token s ~ Char) => m () Integer
number =
tokensWhile1 (\c -> isNumber c || c == '+' || c == '-')
>>^ si' (readMaybe @Integer . lowerTokens) (Just . liftTokens . show)

22
src/Data/Isoparsec/Chunks.hs Normal file
View File

@ -0,0 +1,22 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Isoparsec.Chunks
( Chunk (..),
)
where
import Data.Isoparsec
import Data.Proxy
import GHC.TypeLits
newtype Chunk (n :: Nat) s = Chunk {unChunk :: s}
deriving (Show, Eq, Ord)
instance (CmpNat n 0 ~ 'GT, KnownNat n) => ToIsoparsec (Chunk n s) s where
toIsoparsec =
konst (fromIntegral $ natVal @n Proxy) >>> manyTokens >>> coercing

61
src/Data/Isoparsec/Cokleisli.hs Normal file
View File

@ -0,0 +1,61 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Data.Isoparsec.Cokleisli
( Cokleisli (..),
)
where
import Control.Applicative
import Control.Arrow.Extra
import Control.Monad
import Data.Isoparsec.Internal
import Optics.Iso
import Prelude hiding ((.))
newtype Cokleisli m a b = Cokleisli {unCokleisli :: b -> m a}
instance Monad m => Category (Cokleisli m) where
id = Cokleisli return
(Cokleisli cb) . (Cokleisli ba) = Cokleisli $ cb >=> ba
instance (Alternative m, Monad m) => BaseArrow (Cokleisli m) where
(Cokleisli cb) *** (Cokleisli c'b') = Cokleisli $
\(c, c') -> do
b' <- c'b' c'
b <- cb c
return (b, b')
(Cokleisli cb) &&& (Cokleisli c'b) = Cokleisli $
\(c, c') -> c'b c' >> cb c
instance MonadPlus m => PolyArrow (Cokleisli m) SemiIso' where
arr (SemiIso' si) = Cokleisli $ \t -> case withIso si (flip const) t of
Just x -> return x
Nothing -> mzero
instance MonadPlus m => ArrowZero (Cokleisli m) where
zeroArrow = Cokleisli $ const mzero
instance MonadPlus m => ArrowPlus (Cokleisli m) where
(Cokleisli lhs) <+> (Cokleisli rhs) = Cokleisli $ \x -> lhs x `mplus` rhs x
instance (Alternative m, Monad m) => ArrowChoice (Cokleisli m) where
left (Cokleisli cb) = Cokleisli $ \case
Left c -> Left <$> cb c
Right d -> return $ Right d
right (Cokleisli cb) = Cokleisli $ \case
Left d -> return $ Left d
Right c -> Right <$> cb c
(Cokleisli cb) +++ (Cokleisli c'b') = Cokleisli $ \case
Left c -> Left <$> cb c
Right c' -> Right <$> c'b' c'
(Cokleisli db) ||| (Cokleisli dc) = Cokleisli $ \d ->
(Left <$> db d) <|> (Right <$> dc d)

179
src/Data/Isoparsec/Internal.hs Normal file
View File

@ -0,0 +1,179 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE LiberalTypeSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Isoparsec.Internal
( SemiIso' (..),
SemiIso,
si',
IsoparsecFail (..),
Isoparsec (..),
IsoparsecTry (..),
IsoparsecLabel (..),
konst,
tsnok,
cons',
siJust,
siCheck,
siCheck',
check,
levitate,
siDecompose,
badKonst,
badTsnok,
)
where
import Control.Arrow.Extra
import Control.Monad
import Data.Isoparsec.Tokenable
import Numeric.Natural
import Optics.Iso
import Prelude as P hiding ((.), id)
class
(PolyArrow m SemiIso', ArrowPlus m, ArrowChoice m, IsoparsecTry m, Tokenable s) =>
Isoparsec m s
| m -> s where
{-# MINIMAL anyToken, manyTokens, tuck #-}
anyToken :: m () (Token s)
token :: Token s -> m () ()
default token :: Eq (Token s) => Token s -> m () ()
token x = anyToken >>> tsnok x
tokens :: [Token s] -> m () ()
default tokens :: [Token s] -> m () ()
tokens [] = arr $ isoConst' () ()
tokens (t : ts) = token t &&& tokens ts >>> arr (isoConst' ((), ()) ())
chunk :: s -> m () ()
chunk = tokens . lowerTokens
notToken :: Token s -> m () (Token s)
default notToken :: Eq (Token s) => Token s -> m () (Token s)
notToken t = tokenWhere (/= t)
tokenWhere :: (Token s -> Bool) -> m () (Token s)
tokenWhere f =
anyToken >>> check f
manyTokens :: m Natural s
tokensWhile :: (Token s -> Bool) -> m () s
takeUntil :: s -> m () s
default takeUntil :: Eq (Token s) => s -> m () s
takeUntil s = takeUntil' s >>^ levitate
where
takeUntil' s' = try (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ cons')
default tokensWhile :: (Token s -> Bool) -> m () s
tokensWhile f =
tokensWhile' f >>> check (P.all f) >>^ levitate
where
tokensWhile' g =
try (tokenWhere g &&& tokensWhile' g >>^ cons')
<+^ isoConst' () []
tokensWhile1 :: (Token s -> Bool) -> m () s
tokensWhile1 f =
tokenWhere f &&& tokensWhile f
>>^ si' (\(a, aa) -> Just $ liftToken a <> aa) levitateHead
-- | "tucks" the context of the parser into its input.
-- > ┌─────┐
-- > │ s ├───────┐
-- > └─────┘ │
-- > ┌────┐ │ ┌─────┐
-- > ───┤ () ├────▶ └──────┤ a ├▶
-- > └────┘ └─────┘
-- > │
-- > ┌────┴─────┐
-- > │ tuck │
-- > └────┬─────┘
-- > ▼
-- > ┌─────┐ ┌─────┐
-- > ──┤ s ├──────────────────────────┤ a ├─▶
-- > └─────┘ └─────┘
tuck :: m () a -> m s a
class IsoparsecLabel m l where
label :: l -> m a b -> m a b
levitateHead :: Tokenable s => s -> Maybe (Token s, s)
levitateHead s = case lowerTokens s of
(t : tt) -> Just (t, liftTokens tt)
[] -> Nothing
cons' :: SemiIso' (t, [t]) [t]
cons' =
si'
(Just . uncurry (:))
( \case
(t : ts) -> Just (t, ts)
_ -> Nothing
)
levitate :: Tokenable s => SemiIso' [Token s] s
levitate = siJust liftTokens lowerTokens
class IsoparsecTry m where
try :: m a b -> m a b
class IsoparsecFail m e where
fail :: e -> m a b
newtype SemiIso' s a = SemiIso' (SemiIso s s a a)
siDecompose :: SemiIso' a b -> (a -> Maybe b, b -> Maybe a)
siDecompose (SemiIso' s) = withIso s (,)
type SemiIso s t a b = Iso s (Maybe t) (Maybe a) b
si' :: (s -> Maybe a) -> (a -> Maybe s) -> SemiIso' s a
si' n u = SemiIso' $ iso n u
siCheck' :: (s -> Bool) -> (s -> Maybe a) -> (a -> Maybe s) -> SemiIso' s a
siCheck' f a b =
si'
(\c -> guard (f c) >> a c)
(b >=> (\c -> guard (f c) >> pure c))
siCheck :: (s -> Bool) -> (s -> a) -> (a -> s) -> SemiIso' s a
siCheck f a b = siCheck' f (Just . a) (Just . b)
siJust :: (s -> a) -> (a -> s) -> SemiIso' s a
siJust a b = si' (Just . a) (Just . b)
isoConst' :: s -> a -> SemiIso' s a
isoConst' s a = si' (const $ Just a) (const $ Just s)
konst :: (PolyArrow a SemiIso', Eq x) => x -> a () x
konst x = badKonst x >>> check (== x)
badKonst :: (PolyArrow a SemiIso') => x -> a () x
badKonst x = arr $ si' (const $ Just x) (const $ Just ())
tsnok :: (PolyArrow a SemiIso', Eq x) => x -> a x ()
tsnok x = check (== x) >>> badTsnok x
badTsnok :: (PolyArrow a SemiIso') => x -> a x ()
badTsnok x = arr $ si' (const $ Just ()) (const $ Just x)
check :: PolyArrow a SemiIso' => (s -> Bool) -> a s s
check f = arr $ siCheck f id id

66
src/Data/Isoparsec/Megaparsec.hs Normal file
View File

@ -0,0 +1,66 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Data.Isoparsec.Megaparsec
( runMegaparsec,
)
where
import Control.Arrow.Extra
import Control.Arrow.Extra.Orphans ()
import Control.Monad
import Data.Functor
import Data.Isoparsec.Internal as I
import Data.Isoparsec.Tokenable
import Optics.Getter
import Optics.ReadOnly
import Text.Megaparsec hiding (Token)
import qualified Text.Megaparsec as M
import Prelude hiding ((.))
runMegaparsec ::
(Ord e, Stream s) =>
Kleisli (Parsec e s) () r ->
s ->
Either (ParseErrorBundle s e) r
runMegaparsec (Kleisli f) = runParser (f () <* eof) ""
instance (MonadParsec e s m) => IsoparsecTry (Kleisli m) where
try (Kleisli f) = Kleisli $ \a -> M.try (f a)
instance (MonadParsec e s m) => PolyArrow (Kleisli m) SemiIso' where
arr (SemiIso' si) = Kleisli $ \t -> case view (getting si) t of
Just x -> return x
Nothing -> failure Nothing mempty
instance
(MonadParsec e s m, M.Token s ~ Token s, s ~ M.Tokens s, Tokenable s) =>
Isoparsec (Kleisli m) s
where
anyToken = Kleisli $ const anySingle
token t = Kleisli . const $ M.single t $> ()
manyTokens = Kleisli $ takeP Nothing . fromIntegral
tuck (Kleisli f) = Kleisli $ \sub -> do
sup <- getInput
setInput sub
r <- f () <* eof
setInput sup
return r
instance MonadParsec e s m => IsoparsecFail (Kleisli m) e where
fail e = Kleisli $ \_ -> customFailure e
instance MonadParsec e s m => IsoparsecLabel (Kleisli m) String where
label s (Kleisli m) = Kleisli $ \x -> M.label s (m x)

54
src/Data/Isoparsec/Printer.hs Normal file
View File

@ -0,0 +1,54 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Data.Isoparsec.Printer
( runPrinter,
)
where
import Control.Monad.Writer.Lazy
import Data.Isoparsec
import Data.Isoparsec.Cokleisli
import Prelude hiding ((.), id)
runPrinter ::
forall m s a.
Monad m =>
Cokleisli (WriterT (Dual s) m) () a ->
a ->
m s
runPrinter p = fmap getDual . execWriterT . unCokleisli p
instance IsoparsecFail (Cokleisli (WriterT s Maybe)) e where
fail _ = Cokleisli . const $ WriterT Nothing
instance IsoparsecFail (Cokleisli (WriterT s (Either e))) e where
fail = Cokleisli . const . WriterT . Left
instance IsoparsecLabel (Cokleisli (WriterT s Maybe)) e where
label _ = id
instance IsoparsecLabel (Cokleisli (WriterT s (Either e))) y where
label _ = id
instance IsoparsecTry (Cokleisli (WriterT (Dual s) m)) where
try = id
instance
(MonadPlus m, Monoid s, Eq (Token s), Tokenable s, Show s) =>
Isoparsec (Cokleisli (WriterT (Dual s) m)) s
where
token t = Cokleisli $ const $ tell . Dual . liftToken $ t
anyToken = Cokleisli $ tell . Dual . liftToken
manyTokens = Cokleisli $ \w -> do
tell $ Dual w
return . fromIntegral . length . lowerTokens $ w
tuck (Cokleisli f) = Cokleisli $ lift . fmap getDual . execWriterT . f

60
src/Data/Isoparsec/ToIsoparsec.hs Normal file
View File

@ -0,0 +1,60 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Isoparsec.ToIsoparsec
( ToIsoparsec (..),
)
where
import Control.Arrow.Extra
import Data.Isoparsec.Internal
import Data.Isoparsec.Tokenable
import GHC.Generics
import Prelude hiding ((.))
instance {-# OVERLAPPABLE #-} t ~ Token s => ToIsoparsec t s where
toIsoparsec = anyToken
class ToIsoparsec a s where
toIsoparsec :: Isoparsec m s => m () a
default toIsoparsec :: (Isoparsec m s, Generic a, GToIsoparsec (Rep a) s) => m () a
toIsoparsec = gToIsoparsec >>^ si' (Just . to) (Just . from)
class GToIsoparsec a s where
gToIsoparsec :: Isoparsec m s => m () (a b)
instance GToIsoparsec U1 s where
gToIsoparsec = konst U1
instance ToIsoparsec c s => GToIsoparsec (K1 i c) s where
gToIsoparsec =
toIsoparsec >>^ si' (Just . K1) (Just . unK1)
instance GToIsoparsec c s => GToIsoparsec (M1 i t c) s where
gToIsoparsec =
gToIsoparsec >>^ si' (Just . M1) (Just . unM1)
instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :*: b) s where
gToIsoparsec =
(gToIsoparsec &&& gToIsoparsec)
>>^ si' (\(a, b) -> Just (a :*: b)) (\(a :*: b) -> Just (a, b))
instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :+: b) s where
gToIsoparsec =
( try (gToIsoparsec >>^ si' (Just . Left) (either Just (const Nothing)))
<+> (gToIsoparsec >>^ si' (Just . Right) (either (const Nothing) Just))
)
>>> (arr (si' (Just . L1) fromL) ||| arr (si' (Just . R1) fromR))
where
fromL (L1 a) = Just a
fromL _ = Nothing
fromR (R1 b) = Just b
fromR _ = Nothing

28
src/Data/Isoparsec/Tokenable.hs Normal file
View File

@ -0,0 +1,28 @@
{-# LANGUAGE TypeFamilies #-}
module Data.Isoparsec.Tokenable
( Tokenable (..),
)
where
class Monoid s => Tokenable s where
type Token s
{-# MINIMAL (liftTokens | liftToken), lowerTokens #-}
liftTokens :: [Token s] -> s
liftTokens = mconcat . fmap liftToken
liftToken :: Token s -> s
liftToken = liftTokens . pure
lowerTokens :: s -> [Token s]
instance Tokenable [t] where
type Token [t] = t
liftTokens = id
lowerTokens = id

8
stack.yaml
View File

@ -17,7 +17,7 @@
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-14.7
resolver: lts-14.15
# User packages to be built.
# Various formats can be used as shown in the example below.
@ -39,7 +39,11 @@ packages:
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#
# extra-deps: []
extra-deps:
- optics-core-0.1
- optics-0.1
- optics-extra-0.1
- optics-th-0.1
# Override default flag values for local packages and extra-deps
# flags: {}

36
test/Spec.hs
View File

@ -1,2 +1,36 @@
import qualified Spec.JSON as JSON
import qualified Spec.Megaparsec.BasicNums as BasicNums
import qualified Spec.Ssh as Ssh
import qualified Spec.TwoDigits as TwoDigits
import Test.Tasty
import Test.Tasty.Hspec
main :: IO ()
main = putStrLn "Test suite not yet implemented"
main = do
bsicNumSpec <- testSpec "Basic megaparsec test" BasicNums.spec
twoDigitsSpec <- testSpec "Two digits test" TwoDigits.spec
sshSpec <- testSpec "ssh spec" Ssh.spec
defaultMain
( testGroup
"tests"
[ testGroup
"Basic number test"
[ bsicNumSpec,
BasicNums.quickSpec
],
testGroup
"JSON"
[ JSON.quickSpec
],
testGroup
"TwoDigits"
[ twoDigitsSpec,
TwoDigits.quickSpec
],
testGroup
"ssh"
[ sshSpec,
Ssh.quickSpec
]
]
)

68
test/Spec/Helper.hs Normal file
View File

@ -0,0 +1,68 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Spec.Helper
( shouldParseBS,
roundtrip,
)
where
import Data.ByteString as BS
import Data.Either
import Data.Isoparsec as I
import Data.Isoparsec.Megaparsec
import Data.Isoparsec.Printer
import Data.Maybe
import Data.Void
import Spec.Orphans ()
import Test.Hspec
import Test.Tasty.QuickCheck
import Text.Megaparsec as M
import Prelude as P hiding ((.))
shouldParse ::
forall x s.
( ToIsoparsec x s,
Stream s,
Show x,
Eq x,
Isoparsec (Kleisli (Parsec Void s)) s
) =>
s ->
x ->
Expectation
shouldParse s e = case runMegaparsec @Void @s toIsoparsec s of
Right e' -> e' `shouldBe` e
Left err -> expectationFailure $ errorBundlePretty err
shouldParseBS ::
forall x.
( ToIsoparsec x ByteString,
Show x,
Eq x,
Isoparsec (Kleisli (Parsec Void ByteString)) ByteString
) =>
ByteString ->
x ->
Expectation
shouldParseBS = shouldParse
roundtrip ::
forall x s.
( ToIsoparsec x s,
Stream s,
Show s,
I.Token s ~ M.Token s,
Eq x,
Isoparsec (Kleisli (Parsec Void s)) s
) =>
x ->
Property
roundtrip x =
let s = fromJust $ runPrinter @Maybe @s toIsoparsec x
in counterexample (show s) $ case runMegaparsec @Void @s toIsoparsec s of
Right y -> property $ x == y
Left err -> counterexample (errorBundlePretty err) False

99
test/Spec/JSON.hs Normal file
View File

@ -0,0 +1,99 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Spec.JSON
( quickSpec,
)
where
import Control.Arrow.Extra
import Data.Isoparsec
import Data.Isoparsec.Char
import Data.Isoparsec.Megaparsec
import Data.Isoparsec.Printer
import Data.Maybe
import Data.Void
import Optics hiding (elements)
import Test.Tasty
import Test.Tasty.QuickCheck
import Text.Megaparsec.Error
import Prelude hiding ((.))
data JSON
= Object [(String, JSON)]
| JString String
| Array [JSON]
| JInteger Integer
deriving (Show, Eq)
instance Arbitrary JSON where
arbitrary =
oneof
[ Object <$> listOf ((,) <$> listOf (elements ['.' .. 'z']) <*> scale (`div` 2) arbitrary),
JString <$> listOf (elements ['.' .. 'z']),
Array <$> listOf (scale (`div` 2) arbitrary),
JInteger <$> arbitrary
]
shrink (Object a) = Object <$> shrink a
shrink (JString a) = JString <$> shrink a
shrink (Array a) = Array <$> shrink a
shrink (JInteger a) = JInteger <$> shrink a
makePrisms ''JSON
quickSpec :: TestTree
quickSpec =
testProperty "roundtrips" $ \x ->
let s = fromJust $ runPrinter @Maybe @String json x
in counterexample s $ case runMegaparsec @Void json s of
Right y -> property $ x == y
Left err -> counterexample (errorBundlePretty err) False
json :: (PolyArrow m SemiIso', Isoparsec m String) => m () JSON
json = si' Just Just ^<< (try string <+> try array <+> try integer <+> object)
where
string' = token '"' &&& tokensWhile (/= '"') &&& token '"'
string = _JString <.> string'
array =
_Array
<.> token '['
&&& unsafeWhiteSpace
&&& ( try
( ( ( json &&& unsafeWhiteSpace
&&& try
( repeating
( (token ',' &&& unsafeWhiteSpace &&& json) >>% morphed
)
)
<+> konst []
)
>>% morphed
)
>>^ cons'
)
<+> konst []
)
&&& unsafeWhiteSpace
&&& token ']'
integer = _JInteger <.> number
object =
_Object <.> token '{' &&& unsafeWhiteSpace
&&& ( try
( let pair = (unsafeWhiteSpace &&& string' &&& unsafeWhiteSpace &&& token ':' &&& unsafeWhiteSpace &&& json &&& unsafeWhiteSpace) >>% morphed
in (pair &&& try (repeating ((token ',' &&& unsafeWhiteSpace &&& pair) >>% morphed) <+> konst [])) >>^ cons'
)
<+> konst []
)
&&& unsafeWhiteSpace
&&& token '}'

51
test/Spec/Megaparsec/BasicNums.hs Normal file
View File

@ -0,0 +1,51 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Spec.Megaparsec.BasicNums
( spec,
quickSpec,
)
where
import Data.Either
import Data.Isoparsec
import Data.Isoparsec.Char
import Data.Isoparsec.Megaparsec
import Data.Isoparsec.Printer
import Data.Maybe
import Data.Void
import Optics
import Test.Hspec
import Test.Tasty
import Test.Tasty.QuickCheck
import Text.Megaparsec.Error
import Prelude hiding ((.), fail)
data Foo = Foo Integer Integer
deriving (Show, Eq)
instance Arbitrary Foo where
arbitrary = Foo <$> arbitrary <*> arbitrary
makePrisms ''Foo
parser :: (Isoparsec m s, Token s ~ Char, IsoparsecLabel m String) => m () Foo
parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number <?> "oh no")
spec :: Spec
spec =
it "deserializes" $ do
runMegaparsec @() parser "12 31" `shouldBe` (Right $ Foo 12 31)
runMegaparsec @() parser "1 33" `shouldBe` (Right $ Foo 1 33)
runMegaparsec @() parser "1562" `shouldSatisfy` isLeft
quickSpec :: TestTree
quickSpec = testProperty "roundtrips" $ \x ->
let s = fromJust $ runPrinter @Maybe @String parser x
in counterexample s $ case runMegaparsec @Void parser s of
Right y -> property $ x == y
Left err -> counterexample (errorBundlePretty err) False

39
test/Spec/Orphans.hs Normal file
View File

@ -0,0 +1,39 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Spec.Orphans
(
)
where
import Data.ByteString
import Data.Isoparsec
import Data.Isoparsec.ByteString
import Data.Isoparsec.Chunks
import Data.Proxy
import GHC.TypeLits
import Test.Tasty.QuickCheck
import Prelude hiding ((.))
instance
(CmpNat n 0 ~ 'GT, KnownNat n, Arbitrary (Token s), Tokenable s) =>
Arbitrary (Chunk n s)
where
arbitrary = Chunk . liftTokens <$> vectorOf (fromIntegral $ natVal @n Proxy) arbitrary
instance Arbitrary ByteString where
arbitrary = liftTokens <$> listOf arbitrary
deriving instance Arbitrary (Byte16 e)
deriving instance Arbitrary (Byte32 e)
deriving instance Arbitrary (Byte64 e)

212
test/Spec/Ssh.hs Normal file
View File

@ -0,0 +1,212 @@
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Spec.Ssh
( spec,
quickSpec,
)
where
import Data.ByteString as BS
import qualified Data.Char as C
import Data.Isoparsec
import Data.Isoparsec.ByteString
import qualified Data.Word8 as W8
import GHC.Generics
import Optics
import Spec.Helper
import Spec.Orphans ()
import Test.Hspec
import Test.Tasty
import Test.Tasty.QuickCheck
import Prelude as P hiding ((.), id)
data MessageNumber
= DisconnectMsg
| IgnoreMsg
| UnimplementedMsg
| DebugMsg
| ServiceRequestMsg
| ServiceAcceptMsg
| KextInitMsg
| NewKeysMsg
deriving (Eq, Show, Ord)
instance ToIsoparsec MessageNumber ByteString where
toIsoparsec =
anyToken
>>> mapIso
[ (1, DisconnectMsg),
(2, IgnoreMsg),
(3, UnimplementedMsg),
(4, DebugMsg),
(5, ServiceRequestMsg),
(6, ServiceAcceptMsg),
(20, KextInitMsg),
(21, NewKeysMsg)
]
newtype DisconnectReasonCode
= DisconnectReasonCode {unDisconnectReasonCode :: Byte32 'BE}
deriving (Eq, Ord, Show, Generic, Arbitrary)
instance ToIsoparsec DisconnectReasonCode ByteString
newtype AlwaysDisplay = AlwaysDisplay {unAlwaysDisplay :: Bool}
deriving (Eq, Ord, Show, Generic, Arbitrary)
instance ToIsoparsec AlwaysDisplay ByteString
newtype PacketSequenceNumber
= PacketSequenceNumber {unPacketSequenceNumber :: Byte32 'BE}
deriving (Eq, Ord, Show, Generic, Arbitrary)
instance ToIsoparsec PacketSequenceNumber ByteString
data Payload
= VersionPayload String
| IgnorePayload ByteString
| ServiceRequest SSHString
| DebugPayload AlwaysDisplay SSHString
| DisconnectPayload DisconnectReasonCode String
| ServiceAccept SSHString
| UnimplementedPayload PacketSequenceNumber
deriving (Show, Eq)
instance Arbitrary Payload where
arbitrary =
oneof
[ VersionPayload . P.filter (not . C.isSpace) <$> s,
IgnorePayload <$> arbitrary,
ServiceRequest . SSHString <$> s,
DebugPayload <$> arbitrary <*> (SSHString <$> s),
DisconnectPayload <$> arbitrary <*> s,
ServiceAccept . SSHString <$> s,
UnimplementedPayload <$> arbitrary
]
where
s = getASCIIString <$> arbitrary
makePrisms ''Payload
instance ToIsoparsec Payload ByteString where
toIsoparsec =
try
( _DisconnectPayload
<.> specific DisconnectMsg
&&& auto @DisconnectReasonCode
&&& (tokensWhile (const True) >>> ftu8)
)
<+> try
( _ServiceRequest <.> specific ServiceRequestMsg
&&& auto @SSHString
)
<+> try
( _VersionPayload <.> utf8 "SSH-2.0-"
&&& ( ( try (takeUntil "\r\n" >>> check (BS.all (not . W8.isSpace)))
<+> ((takeUntil " " &&& (takeUntil "\r\n" >>> badTsnok "")) >>% morphed)
)
>>> ftu8
)
)
<+> try (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))
<+> try
( _DebugPayload <.> specific DebugMsg
&&& auto @AlwaysDisplay
&&& auto @SSHString
)
<+> try
( _UnimplementedPayload <.> specific UnimplementedMsg
&&& auto @PacketSequenceNumber
)
<+> try
( _ServiceAccept <.> specific ServiceAcceptMsg
&&& auto @SSHString
)
newtype Padding = Padding {unPadding :: ByteString}
deriving (Eq, Ord, Show, Generic, Arbitrary)
newtype ZeroPadding = ZeroPadding {zeroPaddingLength :: Byte8}
deriving (Eq, Ord, Show, Generic, Arbitrary)
badZeroPadding :: Isoparsec m ByteString => m Byte8 ZeroPadding
badZeroPadding =
throughIntegral
>>> manyTokens
>>^ siJust
(ZeroPadding . fromIntegral . BS.length)
(flip BS.replicate 0 . fromIntegral . zeroPaddingLength)
newtype MAC = MAC {unMAC :: ByteString}
deriving (Eq, Ord, Show, Generic, Arbitrary)
data NoneMAC = NoneMAC
deriving (Eq, Ord, Show, Generic)
instance ToIsoparsec NoneMAC b where
toIsoparsec = konst NoneMAC
instance Arbitrary NoneMAC where
arbitrary = return NoneMAC
data Packet mac
= Packet Payload ZeroPadding mac
deriving (Eq, Show)
instance Arbitrary mac => Arbitrary (Packet mac) where
arbitrary = Packet <$> arbitrary <*> arbitrary <*> arbitrary
makePrisms ''Packet
instance ToIsoparsec mac ByteString => ToIsoparsec (Packet mac) ByteString where
toIsoparsec =
( ( (auto @(Byte32 'BE) &&& auto @Byte8)
>>> (throughIntegral *** throughIntegral)
>>> siJust
(\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))
(\(payloadL, paddingL) -> (payloadL + paddingL + 1, paddingL))
^>> (manyTokens *** throughIntegral)
>>> (tuck (auto @Payload) *** badZeroPadding)
)
&&& auto @mac
)
>>^ siJust (\((a, b), c) -> Packet a b c) (\(Packet a b c) -> ((a, b), c))
spec :: Spec
spec = do
it "deserialize payload" $ do
"SSH-2.0-TesT\r\n" `shouldParseBS` VersionPayload "TesT"
"SSH-2.0-TesT random comment\r\n" `shouldParseBS` VersionPayload "TesT"
"\x2__" `shouldParseBS` IgnorePayload "__"
"\x5\0\0\0\x6tested" `shouldParseBS` ServiceRequest (SSHString "tested")
it "deserialize packet" $ do
("\0\0\0\xd" <> "\x2" <> "\x5\0\0\0\x5henlo" <> "69")
`shouldParseBS` Packet (ServiceRequest (SSHString "henlo")) (ZeroPadding 2) NoneMAC
("\0\0\0\xd" <> "\x2" <> "\x2\0\0\0\x5henlo" <> "69")
`shouldParseBS` Packet (IgnorePayload "\0\0\0\x5henlo") (ZeroPadding 2) NoneMAC
("\0\0\0\xd" <> "\x3" <> "\x2\0\0henlo!" <> "69a")
`shouldParseBS` Packet (IgnorePayload "\0\0henlo!") (ZeroPadding 3) NoneMAC
("\0\0\0\xb" <> "\x3" <> "\x2henlo!" <> "69a")
`shouldParseBS` Packet (IgnorePayload "henlo!") (ZeroPadding 3) NoneMAC
quickSpec :: TestTree
quickSpec =
testGroup
"roundtrips"
[ testProperty "payload" $ roundtrip @Payload @ByteString,
testProperty "packet" $ roundtrip @(Packet NoneMAC) @ByteString
]

81
test/Spec/TwoDigits.hs Normal file
View File

@ -0,0 +1,81 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Spec.TwoDigits
( spec,
quickSpec,
)
where
import Data.Char
import Data.Either
import Data.Isoparsec
import Data.Isoparsec.Chunks
import Data.Isoparsec.Megaparsec
import Data.Isoparsec.Printer
import Data.Maybe
import Data.Void
import GHC.Generics
import Test.Hspec
import Test.Tasty
import Test.Tasty.QuickCheck
import Text.Megaparsec.Error
import Prelude hiding ((.))
newtype SingleDigit = SingleDigit {unSingleDigit :: String}
deriving (Eq, Show, Generic)
instance ToIsoparsec SingleDigit String where
toIsoparsec =
toIsoparsec @(Chunk 1 String)
>>> coercing
>>> check (all @[] isDigit)
>>> coercing
instance (Arbitrary SingleDigit) where
arbitrary = SingleDigit . pure <$> elements ['0' .. '9']
data Digits
= FourDigits SingleDigit SingleDigit SingleDigit SingleDigit
| ThreeDigits SingleDigit SingleDigit SingleDigit
| TwoDigits SingleDigit SingleDigit
deriving (Generic, Show, Eq)
instance Arbitrary Digits where
arbitrary =
oneof
[ FourDigits <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary,
ThreeDigits <$> arbitrary <*> arbitrary <*> arbitrary,
TwoDigits <$> arbitrary <*> arbitrary
]
instance ToIsoparsec Digits String
spec :: Spec
spec = do
let parser = toIsoparsec
it "deserializes" $ do
runMegaparsec @() parser "12" `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))
runMegaparsec @() parser "125" `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))
runMegaparsec @() parser "1253" `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))
runMegaparsec @() parser "12538" `shouldSatisfy` isLeft
runMegaparsec @() parser "2" `shouldSatisfy` isLeft
runMegaparsec @() parser "a" `shouldSatisfy` isLeft
runMegaparsec @() parser "1a" `shouldSatisfy` isLeft
quickSpec :: TestTree
quickSpec = testProperty "roundtrips" $ \x ->
let s = fromJust $ runPrinter @Maybe @String parser x
in counterexample s $ case runMegaparsec @Void parser s of
Right y -> property $ x == y
Left err -> counterexample (errorBundlePretty err) False
where
parser :: Isoparsec m String => m () Digits
parser = toIsoparsec