{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , TemplateHaskell
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Implant.PrettyPrint
    ( pprInput
    )
    where
import Codec.Compression.GZip
import Control.Monad
import Data.Ascii (CIAscii)
import qualified Data.Ascii as A
import qualified Data.ByteString.Lazy as L
import Data.List
import qualified Data.Map as M
import Data.Time
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
import Network.HTTP.Lucu.ETag
import Network.HTTP.Lucu.Implant.Input
import Network.HTTP.Lucu.Implant.Rewrite
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Resource
import Network.HTTP.Lucu.Utils
import Prelude.Unicode

header ∷ Input → Doc
header i@(Input {..})
    = vcat [ text "{- DO NOT EDIT THIS FILE."
           , nest 3 $
             vcat [ text "This file is automatically generated by lucu-implant-file."
                  , text ""
                  , text "           Source:" <+> if iPath ≡ "-" then
                                                      text "(stdin)"
                                                  else
                                                      text iPath
                  , hsep [ text "  Original Length:"
                         , integer (originalLen i)
                         , text "bytes"
                         ]
                  , if useGZip i then
                        vcat [ hsep [ text "Compressed Length:"
                                    , integer (gzippedLen i)
                                    , text "bytes"
                                    ]
                             , text "      Compression: gzip"
                             ]
                    else
                        text "      Compression: disabled"
                  , text "        MIME Type:" <+> mimeTypeToDoc iType
                  , text "             ETag:" <+> eTagToDoc iETag
                  , text "    Last Modified:" <+> text (show iLastMod)
                  ]
           , text " -}"
           , text "{-# LANGUAGE MagicHash #-}"
           ]
    where
      eTagToDoc ∷ ETag → Doc
      eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag

      mimeTypeToDoc ∷ MIMEType → Doc
      mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType

moduleDecl ∷ ModName → Name → Doc
moduleDecl modName symName
    = hsep [ text "module"
           , text (modString modName)
           , lparen
           , ppr symName
           , rparen
           , text "where"
           ]

importDecls ∷ ModMap → Doc
importDecls = vcat ∘ map f ∘ M.toAscList
    where
      f ∷ (ModName, Maybe ModName) → Doc
      f (m, Nothing) = hsep [ text "import"
                            , text (modString m)
                            ]
      f (m, Just m') = hsep [ text "import"
                            , text "qualified"
                            , text (modString m)
                            , text "as"
                            , text (modString m')
                            ]

entityTag ∷ Name
entityTag = mkName "entityTag"

lastModified ∷ Name
lastModified = mkName "lastModified"

contentType ∷ Name
contentType = mkName "contentType"

rawData ∷ Name
rawData = mkName "rawData"

gzippedData ∷ Name
gzippedData = mkName "gzippedData"

gzipEncoding ∷ Name
gzipEncoding = mkName "gzipEncoding"

resourceDecl ∷ Input → Name → Q [Dec]
resourceDecl i symName
    = sequence [ sigD symName [t| ResourceDef |]
               , valD (varP symName) (normalB (resourceE i)) decls
               ]
    where
      decls ∷ [Q Dec]
      decls | useGZip i
                = [ sigD gzipEncoding [t| CIAscii |]
                  , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) []
                  ]
            | otherwise
                = []

resourceE ∷ Input → Q Exp
resourceE i = [| emptyResource {
                   resGet  = $(resGetE  i)
                 , resHead = $(resHeadE i)
                 }
               |]

resGetE ∷ Input → Q Exp
resGetE i
    | useGZip i
        = [| Just $
             do foundEntity $(varE entityTag) $(varE lastModified)
                setContentType $(varE contentType)

                gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
                if gzipAllowed then
                    do setContentEncoding [$(varE gzipEncoding)]
                       putChunks $(varE gzippedData)
                else
                    putChunks (decompress $(varE gzippedData))
           |]
    | otherwise
        = [| Just $
             do foundEntity $(varE entityTag) $(varE lastModified)
                setContentType $(varE contentType)
                putChunks $(varE rawData)
           |]

resHeadE ∷ Input → Q Exp
resHeadE i
    | useGZip i
        = [| Just $
             do foundEntity $(varE entityTag) $(varE lastModified)
                setContentType $(varE contentType)

                gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
                when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
           |]
    | otherwise
        = [| Just $
             do foundEntity $(varE entityTag)
                            $(varE lastModified)
                setContentType $(varE contentType)
           |]

eTagDecl ∷ Input → Q [Dec]
eTagDecl (Input {..})
    = sequence [ sigD entityTag [t| ETag |]
               , valD (varP entityTag) (normalB (lift iETag)) []
               ]

lastModDecl ∷ Input → Q [Dec]
lastModDecl (Input {..})
    = sequence [ sigD lastModified [t| UTCTime |]
               , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) []
               ]

contTypeDecl ∷ Input → Q [Dec]
contTypeDecl (Input {..})
    = sequence [ sigD contentType [t| MIMEType |]
               , valD (varP contentType) (normalB (lift iType)) []
               ]

binDecl ∷ Input → Q [Dec]
binDecl i@(Input {..})
    | useGZip i
        = sequence [ sigD gzippedData [t| L.ByteString |]
                   , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) []
                   ]
    | otherwise
        = sequence [ sigD rawData [t| L.ByteString |]
                   , valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
                   ]

pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc
pprInput i modName symName
    = do decls ← runQ $ sequence [ resourceDecl i symName
                                 , eTagDecl i
                                 , lastModDecl i
                                 , contTypeDecl i
                                 , binDecl i
                                 ]
         let (decls', mods) = rewriteNames decls
         return $ vcat [ header i
                       , moduleDecl modName symName
                       , importDecls mods
                       , text ""
                       , vcat $ intersperse (text "") $ map ppr decls'
                       ]