{-# LANGUAGE
    DeriveDataTypeable
  , FlexibleInstances
  , MultiParamTypeClasses
  , OverloadedStrings
  , RecordWildCards
  , TemplateHaskell
  , UnicodeSyntax
  #-}
-- |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 Data.Ascii (Ascii, AsciiBuilder, CIAscii)
import Data.Attoparsec.Char8
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
import Data.Monoid.Unicode
import Data.Typeable
import Language.Haskell.TH.Syntax
import Network.HTTP.Lucu.MIMEParams
import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Parser
import Network.HTTP.Lucu.Parser.Http
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 'Network.HTTP.Lucu.MIMEType.TH.mimeType'.
instance ConvertAttempt Ascii MIMEType where
    {-# INLINEABLE convertAttempt #-}
    convertAttempt str
        = case parseOnly (finishOff mimeType) (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  ← cs <$> token
              _      ← char '/'
              sub    ← cs <$> token
              params ← mimeParams
              return $ MIMEType media sub params

-- |'Parser' for a list of 'MIMEType's.
mimeTypeList ∷ Parser [MIMEType]
{-# INLINE mimeTypeList #-}
mimeTypeList = listOf mimeType