git.iko.soy/isoparsec
on master help sign in
Removed try (#25)

* Removed try * fixed hlint and added extensions

commit5da78b3f15820ddba8fb72906817e9e1f4ad36a4 authoriko <ilyakooo0@gmail.com> dateSun 9 Feb 2020, 21:16 (7 years ago) parent7e12587
11 files changed+79−75
compare with master
unifiedsplit
.hlint.yaml+25 src/Control/Prism.hs+2−2 src/Control/SemiIso.hs+1−5 src/Data/Isoparsec.hs+6−6 src/Data/Isoparsec/Internal.hs+3−7 src/Data/Isoparsec/Megaparsec.hs+3−3 src/Data/Isoparsec/Printer.hs−3 src/Data/Isoparsec/ToIsoparsec.hs+1−1 stack.yaml+1−1 test/Spec/JSON.hs+12−16 test/Spec/Ssh.hs+25−31
.hlint.yaml+25
@@ -60,3 +60,28 @@
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
src/Control/Prism.hs+2−2
@@ -20,12 +20,12 @@ instance Profunctor (Market a b) where
2020 rmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)
2121
2222instance Choice (Market a b) where
23− left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of
23+ left' (Market bt seta) = Market (Left . bt) $ \case
2424 Left s -> case seta s of
2525 Left t -> Left (Left t)
2626 Right a -> Right a
2727 Right c -> Left (Right c)
28− right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of
28+ right' (Market bt seta) = Market (Right . bt) $ \case
2929 Left c -> Left (Left c)
3030 Right s -> case seta s of
3131 Left t -> Left (Right t)
src/Control/SemiIso.hs+1−5
@@ -11,11 +11,7 @@ module Control.SemiIso
1111where
1212
1313import Control.Applicative as X
14−import Control.Arrow.Extra.ArrowChoice
15−import Control.Arrow.Extra.ArrowPlus
16−import Control.Arrow.Extra.ArrowZero
17−import Control.Arrow.Extra.BaseArrow
18−import Control.Category (Category (..))
14+import Control.Arrow.Extra
1915import Control.Monad as X
2016import Data.Bitraversable
2117import Prelude hiding ((.), id)
src/Data/Isoparsec.hs+6−6
@@ -37,14 +37,14 @@ import Data.Isoparsec.Tokenable as X
3737import qualified Data.Map as M
3838import Prelude hiding ((.), fail, id)
3939
40−opt :: (ArrowPlus m, IsoparsecTry m, PolyArrow m SemiIso) => m () () -> m () ()
41−opt m = try m <+> konst ()
40+opt :: (ArrowPlus m, PolyArrow m SemiIso) => m () () -> m () ()
41+opt m = m <+> konst ()
4242
43−opt' :: (ArrowPlus m, IsoparsecTry m, PolyArrow m SemiIso, Eq a) => a -> m () a -> m () ()
44−opt' a m = (try m >>> tsnok a) <+> konst ()
43+opt' :: (ArrowPlus m, PolyArrow m SemiIso, Eq a) => a -> m () a -> m () ()
44+opt' a m = (m >>> tsnok a) <+> konst ()
4545
46−repeating :: (PolyArrow m SemiIso, IsoparsecTry m, ArrowPlus m, Eq b) => m () b -> m () [b]
47−repeating m = (try m &&& (try (repeating m) <+> konst [])) >>^ cons'
46+repeating :: (PolyArrow m SemiIso, ArrowPlus m, Eq b) => m () b -> m () [b]
47+repeating m = (m &&& (repeating m <+> konst [])) >>^ cons'
4848
4949infixr 1 %>>
5050
src/Data/Isoparsec/Internal.hs+3−7
@@ -2,7 +2,6 @@ module Data.Isoparsec.Internal
22 ( module X,
33 IsoparsecFail (..),
44 Isoparsec (..),
5− IsoparsecTry (..),
65 konst,
76 tsnok,
87 cons',
@@ -24,7 +23,7 @@ import Numeric.Natural
2423import Prelude as P hiding ((.), id)
2524
2625class
27− (PolyArrow m SemiIso, ArrowPlus m, ArrowChoice m, IsoparsecTry m, Tokenable s) =>
26+ (PolyArrow m SemiIso, ArrowPlus m, ArrowChoice m, Tokenable s) =>
2827 Isoparsec m s
2928 | m -> s where
3029 {-# MINIMAL anyToken, manyTokens, tuck #-}
@@ -59,14 +58,14 @@ class
5958 default takeUntil :: Eq (Token s) => s -> m () s
6059 takeUntil s = takeUntil' s >>^ levitate
6160 where
62− takeUntil' s' = try (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ cons')
61+ takeUntil' s' = (chunk s' >>> konst []) <+> ((anyToken &&& takeUntil' s') >>^ cons')
6362
6463 default tokensWhile :: (Token s -> Bool) -> m () s
6564 tokensWhile f =
6665 tokensWhile' f >>> check (P.all f) >>^ levitate
6766 where
6867 tokensWhile' g =
69− try (tokenWhere g &&& tokensWhile' g >>^ cons')
68+ (tokenWhere g &&& tokensWhile' g >>^ cons')
7069 <+^ isoConst' () []
7170
7271 tokensWhile1 :: (Token s -> Bool) -> m () s
@@ -108,9 +107,6 @@ cons' =
108107levitate :: Tokenable s => SemiIso [Token s] s
109108levitate = siJust liftTokens lowerTokens
110109
111−class IsoparsecTry m where
112− try :: m a b -> m a b
113−
114110class IsoparsecFail m e where
115111 failure :: e -> m a b
116112
src/Data/Isoparsec/Megaparsec.hs+3−3
@@ -22,9 +22,6 @@ runMegaparsec ::
2222 Either (ParseErrorBundle s e) r
2323runMegaparsec (Kleisli f) = runParser (f () <* eof) ""
2424
25−instance (MonadParsec e s m) => IsoparsecTry (Kleisli m) where
26− try (Kleisli f) = Kleisli $ \a -> M.try (f a)
27−
2825instance (MonadParsec e s m) => PolyArrow (Kleisli m) SemiIso where
2926 arr si = Kleisli $ \t -> case embed si t of
3027 Just x -> return x
@@ -49,3 +46,6 @@ instance
4946
5047instance MonadParsec e s m => IsoparsecFail (Kleisli m) e where
5148 failure e = Kleisli $ \_ -> customFailure e
49+
50+instance (MonadParsec e s m, M.Token s ~ Token s, s ~ M.Tokens s) => ArrowPlus (Kleisli m) where
51+ (Kleisli lhs) <+> (Kleisli rhs) = Kleisli $ \x -> try (lhs x) <|> rhs x
src/Data/Isoparsec/Printer.hs−3
@@ -24,9 +24,6 @@ instance IsoparsecFail (Cokleisli (WriterT s Maybe)) e where
2424instance IsoparsecFail (Cokleisli (WriterT s (Either e))) e where
2525 failure = Cokleisli . const . WriterT . Left
2626
27−instance IsoparsecTry (Cokleisli (WriterT (Dual s) m)) where
28− try = id
29−
3027instance
3128 (MonadPlus m, Monoid s, Eq (Token s), Tokenable s, Show s) =>
3229 Isoparsec (Cokleisli (WriterT (Dual s) m)) s
src/Data/Isoparsec/ToIsoparsec.hs+1−1
@@ -38,7 +38,7 @@ instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :*: b) s where
3838
3939instance (GToIsoparsec a s, GToIsoparsec b s) => GToIsoparsec (a :+: b) s where
4040 gToIsoparsec =
41− ( try (gToIsoparsec >>^ SI (pure . Left) (either pure (const empty)))
41+ ( (gToIsoparsec >>^ SI (pure . Left) (either pure (const empty)))
4242 <+> (gToIsoparsec >>^ SI (pure . Right) (either (const empty) pure))
4343 )
4444 >>> (arr (SI (pure . L1) fromL) ||| arr (SI (pure . R1) fromR))
stack.yaml+1−1
@@ -70,4 +70,4 @@ extra-deps:
7070# compiler-check: newer-minor
7171
7272ghc-options:
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
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 -Wunused-imports
test/Spec/JSON.hs+12−16
@@ -50,7 +50,7 @@ quickSpec =
5050 Left err -> counterexample (errorBundlePretty err) False
5151
5252json :: (PolyArrow m SemiIso, Isoparsec m String) => m () JSON
53−json = SI pure pure ^<< (try string <+> try array <+> try integer <+> object)
53+json = SI pure pure ^<< (string <+> array <+> integer <+> object)
5454 where
5555 string' = token '"' &&& tokensWhile (/= '"') &&& token '"'
5656 string = _JString <.> string'
@@ -58,19 +58,16 @@ json = SI pure pure ^<< (try string <+> try array <+> try integer <+> object)
5858 _Array
5959 <.> token '['
6060 &&& unsafeWhiteSpace
61− &&& ( try
62− ( ( ( json &&& unsafeWhiteSpace
63− &&& try
64− ( repeating
65− ( (token ',' &&& unsafeWhiteSpace &&& json) >>% morphed
66− )
67− )
68− <+> konst []
69− )
70− >>% morphed
61+ &&& ( ( ( ( json &&& unsafeWhiteSpace
62+ &&& repeating
63+ ( (token ',' &&& unsafeWhiteSpace &&& json) >>% morphed
64+ )
65+ <+> konst []
7166 )
72− >>^ cons'
67+ >>% morphed
7368 )
69+ >>^ cons'
70+ )
7471 <+> konst []
7572 )
7673 &&& unsafeWhiteSpace
@@ -78,10 +75,9 @@ json = SI pure pure ^<< (try string <+> try array <+> try integer <+> object)
7875 integer = _JInteger <.> number
7976 object =
8077 _Object <.> token '{' &&& unsafeWhiteSpace
81− &&& ( try
82− ( let pair = (unsafeWhiteSpace &&& string' &&& unsafeWhiteSpace &&& token ':' &&& unsafeWhiteSpace &&& json &&& unsafeWhiteSpace) >>^ morphed
83− in (pair &&& try (repeating ((token ',' &&& unsafeWhiteSpace &&& pair) >>^ morphed) <+> konst [])) >>^ cons'
84− )
78+ &&& ( ( let pair = (unsafeWhiteSpace &&& string' &&& unsafeWhiteSpace &&& token ':' &&& unsafeWhiteSpace &&& json &&& unsafeWhiteSpace) >>^ morphed
79+ in (pair &&& (repeating ((token ',' &&& unsafeWhiteSpace &&& pair) >>^ morphed) <+> konst [])) >>^ cons'
80+ )
8581 <+> konst []
8682 )
8783 &&& unsafeWhiteSpace
test/Spec/Ssh.hs+25−31
@@ -90,38 +90,32 @@ makePrisms ''Payload
9090
9191instance ToIsoparsec Payload ByteString where
9292 toIsoparsec =
93− try
94− ( _DisconnectPayload
95− <.> specific DisconnectMsg
96− &&& auto @DisconnectReasonCode
97− &&& (tokensWhile (const True) >>> ftu8)
98− )
99− <+> try
100− ( _ServiceRequest <.> specific ServiceRequestMsg
101− &&& auto @SSHString
102− )
103− <+> try
104− ( _VersionPayload <.> utf8 "SSH-2.0-"
105− &&& ( ( try (takeUntil "\r\n" >>> check (BS.all (not . W8.isSpace)))
106− <+> ((takeUntil " " &&& (takeUntil "\r\n" >>> badTsnok "")) >>% morphed)
93+ ( _DisconnectPayload
94+ <.> specific DisconnectMsg
95+ &&& auto @DisconnectReasonCode
96+ &&& (tokensWhile (const True) >>> ftu8)
97+ )
98+ <+> ( _ServiceRequest <.> specific ServiceRequestMsg
99+ &&& auto @SSHString
100+ )
101+ <+> ( _VersionPayload <.> utf8 "SSH-2.0-"
102+ &&& ( ( (takeUntil "\r\n" >>> check (BS.all (not . W8.isSpace)))
103+ <+> ((takeUntil " " &&& (takeUntil "\r\n" >>> badTsnok "")) >>% morphed)
104+ )
105+ >>> ftu8
107106 )
108− >>> ftu8
109− )
110− )
111− <+> try (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))
112− <+> try
113− ( _DebugPayload <.> specific DebugMsg
114− &&& auto @AlwaysDisplay
115− &&& auto @SSHString
116− )
117− <+> try
118− ( _UnimplementedPayload <.> specific UnimplementedMsg
119− &&& auto @PacketSequenceNumber
120− )
121− <+> try
122− ( _ServiceAccept <.> specific ServiceAcceptMsg
123− &&& auto @SSHString
124− )
107+ )
108+ <+> (_IgnorePayload <.> specific IgnoreMsg &&& tokensWhile (const True))
109+ <+> ( _DebugPayload <.> specific DebugMsg
110+ &&& auto @AlwaysDisplay
111+ &&& auto @SSHString
112+ )
113+ <+> ( _UnimplementedPayload <.> specific UnimplementedMsg
114+ &&& auto @PacketSequenceNumber
115+ )
116+ <+> ( _ServiceAccept <.> specific ServiceAcceptMsg
117+ &&& auto @SSHString
118+ )
125119
126120newtype Padding = Padding {unPadding :: ByteString}
127121 deriving (Eq, Ord, Show, Generic, Arbitrary)