From 23e8888625b7aa32273fae46efab131b6df457ab Mon Sep 17 00:00:00 2001
From: iko <ilyakooo0@gmail.com>
Date: Sun, 15 Mar 2020 17:04:43 +0300
Subject: [PATCH] Added newtypes and optimized implementations (#48)

---
 package.yaml                      |  1 +
 src/Data/Isoparsec/Megaparsec.hs  | 82 +++++++++++++++++++++----------
 src/Data/Isoparsec/Printer.hs     | 80 +++++++++++++++++++++++-------
 src/Data/Isoparsec/ToIsoparsec.hs |  3 --
 test/Spec/BasicReader.hs          |  2 +-
 test/Spec/Helper.hs               | 37 +++++++-------
 test/Spec/JSON.hs                 |  5 +-
 test/Spec/Megaparsec/BasicNums.hs | 11 ++---
 test/Spec/Ssh.hs                  |  2 +-
 test/Spec/TwoDigits.hs            | 19 ++++---
 10 files changed, 154 insertions(+), 88 deletions(-)

diff --git a/package.yaml b/package.yaml
index 6342a47..b8f2cc2 100644
--- a/package.yaml
+++ b/package.yaml
@@ -28,6 +28,7 @@ dependencies:
 - mtl
 - profunctors
 - mono-traversable
+- split
 
 library:
   source-dirs: src
diff --git a/src/Data/Isoparsec/Megaparsec.hs b/src/Data/Isoparsec/Megaparsec.hs
index b3e402b..7421332 100644
--- a/src/Data/Isoparsec/Megaparsec.hs
+++ b/src/Data/Isoparsec/Megaparsec.hs
@@ -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
diff --git a/src/Data/Isoparsec/Printer.hs b/src/Data/Isoparsec/Printer.hs
index 1d22405..3d1dd70 100644
--- a/src/Data/Isoparsec/Printer.hs
+++ b/src/Data/Isoparsec/Printer.hs
@@ -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
diff --git a/src/Data/Isoparsec/ToIsoparsec.hs b/src/Data/Isoparsec/ToIsoparsec.hs
index cd72749..e118c24 100644
--- a/src/Data/Isoparsec/ToIsoparsec.hs
+++ b/src/Data/Isoparsec/ToIsoparsec.hs
@@ -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
diff --git a/test/Spec/BasicReader.hs b/test/Spec/BasicReader.hs
index c5be3ba..01ca11e 100644
--- a/test/Spec/BasicReader.hs
+++ b/test/Spec/BasicReader.hs
@@ -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)
diff --git a/test/Spec/Helper.hs b/test/Spec/Helper.hs
index 4f8d73d..e9b7474 100644
--- a/test/Spec/Helper.hs
+++ b/test/Spec/Helper.hs
@@ -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
diff --git a/test/Spec/JSON.hs b/test/Spec/JSON.hs
index a0abc12..60c5271 100644
--- a/test/Spec/JSON.hs
+++ b/test/Spec/JSON.hs
@@ -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
 
diff --git a/test/Spec/Megaparsec/BasicNums.hs b/test/Spec/Megaparsec/BasicNums.hs
index 7c53976..4c5880d 100644
--- a/test/Spec/Megaparsec/BasicNums.hs
+++ b/test/Spec/Megaparsec/BasicNums.hs
@@ -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
diff --git a/test/Spec/Ssh.hs b/test/Spec/Ssh.hs
index 0e800de..0ba51c1 100644
--- a/test/Spec/Ssh.hs
+++ b/test/Spec/Ssh.hs
@@ -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))
diff --git a/test/Spec/TwoDigits.hs b/test/Spec/TwoDigits.hs
index f2ee9c6..24f45f2 100644
--- a/test/Spec/TwoDigits.hs
+++ b/test/Spec/TwoDigits.hs
@@ -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