{-# LANGUAGE
    DeriveDataTypeable
  , FlexibleInstances
  , MultiParamTypeClasses
  , OverloadedStrings
  , RecordWildCards
  , TemplateHaskell
  , 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.Attoparsec.Parsable
import Data.ByteString (ByteString)
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 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 parser) (cs str) of
            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 Parsable ByteString [MIMEType] where
    {-# INLINE parser #-}
    parser = listOf parser

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