{-# LANGUAGE
    DoAndIfThenElse
  , FlexibleContexts
  , MultiParamTypeClasses
  , 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 (Ascii, CIAscii)
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Collections
import Data.Convertible.Base
import Data.Convertible.Utils
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:" <+> toDoc iType
                  , text "             ETag:" <+> toDoc iETag
                  , text "    Last Modified:" <+> text (show iLastMod)
                  ]
           , text " -}"
           , text "{-# LANGUAGE MagicHash #-}"
           ]
    where
      toDoc  ConvertSuccess α Ascii  α  Doc
      toDoc = text  convertSuccessVia (()  Ascii)

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'
                       ]