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