Destroy Data.Attoparsec.Parsable; use Data.Default instead

diff --git a/Data/Attoparsec/Parsable.hs b/Data/Attoparsec/Parsable.hs
deleted file mode 100644 (file)
index d801fb7..0000000
--- a/Data/Attoparsec/Parsable.hs
+++ /dev/null
@@ -1,65 +0,0 @@
-{-# LANGUAGE MultiParamTypeClasses #-}
-module Data.Attoparsec.Parsable
-    ( Parsable(..)
-    )
-    where
-import qualified Data.Attoparsec.ByteString as B
-import qualified Data.Attoparsec.ByteString.Char8 as B
-import qualified Data.Attoparsec.Text as T
-import Data.Attoparsec.Number
-import Data.Attoparsec.Types
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as LB
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as LT
-import Data.Word
-
--- |Class of types which have their corresponding parsers.
---
--- Minimal complete definition: 'parser'
-class Parsable t a where
-    parser :: Parser t a
-
-instance Parsable B.ByteString Word8 where
-    {-# INLINE CONLIKE parser #-}
-    parser = B.anyWord8
-
-instance Parsable B.ByteString Char where
-    {-# INLINE CONLIKE parser #-}
-    parser = B.anyChar
-
-instance Parsable B.ByteString B.ByteString where
-    {-# INLINE CONLIKE parser #-}
-    parser = B.takeByteString
-
-instance Parsable B.ByteString LB.ByteString where
-    {-# INLINE CONLIKE parser #-}
-    parser = B.takeLazyByteString
-
-instance Parsable B.ByteString Double where
-    {-# INLINE CONLIKE parser #-}
-    parser = B.double
-
-instance Parsable B.ByteString Number where
-    {-# INLINE CONLIKE parser #-}
-    parser = B.number
-
-instance Parsable T.Text Char where
-    {-# INLINE CONLIKE parser #-}
-    parser = T.anyChar
-
-instance Parsable T.Text T.Text where
-    {-# INLINE CONLIKE parser #-}
-    parser = T.takeText
-
-instance Parsable T.Text LT.Text where
-    {-# INLINE CONLIKE parser #-}
-    parser = T.takeLazyText
-
-instance Parsable T.Text Double where
-    {-# INLINE CONLIKE parser #-}
-    parser = T.double
-
-instance Parsable T.Text Number where
-    {-# INLINE CONLIKE parser #-}
-    parser = T.number

diff --git a/Lucu.cabal b/Lucu.cabal
index effcefd44304ba3cf398d75b24a5d3dd20ba43ac..d07f14f29f20df625c9c226d2a5b9b0f6ae29e37 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -88,7 +88,6 @@ Library
             -DHAVE_SSL
 
     Exposed-Modules:
             -DHAVE_SSL
 
     Exposed-Modules:

-        Data.Attoparsec.Parsable

         Data.Collections.Newtype.TH
         Network.HTTP.Lucu
         Network.HTTP.Lucu.Abortion
         Data.Collections.Newtype.TH
         Network.HTTP.Lucu
         Network.HTTP.Lucu.Abortion

diff --git a/Network/HTTP/Lucu/Authentication.hs b/Network/HTTP/Lucu/Authentication.hs
index c91aa7ea54dfae12364f2dde106aa4c3b4e89dca..a63419cea4b6b03e814120f82afeede81869d8cc 100644 (file)
--- a/Network/HTTP/Lucu/Authentication.hs
+++ b/Network/HTTP/Lucu/Authentication.hs
@@ -3,6 +3,7 @@
   , MultiParamTypeClasses
   , OverloadedStrings
   , TemplateHaskell
   , MultiParamTypeClasses
   , OverloadedStrings
   , TemplateHaskell

+  , TypeSynonymInstances

   , UnicodeSyntax
   #-}
 -- |An internal module for HTTP authentication.
   , UnicodeSyntax
   #-}
 -- |An internal module for HTTP authentication.


@@ -18,13 +19,12 @@ import Control.Monad
 import Data.Ascii (Ascii, AsciiBuilder)
 import Data.Attempt
 import Data.Attoparsec.Char8
 import Data.Ascii (Ascii, AsciiBuilder)
 import Data.Attempt
 import Data.Attoparsec.Char8

-import Data.Attoparsec.Parsable

 import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Base64 as B64

-import Data.ByteString (ByteString)

 import qualified Data.ByteString.Char8 as C8
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils
 import qualified Data.ByteString.Char8 as C8
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils

+import Data.Default

 import Data.Monoid.Unicode
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
 import Data.Monoid.Unicode
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils


@@ -65,18 +65,18 @@ deriveAttempts [ ([t| AuthChallenge |], [t| Ascii        |])
                , ([t| AuthChallenge |], [t| AsciiBuilder |])
                ]
 
                , ([t| AuthChallenge |], [t| AsciiBuilder |])
                ]
 

-instance Parsable ByteString AuthCredential where
-    parser = do void $ string "Basic"
-                skipMany1 lws
-                b64 ← takeWhile1 base64
-                case C8.break (≡ ':') (B64.decodeLenient b64) of
-                  (user, cPassword)
-                      | C8.null cPassword
-                          → fail "no colons in the basic auth credential"
-                      | otherwise
-                          → do u ← asc user
-                               p ← asc (C8.tail cPassword)
-                               return (BasicAuthCredential u p)
+instance Default (Parser AuthCredential) where
+    def = do void $ string "Basic"
+             skipMany1 lws
+             b64 ← takeWhile1 base64
+             case C8.break (≡ ':') (B64.decodeLenient b64) of
+               (user, cPassword)
+                   | C8.null cPassword
+                       → fail "no colons in the basic auth credential"
+                   | otherwise
+                       → do u ← asc user
+                            p ← asc (C8.tail cPassword)
+                            return (BasicAuthCredential u p)

         where
           base64 ∷ Char → Bool
           base64 = inClass "a-zA-Z0-9+/="
         where
           base64 ∷ Char → Bool
           base64 = inClass "a-zA-Z0-9+/="

diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs
index 101ed7436c9b281db152af0ad542137335aef7c0..c2135ef1105ae96e85f0f39db1a32240b7ee5929 100644 (file)
--- a/Network/HTTP/Lucu/Chunk.hs
+++ b/Network/HTTP/Lucu/Chunk.hs
@@ -9,8 +9,8 @@ module Network.HTTP.Lucu.Chunk
     where
 import Control.Applicative
 import Data.Attoparsec.Char8
     where
 import Control.Applicative
 import Data.Attoparsec.Char8

-import Data.Attoparsec.Parsable

 import Data.Bits
 import Data.Bits

+import Data.Default

 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Parser.Http
 
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Parser.Http
 


@@ -29,7 +29,9 @@ chunkHeader = do len ← hexadecimal
                        (token <|> quotedStr) )
 
 chunkFooter ∷ Parser ()
                        (token <|> quotedStr) )
 
 chunkFooter ∷ Parser ()

+{-# INLINE chunkFooter #-}

 chunkFooter = crlf
 
 chunkTrailer ∷ Parser Headers
 chunkFooter = crlf
 
 chunkTrailer ∷ Parser Headers

-chunkTrailer = parser
+{-# INLINE chunkTrailer #-}
+chunkTrailer = def

diff --git a/Network/HTTP/Lucu/ContentCoding.hs b/Network/HTTP/Lucu/ContentCoding.hs
index 033b48b4d941b6d462cfa4ebac231d0f3f1869d2..45a8b4e7dcd903deed0b9cecf92640c0b17ba7ff 100644 (file)
--- a/Network/HTTP/Lucu/ContentCoding.hs
+++ b/Network/HTTP/Lucu/ContentCoding.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     FlexibleInstances
   , MultiParamTypeClasses
 {-# LANGUAGE
     FlexibleInstances
   , MultiParamTypeClasses

+  , TypeSynonymInstances

   , OverloadedStrings
   , UnicodeSyntax
   #-}
   , OverloadedStrings
   , UnicodeSyntax
   #-}


@@ -13,8 +14,7 @@ module Network.HTTP.Lucu.ContentCoding
 import Control.Applicative
 import Data.Ascii (CIAscii, toCIAscii)
 import Data.Attoparsec.Char8
 import Control.Applicative
 import Data.Ascii (CIAscii, toCIAscii)
 import Data.Attoparsec.Char8

-import Data.Attoparsec.Parsable
-import Data.ByteString (ByteString)
+import Data.Default

 import Data.Ord
 import Data.Maybe
 import Network.HTTP.Lucu.Parser.Http
 import Data.Ord
 import Data.Maybe
 import Network.HTTP.Lucu.Parser.Http


@@ -36,18 +36,18 @@ instance Ord AcceptEncoding where
           q1' = fromMaybe 0 q1
           q2' = fromMaybe 0 q2
 
           q1' = fromMaybe 0 q1
           q2' = fromMaybe 0 q2
 

-instance Parsable ByteString [AcceptEncoding] where
-    {-# INLINE parser #-}
-    parser = listOf parser
+instance Default (Parser [AcceptEncoding]) where
+    {-# INLINE def #-}
+    def = listOf def

 
 

-instance Parsable ByteString AcceptEncoding where
-    {-# INLINE parser #-}
-    parser = do coding ← toCIAscii <$> token
-                qVal   ← option Nothing
-                             $ do _ ← string ";q="
-                                  q ← qvalue
-                                  return $ Just q
-                return $ AcceptEncoding (normalizeCoding coding) qVal
+instance Default (Parser AcceptEncoding) where
+    {-# INLINEABLE def #-}
+    def = do coding ← toCIAscii <$> token
+             qVal   ← option Nothing
+                          $ do _ ← string ";q="
+                               q ← qvalue
+                               return $ Just q
+             return $ AcceptEncoding (normalizeCoding coding) qVal

 
 normalizeCoding ∷ CIAscii → CIAscii
 {-# INLINEABLE normalizeCoding #-}
 
 normalizeCoding ∷ CIAscii → CIAscii
 {-# INLINEABLE normalizeCoding #-}

diff --git a/Network/HTTP/Lucu/ETag.hs b/Network/HTTP/Lucu/ETag.hs
index b04912002be300ad01ad2b17b9a167caff195ebc..de7780c538992f696d1d7aa322685f2f8d13192f 100644 (file)
--- a/Network/HTTP/Lucu/ETag.hs
+++ b/Network/HTTP/Lucu/ETag.hs
@@ -5,6 +5,7 @@
   , OverloadedStrings
   , RecordWildCards
   , TemplateHaskell
   , OverloadedStrings
   , RecordWildCards
   , TemplateHaskell

+  , TypeSynonymInstances

   , UnicodeSyntax
   #-}
 -- |An internal module for entity tags.
   , UnicodeSyntax
   #-}
 -- |An internal module for entity tags.


@@ -15,15 +16,13 @@ module Network.HTTP.Lucu.ETag
     )
     where
 import Control.Applicative
     )
     where
 import Control.Applicative

-import Control.Monad

 import Data.Ascii (Ascii, AsciiBuilder)
 import Data.Attoparsec.Char8
 import Data.Ascii (Ascii, AsciiBuilder)
 import Data.Attoparsec.Char8

-import Data.Attoparsec.Parsable
-import Data.ByteString (ByteString)

 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils
 import Data.Data
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils
 import Data.Data

+import Data.Default

 import Data.Monoid.Unicode
 import Language.Haskell.TH.Syntax
 import Network.HTTP.Lucu.OrphanInstances ()
 import Data.Monoid.Unicode
 import Language.Haskell.TH.Syntax
 import Network.HTTP.Lucu.OrphanInstances ()


@@ -81,15 +80,12 @@ weakETag ∷ Ascii → ETag
 {-# INLINE weakETag #-}
 weakETag = ETag True
 
 {-# INLINE weakETag #-}
 weakETag = ETag True
 

-instance Parsable ByteString ETag where
-    {-# INLINEABLE parser #-}
-    parser = do isWeak ← option False (string "W/" *> return True)
-                str    ← quotedStr
-                return $ ETag isWeak str
+instance Default (Parser ETag) where
+    {-# INLINEABLE def #-}
+    def = do isWeak ← option False (string "W/" *> return True)
+             str    ← quotedStr
+             return $ ETag isWeak str

 
 

-instance Parsable ByteString [ETag] where
-    {-# INLINEABLE parser #-}
-    parser = do xs ← listOf parser
-                when (null xs) $
-                    fail "empty list of ETags"
-                return xs
+instance Default (Parser [ETag]) where
+    {-# INLINE def #-}
+    def = listOf def

diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index e6641154adc1d390b1c7cd35bb4d5d5a4c71342d..5391743d1163833a1b47b8f10e14ef4edf91e369 100644 (file)
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -20,12 +20,11 @@ import Control.Monad
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8

-import Data.Attoparsec.Parsable
-import Data.ByteString (ByteString)

 import qualified Data.Collections.Newtype.TH as C
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils
 import qualified Data.Collections.Newtype.TH as C
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils

+import Data.Default

 import Data.List (intersperse)
 import qualified Data.Map as M (Map)
 import Data.Collections
 import Data.List (intersperse)
 import qualified Data.Map as M (Map)
 import Data.Collections


@@ -139,11 +138,11 @@ deriveAttempts [ ([t| Headers |], [t| Ascii        |])
   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
   LWS は單一の SP に變換される。
 -}
   field-value の先頭および末尾にある LWS は全て削除され、それ以外の
   LWS は單一の SP に變換される。
 -}

-instance Parsable ByteString Headers where
-    {-# INLINEABLE parser #-}
-    parser = do xs ← many header
-                crlf
-                return $ fromFoldable xs
+instance Default (Parser Headers) where
+    {-# INLINEABLE def #-}
+    def = do xs ← many header
+             crlf
+             return $ fromFoldable xs

         where
           header ∷ Parser (CIAscii, Ascii)
           {-# INLINEABLE header #-}
         where
           header ∷ Parser (CIAscii, Ascii)
           {-# INLINEABLE header #-}

diff --git a/Network/HTTP/Lucu/HttpVersion.hs b/Network/HTTP/Lucu/HttpVersion.hs
index 983cb503f09d0f85a670af16a387906f3c8d1a02..0a850c7aa1cc30f5005b122c2cd7567b8c4b87b9 100644 (file)
--- a/Network/HTTP/Lucu/HttpVersion.hs
+++ b/Network/HTTP/Lucu/HttpVersion.hs
@@ -3,6 +3,7 @@
   , MultiParamTypeClasses
   , OverloadedStrings
   , TemplateHaskell
   , MultiParamTypeClasses
   , OverloadedStrings
   , TemplateHaskell

+  , TypeSynonymInstances

   , UnicodeSyntax
   #-}
 -- |An internal module for HTTP version numbers.
   , UnicodeSyntax
   #-}
 -- |An internal module for HTTP version numbers.


@@ -14,11 +15,10 @@ import Control.Applicative
 import Control.Applicative.Unicode
 import Data.Ascii (Ascii, AsciiBuilder)
 import Data.Attoparsec.Char8
 import Control.Applicative.Unicode
 import Data.Ascii (Ascii, AsciiBuilder)
 import Data.Attoparsec.Char8

-import Data.Attoparsec.Parsable
-import Data.ByteString (ByteString)

 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils

+import Data.Default

 import Data.Monoid.Unicode
 import Prelude hiding (min)
 import Prelude.Unicode
 import Data.Monoid.Unicode
 import Prelude hiding (min)
 import Prelude.Unicode


@@ -58,8 +58,8 @@ deriveAttempts [ ([t| HttpVersion |], [t| Ascii        |])
                , ([t| HttpVersion |], [t| AsciiBuilder |])
                ]
 
                , ([t| HttpVersion |], [t| AsciiBuilder |])
                ]
 

-instance Parsable ByteString HttpVersion where
-    {-# INLINEABLE parser #-}
-    parser = string "HTTP/"
-             *>
-             (HttpVersion <$> decimal ⊛ (char '.' *> decimal))
+instance Default (Parser HttpVersion) where
+    {-# INLINEABLE def #-}
+    def = string "HTTP/"
+          *>
+          (HttpVersion <$> decimal ⊛ (char '.' *> decimal))

diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs
index 37410330bd25fee7c589f5a1c3b7a234cbce0e18..e4e4271a6fcdd405b25804c113778f4158ae344a 100644 (file)
--- a/Network/HTTP/Lucu/MIMEParams.hs
+++ b/Network/HTTP/Lucu/MIMEParams.hs
@@ -24,9 +24,7 @@ import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8

-import Data.Attoparsec.Parsable

 import Data.Bits
 import Data.Bits

-import Data.ByteString (ByteString)

 import qualified Data.ByteString.Char8 as BS
 import Data.Char
 import Data.Collections
 import qualified Data.ByteString.Char8 as BS
 import Data.Char
 import Data.Collections


@@ -35,6 +33,7 @@ import qualified Data.Collections.Newtype.TH as C
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils

+import Data.Default

 import qualified Data.Map as M (Map)
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import qualified Data.Map as M (Map)
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)


@@ -146,26 +145,26 @@ section ∷ ExtendedParam → Integer
 section (InitialEncodedParam {..}) = 0
 section ep                         = epSection ep
 
 section (InitialEncodedParam {..}) = 0
 section ep                         = epSection ep
 

-instance Parsable ByteString MIMEParams where
-    {-# INLINEABLE parser #-}
-    parser = decodeParams =≪ many (try parser)
+instance Default (Parser MIMEParams) where
+    {-# INLINE def #-}
+    def = decodeParams =≪ many (try def)

 
 

-instance Parsable ByteString ExtendedParam where
-    parser = do skipMany lws
-                void $ char ';'
-                skipMany lws
-                epm ← name
-                void $ char '='
-                case epm of
-                  (nm, 0, True)
-                      → do (charset, payload) ← initialEncodedValue
-                           return $ InitialEncodedParam nm charset payload
-                  (nm, sect, True)
-                      → do payload ← encodedPayload
-                           return $ ContinuedEncodedParam nm sect payload
-                  (nm, sect, False)
-                      → do payload ← token <|> quotedStr
-                           return $ AsciiParam nm sect payload
+instance Default (Parser ExtendedParam) where
+    def = do skipMany lws
+             void $ char ';'
+             skipMany lws
+             epm ← name
+             void $ char '='
+             case epm of
+               (nm, 0, True)
+                   → do (charset, payload) ← initialEncodedValue
+                        return $ InitialEncodedParam nm charset payload
+               (nm, sect, True)
+                   → do payload ← encodedPayload
+                        return $ ContinuedEncodedParam nm sect payload
+               (nm, sect, False)
+                   → do payload ← token <|> quotedStr
+                        return $ AsciiParam nm sect payload

 
 name ∷ Parser (CIAscii, Integer, Bool)
 name = do nm        ← (cs ∘ A.unsafeFromByteString) <$>
 
 name ∷ Parser (CIAscii, Integer, Bool)
 name = do nm        ← (cs ∘ A.unsafeFromByteString) <$>

diff --git a/Network/HTTP/Lucu/MIMEType.hs b/Network/HTTP/Lucu/MIMEType.hs
index 949bc44d2668219cef9b265eecc66b9eacae9774..768b4cf53d3227c1ff1fde966755acfa23eef780 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType.hs
+++ b/Network/HTTP/Lucu/MIMEType.hs
@@ -5,6 +5,7 @@
   , OverloadedStrings
   , RecordWildCards
   , TemplateHaskell
   , OverloadedStrings
   , RecordWildCards
   , TemplateHaskell

+  , TypeSynonymInstances

   , UnicodeSyntax
   , ViewPatterns
   #-}
   , UnicodeSyntax
   , ViewPatterns
   #-}


@@ -20,11 +21,10 @@ import Control.Monad.Unicode
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import Data.Attempt
 import Data.Attoparsec.Char8
 import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
 import Data.Attempt
 import Data.Attoparsec.Char8

-import Data.Attoparsec.Parsable
-import Data.ByteString (ByteString)

 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils

+import Data.Default

 import Data.Monoid.Unicode
 import Data.Typeable
 import Language.Haskell.TH.Syntax
 import Data.Monoid.Unicode
 import Data.Typeable
 import Language.Haskell.TH.Syntax


@@ -75,21 +75,21 @@ deriveAttempts [ ([t| MIMEType |], [t| Ascii        |])
 instance ConvertAttempt Ascii MIMEType where
     {-# INLINEABLE convertAttempt #-}
     convertAttempt str
 instance ConvertAttempt Ascii MIMEType where
     {-# INLINEABLE convertAttempt #-}
     convertAttempt str

-        = case parseOnly (finishOff parser) (cs str) of
+        = case parseOnly (finishOff def) (cs str) of

             Right  t → return t
             Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)
 
             Right  t → return t
             Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)
 

-instance Parsable ByteString MIMEType where
-    {-# INLINEABLE parser #-}
-    parser = do media  ← cs <$> token
-                _      ← char '/'
-                sub    ← cs <$> token
-                params ← parser
-                return $ MIMEType media sub params
+instance Default (Parser MIMEType) where
+    {-# INLINEABLE def #-}
+    def = do media  ← cs <$> token
+             _      ← char '/'
+             sub    ← cs <$> token
+             params ← def
+             return $ MIMEType media sub params

 
 

-instance Parsable ByteString [MIMEType] where
-    {-# INLINE parser #-}
-    parser = listOf parser
+instance Default (Parser [MIMEType]) where
+    {-# INLINE def #-}
+    def = listOf def

 
 -- |'QuasiQuoter' for 'MIMEType' literals.
 --
 
 -- |'QuasiQuoter' for 'MIMEType' literals.
 --

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index 3149859026d9a28d3feeb99a2286961f1c74eca6..05d0cd606f383eccdbef688a39dfa4f1e215b3d5 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -19,10 +19,10 @@ module Network.HTTP.Lucu.MIMEType.Guess
 import Control.Applicative
 import Data.Attoparsec.Char8
 import qualified Data.Attoparsec.Lazy as LP
 import Control.Applicative
 import Data.Attoparsec.Char8
 import qualified Data.Attoparsec.Lazy as LP

-import Data.Attoparsec.Parsable

 import qualified Data.ByteString.Lazy.Char8 as Lazy
 import Data.Convertible.Base
 import Data.Convertible.Instances.Text ()
 import qualified Data.ByteString.Lazy.Char8 as Lazy
 import Data.Convertible.Base
 import Data.Convertible.Instances.Text ()

+import Data.Default

 import qualified Data.Map as M
 import Data.Map (Map)
 import Data.Typeable
 import qualified Data.Map as M
 import Data.Map (Map)
 import Data.Typeable


@@ -99,7 +99,7 @@ instance ConvertAttempt Lazy.ByteString ExtMap where
 
           pair ∷ Parser (MIMEType, [Text])
           pair = do skipSpace
 
           pair ∷ Parser (MIMEType, [Text])
           pair = do skipSpace

-                    mime ← parser
+                    mime ← def

                     skipSpace1
                     exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
                     return (mime, exts)
                     skipSpace1
                     exts ← sepBy1 ext $ skipWhile1 (≡ '\x20')
                     return (mime, exts)

diff --git a/Network/HTTP/Lucu/MultipartForm.hs b/Network/HTTP/Lucu/MultipartForm.hs
index ecff350619b31c79c1e1b4ff1e960a3ed68cea9a..98699e43ca37d2e2a2978236130f50b6a705c04a 100644 (file)
--- a/Network/HTTP/Lucu/MultipartForm.hs
+++ b/Network/HTTP/Lucu/MultipartForm.hs
@@ -26,7 +26,6 @@ import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Data.Attempt
 import Data.Attoparsec
 import qualified Data.Attoparsec.Lazy as LP
 import Data.Attempt
 import Data.Attoparsec
 import qualified Data.Attoparsec.Lazy as LP

-import Data.Attoparsec.Parsable

 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LS
 import Data.ByteString.Lazy.Search
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as LS
 import Data.ByteString.Lazy.Search


@@ -34,6 +33,7 @@ import Data.Collections
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils
 import Data.Convertible.Base
 import Data.Convertible.Instances.Ascii ()
 import Data.Convertible.Utils

+import Data.Default

 import Data.List (intercalate)
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.List (intercalate)
 import Data.Maybe
 import Data.Monoid.Unicode


@@ -169,7 +169,8 @@ parsePart boundary src
         defaultCType = [mimeType| text/plain |]
 
 partHeader ∷ Parser Headers
         defaultCType = [mimeType| text/plain |]
 
 partHeader ∷ Parser Headers

-partHeader = crlf *> parser
+{-# INLINE partHeader #-}
+partHeader = crlf *> def

 
 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
 {-# INLINEABLE getContDispo #-}
 
 getContDispo ∷ MonadError String m ⇒ Headers → m ContDispo
 {-# INLINEABLE getContDispo #-}


@@ -186,8 +187,9 @@ getContDispo hdrs
                                        ⊕ err
 
 contentDisposition ∷ Parser ContDispo
                                        ⊕ err
 
 contentDisposition ∷ Parser ContDispo

+{-# INLINEABLE contentDisposition #-}

 contentDisposition
 contentDisposition

-    = (ContDispo <$> (cs <$> token) ⊛ parser)
+    = (ContDispo <$> (cs <$> token) ⊛ def)

       <?>
       "contentDisposition"
 
       <?>
       "contentDisposition"
 


@@ -198,7 +200,7 @@ getContType hdrs
         Nothing
             → return Nothing
         Just str
         Nothing
             → return Nothing
         Just str

-            → case parseOnly (finishOff parser) $ cs str of
+            → case parseOnly (finishOff def) $ cs str of

                  Right  d → return $ Just d
                  Left err → throwError $ "malformed Content-Type: "
                                        ⊕ cs str
                  Right  d → return $ Just d
                  Left err → throwError $ "malformed Content-Type: "
                                        ⊕ cs str

diff --git a/Network/HTTP/Lucu/Request.hs b/Network/HTTP/Lucu/Request.hs
index b6ffedbdb11ccf2ef0bfa2701998d0183e82c808..13ccf9c9420b8265fa244934ed2d98cebc1a497f 100644 (file)
--- a/Network/HTTP/Lucu/Request.hs
+++ b/Network/HTTP/Lucu/Request.hs
@@ -1,6 +1,8 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    MultiParamTypeClasses
+    FlexibleInstances
+  , MultiParamTypeClasses

   , OverloadedStrings
   , OverloadedStrings

+  , TypeSynonymInstances

   , UnicodeSyntax
   , ViewPatterns
   #-}
   , UnicodeSyntax
   , ViewPatterns
   #-}


@@ -17,9 +19,8 @@ import Control.Applicative
 import Control.Monad.Unicode
 import Data.Ascii (Ascii)
 import Data.Attoparsec.Char8
 import Control.Monad.Unicode
 import Data.Ascii (Ascii)
 import Data.Attoparsec.Char8

-import Data.Attoparsec.Parsable
-import Data.ByteString (ByteString)

 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Char8 as C8

+import Data.Default

 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Parser.Http


@@ -63,17 +64,17 @@ reqHasBody (reqMethod → m)
     | m ≡ PUT   = True
     | otherwise = False
 
     | m ≡ PUT   = True
     | otherwise = False
 

-instance Parsable ByteString Request where
-    {-# INLINEABLE parser #-}
-    parser = do skipMany crlf
-                (meth, u, ver) ← requestLine
-                hdrs           ← parser
-                return Request {
-                             reqMethod  = meth
-                           , reqURI     = u
-                           , reqVersion = ver
-                           , reqHeaders = hdrs
-                           }
+instance Default (Parser Request) where
+    {-# INLINEABLE def #-}
+    def = do skipMany crlf
+             (meth, u, ver) ← requestLine
+             hdrs           ← def
+             return Request {
+                          reqMethod  = meth
+                        , reqURI     = u
+                        , reqVersion = ver
+                        , reqHeaders = hdrs
+                        }

 
 requestLine ∷ Parser (Method, URI, HttpVersion)
 {-# INLINEABLE requestLine #-}
 
 requestLine ∷ Parser (Method, URI, HttpVersion)
 {-# INLINEABLE requestLine #-}


@@ -81,7 +82,7 @@ requestLine = do meth ← method
                  sp
                  u ← uri
                  sp
                  sp
                  u ← uri
                  sp

-                 ver ← parser
+                 ver ← def

                  crlf
                  return (meth, u, ver)
 
                  crlf
                  return (meth, u, ver)
 

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 062ffe204ec192e5f5b0d0e52131f352989752d4..543c82e52e182524460a13d95efb09295fdd4578 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -16,11 +16,11 @@ import Control.Exception hiding (block)
 import Control.Monad
 import Control.Monad.Trans.Maybe
 import qualified Data.Attoparsec.Lazy as LP
 import Control.Monad
 import Control.Monad.Trans.Maybe
 import qualified Data.Attoparsec.Lazy as LP

-import Data.Attoparsec.Parsable

 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Convertible.Base
 import Data.Convertible.Instances.Text ()
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.Convertible.Base
 import Data.Convertible.Instances.Text ()

+import Data.Default

 import Data.List
 import Data.Maybe
 import Data.Monoid.Unicode
 import Data.List
 import Data.Maybe
 import Data.Monoid.Unicode


@@ -95,7 +95,7 @@ acceptRequest ctx@(Context {..}) input
          if Lazy.null input then
              return ()
          else
          if Lazy.null input then
              return ()
          else

-             case LP.parse parser input of
+             case LP.parse def input of

                LP.Done input' req → acceptParsableRequest ctx req input'
                LP.Fail _ _ _      → acceptNonparsableRequest ctx
 
                LP.Done input' req → acceptParsableRequest ctx req input'
                LP.Fail _ _ _      → acceptNonparsableRequest ctx
 


@@ -114,15 +114,15 @@ acceptParsableRequest ctx@(Context {..}) req input
          if isError $ arInitialStatus ar then
              acceptSemanticallyInvalidRequest ctx ar input
          else
          if isError $ arInitialStatus ar then
              acceptSemanticallyInvalidRequest ctx ar input
          else

-             do rsrc ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
-                case rsrc of
+             do rsrcM ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
+                case rsrcM of

                   Nothing
                       → do let ar' = ar {
                                        arInitialStatus = fromStatusCode NotFound
                                      }
                            acceptSemanticallyInvalidRequest ctx ar' input
                   Nothing
                       → do let ar' = ar {
                                        arInitialStatus = fromStatusCode NotFound
                                      }
                            acceptSemanticallyInvalidRequest ctx ar' input

-                  Just (path, def)
-                      → acceptRequestForResource ctx ar input path def
+                  Just (path, rsrc)
+                      → acceptRequestForResource ctx ar input path rsrc

 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h
 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h


@@ -141,7 +141,7 @@ acceptRequestForResource ∷ HandleLike h
                          → [Strict.ByteString]
                          → Resource
                          → IO ()
                          → [Strict.ByteString]
                          → Resource
                          → IO ()

-acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrc

     = do
 #if defined(HAVE_SSL)
          cert ← hGetPeerCert cHandle
     = do
 #if defined(HAVE_SSL)
          cert ← hGetPeerCert cHandle


@@ -149,7 +149,7 @@ acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsr
 #else
          ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
 #endif
 #else
          ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
 #endif

-         tid  ← spawnRsrc rsrcDef ni
+         tid  ← spawnRsrc rsrc ni

          enqueue ctx ni
          if reqHasBody arRequest then
              waitForReceiveBodyReq ctx ni tid input
          enqueue ctx ni
          if reqHasBody arRequest then
              waitForReceiveBodyReq ctx ni tid input

diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index 41415290961632701c97e8b9bb2c1639ba729e19..1abf14be8e6bc7782d47e97bb3ddda75128b8c3b 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -151,7 +151,6 @@ import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Data.Attempt
 import qualified Data.Attoparsec.Char8 as P
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 import Data.Attempt
 import qualified Data.Attoparsec.Char8 as P

-import Data.Attoparsec.Parsable

 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy


@@ -159,6 +158,7 @@ import Data.Collections
 import Data.Convertible.Base
 import Data.Convertible.Instances.Text ()
 import Data.Convertible.Utils
 import Data.Convertible.Base
 import Data.Convertible.Instances.Text ()
 import Data.Convertible.Utils

+import Data.Default

 import Data.List (intersperse, sort)
 import Data.Maybe
 import Data.Monoid
 import Data.List (intersperse, sort)
 import Data.Maybe
 import Data.Monoid


@@ -264,7 +264,7 @@ getAccept
            Nothing
                → return []
            Just accept
            Nothing
                → return []
            Just accept

-               → case P.parseOnly (finishOff parser) (cs accept) of
+               → case P.parseOnly (finishOff def) (cs accept) of

                     Right xs → return xs
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ cs accept
                     Right xs → return xs
                     Left  _  → abort $ mkAbortion' BadRequest
                                      $ "Unparsable Accept: " ⊕ cs accept


@@ -292,7 +292,7 @@ getAcceptEncoding
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else
                       -- identity のみが許される。
                       return [("identity", Nothing)]
                  else

-                     case P.parseOnly (finishOff parser) (cs ae) of
+                     case P.parseOnly (finishOff def) (cs ae) of

                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ cs ae
                        Right xs → return $ map toTuple $ reverse $ sort xs
                        Left  _  → abort $ mkAbortion' BadRequest
                                         $ "Unparsable Accept-Encoding: " ⊕ cs ae


@@ -316,7 +316,7 @@ getContentType
            Nothing
                → return Nothing
            Just cType
            Nothing
                → return Nothing
            Just cType

-               → case P.parseOnly (finishOff parser) (cs cType) of
+               → case P.parseOnly (finishOff def) (cs cType) of

                     Right t → return $ Just t
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ cs cType
                     Right t → return $ Just t
                     Left  _ → abort $ mkAbortion' BadRequest
                                     $ "Unparsable Content-Type: " ⊕ cs cType


@@ -330,7 +330,7 @@ getAuthorization
            Nothing
                → return Nothing
            Just auth
            Nothing
                → return Nothing
            Just auth

-               → case P.parseOnly (finishOff parser) (cs auth) of
+               → case P.parseOnly (finishOff def) (cs auth) of

                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 
                     Right ac → return $ Just ac
                     Left  _  → return Nothing
 


@@ -393,11 +393,14 @@ foundETag tag
                → if value ≡ "*" then
                       return ()
                   else
                → if value ≡ "*" then
                       return ()
                   else

-                      case P.parseOnly (finishOff parser) (cs value) of
+                      case P.parseOnly (finishOff def) (cs value) of
+                        Right []
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Empty If-Match"

                         Right tags
                             -- tags の中に一致するものが無ければ
                             -- PreconditionFailed で終了。
                         Right tags
                             -- tags の中に一致するものが無ければ
                             -- PreconditionFailed で終了。

-                            → when ((¬) (any (≡ tag) (tags ∷ [ETag])))
+                            → when ((¬) (any (≡ tag) tags))

                                   $ abort
                                   $ mkAbortion' PreconditionFailed
                                   $ "The entity tag doesn't match: " ⊕ cs value
                                   $ abort
                                   $ mkAbortion' PreconditionFailed
                                   $ "The entity tag doesn't match: " ⊕ cs value


@@ -421,9 +424,12 @@ foundETag tag
                       abort $ mkAbortion' statusForNoneMatch
                             $ "The entity tag matches: *"
                   else
                       abort $ mkAbortion' statusForNoneMatch
                             $ "The entity tag matches: *"
                   else

-                      case P.parseOnly (finishOff parser) (cs value) of
+                      case P.parseOnly (finishOff def) (cs value) of
+                        Right []
+                            → abort $ mkAbortion' BadRequest
+                                    $ "Empty If-None-Match"

                         Right tags
                         Right tags

-                            → when (any (≡ tag) (tags ∷ [ETag]))
+                            → when (any (≡ tag) tags)

                                   $ abort
                                   $ mkAbortion' statusForNoneMatch
                                   $ "The entity tag matches: " ⊕ cs value
                                   $ abort
                                   $ mkAbortion' statusForNoneMatch
                                   $ "The entity tag matches: " ⊕ cs value

diff --git a/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml b/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml
deleted file mode 100644 (file)
index 3ff42d3..0000000
--- a/bugs/issue-d23a51590bc111f85646532c9a8538dd04aa20b4.yaml
+++ /dev/null
@@ -1,27 +0,0 @@
---- !ditz.rubyforge.org,2008-03-06/issue 
-title: Introduce 'Parsable' type class
-desc: I'll send a pull request to bos/attoparsec when it's ready.
-type: :task
-component: Lucu
-release: Lucu-1.0
-reporter: PHO <pho@cielonegro.org>
-status: :closed
-disposition: :fixed
-creation_time: 2011-12-19 13:01:51.401625 Z
-references: []
-
-id: d23a51590bc111f85646532c9a8538dd04aa20b4
-log_events: 
-- - 2011-12-19 13:01:52.375925 Z
-  - PHO <pho@cielonegro.org>
-  - created
-  - ""
-- - 2011-12-19 13:02:07.064863 Z
-  - PHO <pho@cielonegro.org>
-  - changed status from unstarted to in_progress
-  - ""
-- - 2011-12-19 14:29:32.083785 Z
-  - PHO <pho@cielonegro.org>
-  - closed with disposition fixed
-  - Done.
-git_branch: