Network/HTTP/Lucu/Parser.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , ScopedTypeVariables
   4   , UnicodeSyntax
   5   #-}
   6 -- |This is an auxiliary parser utilities. You usually don't have to
   7 -- use this module directly.
   8 module Network.HTTP.Lucu.Parser
   9     ( atMost
  10     , manyOctetsTill
  11     )
  12     where
  13 import Blaze.ByteString.Builder (Builder, Write)
  14 import qualified Blaze.ByteString.Builder as BB
  15 import qualified Blaze.ByteString.Builder.Internal as BI
  16 import Control.Applicative
  17 import Control.Applicative.Unicode hiding ((∅))
  18 import Control.Monad.Unicode
  19 import qualified Data.ByteString as BS
  20 import qualified Data.ByteString.Lazy as LS
  21 import Data.Monoid
  22 import Data.Monoid.Unicode
  23 import Data.Word
  24 import Prelude.Unicode
  25
  26 -- |@'atMost' n v@ is like @'P.many' v@ but accumulates @v@ at most
  27 -- @n@ times.
  28 atMost ∷ Alternative f ⇒ Int → f a → f [a]
  29 {-# INLINE atMost #-}
  30 atMost 0 _ = pure []
  31 atMost n v = ( (:) <$> v ⊛ atMost (n-1) v )
  32              <|>
  33              pure []
  34
  35 data OctetAccumState
  36     = OctetAccumState {
  37         casChunks    ∷ !Builder
  38       , casLastChunk ∷ !Write
  39       }
  40
  41 instance Monoid OctetAccumState where
  42     {-# INLINE mempty #-}
  43     mempty
  44         = OctetAccumState {
  45             casChunks    = (∅)
  46           , casLastChunk = (∅)
  47           }
  48     {-# INLINEABLE mappend #-}
  49     mappend !a !b
  50         = b {
  51             casChunks = casChunks a ⊕ lastChunk a ⊕ casChunks b
  52           }
  53
  54 lastChunk ∷ OctetAccumState → Builder
  55 {-# INLINEABLE lastChunk #-}
  56 lastChunk !s = case toChunk s of
  57                  c → BB.insertByteString c
  58     where
  59       toChunk ∷ OctetAccumState → BS.ByteString
  60       {-# INLINE toChunk #-}
  61       toChunk = BB.toByteString ∘ BB.fromWrite ∘ casLastChunk
  62
  63 snoc ∷ OctetAccumState → Word8 → OctetAccumState
  64 {-# INLINEABLE snoc #-}
  65 snoc !s !o
  66     | BI.getBound (casLastChunk s) ≥ BI.defaultBufferSize
  67         = s {
  68             casChunks    = casChunks s ⊕ lastChunk s
  69           , casLastChunk = BB.writeWord8 o
  70           }
  71     | otherwise
  72         = s {
  73             casLastChunk = casLastChunk s ⊕ BB.writeWord8 o
  74           }
  75
  76 finish ∷ OctetAccumState → LS.ByteString
  77 {-# INLINEABLE finish #-}
  78 finish = BB.toLazyByteString ∘ toChunks
  79     where
  80       toChunks ∷ OctetAccumState → Builder
  81       {-# INLINE toChunks #-}
  82       toChunks !s = casChunks s ⊕ lastChunk s
  83
  84 -- |@'manyOctetsTill' p end@ takes as many octets untill @p@ succeeds.
  85 manyOctetsTill ∷ ∀m b. (Monad m, Alternative m)
  86               ⇒ m Word8
  87               → m b
  88               → m LS.ByteString
  89 {-# INLINEABLE manyOctetsTill #-}
  90 manyOctetsTill p end = scan (∅)
  91     where
  92       scan ∷ OctetAccumState → m LS.ByteString
  93       {-# INLINE scan #-}
  94       scan !s
  95           = (end *> pure (finish s))
  96             <|>
  97             (scan =≪ (snoc s <$> p))