{-# LANGUAGE
    DeriveDataTypeable
  , FlexibleInstances
  , MultiParamTypeClasses
  , 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
    )
    where
import Control.Applicative
import Control.Monad.Unicode
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
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.
data MIMEType
    = MIMEType {
        mtMedia  ∷ !CIAscii
      , mtSub    ∷ !CIAscii
      , mtParams ∷ !MIMEParams
      }
    deriving (Eq, Show, Read, Typeable)

instance Lift MIMEType where
    lift (MIMEType {..})
        = [| MIMEType {
               mtMedia  = $(lift mtMedia )
             , mtSub    = $(lift mtSub   )
             , mtParams = $(lift mtParams)
             }
           |]

instance ConvertSuccess MIMEType Ascii where
    {-# INLINE convertSuccess #-}
    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)

instance ConvertSuccess MIMEType AsciiBuilder where
    {-# INLINEABLE convertSuccess #-}
    convertSuccess (MIMEType {..})
        = cs mtMedia       ⊕
          cs ("/" ∷ Ascii) ⊕
          cs mtSub         ⊕
          cs mtParams

deriveAttempts [ ([t| MIMEType |], [t| Ascii        |])
               , ([t| MIMEType |], [t| AsciiBuilder |])
               ]

-- |Parse 'MIMEType' from an 'Ascii'. For MIME type literals, consider
-- using 'mimeType' quasi-quoter.
instance ConvertAttempt Ascii MIMEType where
    {-# INLINEABLE convertAttempt #-}
    convertAttempt str
        = case parseOnly (finishOff def) (cs str) of
            Right  t → return t
            Left err → fail ("Unparsable MIME Type: " ⧺ cs str ⧺ ": " ⧺ err)

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

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."