mirror of
https://github.com/ilyakooo0/isoparsec.git
synced 2024-11-22 04:43:48 +03:00
Added newtypes and optimized implementations (#48)
This commit is contained in:
GitHub
parent
ef948c15d5
commit
23e8888625
@ -28,6 +28,7 @@ dependencies:
|
||||
- mtl
|
||||
- profunctors
|
||||
- mono-traversable
|
||||
- split
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
|
||||
@ -1,8 +1,9 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Data.Isoparsec.Megaparsec
|
||||
( runMegaparsec,
|
||||
runMegaparsecT,
|
||||
( runMegaparsecParser,
|
||||
ParseErrorBundle (..),
|
||||
MegaparsecParser (..),
|
||||
)
|
||||
where
|
||||
|
||||
@ -10,24 +11,30 @@ import Control.Arrow.Extra
|
||||
import Control.Arrow.Extra.Orphans ()
|
||||
import Control.Monad
|
||||
import Data.Functor
|
||||
import Data.Isoparsec.Internal as I
|
||||
import Data.Functor.Identity
|
||||
import Data.Isoparsec
|
||||
import Data.Void
|
||||
import Text.Megaparsec hiding (Token)
|
||||
import qualified Text.Megaparsec as M
|
||||
import Prelude hiding ((.))
|
||||
|
||||
runMegaparsec ::
|
||||
(Ord e, Stream s) =>
|
||||
s ->
|
||||
Kleisli (Parsec e s) () r ->
|
||||
Either (ParseErrorBundle s e) r
|
||||
runMegaparsec s (Kleisli f) = runParser (f () <* eof) "" s
|
||||
newtype MegaparsecParser s a b
|
||||
= MegaparsecParser {unMegaparsecParser :: Kleisli (ParsecT Void s Identity) a b}
|
||||
deriving (Category, BaseArrow, ArrowZero, ArrowChoice, PolyArrow SemiIso)
|
||||
|
||||
runMegaparsecT ::
|
||||
(Ord e, Stream s, Monad m) =>
|
||||
instance
|
||||
(Stream s, s ~ M.Tokens s, Element s ~ M.Token s) =>
|
||||
ArrowPlus (MegaparsecParser s)
|
||||
where
|
||||
(MegaparsecParser (Kleisli lhs)) <+> (MegaparsecParser (Kleisli rhs)) =
|
||||
MegaparsecParser . Kleisli $ \x -> try (lhs x) <|> rhs x
|
||||
|
||||
runMegaparsecParser ::
|
||||
(Stream s) =>
|
||||
s ->
|
||||
Kleisli (ParsecT e s m) () r ->
|
||||
m (Either (ParseErrorBundle s e) r)
|
||||
runMegaparsecT s (Kleisli f) = runParserT (f () <* eof) "" s
|
||||
MegaparsecParser s () r ->
|
||||
Either (ParseErrorBundle s Void) r
|
||||
runMegaparsecParser s (MegaparsecParser (Kleisli f)) = runParser (f () <* eof) "" s
|
||||
|
||||
instance (MonadParsec e s m) => PolyArrow SemiIso (Kleisli m) where
|
||||
arr si = Kleisli $ \t -> case embed si t of
|
||||
@ -35,24 +42,47 @@ instance (MonadParsec e s m) => PolyArrow SemiIso (Kleisli m) where
|
||||
Nothing -> M.failure Nothing mempty
|
||||
|
||||
instance
|
||||
(MonadParsec e s m, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>
|
||||
Isoparsec (Kleisli m) s
|
||||
(Stream s, M.Token s ~ Element s, s ~ M.Tokens s, IsSequence s) =>
|
||||
Isoparsec (MegaparsecParser s) s
|
||||
where
|
||||
anyToken = Kleisli $ const anySingle
|
||||
anyToken = MegaparsecParser . Kleisli $ const anySingle
|
||||
|
||||
token t = Kleisli . const $ M.single t $> ()
|
||||
token t = MegaparsecParser . Kleisli . const $ M.single t $> ()
|
||||
|
||||
manyTokens = Kleisli $ takeP Nothing . fromIntegral
|
||||
token' = MegaparsecParser . Kleisli $ \t -> M.single t $> t
|
||||
|
||||
tuck' (Kleisli f) = Kleisli $ \(x, sub) -> do
|
||||
tokens ts = MegaparsecParser . Kleisli . const $ M.chunk (fromList ts) $> ()
|
||||
|
||||
tokens' = MegaparsecParser . Kleisli $ \ts -> M.chunk (fromList ts) $> ts
|
||||
|
||||
chunk c = MegaparsecParser . Kleisli . const $ M.chunk c $> ()
|
||||
|
||||
chunk' = MegaparsecParser . Kleisli $ \c -> M.chunk c $> c
|
||||
|
||||
notToken t = MegaparsecParser . Kleisli . const $ M.anySingleBut t
|
||||
|
||||
tokenWhere f = MegaparsecParser . Kleisli . const $ satisfy f
|
||||
|
||||
manyTokens = MegaparsecParser . Kleisli $ takeP Nothing . fromIntegral
|
||||
|
||||
takeUntil c = MegaparsecParser . Kleisli $ \() -> do
|
||||
ta <- M.manyTill M.anySingle (M.chunk c)
|
||||
return $ fromList ta
|
||||
|
||||
tokensWhile f = MegaparsecParser . Kleisli . const $ M.takeWhileP Nothing f
|
||||
|
||||
tokensWhile1 f = MegaparsecParser . Kleisli . const $ M.takeWhile1P Nothing f
|
||||
|
||||
tuck (MegaparsecParser (Kleisli f)) = MegaparsecParser . Kleisli $ \sub -> do
|
||||
sup <- getInput
|
||||
setInput sub
|
||||
r <- f () <* eof
|
||||
setInput sup
|
||||
return r
|
||||
|
||||
tuck' (MegaparsecParser (Kleisli f)) = MegaparsecParser . Kleisli $ \(x, sub) -> do
|
||||
sup <- getInput
|
||||
setInput sub
|
||||
r <- f x <* eof
|
||||
setInput sup
|
||||
return r
|
||||
|
||||
instance MonadParsec e s m => IsoparsecFail (Kleisli m) e where
|
||||
failure e = Kleisli $ \_ -> customFailure e
|
||||
|
||||
instance (MonadParsec e s m, M.Token s ~ Element s, s ~ M.Tokens s) => ArrowPlus (Kleisli m) where
|
||||
(Kleisli lhs) <+> (Kleisli rhs) = Kleisli $ \x -> try (lhs x) <|> rhs x
|
||||
|
||||
@ -1,39 +1,83 @@
|
||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||
|
||||
module Data.Isoparsec.Printer
|
||||
( runPrinter,
|
||||
( runMonoidPrinter,
|
||||
MonoidPrinter (..),
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Cokleisli
|
||||
import Control.Monad.Writer.Lazy
|
||||
import Data.Functor
|
||||
import Data.Isoparsec
|
||||
import Data.List.Split
|
||||
import Prelude hiding ((.), id)
|
||||
|
||||
runPrinter ::
|
||||
forall m s a.
|
||||
Monad m =>
|
||||
Cokleisli (WriterT (Dual s) m) () a ->
|
||||
newtype MonoidPrinter s a b
|
||||
= MonoidPrinter {unMonoidPrinter :: Cokleisli (WriterT (Dual s) Maybe) a b}
|
||||
deriving (Category, BaseArrow, ArrowZero, ArrowPlus, ArrowChoice, PolyArrow SemiIso)
|
||||
|
||||
runMonoidPrinter ::
|
||||
forall s a.
|
||||
MonoidPrinter s () a ->
|
||||
a ->
|
||||
m s
|
||||
runPrinter p = fmap getDual . execWriterT . runCokleisli p
|
||||
Maybe s
|
||||
runMonoidPrinter p = fmap getDual . execWriterT . runCokleisli (unMonoidPrinter p)
|
||||
|
||||
instance IsoparsecFail (Cokleisli (WriterT s Maybe)) e where
|
||||
failure _ = Cokleisli . const $ WriterT Nothing
|
||||
|
||||
instance IsoparsecFail (Cokleisli (WriterT s (Either e))) e where
|
||||
failure = Cokleisli . const . WriterT . Left
|
||||
instance IsoparsecFail (MonoidPrinter s) e where
|
||||
failure _ = MonoidPrinter . Cokleisli . const $ WriterT Nothing
|
||||
|
||||
instance
|
||||
(MonadPlus m, Monoid s, Eq (Element s), Eq s, IsSequence s, Show s) =>
|
||||
Isoparsec (Cokleisli (WriterT (Dual s) m)) s
|
||||
(Monoid s, Eq (Element s), IsSequence s) =>
|
||||
Isoparsec (MonoidPrinter s) s
|
||||
where
|
||||
token t = Cokleisli $ const $ tell . Dual . singleton $ t
|
||||
anyToken = MonoidPrinter . Cokleisli $ tell . Dual . singleton
|
||||
|
||||
anyToken = Cokleisli $ tell . Dual . singleton
|
||||
token t = MonoidPrinter . Cokleisli $ const $ tell . Dual . singleton $ t
|
||||
|
||||
manyTokens = Cokleisli $ \w -> do
|
||||
token' = MonoidPrinter . Cokleisli $ \t -> (tell . Dual . singleton) t $> t
|
||||
|
||||
tokens ts = MonoidPrinter . Cokleisli $ const $ tell . Dual . fromList $ ts
|
||||
|
||||
tokens' = MonoidPrinter . Cokleisli $ \ts -> (tell . Dual . fromList) ts $> ts
|
||||
|
||||
chunk c = MonoidPrinter . Cokleisli . const $ tell . Dual $ c
|
||||
|
||||
chunk' = MonoidPrinter . Cokleisli $ \c -> (tell . Dual) c $> c
|
||||
|
||||
notToken nt = MonoidPrinter . Cokleisli $ \t ->
|
||||
if t == nt
|
||||
then empty
|
||||
else (tell . Dual . singleton) t
|
||||
|
||||
tokenWhere f = MonoidPrinter . Cokleisli $ \t ->
|
||||
if f t
|
||||
then (tell . Dual . singleton) t
|
||||
else empty
|
||||
|
||||
manyTokens = MonoidPrinter . Cokleisli $ \w -> do
|
||||
tell $ Dual w
|
||||
return . fromIntegral . olength $ w
|
||||
|
||||
tuck' (Cokleisli f) = Cokleisli $ lift . (fmap . fmap) getDual . runWriterT . f
|
||||
takeUntil end = MonoidPrinter . Cokleisli $ \s ->
|
||||
if length ((split . onSublist $ otoList end) . otoList $ s) > 1
|
||||
then empty
|
||||
else do
|
||||
tell . Dual $ s
|
||||
tell . Dual $ end
|
||||
|
||||
tokensWhile f = MonoidPrinter . Cokleisli $ \s ->
|
||||
if oall f s
|
||||
then (tell . Dual) s
|
||||
else empty
|
||||
|
||||
tokensWhile1 f = MonoidPrinter . Cokleisli $ \s ->
|
||||
if oall f s && not (onull s)
|
||||
then (tell . Dual) s
|
||||
else empty
|
||||
|
||||
tuck (MonoidPrinter (Cokleisli f)) =
|
||||
MonoidPrinter . Cokleisli $ lift . fmap getDual . execWriterT . f
|
||||
|
||||
tuck' (MonoidPrinter (Cokleisli f)) =
|
||||
MonoidPrinter . Cokleisli $ lift . (fmap . fmap) getDual . runWriterT . f
|
||||
|
||||
@ -42,6 +42,3 @@ instance (GToIsoparsec a s m, GToIsoparsec b s m) => GToIsoparsec (a :+: b) s m
|
||||
fromL _ = empty
|
||||
fromR (R1 b) = pure b
|
||||
fromR _ = empty
|
||||
|
||||
instance {-# OVERLAPPABLE #-} t ~ Element s => ToIsoparsec t s m where
|
||||
toIsoparsec = anyToken
|
||||
|
||||
@ -27,7 +27,7 @@ instance ArrowReader String a => ToIsoparsec ConstSep String a where
|
||||
spec :: Spec
|
||||
spec = do
|
||||
let run (sep :: String) (s :: String) =
|
||||
runMegaparsec @() s . runReaderArrow sep $ (auto @ConstSep)
|
||||
runMegaparsecParser s . runReaderArrow sep $ (auto @ConstSep)
|
||||
it "deserializes" $ do
|
||||
run "s" "12s31" `shouldBe` Right (ConstSep 12 31)
|
||||
run " " "12 31" `shouldBe` Right (ConstSep 12 31)
|
||||
|
||||
@ -6,8 +6,6 @@ module Spec.Helper
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Cokleisli
|
||||
import Control.Monad.Writer.Lazy
|
||||
import Data.ByteString as BS
|
||||
import Data.Either
|
||||
import Data.Isoparsec as I
|
||||
@ -23,23 +21,23 @@ import Prelude as P hiding ((.))
|
||||
|
||||
parseSatisfy ::
|
||||
forall x s.
|
||||
( ToIsoparsec x s (Kleisli (Parsec Void s)),
|
||||
( ToIsoparsec x s (MegaparsecParser s),
|
||||
Stream s,
|
||||
Show x,
|
||||
Show (M.Token s),
|
||||
Show s,
|
||||
Isoparsec (Kleisli (Parsec Void s)) s
|
||||
Isoparsec (MegaparsecParser s) s
|
||||
) =>
|
||||
s ->
|
||||
(Either (ParseErrorBundle s Void) x -> Bool) ->
|
||||
Expectation
|
||||
parseSatisfy s p = runMegaparsec @Void @s s toIsoparsec `shouldSatisfy` p
|
||||
parseSatisfy s p = runMegaparsecParser @s s toIsoparsec `shouldSatisfy` p
|
||||
|
||||
parseSatisfyBS ::
|
||||
forall x.
|
||||
( ToIsoparsec x ByteString (Kleisli (Parsec Void ByteString)),
|
||||
( ToIsoparsec x ByteString (MegaparsecParser ByteString),
|
||||
Show x,
|
||||
Isoparsec (Kleisli (Parsec Void ByteString)) ByteString
|
||||
Isoparsec (MegaparsecParser ByteString) ByteString
|
||||
) =>
|
||||
ByteString ->
|
||||
(Either (ParseErrorBundle ByteString Void) x -> Bool) ->
|
||||
@ -48,25 +46,25 @@ parseSatisfyBS = parseSatisfy
|
||||
|
||||
shouldParse ::
|
||||
forall x s.
|
||||
( ToIsoparsec x s (Kleisli (Parsec Void s)),
|
||||
( ToIsoparsec x s (MegaparsecParser s),
|
||||
Stream s,
|
||||
Show x,
|
||||
Eq x,
|
||||
Isoparsec (Kleisli (Parsec Void s)) s
|
||||
Isoparsec (MegaparsecParser s) s
|
||||
) =>
|
||||
s ->
|
||||
x ->
|
||||
Expectation
|
||||
shouldParse s e = case runMegaparsec @Void @s s toIsoparsec of
|
||||
shouldParse s e = case runMegaparsecParser @s s toIsoparsec of
|
||||
Right e' -> e' `shouldBe` e
|
||||
Left err -> expectationFailure $ errorBundlePretty err
|
||||
|
||||
shouldParseBS ::
|
||||
forall x.
|
||||
( ToIsoparsec x ByteString (Kleisli (Parsec Void ByteString)),
|
||||
( ToIsoparsec x ByteString (MegaparsecParser ByteString),
|
||||
Show x,
|
||||
Eq x,
|
||||
Isoparsec (Kleisli (Parsec Void ByteString)) ByteString
|
||||
Isoparsec (MegaparsecParser ByteString) ByteString
|
||||
) =>
|
||||
ByteString ->
|
||||
x ->
|
||||
@ -75,10 +73,10 @@ shouldParseBS = shouldParse
|
||||
|
||||
shouldParseS ::
|
||||
forall x.
|
||||
( ToIsoparsec x String (Kleisli (Parsec Void String)),
|
||||
( ToIsoparsec x String (MegaparsecParser String),
|
||||
Show x,
|
||||
Eq x,
|
||||
Isoparsec (Kleisli (Parsec Void String)) String
|
||||
Isoparsec (MegaparsecParser String) String
|
||||
) =>
|
||||
String ->
|
||||
x ->
|
||||
@ -87,19 +85,18 @@ shouldParseS = shouldParse
|
||||
|
||||
roundtrip ::
|
||||
forall x s.
|
||||
( ToIsoparsec x s (Kleisli (Parsec Void s)),
|
||||
ToIsoparsec x s (Cokleisli (WriterT (Dual s) Maybe)),
|
||||
( ToIsoparsec x s (MegaparsecParser s),
|
||||
ToIsoparsec x s (MonoidPrinter s),
|
||||
Stream s,
|
||||
Show s,
|
||||
I.Element s ~ M.Token s,
|
||||
Eq x,
|
||||
Eq s,
|
||||
Isoparsec (Kleisli (Parsec Void s)) s
|
||||
Isoparsec (MegaparsecParser s) s
|
||||
) =>
|
||||
x ->
|
||||
Property
|
||||
roundtrip x =
|
||||
let s = fromJust $ runPrinter @Maybe @s toIsoparsec x
|
||||
in counterexample (show s) $ case runMegaparsec @Void @s s toIsoparsec of
|
||||
let s = fromJust $ runMonoidPrinter @s toIsoparsec x
|
||||
in counterexample (show s) $ case runMegaparsecParser @s s toIsoparsec of
|
||||
Right y -> property $ x == y
|
||||
Left err -> counterexample (errorBundlePretty err) False
|
||||
|
||||
@ -13,7 +13,6 @@ import Data.Isoparsec.Char
|
||||
import Data.Isoparsec.Megaparsec
|
||||
import Data.Isoparsec.Printer
|
||||
import Data.Maybe
|
||||
import Data.Void
|
||||
import Spec.Helper
|
||||
import Test.Hspec
|
||||
import Test.Tasty
|
||||
@ -56,8 +55,8 @@ spec =
|
||||
quickSpec :: TestTree
|
||||
quickSpec =
|
||||
testProperty "roundtrips" $ \x ->
|
||||
let s = fromJust $ runPrinter @Maybe @String json x
|
||||
in counterexample s $ case runMegaparsec @Void s json of
|
||||
let s = fromJust $ runMonoidPrinter @String json x
|
||||
in counterexample s $ case runMegaparsecParser s json of
|
||||
Right y -> property $ x == y
|
||||
Left err -> counterexample (errorBundlePretty err) False
|
||||
|
||||
|
||||
@ -13,7 +13,6 @@ import Data.Isoparsec.Char
|
||||
import Data.Isoparsec.Megaparsec
|
||||
import Data.Isoparsec.Printer
|
||||
import Data.Maybe
|
||||
import Data.Void
|
||||
import Test.Hspec
|
||||
import Test.Tasty
|
||||
import Test.Tasty.QuickCheck
|
||||
@ -34,13 +33,13 @@ parser = _Foo <.> (number &&& unsafeWhiteSpace1 &&& number)
|
||||
spec :: Spec
|
||||
spec =
|
||||
it "deserializes" $ do
|
||||
runMegaparsec @() "12 31" parser `shouldBe` Right (Foo 12 31)
|
||||
runMegaparsec @() "1 33" parser `shouldBe` Right (Foo 1 33)
|
||||
runMegaparsec @() "1562" parser `shouldSatisfy` isLeft
|
||||
runMegaparsecParser "12 31" parser `shouldBe` Right (Foo 12 31)
|
||||
runMegaparsecParser "1 33" parser `shouldBe` Right (Foo 1 33)
|
||||
runMegaparsecParser "1562" parser `shouldSatisfy` isLeft
|
||||
|
||||
quickSpec :: TestTree
|
||||
quickSpec = testProperty "roundtrips" $ \x ->
|
||||
let s = fromJust $ runPrinter @Maybe @String parser x
|
||||
in counterexample s $ case runMegaparsec @Void s parser of
|
||||
let s = fromJust $ runMonoidPrinter @String parser x
|
||||
in counterexample s $ case runMegaparsecParser s parser of
|
||||
Right y -> property $ x == y
|
||||
Left err -> counterexample (errorBundlePretty err) False
|
||||
|
||||
@ -153,7 +153,7 @@ makePrisms ''Packet
|
||||
|
||||
instance ToIsoparsec mac ByteString a => ToIsoparsec (Packet mac) ByteString a where
|
||||
toIsoparsec =
|
||||
( auto @(Byte32 'BE) &&& auto @Byte8
|
||||
( auto @(Byte32 'BE) &&& anyToken
|
||||
>>> throughIntegral *** throughIntegral
|
||||
>>^ siPure
|
||||
(\(packetL, paddingL) -> (packetL - paddingL - 1, paddingL))
|
||||
|
||||
@ -11,7 +11,6 @@ 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
|
||||
@ -52,18 +51,18 @@ spec :: Spec
|
||||
spec = do
|
||||
let parser = toIsoparsec @_ @String
|
||||
it "deserializes" $ do
|
||||
runMegaparsec @() "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))
|
||||
runMegaparsec @() "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))
|
||||
runMegaparsec @() "1253" parser `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))
|
||||
runMegaparsec @() "12538" parser `shouldSatisfy` isLeft
|
||||
runMegaparsec @() "2" parser `shouldSatisfy` isLeft
|
||||
runMegaparsec @() "a" parser `shouldSatisfy` isLeft
|
||||
runMegaparsec @() "1a" parser `shouldSatisfy` isLeft
|
||||
runMegaparsecParser "12" parser `shouldBe` Right (TwoDigits (SingleDigit "1") (SingleDigit "2"))
|
||||
runMegaparsecParser "125" parser `shouldBe` Right (ThreeDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5"))
|
||||
runMegaparsecParser "1253" parser `shouldBe` Right (FourDigits (SingleDigit "1") (SingleDigit "2") (SingleDigit "5") (SingleDigit "3"))
|
||||
runMegaparsecParser "12538" parser `shouldSatisfy` isLeft
|
||||
runMegaparsecParser "2" parser `shouldSatisfy` isLeft
|
||||
runMegaparsecParser "a" parser `shouldSatisfy` isLeft
|
||||
runMegaparsecParser "1a" parser `shouldSatisfy` isLeft
|
||||
|
||||
quickSpec :: TestTree
|
||||
quickSpec = testProperty "roundtrips" $ \x ->
|
||||
let s = fromJust $ runPrinter @Maybe @String parser x
|
||||
in counterexample s $ case runMegaparsec @Void s parser of
|
||||
let s = fromJust $ runMonoidPrinter @String parser x
|
||||
in counterexample s $ case runMegaparsecParser s parser of
|
||||
Right y -> property $ x == y
|
||||
Left err -> counterexample (errorBundlePretty err) False
|
||||
where
|
||||
|
||||
Loading…
Reference in New Issue
Block a user