summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorkoral <>2015-06-02 21:30:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2015-06-02 21:30:00 (GMT)
commit6ac627edeb1b817ef353f382a9ba74c44fb1e40e (patch)
treed5e378d24421d2202759fe40eafe6108c97068c0
version 0.1.0.00.1.0.0
-rw-r--r--Data/Conduit/Parser.hs175
-rw-r--r--LICENSE13
-rw-r--r--Setup.hs2
-rw-r--r--conduit-parse.cabal50
-rw-r--r--test/Main.hs90
5 files changed, 330 insertions, 0 deletions
diff --git a/Data/Conduit/Parser.hs b/Data/Conduit/Parser.hs
new file mode 100644
index 0000000..83575d4
--- /dev/null
+++ b/Data/Conduit/Parser.hs
@@ -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
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..9c20de0
--- /dev/null
+++ b/LICENSE
@@ -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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/conduit-parse.cabal b/conduit-parse.cabal
new file mode 100644
index 0000000..0c26ec8
--- /dev/null
+++ b/conduit-parse.cabal
@@ -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
diff --git a/test/Main.hs b/test/Main.hs
new file mode 100644
index 0000000..551d8bd
--- /dev/null
+++ b/test/Main.hs
@@ -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