{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , TemplateHaskell
  , UnicodeSyntax
  , ViewPatterns
  #-}
-- |An internal module for generating Haskell modules eith an
-- arbitrary file implanted.
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.Char
import Data.Collections
import Data.Convertible.Base
import Data.List (intersperse)
import Data.Monoid
import Data.Ratio
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
import Network.HTTP.Lucu.Implant.Rewrite
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.OrphanInstances ()
import Network.HTTP.Lucu.Resource
import Prelude hiding (head)
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 ∘ cs

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

moduleDecl ∷ ModName → Name → Doc
moduleDecl modName symName
    = text "module" <+> text (modString modName) $+$
      nest 4 (vcat [ lparen <+> ppr symName
                   , rparen
                   , text "where"
                   ])

importDecls ∷ Imports → Doc
importDecls = vcat ∘ map pprImport ∘ fromFoldable

pprImport ∷ ImportOp → Doc
pprImport (QualifiedImp {..})
    = hsep [ text "import"
           , text "qualified"
           , text (modString impModule)
           , text "as"
           , text (modString impAlias)
           ]
pprImport (UnqualifiedImp {impNames = Nothing, ..})
    = hsep [ text "import"
           , text (modString impModule)
           ]
pprImport (UnqualifiedImp {impNames = Just ns, ..})
    = hsep [ text "import"
           , text (modString impModule)
           , hcat [ lparen
                  , sep $ punctuate comma
                        $ map (uncurry pprImpName)
                        $ fromFoldable ns
                  , rparen
                  ]
           ]
    where
      pprImpName ∷ NameSpace → OccName → Doc
      pprImpName TcClsName (occString → o)
          = hcat [text o, text "(..)"]
      pprImpName _         (occString → o)
          | needParen o = hcat [lparen, text o, rparen]
          | otherwise   = text o

      needParen ∷ String → Bool
      needParen (head → c)
          | isPunctuation c = True
          | isSymbol      c = True
          | otherwise       = False

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| Resource |]
               , valD (varP symName) (normalB (resourceE i)) decls
               ]
    where
      decls ∷ [Q Dec]
      decls | useGZip i
                = [ sigD gzipEncoding [t| CIAscii |]
                  , valD (varP gzipEncoding) (normalB (lift ("gzip" ∷ CIAscii))) []
                  ]
            | otherwise
                = []

resourceE ∷ Input → Q Exp
resourceE i = [| mempty {
                   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 (lift 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 (lift iGZipped)) []
                   ]
    | otherwise
        = sequence [ sigD rawData [t| L.ByteString |]
                   , valD (varP rawData) (normalB (lift iRawData)) []
                   ]

rules ∷ Rules
rules = [ qualifyAll   "Codec.Compression.GZip"              "G"
        , unqualify    ''CIAscii                             "Data.Ascii"
        , qualifyAll   "Data.Ascii"                          "A"
        , qualifyAll   "Data.ByteString.Char8"               "B"
        , qualifyAll   "Data.ByteString.Lazy.Internal"       "L"
        , qualifyAll   "Data.CaseInsensitive"                "CI"
        , qualifyAll   "Data.Collections"                    "C"
        , qualifyAll   "Data.Text"                           "T"
        , unqualifyAll "Network.HTTP.Lucu.ETag"              "Network.HTTP.Lucu"
        , unqualifyAll "Network.HTTP.Lucu.Resource"          "Network.HTTP.Lucu"
        , unqualifyAll "Network.HTTP.Lucu.Resource.Internal" "Network.HTTP.Lucu"
        , unqualifyAll "Network.HTTP.Lucu.MIMEType"          "Network.HTTP.Lucu"
        , unqualify    'when                                 "Control.Monad"
        , unqualify    'mempty                               "Data.Monoid"
        , unqualify    '(%)                                  "Data.Ratio"
        , unqualify    ''DiffTime                            "Data.Time"
        , unqualifyIn  'ModifiedJulianDay  ''Day             "Data.Time"
        , unqualifyIn  'UTCTime            ''UTCTime         "Data.Time"
        , unqualifyIn  'False              ''Bool            "Prelude"
        , unqualifyIn  'Just               ''Maybe           "Prelude"
        , unqualify    'fromRational                         "Prelude"
        ]

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 rules decls
         return $ vcat [ header i
                       , moduleDecl modName symName
                       , importDecls mods
                       , text ""
                       , vcat $ intersperse (text "") $ map ppr decls'
                       ]