, OverloadedStrings
, RecordWildCards
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
+ , ViewPatterns
#-}
-- |Parsing and printing MIME Media Types
-- (<http://tools.ietf.org/html/rfc2046>).
module Network.HTTP.Lucu.MIMEType
( MIMEType(..)
, mimeType
- , mimeTypeList
)
where
import Control.Applicative
+import Control.Monad.Unicode
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
-import qualified Data.Ascii as A
-import Data.Attoparsec.Char8 as P
+import Data.Attempt
+import Data.Attoparsec.Char8
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 Language.Haskell.TH.Quote
import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
+import Network.HTTP.Lucu.Utils
import Prelude.Unicode
-- |A media type, subtype, and parameters.
]
-- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider
--- using 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
+-- using 'mimeType' quasi-quoter.
instance ConvertAttempt Ascii MIMEType where
{-# INLINEABLE convertAttempt #-}
convertAttempt str
- = case parseOnly (finishOff mimeType) (cs str) of
+ = case parseOnly (finishOff def) (cs str) of
Right t → return t
Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)
--- |'Parser' for an 'MIMEType'.
-mimeType ∷ Parser MIMEType
-{-# INLINEABLE mimeType #-}
-mimeType = do media ← A.toCIAscii <$> token
- _ ← char '/'
- sub ← A.toCIAscii <$> token
- params ← mimeParams
- 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
--- |'Parser' for a list of 'MIMEType's.
-mimeTypeList ∷ Parser [MIMEType]
-{-# INLINE mimeTypeList #-}
-mimeTypeList = listOf mimeType
+instance Default (Parser [MIMEType]) where
+ {-# INLINE def #-}
+ def = listOf def
+
+-- |'QuasiQuoter' for 'MIMEType' literals.
+--
+-- @
+-- textPlain :: 'MIMEType'
+-- textPlain = ['mimeType'| text/plain; charset=\"UTF-8\" |]
+-- @
+mimeType ∷ QuasiQuoter
+mimeType = QuasiQuoter {
+ quoteExp = (lift =≪) ∘ (parseType =≪) ∘ toAscii
+ , quotePat = const unsupported
+ , quoteType = const unsupported
+ , quoteDec = const unsupported
+ }
+ where
+ parseType ∷ Monad m ⇒ Ascii → m MIMEType
+ parseType a
+ = case ca a of
+ Success t → return t
+ Failure e → fail (show e)
+
+ toAscii ∷ Monad m ⇒ String → m Ascii
+ toAscii (trim → s)
+ = case ca s of
+ Success a → return a
+ Failure e → fail (show e)
+
+ unsupported ∷ Monad m ⇒ m α
+ unsupported = fail "Unsupported usage of mimeType quasi-quoter."