2746b08 · isoparsec · git.iko.soy

git.iko.soy/isoparsec

added unit operators (#41)

* Added more operators and removed uses of morphed # Conflicts: # src/Data/Isoparsec/Internal.hs * Added more json tests * 🔥 parseSatisfyS

commit2746b085b1957c6b8555d9d1d61c2f74f3d84135 authoriko <ilyakooo0@gmail.com> dateThu 20 Feb 2020, 12:09 (7 years ago) parent3afcafd

6 files changed+110−44

compare with master

unifiedsplit

src/Control/SemiIso.hs+71 src/Data/Isoparsec.hs+1−2 src/Data/Isoparsec/Internal.hs−30 test/Spec.hs+3−1 test/Spec/Helper.hs+13 test/Spec/JSON.hs+22−11

src/Control/SemiIso.hs+71

@@ -9,6 +9,21 @@ module Control.SemiIso

99 AlternativeMonad,

1010 maskr,

1111 maskl,

12+ isoCheck,

13+ siCheck,

14+ check,

15+ konst,

16+ isoConst,

17+ assoc,

18+ ($$$),

19+ (*>>),

20+ (**>),

21+ (>>*),

22+ (>**),

23+ (<<*),

24+ (<**),

25+ (*<<),

26+ (**<),

1227 )

1328where

1429

@@ -90,3 +105,59 @@ maskr (SemiIso e p) = SemiIso (\a -> e a <|> pure ()) p

90105

91106maskl :: SemiIso () b -> SemiIso () b

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

108+

109+infixl 1 *>>, **>, >>*, >**, <<*, <**, *<<, **<

110+

111+infixl 3 $$$

112+

113+($$$) :: (PolyArrow m SemiIso, Eq b) => m a b -> m c b -> m (a, c) b

114+a $$$ c = a *** c >>^ check (uncurry (==)) >>^ siPure fst (\x -> (x, x))

115+

116+(*>>) :: (PolyArrow m SemiIso) => m a () -> m a b -> m a b

117+a *>> b = a &&& b >>^ siPure snd ((),)

118+

119+(**>) :: (PolyArrow m SemiIso) => m () () -> m a b -> m a b

120+a **> b = siPure ((),) snd ^>> a *** b >>^ siPure snd ((),)

121+

122+(>>*) :: (PolyArrow m SemiIso, Eq b) => m a b -> m () b -> m a b

123+a >>* b = siPure (,()) fst ^>> a $$$ b

124+

125+(>**) :: (PolyArrow m SemiIso) => m a b -> m () () -> m a b

126+a >** b = siPure (,()) fst ^>> a *** b >>^ siPure fst (,())

127+

128+(<<*) :: (PolyArrow m SemiIso, Eq b) => m a b -> m () b -> m a b

129+a <<* b = siPure ((),) snd ^>> b $$$ a

130+

131+(<**) :: (PolyArrow m SemiIso) => m a b -> m () () -> m a b

132+a <** b = siPure ((),) snd ^>> b *** a >>^ siPure snd ((),)

133+

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

135+a *<< b = b &&& a >>^ siPure fst (,())

136+

137+(**<) :: (PolyArrow m SemiIso) => m () () -> m a b -> m a b

138+a **< b = siPure (,()) fst ^>> b *** a >>^ siPure fst (,())

139+

140+check :: (s -> Bool) -> SemiIso s s

141+check f = isoCheck f id id

142+

143+siCheck ::

144+ (s -> Bool) ->

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

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

147+ SemiIso s a

148+siCheck f a b =

149+ SI

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

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

152+

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

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

155+

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

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

158+

159+konst :: Eq x => x -> SemiIso () x

160+konst x = isoConst () x >>> check (== x)

161+

162+assoc :: SemiIso (a, (b, c)) ((a, b), c)

163+assoc = siPure (\(a, (b, c)) -> ((a, b), c)) (\((a, b), c) -> (a, (b, c)))

src/Data/Isoparsec.hs+1−2

@@ -48,8 +48,7 @@ b <.> p = (p >>^ morphed) >>^ si b

4848coercing :: forall b a. Coercible a b => SemiIso a b

4949coercing = siPure coerce coerce

5050

51−morphed ::

52− (TupleMorphable a c, TupleMorphable b c) => SemiIso a b

51+morphed :: (TupleMorphable a c, TupleMorphable b c) => SemiIso a b

5352morphed = siPure morphTuples morphTuples

5453

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

src/Data/Isoparsec/Internal.hs−30

@@ -2,14 +2,9 @@ module Data.Isoparsec.Internal

22 ( module X,

33 IsoparsecFail (..),

44 Isoparsec (..),

5− konst,

65 siCons,

7− isoCheck,

8− siCheck,

9− check,

106 unroll,

117 arrowsWhile,

12− assoc,

138 arrowsUntil,

149 )

1510where

@@ -100,28 +95,3 @@ siCons =

10095

10196class IsoparsecFail m e where

10297 failure :: e -> m a b

103−

104−siCheck ::

105− (s -> Bool) ->

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

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

108− SemiIso s a

109−siCheck f a b =

110− SI

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

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

113−

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

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

116−

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

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

119−

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

121−check f = isoCheck f id id

122−

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

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

125−

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

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

test/Spec.hs+3−1

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

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

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

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

13+ jsonSpec <- testSpec "json spec" JSON.spec

1314 defaultMain

1415 ( testGroup

1516 "tests"

@@ -20,7 +21,8 @@ main = do

2021 ],

2122 testGroup

2223 "JSON"

23− [ JSON.quickSpec

24+ [ jsonSpec,

25+ JSON.quickSpec

2426 ],

2527 testGroup

2628 "TwoDigits"

test/Spec/Helper.hs+13

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

22 ( shouldParseBS,

33 roundtrip,

44 parseSatisfyBS,

5+ shouldParseS,

56 )

67where

@@ -70,6 +71,18 @@ shouldParseBS ::

7071 Expectation

7172shouldParseBS = shouldParse

7273

74+shouldParseS ::

75+ forall x.

76+ ( ToIsoparsec x String,

77+ Show x,

78+ Eq x,

79+ Isoparsec (Kleisli (Parsec Void String)) String

80+ ) =>

81+ String ->

82+ x ->

83+ Expectation

84+shouldParseS = shouldParse

85+

7386roundtrip ::

7487 forall x s.

7588 ( ToIsoparsec x s,

test/Spec/JSON.hs+22−11

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

33module Spec.JSON

44 ( quickSpec,

5+ spec,

56 )

67where

@@ -13,6 +14,8 @@ import Data.Isoparsec.Megaparsec

1314import Data.Isoparsec.Printer

1415import Data.Maybe

1516import Data.Void

17+import Spec.Helper

18+import Test.Hspec

1619import Test.Tasty

1720import Test.Tasty.QuickCheck

1821import Text.Megaparsec.Error

@@ -41,6 +44,15 @@ instance Arbitrary JSON where

4144

4245makePrisms ''JSON

4346

47+spec :: Spec

48+spec =

49+ it "deserializes" $ do

50+ "{\"foo\": 8}" `shouldParseS` Object [("foo", JInteger 8)]

51+ "{\"foo\": 8, \"\": \"\"}" `shouldParseS` Object [("foo", JInteger 8), ("", JString "")]

52+ "{}" `shouldParseS` Object []

53+ "[{\"foo\": 8}, 2, 3]" `shouldParseS` Array [Object [("foo", JInteger 8)], JInteger 2, JInteger 3]

54+ "[{\"foo\": \"oh no\"}, 2, 3]" `shouldParseS` Array [Object [("foo", JString "oh no")], JInteger 2, JInteger 3]

55+

4456quickSpec :: TestTree

4557quickSpec =

4658 testProperty "roundtrips" $ \x ->

@@ -49,22 +61,20 @@ quickSpec =

4961 Right y -> property $ x == y

5062 Left err -> counterexample (errorBundlePretty err) False

5163

64+instance ToIsoparsec JSON String where

65+ toIsoparsec = json

66+

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

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

5469 where

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

70+ string' = token '"' **> tokensWhile (/= '"') >** token '"'

5671 string = _JString <.> string'

5772 array =

5873 _Array

5974 <.> token '['

6075 &&& unsafeWhiteSpace

61− &&& ( ( ( ( json &&& unsafeWhiteSpace

62− &&& repeating

63− ( (token ',' &&& unsafeWhiteSpace &&& json) >>^ morphed

64− )

65− <+^ konst []

66− )

67− >>^ morphed

76+ &&& ( ( ( (json >** unsafeWhiteSpace)

77+ &&& repeating (token ',' *>> unsafeWhiteSpace >>> json) <+^ konst []

6878 )

6979 >>^ siCons

7080 )

@@ -75,10 +85,11 @@ json = SI pure pure ^<< (string <+> array <+> integer <+> object)

7585 integer = _JInteger <.> number

7686 object =

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

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

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

80− )

88+ &&& ( (pair &&& repeating (token ',' **> unsafeWhiteSpace **> pair) <+^ konst [] >>^ siCons)

8189 <+^ konst []

8290 )

8391 &&& unsafeWhiteSpace

8492 &&& token '}'

93+ pair =

94+ (unsafeWhiteSpace **> string' >** unsafeWhiteSpace >** token ':' >** unsafeWhiteSpace)

95+ &&& (json >** unsafeWhiteSpace)