diff --git a/Data/Syntax/Printer/ByteString.hs b/Data/Syntax/Printer/ByteString.hs --- a/Data/Syntax/Printer/ByteString.hs +++ b/Data/Syntax/Printer/ByteString.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Module : Data.Syntax.Printer.ByteString @@ -11,33 +12,69 @@ -} module Data.Syntax.Printer.ByteString ( Printer, - runPrinter + runPrinter, + runPrinter_ ) where +import Control.Arrow (Kleisli(..)) +import Control.Category +import Control.Category.Structures import Control.Monad +import Control.SIArrow import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Data.ByteString.Lazy (toStrict) import Data.ByteString.Lazy.Builder -import Data.SemiIsoFunctor +import Data.Monoid (mempty) +import Data.Semigroupoid.Dual import Data.Syntax import Data.Syntax.Printer.Consumer +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import Prelude hiding (id, (.)) --- | Prints a value to a Text Builder using a syntax description. -newtype Printer a = Printer { getConsumer :: Consumer Builder a } - deriving (SemiIsoFunctor, SemiIsoApply, SemiIsoAlternative, SemiIsoMonad) +-- | Prints a value to a ByteString Builder using a syntax description. +newtype Printer a b = Printer { unPrinter :: Dual (Kleisli (Consumer Builder)) a b } + deriving (Category, Products, Coproducts, CatPlus, SIArrow) -instance Syntax Printer ByteString where - anyChar = Printer . Consumer $ Right . word8 - take n = Printer . Consumer $ Right . byteString . BS.take n - takeWhile p = Printer . Consumer $ Right . byteString . BS.takeWhile p - takeWhile1 p = Printer . Consumer $ Right . byteString <=< notNull . BS.takeWhile p +wrap :: (b -> Either String Builder) -> Printer () b +wrap f = Printer $ Dual $ Kleisli $ (Consumer . fmap (, ())) . f + +unwrap :: Printer a b -> b -> Consumer Builder a +unwrap = runKleisli . getDual . unPrinter + +instance Syntax Printer where + type Seq Printer = ByteString + anyChar = wrap $ Right . word8 + take n = wrap $ Right . byteString . BS.take n + takeWhile p = wrap $ Right . byteString . BS.takeWhile p + takeWhile1 p = wrap $ Right . byteString <=< notNull . BS.takeWhile p where notNull t | BS.null t = Left "takeWhile1 failed" | otherwise = Right t - takeTill1 p = Printer . Consumer $ Right . byteString <=< notNull . BS.takeWhile (not . p) + takeTill1 p = wrap $ Right . byteString <=< notNull . BS.takeWhile (not . p) where notNull t | BS.null t = Left "takeTill1 failed" | otherwise = Right t + vecN n e = wrap $ \v -> if V.length v == n + then fmap fst $ runConsumer (V.mapM_ (unwrap e) v) + else Left "vecN: invalid vector size" + ivecN n e = wrap $ \v -> if V.length v == n + then fmap fst $ runConsumer (V.mapM_ (unwrap e) (V.indexed v)) + else Left "ivecN: invalid vector size" + uvecN n e = wrap $ \v -> if VU.length v == n + then fmap fst $ runConsumer (VU.mapM_ (unwrap e) v) + else Left "uvecN: invalid vector size" + uivecN n e = wrap $ \v -> if VU.length v == n + then fmap fst $ runConsumer (VU.mapM_ (unwrap e) (VU.indexed v)) + else Left "uivecN: invalid vector size" +instance Isolable Printer where + isolate p = Printer $ Dual $ Kleisli $ + Consumer . fmap ((mempty, ) . toStrict . toLazyByteString) . runPrinter_ p -- | Runs the printer. -runPrinter :: Printer a -> a -> Either String Builder -runPrinter = runConsumer . getConsumer +runPrinter :: Printer a b -> b -> Either String (Builder, a) +runPrinter = (runConsumer .) . runKleisli . getDual . unPrinter + +-- | Runs the printer and discards the result. +runPrinter_ :: Printer a b -> b -> Either String Builder +runPrinter_ = (fmap fst .) . runPrinter diff --git a/Data/Syntax/Printer/ByteString/Lazy.hs b/Data/Syntax/Printer/ByteString/Lazy.hs --- a/Data/Syntax/Printer/ByteString/Lazy.hs +++ b/Data/Syntax/Printer/ByteString/Lazy.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Module : Data.Syntax.Printer.ByteString.Lazy @@ -11,33 +12,69 @@ -} module Data.Syntax.Printer.ByteString.Lazy ( Printer, - runPrinter + runPrinter, + runPrinter_ ) where +import Control.Arrow (Kleisli(..)) +import Control.Category +import Control.Category.Structures import Control.Monad +import Control.SIArrow import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BS import Data.ByteString.Lazy.Builder -import Data.SemiIsoFunctor +import Data.Monoid (mempty) +import Data.Semigroupoid.Dual import Data.Syntax import Data.Syntax.Printer.Consumer +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import Prelude hiding (id, (.)) --- | Prints a value to a Text Builder using a syntax description. -newtype Printer a = Printer { getConsumer :: Consumer Builder a } - deriving (SemiIsoFunctor, SemiIsoApply, SemiIsoAlternative, SemiIsoMonad) +-- | Prints a value to a ByteString Builder using a syntax description. +newtype Printer a b = Printer { unPrinter :: Dual (Kleisli (Consumer Builder)) a b } + deriving (Category, Products, Coproducts, CatPlus, SIArrow) -instance Syntax Printer ByteString where - anyChar = Printer . Consumer $ Right . word8 - take n = Printer . Consumer $ Right . lazyByteString . BS.take (fromIntegral n) - takeWhile p = Printer . Consumer $ Right . lazyByteString . BS.takeWhile p - takeWhile1 p = Printer . Consumer $ Right . lazyByteString <=< notNull . BS.takeWhile p +wrap :: (b -> Either String Builder) -> Printer () b +wrap f = Printer $ Dual $ Kleisli $ (Consumer . fmap (, ())) . f + +unwrap :: Printer a b -> b -> Consumer Builder a +unwrap = runKleisli . getDual . unPrinter + +instance Syntax Printer where + type Seq Printer = ByteString + anyChar = wrap $ Right . word8 + take n = wrap $ Right . lazyByteString . BS.take (fromIntegral n) + takeWhile p = wrap $ Right . lazyByteString . BS.takeWhile p + takeWhile1 p = wrap $ Right . lazyByteString <=< notNull . BS.takeWhile p where notNull t | BS.null t = Left "takeWhile1 failed" | otherwise = Right t - takeTill1 p = Printer . Consumer $ Right . lazyByteString <=< notNull . BS.takeWhile (not . p) + takeTill1 p = wrap $ Right . lazyByteString <=< notNull . BS.takeWhile (not . p) where notNull t | BS.null t = Left "takeTill1 failed" | otherwise = Right t + vecN n e = wrap $ \v -> if V.length v == n + then fmap fst $ runConsumer (V.mapM_ (unwrap e) v) + else Left "vecN: invalid vector size" + ivecN n e = wrap $ \v -> if V.length v == n + then fmap fst $ runConsumer (V.mapM_ (unwrap e) (V.indexed v)) + else Left "ivecN: invalid vector size" + uvecN n e = wrap $ \v -> if VU.length v == n + then fmap fst $ runConsumer (VU.mapM_ (unwrap e) v) + else Left "uvecN: invalid vector size" + uivecN n e = wrap $ \v -> if VU.length v == n + then fmap fst $ runConsumer (VU.mapM_ (unwrap e) (VU.indexed v)) + else Left "uivecN: invalid vector size" +instance Isolable Printer where + isolate p = Printer $ Dual $ Kleisli $ + Consumer . fmap ((mempty, ) . toLazyByteString) . runPrinter_ p + -- | Runs the printer. -runPrinter :: Printer a -> a -> Either String Builder -runPrinter = runConsumer . getConsumer +runPrinter :: Printer a b -> b -> Either String (Builder, a) +runPrinter = (runConsumer .) . runKleisli . getDual . unPrinter + +-- | Runs the printer and discards the result. +runPrinter_ :: Printer a b -> b -> Either String Builder +runPrinter_ = (fmap fst .) . runPrinter diff --git a/Data/Syntax/Printer/Consumer.hs b/Data/Syntax/Printer/Consumer.hs --- a/Data/Syntax/Printer/Consumer.hs +++ b/Data/Syntax/Printer/Consumer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveFunctor #-} {- | Module : Data.Syntax.Printer.Consumer Description : Common base for both Text and ByteString printers. @@ -10,24 +11,34 @@ module Data.Syntax.Printer.Consumer where import Control.Applicative -import Control.Lens.SemiIso import Control.Monad +import Data.Bifunctor.Apply import Data.Monoid -import Data.SemiIsoFunctor --- | A contravariant functor that consumes values using a monoid. -newtype Consumer m a = Consumer { runConsumer :: a -> Either String m } +-- | A writer monad combined with Either String. +newtype Consumer m a = Consumer { runConsumer :: Either String (m, a) } + deriving (Functor) -instance SemiIsoFunctor (Consumer m) where - simap f (Consumer p) = Consumer $ apply f >=> p +instance Monoid m => Applicative (Consumer m) where + pure x = Consumer $ Right (mempty, x) + f <*> x = Consumer $ bilift2 (flip (<>)) ($) <$> runConsumer f <*> runConsumer x -instance Monoid m => SemiIsoApply (Consumer m) where - siunit = Consumer $ \_ -> Right mempty - Consumer f /*/ Consumer g = Consumer $ \(a, b) -> (<>) <$> f a <*> g b +instance Monoid m => Alternative (Consumer m) where + empty = Consumer $ Left "empty" + f <|> g = Consumer $ case runConsumer f of + Left _ -> case runConsumer g of + Left e2 -> Left e2 + Right x -> Right x + Right x -> Right x -instance Monoid m => SemiIsoAlternative (Consumer m) where - siempty = Consumer $ \_ -> Left "siempty" - Consumer f /|/ Consumer g = Consumer $ \a -> f a <|> g a +instance Monoid m => Monad (Consumer m) where + return = pure + m >>= f = Consumer $ do + (m1, x) <- runConsumer m + (m2, y) <- runConsumer (f x) + return (m2 <> m1, y) + fail = Consumer . Left -instance Monoid m => SemiIsoMonad (Consumer m) where - Consumer m //= f = Consumer $ \(a, b) -> (<>) <$> m a <*> runConsumer (f a) b +instance Monoid m => MonadPlus (Consumer m) where + mzero = empty + mplus = (<|>) diff --git a/Data/Syntax/Printer/Text.hs b/Data/Syntax/Printer/Text.hs --- a/Data/Syntax/Printer/Text.hs +++ b/Data/Syntax/Printer/Text.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Module : Data.Syntax.Printer.Text @@ -11,43 +12,80 @@ -} module Data.Syntax.Printer.Text ( Printer, - runPrinter + runPrinter, + runPrinter_ ) where +import Control.Arrow (Kleisli(..)) +import Control.Category +import Control.Category.Structures import Control.Monad -import Data.SemiIsoFunctor +import Control.SIArrow +import Data.Monoid (mempty) +import Data.Semigroupoid.Dual import Data.Syntax import Data.Syntax.Char import Data.Syntax.Printer.Consumer import Data.Text (Text) import qualified Data.Text as T +import Data.Text.Lazy (toStrict) import Data.Text.Lazy.Builder import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Builder.RealFloat as B import qualified Data.Text.Lazy.Builder.Scientific as B +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import Prelude hiding (id, (.)) -- | Prints a value to a Text Builder using a syntax description. -newtype Printer a = Printer { getConsumer :: Consumer Builder a } - deriving (SemiIsoFunctor, SemiIsoApply, SemiIsoAlternative, SemiIsoMonad) +newtype Printer a b = Printer { unPrinter :: Dual (Kleisli (Consumer Builder)) a b } + deriving (Category, Products, Coproducts, CatPlus, SIArrow) -instance Syntax Printer Text where - anyChar = Printer . Consumer $ Right . singleton - take n = Printer . Consumer $ Right . fromText . T.take n - takeWhile p = Printer . Consumer $ Right . fromText . T.takeWhile p - takeWhile1 p = Printer . Consumer $ Right . fromText <=< notNull . T.takeWhile p +wrap :: (b -> Either String Builder) -> Printer () b +wrap f = Printer $ Dual $ Kleisli $ (Consumer . fmap (, ())) . f + +unwrap :: Printer a b -> b -> Consumer Builder a +unwrap = runKleisli . getDual . unPrinter + +instance Syntax Printer where + type Seq Printer = Text + anyChar = wrap $ Right . singleton + take n = wrap $ Right . fromText . T.take n + takeWhile p = wrap $ Right . fromText . T.takeWhile p + takeWhile1 p = wrap $ Right . fromText <=< notNull . T.takeWhile p where notNull t | T.null t = Left "takeWhile1 failed" | otherwise = Right t - takeTill1 p = Printer . Consumer $ Right . fromText <=< notNull . T.takeWhile (not . p) + takeTill1 p = wrap $ Right . fromText <=< notNull . T.takeWhile (not . p) where notNull t | T.null t = Left "takeTill1 failed" | otherwise = Right t + vecN n e = wrap $ \v -> if V.length v == n + then fmap fst $ runConsumer (V.mapM_ (unwrap e) v) + else Left "vecN: invalid vector size" + ivecN n e = wrap $ \v -> if V.length v == n + then fmap fst $ runConsumer (V.mapM_ (unwrap e) (V.indexed v)) + else Left "ivecN: invalid vector size" + uvecN n e = wrap $ \v -> if VU.length v == n + then fmap fst $ runConsumer (VU.mapM_ (unwrap e) v) + else Left "uvecN: invalid vector size" + uivecN n e = wrap $ \v -> if VU.length v == n + then fmap fst $ runConsumer (VU.mapM_ (unwrap e) (VU.indexed v)) + else Left "uivecN: invalid vector size" -instance SyntaxChar Printer Text where - decimal = Printer . Consumer $ Right . B.decimal - hexadecimal = Printer . Consumer $ Right . B.hexadecimal - realFloat = Printer . Consumer $ Right . B.realFloat - scientific = Printer . Consumer $ Right . B.scientificBuilder +instance Isolable Printer where + isolate p = Printer $ Dual $ Kleisli $ + Consumer . fmap ((mempty, ) . toStrict . toLazyText) . runPrinter_ p +instance SyntaxChar Printer where + decimal = wrap $ Right . B.decimal + hexadecimal = wrap $ Right . B.hexadecimal + realFloat = wrap $ Right . B.realFloat + scientific = wrap $ Right . B.scientificBuilder + -- | Runs the printer. -runPrinter :: Printer a -> a -> Either String Builder -runPrinter = runConsumer . getConsumer +runPrinter :: Printer a b -> b -> Either String (Builder, a) +runPrinter = (runConsumer .) . runKleisli . getDual . unPrinter + +-- | Runs the printer and discards the result. +runPrinter_ :: Printer a b -> b -> Either String Builder +runPrinter_ = (fmap fst .) . runPrinter diff --git a/Data/Syntax/Printer/Text/Lazy.hs b/Data/Syntax/Printer/Text/Lazy.hs --- a/Data/Syntax/Printer/Text/Lazy.hs +++ b/Data/Syntax/Printer/Text/Lazy.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {- | Module : Data.Syntax.Printer.Text.Lazy @@ -11,12 +12,18 @@ -} module Data.Syntax.Printer.Text.Lazy ( Printer, - runPrinter + runPrinter, + runPrinter_ ) where +import Control.Arrow (Kleisli(..)) +import Control.Category +import Control.Category.Structures import Control.Monad -import Data.SemiIsoFunctor +import Control.SIArrow +import Data.Monoid (mempty) +import Data.Semigroupoid.Dual import Data.Syntax import Data.Syntax.Char import Data.Syntax.Printer.Consumer @@ -26,28 +33,58 @@ import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Builder.RealFloat as B import qualified Data.Text.Lazy.Builder.Scientific as B +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import Prelude hiding (id, (.)) -- | Prints a value to a Text Builder using a syntax description. -newtype Printer a = Printer { getConsumer :: Consumer Builder a } - deriving (SemiIsoFunctor, SemiIsoApply, SemiIsoAlternative, SemiIsoMonad) +newtype Printer a b = Printer { unPrinter :: Dual (Kleisli (Consumer Builder)) a b } + deriving (Category, Products, Coproducts, CatPlus, SIArrow) -instance Syntax Printer Text where - anyChar = Printer . Consumer $ Right . singleton - take n = Printer . Consumer $ Right . fromLazyText . T.take (fromIntegral n) - takeWhile p = Printer . Consumer $ Right . fromLazyText . T.takeWhile p - takeWhile1 p = Printer . Consumer $ Right . fromLazyText <=< notNull . T.takeWhile p +wrap :: (b -> Either String Builder) -> Printer () b +wrap f = Printer $ Dual $ Kleisli $ (Consumer . fmap (, ())) . f + +unwrap :: Printer a b -> b -> Consumer Builder a +unwrap = runKleisli . getDual . unPrinter + +instance Syntax Printer where + type Seq Printer = Text + anyChar = wrap $ Right . singleton + take n = wrap $ Right . fromLazyText . T.take (fromIntegral n) + takeWhile p = wrap $ Right . fromLazyText . T.takeWhile p + takeWhile1 p = wrap $ Right . fromLazyText <=< notNull . T.takeWhile p where notNull t | T.null t = Left "takeWhile1 failed" | otherwise = Right t - takeTill1 p = Printer . Consumer $ Right . fromLazyText <=< notNull . T.takeWhile (not . p) + takeTill1 p = wrap $ Right . fromLazyText <=< notNull . T.takeWhile (not . p) where notNull t | T.null t = Left "takeTill1 failed" | otherwise = Right t + vecN n e = wrap $ \v -> if V.length v == n + then fmap fst $ runConsumer (V.mapM_ (unwrap e) v) + else Left "vecN: invalid vector size" + ivecN n e = wrap $ \v -> if V.length v == n + then fmap fst $ runConsumer (V.mapM_ (unwrap e) (V.indexed v)) + else Left "ivecN: invalid vector size" + uvecN n e = wrap $ \v -> if VU.length v == n + then fmap fst $ runConsumer (VU.mapM_ (unwrap e) v) + else Left "uvecN: invalid vector size" + uivecN n e = wrap $ \v -> if VU.length v == n + then fmap fst $ runConsumer (VU.mapM_ (unwrap e) (VU.indexed v)) + else Left "uivecN: invalid vector size" -instance SyntaxChar Printer Text where - decimal = Printer . Consumer $ Right . B.decimal - hexadecimal = Printer . Consumer $ Right . B.hexadecimal - realFloat = Printer . Consumer $ Right . B.realFloat - scientific = Printer . Consumer $ Right . B.scientificBuilder +instance Isolable Printer where + isolate p = Printer $ Dual $ Kleisli $ + Consumer . fmap ((mempty, ) . toLazyText) . runPrinter_ p +instance SyntaxChar Printer where + decimal = wrap $ Right . B.decimal + hexadecimal = wrap $ Right . B.hexadecimal + realFloat = wrap $ Right . B.realFloat + scientific = wrap $ Right . B.scientificBuilder + -- | Runs the printer. -runPrinter :: Printer a -> a -> Either String Builder -runPrinter = runConsumer . getConsumer +runPrinter :: Printer a b -> b -> Either String (Builder, a) +runPrinter = (runConsumer .) . runKleisli . getDual . unPrinter + +-- | Runs the printer and discards the result. +runPrinter_ :: Printer a b -> b -> Either String Builder +runPrinter_ = (fmap fst .) . runPrinter diff --git a/syntax-printer.cabal b/syntax-printer.cabal --- a/syntax-printer.cabal +++ b/syntax-printer.cabal @@ -1,5 +1,5 @@ name: syntax-printer -version: 0.1.0.0 +version: 1.0.0.0 synopsis: Text and ByteString printers for 'syntax'. license: MIT license-file: LICENSE @@ -16,6 +16,7 @@ Data.Syntax.Printer.Text.Lazy Data.Syntax.Printer.ByteString Data.Syntax.Printer.ByteString.Lazy - build-depends: base >=4.7 && <4.8, semi-iso >= 0.5, syntax >= 0.3, text, bytestring, scientific >= 0.3 + build-depends: base >=4.7 && <4.8, semi-iso >= 1, syntax >= 1, + text, bytestring, scientific >= 0.3, bifunctors, semigroupoids, vector default-language: Haskell2010 ghc-options: -Wall