+{-# LANGUAGE
+ BangPatterns
+ , ScopedTypeVariables
+ , UnicodeSyntax
+ #-}
+-- |This is an auxiliary parser utilities. You usually don't have to
+-- use this module directly.
+module Network.HTTP.Lucu.Parser
+ ( atMost
+ , manyOctetsTill
+ )
+ where
+import Blaze.ByteString.Builder (Builder, Write)
+import qualified Blaze.ByteString.Builder as BB
+import qualified Blaze.ByteString.Builder.Internal as BI
+import Control.Applicative
+import Control.Applicative.Unicode hiding ((∅))
+import Control.Monad.Unicode
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LS
+import Data.Monoid
+import Data.Monoid.Unicode
+import Data.Word
+import Prelude.Unicode
+
+-- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most
+-- @n@ times.
+atMost ∷ Alternative f ⇒ Int → f a → f [a]
+{-# INLINE atMost #-}
+atMost 0 _ = pure []
+atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
+ <|>
+ pure []
+
+data OctetAccumState
+ = OctetAccumState {
+ casChunks ∷ !Builder
+ , casLastChunk ∷ !Write
+ }
+
+instance Monoid OctetAccumState where
+ {-# INLINE mempty #-}
+ mempty
+ = OctetAccumState {
+ casChunks = (∅)
+ , casLastChunk = (∅)
+ }
+ {-# INLINEABLE mappend #-}
+ mappend !a !b
+ = b {
+ casChunks = casChunks a ⊕ lastChunk a ⊕ casChunks b
+ }
+
+lastChunk ∷ OctetAccumState → Builder
+{-# INLINEABLE lastChunk #-}
+lastChunk !s = case toChunk s of
+ c → BB.insertByteString c
+ where
+ toChunk ∷ OctetAccumState → BS.ByteString
+ {-# INLINE toChunk #-}
+ toChunk = BB.toByteString ∘ BB.fromWrite ∘ casLastChunk
+
+snoc ∷ OctetAccumState → Word8 → OctetAccumState
+{-# INLINEABLE snoc #-}
+snoc !s !o
+ | BI.getBound (casLastChunk s) ≥ BI.defaultBufferSize
+ = s {
+ casChunks = casChunks s ⊕ lastChunk s
+ , casLastChunk = BB.writeWord8 o
+ }
+ | otherwise
+ = s {
+ casLastChunk = casLastChunk s ⊕ BB.writeWord8 o
+ }
+
+finish ∷ OctetAccumState → LS.ByteString
+{-# INLINEABLE finish #-}
+finish = BB.toLazyByteString ∘ toChunks
+ where
+ toChunks ∷ OctetAccumState → Builder
+ {-# INLINE toChunks #-}
+ toChunks !s = casChunks s ⊕ lastChunk s
+
+-- |@'manyOctetsTill' p end@ takes as many octets untill @p@ succeeds.
+manyOctetsTill ∷ ∀m b. (Monad m, Alternative m)
+ ⇒ m Word8
+ → m b
+ → m LS.ByteString
+{-# INLINEABLE manyOctetsTill #-}
+manyOctetsTill p end = scan (∅)
+ where
+ scan ∷ OctetAccumState → m LS.ByteString
+ {-# INLINE scan #-}
+ scan !s
+ = (end *> pure (finish s))
+ <|>
+ (scan =≪ (snoc s <$> p))
projects / Lucu.git / commitdiff