{-# LANGUAGE
- BangPatterns
- , OverloadedStrings
- , ScopedTypeVariables
+ OverloadedStrings
, UnicodeSyntax
#-}
-- |This is an auxiliary parser utilities for parsing things related
, separators
, quotedStr
, qvalue
-
- , atMost
- , manyCharsTill
)
where
import Control.Applicative
-import Control.Applicative.Unicode hiding ((∅))
-import Control.Monad.Unicode
+import Control.Monad
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8 as P hiding (scan)
import qualified Data.Attoparsec.FastSet as FS
import qualified Data.ByteString.Char8 as BS
-import qualified Data.ByteString.Lazy.Char8 as LS
-import qualified Data.ByteString.Lazy.Internal as LS
-import Data.Foldable
-import Data.Monoid
-import Data.Monoid.Unicode
-import qualified Data.Sequence as S
-import Data.Sequence.Unicode hiding ((∅))
+import Network.HTTP.Lucu.Parser
import Prelude.Unicode
--- |@'isCtl' c@ is 'Prelude.False' iff @0x20 <= c < 0x7F@.
+-- |@'isCtl' c@ returns 'False' iff @0x20 <= c < 0x7F@.
isCtl ∷ Char → Bool
{-# INLINE isCtl #-}
isCtl c
{-# INLINE isText #-}
isText = (¬) ∘ isCtl
--- |@'isSeparator' c@ is 'Prelude.True' iff c is one of HTTP
+-- |@'isSeparator' c@ returns 'True' iff c is one of the HTTP
-- separators.
isSeparator ∷ Char → Bool
{-# INLINE isSeparator #-}
{-# NOINLINE set #-}
set = FS.charClass "()<>@,;:\\\"/[]?={}\x20\x09"
--- |@'isChar' c@ is 'Prelude.True' iff @c <= 0x7f@.
+-- |@'isChar' c@ returns 'True' iff @c <= 0x7f@.
isChar ∷ Char → Bool
{-# INLINE isChar #-}
isChar = (≤ '\x7F')
--- |@'isToken' c@ is equivalent to @not ('isCtl' c || 'isSeparator'
+-- |@'isToken' c@ is equivalent to @not ('isCtl' c '||' 'isSeparator'
-- c)@
isToken ∷ Char → Bool
{-# INLINE isToken #-}
-isToken !c
- = (¬) (isCtl c ∨ isSeparator c)
+isToken c = (¬) (isCtl c ∨ isSeparator c)
-- |@'listOf' p@ is similar to @'sepBy' p ('char' \',\')@ but it
-- allows any occurrences of 'lws' before and after each tokens.
{-# INLINEABLE listOf #-}
listOf p
= do skipMany lws
- sepBy p $ do skipMany lws
- _ <- char ','
+ p `sepBy` do skipMany lws
+ void $ char ','
skipMany lws
+ <?>
+ "listOf"
--- |'token' is similar to @'takeWhile1' 'isToken'@
+-- |'token' is almost the same as @'takeWhile1' 'isToken'@
token ∷ Parser Ascii
{-# INLINE token #-}
-token = A.unsafeFromByteString <$> takeWhile1 isToken
+token = (A.unsafeFromByteString <$> takeWhile1 isToken)
+ <?>
+ "token"
-- |The CRLF: 0x0D 0x0A.
crlf ∷ Parser ()
{-# INLINE crlf #-}
-crlf = string "\x0D\x0A" ≫ return ()
+crlf = (string "\x0D\x0A" *> return ())
+ <?>
+ "crlf"
-- |The SP: 0x20.
sp ∷ Parser ()
{-# INLINE sp #-}
-sp = char '\x20' ≫ return ()
+sp = char '\x20' *> return ()
-- |HTTP LWS: crlf? (sp | ht)+
lws ∷ Parser ()
{-# INLINEABLE lws #-}
-lws = do option () crlf
- _ ← takeWhile1 isSPHT
- return ()
+lws = (option () crlf *> void (takeWhile1 isSPHT))
+ <?>
+ "lws"
-- |Returns 'True' for SP and HT.
isSPHT ∷ Char → Bool
isSPHT '\x09' = True
isSPHT _ = False
--- |@'separators'@ is similar to @'takeWhile1' 'isSeparator'@.
+-- |@'separators'@ is almost the same as @'takeWhile1' 'isSeparator'@.
separators ∷ Parser Ascii
{-# INLINE separators #-}
-separators = A.unsafeFromByteString <$> takeWhile1 isSeparator
+separators = (A.unsafeFromByteString <$> takeWhile1 isSeparator)
+ <?>
+ "separators"
-- |'quotedStr' accepts a string surrounded by double quotation
-- marks. Quotes can be escaped by backslashes.
quotedStr ∷ Parser Ascii
{-# INLINEABLE quotedStr #-}
-quotedStr = try $
- do _ ← char '"'
+quotedStr = do void $ char '"'
xs ← P.many (qdtext <|> quotedPair)
- _ ← char '"'
+ void $ char '"'
return $ A.unsafeFromByteString $ BS.pack xs
+ <?>
+ "quotedStr"
where
qdtext ∷ Parser Char
{-# INLINE qdtext #-}
qdtext = satisfy (\c → c ≢ '"' ∧ (¬) (isCtl c))
+ <?>
+ "qdtext"
quotedPair ∷ Parser Char
{-# INLINE quotedPair #-}
- quotedPair = char '\\' ≫ satisfy isChar
+ quotedPair = (char '\\' *> satisfy isChar)
+ <?>
+ "quotedPair"
-- |'qvalue' accepts a so-called qvalue.
qvalue ∷ Parser Double
{-# INLINEABLE qvalue #-}
-qvalue = do x ← char '0'
- xs ← option "" $
- do y ← char '.'
- ys ← atMost 3 digit
- return (y:ys)
- return $ read (x:xs)
- <|>
- do x ← char '1'
- xs ← option "" $
- do y ← char '.'
- ys ← atMost 3 (char '0')
- return (y:ys)
- return $ read (x:xs)
-
--- |@'atMost' n v@ is like @'P.many' v@ but applies the given action
--- 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 CharAccumState
- = CharAccumState {
- casChunks ∷ !(S.Seq BS.ByteString)
- , casLastChunk ∷ !(S.Seq Char)
- }
-
-instance Monoid CharAccumState where
- mempty
- = CharAccumState {
- casChunks = (∅)
- , casLastChunk = (∅)
- }
- mappend a b
- = b {
- casChunks = (casChunks a ⊳ lastChunk a) ⋈ casChunks b
- }
-
-lastChunk ∷ CharAccumState → BS.ByteString
-{-# INLINE lastChunk #-}
-lastChunk = BS.pack ∘ toList ∘ casLastChunk
-
-snoc ∷ CharAccumState → Char → CharAccumState
-{-# INLINEABLE snoc #-}
-snoc cas c
- | S.length (casLastChunk cas) ≥ LS.defaultChunkSize
- = cas {
- casChunks = casChunks cas ⊳ lastChunk cas
- , casLastChunk = S.singleton c
- }
- | otherwise
- = cas {
- casLastChunk = casLastChunk cas ⊳ c
- }
-
-finish ∷ CharAccumState → LS.ByteString
-{-# INLINEABLE finish #-}
-finish cas
- = let chunks = toList $ casChunks cas ⊳ lastChunk cas
- str = LS.fromChunks chunks
- in
- str
-
-manyCharsTill ∷ ∀m b. (Monad m, Alternative m)
- ⇒ m Char
- → m b
- → m LS.ByteString
-{-# INLINEABLE manyCharsTill #-}
-manyCharsTill p end = scan (∅)
- where
- scan ∷ CharAccumState → m LS.ByteString
- {-# INLINE scan #-}
- scan s
- = (end *> pure (finish s))
- <|>
- (scan =≪ (snoc s <$> p))
+qvalue = ( do x ← char '0'
+ xs ← option "" $
+ do y ← char '.'
+ ys ← atMost 3 digit
+ return (y:ys)
+ return $ read (x:xs)
+ <|>
+ do x ← char '1'
+ xs ← option "" $
+ do y ← char '.'
+ ys ← atMost 3 (char '0')
+ return (y:ys)
+ return $ read (x:xs)
+ )
+ <?>
+ "qvalue"
projects / Lucu.git / blobdiff