conduit-parse (empty) → 0.1.0.0
raw patch · 5 files changed
+330/−0 lines, 5 filesdep +basedep +conduitdep +conduit-parsesetup-changed
Dependencies added: base, conduit, conduit-parse, exceptions, hlint, parsers, resourcet, tasty, tasty-hunit, text, transformers
Files
- Data/Conduit/Parser.hs +175/−0
- LICENSE +13/−0
- Setup.hs +2/−0
- conduit-parse.cabal +50/−0
- test/Main.hs +90/−0
+ Data/Conduit/Parser.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+-- | This module introduces 'ConduitParser', a wrapper around 'Sink' that behaves like a parser.+--+-- You probably want to import the "Text.Parser.Combinators" module together with this module.+module Data.Conduit.Parser+ ( -- * Conduit parser monad+ ConduitParser()+ , runConduitParser+ , named+ -- * Primitives+ , await+ , leftover+ , getParserName+ -- * Utility+ , peek+ -- * Exception+ , ConduitParserException(..)+ ) where++-- {{{ Imports+import Control.Applicative+import Control.Arrow (second)+import Control.Monad+import Control.Monad.Catch as Exception+import Control.Monad.Trans.Class+import Control.Monad.Trans.State++import Data.Conduit hiding (await, leftover)+import qualified Data.Conduit as Conduit+import qualified Data.Conduit.List as Conduit+import Data.Text as Text (Text, null, pack, unpack)++import Text.Parser.Combinators as Parser+-- }}}++-- | Core type of the package. This is basically a 'Sink' with a parsing state.+newtype ConduitParser i m a = ConduitParser (StateT (Text, [i]) (Sink i m) a)++deriving instance Applicative (ConduitParser i m)+deriving instance Functor (ConduitParser i m)+deriving instance (Monad m) => Monad (ConduitParser i m)++-- | Parsers can be combined with @(\<|\>)@, 'some', 'many', 'optional', 'choice'.+--+-- The use of 'guard' is not recommended as it generates unhelpful error messages.+-- Please consider using 'throwM' or 'unexpected' instead.+--+-- Note: only 'ConduitParserException's will trigger the 'Alternative' features, all other exceptions are rethrown.+instance (MonadCatch m) => Alternative (ConduitParser i m) where+ empty = throwM $ Unexpected "ConduitParser.empty"++ parserA <|> parserB = catch parserA $ \(ea :: ConduitParserException) ->+ catch parserB $ \(eb :: ConduitParserException) ->+ throwM $ BothFailed ea eb++-- | Consumed elements are pushed back with 'leftover' whenever an exception occurs. In other words, backtracking is supported.+instance (MonadThrow m) => MonadThrow (ConduitParser i m) where+ throwM e = case fromException (toException e) of+ Just (e' :: ConduitParserException) -> do+ backtrack+ name <- getParserName+ if Text.null name+ then ConduitParser $ throwM e'+ else ConduitParser . throwM $ NamedParserException name e'+ _ -> ConduitParser $ throwM e++instance (MonadCatch m) => MonadCatch (ConduitParser i m) where+ catch (ConduitParser f) handler = do+ buffer <- resetBuffer+ result <- ConduitParser $ Exception.try f+ case result of+ Right a -> prependBuffer buffer >> return a+ Left e -> prependBuffer buffer >> handler e++instance MonadTrans (ConduitParser i) where+ lift = ConduitParser . lift . lift++-- | Parsing combinators can be used with 'ConduitParser's.+instance (MonadCatch m) => Parsing (ConduitParser i m) where+ try parser = parser++ parser <?> name = do+ oldName <- getParserName+ setParserName $ pack name+ a <- parser+ setParserName oldName+ return a++ unexpected = throwM . Unexpected . pack++ eof = do+ result <- peek+ maybe (return ()) (const $ throwM ExpectedEndOfInput) result++ notFollowedBy parser = do+ result <- optional parser+ name <- getParserName+ forM_ result $ \_ -> throwM $ UnexpectedFollowedBy name++-- | Flipped version of @(\<?\>)@.+named :: (MonadCatch m) => Text -> ConduitParser i m a -> ConduitParser i m a+named name = flip (<?>) (unpack name)+++-- | Run a 'ConduitParser'.+-- Any parsing failure will be thrown as an exception.+runConduitParser :: (MonadThrow m) => ConduitParser i m a -> Sink i m a+runConduitParser (ConduitParser p) = fst <$> runStateT p (mempty, mempty)++-- | Return the name of the parser (assigned through @(\<?\>)@), or 'mempty' if has none.+getParserName :: ConduitParser i m Text+getParserName = ConduitParser $ gets fst++setParserName :: Text -> ConduitParser i m ()+setParserName name = ConduitParser . modify $ \(_, b) -> (name, b)++getBuffer :: ConduitParser i m [i]+getBuffer = ConduitParser $ gets snd++appendBuffer :: [i] -> ConduitParser i m ()+appendBuffer new = ConduitParser $ modify (\(n, b) -> (n, b ++ new))++prependBuffer :: [i] -> ConduitParser i m ()+prependBuffer new = ConduitParser $ modify (second (new ++))++resetBuffer :: (Monad m) => ConduitParser i m [i]+resetBuffer = do+ b <- getBuffer+ ConduitParser $ modify (\(n, _) -> (n, mempty))+ return b++backtrack :: (Monad m) => ConduitParser i m ()+backtrack = mapM_ leftover . reverse =<< resetBuffer++-- | 'Conduit.await' wrapped as a 'ConduitParser'.+--+-- If no data is available, 'UnexpectedEndOfInput' is thrown.+await :: (MonadCatch m) => ConduitParser i m i+await = do+ event <- ConduitParser . lift $ Conduit.await+ e <- maybe (throwM UnexpectedEndOfInput) return event+ appendBuffer [e]+ return e++-- | 'Conduit.leftover' wrapped as a 'ConduitParser'.+leftover :: (Monad m) => i -> ConduitParser i m ()+leftover = ConduitParser . lift . Conduit.leftover++-- | 'Conduit.peek' wrapped as a 'ConduitParser'.+peek :: (Monad m) => ConduitParser i m (Maybe i)+peek = ConduitParser . lift $ Conduit.peek+++data ConduitParserException = BothFailed ConduitParserException ConduitParserException+ | ExpectedEndOfInput+ | NamedParserException Text ConduitParserException+ | UnexpectedEndOfInput+ | UnexpectedFollowedBy Text+ | Unexpected Text++deriving instance Eq ConduitParserException++instance Show ConduitParserException where+ show (BothFailed ea eb) = show ea ++ "\n" ++ show eb+ show ExpectedEndOfInput = "Unexpected input, expected end of input."+ show (NamedParserException t e) = "While parsing " ++ unpack t ++ ": " ++ show e+ show UnexpectedEndOfInput = "Unexpected end of input."+ show (UnexpectedFollowedBy t) = "Should not be followed by " ++ unpack t+ show (Unexpected t) = unpack t++instance Exception ConduitParserException
+ LICENSE view
@@ -0,0 +1,13 @@+DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+Version 2, December 2004++Copyright (C) 2015 koral <koral at mailoo dot org>++Everyone is permitted to copy and distribute verbatim or modified+copies of this license document, and changing it is allowed as long+as the name is changed.++DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE+TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++0. You just DO WHAT THE FUCK YOU WANT TO.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ conduit-parse.cabal view
@@ -0,0 +1,50 @@+name: conduit-parse+version: 0.1.0.0+synopsis: Parsing framework based on conduit.+description:+ The @conduit-extra@ package provides utilities to turn a 'Parser' into a 'Consumer', but only for streams of 'ByteString's of 'Text's (cf @Data.Conduit.Attoparsec@ module).+ .+ This library makes it possible to work with any kind of input by providing a general-purpose parsing framework based on 'conduit'.+homepage: https://github.com/k0ral/conduit-parse+license: OtherLicense+license-file: LICENSE+author: koral <koral@mailoo.org>+maintainer: koral <koral@mailoo.org>+category: Conduit, Text+build-type: Simple+cabal-version: >=1.10++source-repository head+ type: git+ location: git://github.com/k0ral/conduit-parse.git++library+ exposed-modules:+ Data.Conduit.Parser+ build-depends:+ base >= 4.8 && < 5+ , conduit+ , exceptions+ , parsers+ , text+ , transformers+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-unused-do-bind++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ build-depends:+ base >= 4.8 && < 5+ , conduit+ , conduit-parse+ , exceptions+ , hlint+ , parsers+ , resourcet+ , tasty+ , tasty-hunit+ -- , tasty-quickcheck+ default-language: Haskell2010+ ghc-options: -Wall -fno-warn-unused-do-bind
+ test/Main.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+import Control.Applicative+import Control.Monad.Catch as Exception+import Control.Monad.Trans.Resource++import Data.Conduit hiding (await, leftover)+import Data.Conduit.List hiding (drop, peek)+import Data.Conduit.Parser++import qualified Language.Haskell.HLint as HLint (hlint)++import Prelude hiding (drop)++import Test.Tasty+import Test.Tasty.HUnit+-- import Test.Tasty.QuickCheck++import Text.Parser.Combinators++main :: IO ()+main = defaultMain $ testGroup "Tests"+ [ unitTests+ -- , properties+ , hlint+ ]++unitTests :: TestTree+unitTests = testGroup "Unit tests"+ [ awaitCase+ , peekCase+ , leftoverCase+ , alternativeCase+ , catchCase+ , parsingCase+ ]++hlint :: TestTree+hlint = testCase "HLint check" $ do+ result <- HLint.hlint [ "test/", "Data/" ]+ null result @?= True++awaitCase :: TestTree+awaitCase = testCase "await" $ do+ i <- runResourceT . runConduit $ sourceList [1 :: Int] =$= runConduitParser parser+ i @=? (1, Left UnexpectedEndOfInput)+ where parser = (,) <$> await <*> Exception.try await++peekCase :: TestTree+peekCase = testCase "peek" $ do+ result <- runResourceT . runConduit $ sourceList [1 :: Int, 2] =$= runConduitParser parser+ result @=? (Just 1, 1, 2, Nothing)+ where parser = (,,,) <$> peek <*> await <*> await <*> peek++leftoverCase :: TestTree+leftoverCase = testCase "leftover" $ do+ result <- runResourceT . runConduit $ sourceList [1 :: Int, 2, 3] =$= runConduitParser parser+ result @=? (3, 2, 1)+ where parser = do+ (a, b, c) <- (,,) <$> await <*> await <*> await+ leftover a >> leftover b >> leftover c+ (,,) <$> await <*> await <*> await++alternativeCase :: TestTree+alternativeCase = testCase "alternative" $ do+ result <- runResourceT . runConduit $ sourceList [1 :: Int, 2, 3] =$= runConduitParser parser+ result @=? (1, 2, Nothing)+ where parser = do+ a <- parseInt 1 <|> parseInt 2+ b <- parseInt 1 <|> parseInt 2+ c <- optional $ parseInt 1 <|> parseInt 2+ await+ eof+ return (a, b, c)+ parseInt :: (MonadCatch m) => Int -> ConduitParser Int m Int+ parseInt i = do+ a <- await+ if i == a then return a else unexpected ("Expected " ++ show i ++ ", got " ++ show a)++catchCase :: TestTree+catchCase = testCase "catch" $ do+ result <- runResourceT . runConduit $ sourceList [1 :: Int, 2] =$= runConduitParser parser+ result @=? (1, 2)+ where parser = catchAll (await >> await >> throwM (Unexpected "ERROR")) . const $ (,) <$> await <*> await++parsingCase :: TestTree+parsingCase = testCase "parsing" $ do+ result <- runResourceT . runConduit $ sourceList [1 :: Int, 2] =$= runConduitParser parser+ result @=? (1, 2)+ where parser = (,) <$> await <*> await <* notFollowedBy await <* eof