9 -- |An internal module for generating Haskell modules eith an
10 -- arbitrary file implanted.
11 module Network.HTTP.Lucu.Implant.PrettyPrint
15 import Codec.Compression.GZip
17 import Data.Ascii (CIAscii)
18 import qualified Data.Ascii as A
19 import qualified Data.ByteString.Lazy as L
25 import Language.Haskell.TH.Lib
26 import Language.Haskell.TH.Ppr
27 import Language.Haskell.TH.PprLib
28 import Language.Haskell.TH.Syntax
29 import Network.HTTP.Lucu.ETag
30 import Network.HTTP.Lucu.Implant
31 import Network.HTTP.Lucu.Implant.Rewrite
32 import Network.HTTP.Lucu.MIMEType
33 import Network.HTTP.Lucu.Resource
34 import Network.HTTP.Lucu.Utils
35 import Prelude.Unicode
39 = vcat [ text "{- DO NOT EDIT THIS FILE."
41 vcat [ text "This file is automatically generated by lucu-implant-file."
43 , text " Source:" <+> if iPath ≡ "-" then
47 , hsep [ text " Original Length:"
48 , integer (originalLen i)
52 vcat [ hsep [ text "Compressed Length:"
53 , integer (gzippedLen i)
56 , text " Compression: gzip"
59 text " Compression: disabled"
60 , text " MIME Type:" <+> mimeTypeToDoc iType
61 , text " ETag:" <+> eTagToDoc iETag
62 , text " Last Modified:" <+> text (show iLastMod)
65 , text "{-# LANGUAGE MagicHash #-}"
68 eTagToDoc ∷ ETag → Doc
69 eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag
71 mimeTypeToDoc ∷ MIMEType → Doc
72 mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
74 moduleDecl ∷ ModName → Name → Doc
75 moduleDecl modName symName
76 = text "module" <+> text (modString modName) $+$
77 nest 4 (vcat [ lparen <+> ppr symName
82 importDecls ∷ Imports ImportOp → Doc
83 importDecls = vcat ∘ map pprImport ∘ toList
85 pprImport ∷ ImportOp → Doc
86 pprImport (QualifiedImp {..})
87 = hsep [ text "import"
89 , text (modString impModule)
91 , text (modString impAlias)
93 pprImport (UnqualifiedImp {impNames = Nothing, ..})
94 = hsep [ text "import"
95 , text (modString impModule)
97 pprImport (UnqualifiedImp {impNames = Just ns, ..})
98 = hsep [ text "import"
99 , text (modString impModule)
101 , sep $ punctuate comma
102 $ map (uncurry pprImpName)
108 pprImpName ∷ NameSpace → OccName → Doc
109 pprImpName TcClsName (occString → o)
110 = hcat [text o, text "(..)"]
111 pprImpName _ (occString → o)
112 | needParen o = hcat [lparen, text o, rparen]
115 needParen ∷ String → Bool
117 | isPunctuation c = True
122 entityTag = mkName "entityTag"
125 lastModified = mkName "lastModified"
128 contentType = mkName "contentType"
131 rawData = mkName "rawData"
134 gzippedData = mkName "gzippedData"
137 gzipEncoding = mkName "gzipEncoding"
139 resourceDecl ∷ Input → Name → Q [Dec]
140 resourceDecl i symName
141 = sequence [ sigD symName [t| ResourceDef |]
142 , valD (varP symName) (normalB (resourceE i)) decls
147 = [ sigD gzipEncoding [t| CIAscii |]
148 , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) []
153 resourceE ∷ Input → Q Exp
154 resourceE i = [| emptyResource {
155 resGet = $(resGetE i)
156 , resHead = $(resHeadE i)
160 resGetE ∷ Input → Q Exp
163 = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
164 setContentType $(varE contentType)
166 gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
168 do setContentEncoding [$(varE gzipEncoding)]
169 putChunks $(varE gzippedData)
171 putChunks (decompress $(varE gzippedData))
175 = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
176 setContentType $(varE contentType)
177 putChunks $(varE rawData)
181 resHeadE ∷ Input → Q Exp
184 = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
185 setContentType $(varE contentType)
187 gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
188 when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
192 = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
193 setContentType $(varE contentType)
197 eTagDecl ∷ Input → Q [Dec]
198 eTagDecl (Input {..})
199 = sequence [ sigD entityTag [t| ETag |]
200 , valD (varP entityTag) (normalB (lift iETag)) []
203 lastModDecl ∷ Input → Q [Dec]
204 lastModDecl (Input {..})
205 = sequence [ sigD lastModified [t| UTCTime |]
206 , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) []
209 contTypeDecl ∷ Input → Q [Dec]
210 contTypeDecl (Input {..})
211 = sequence [ sigD contentType [t| MIMEType |]
212 , valD (varP contentType) (normalB (lift iType)) []
215 binDecl ∷ Input → Q [Dec]
216 binDecl i@(Input {..})
218 = sequence [ sigD gzippedData [t| L.ByteString |]
219 , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) []
222 = sequence [ sigD rawData [t| L.ByteString |]
223 , valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
227 rules = [ qualifyAll "Codec.Compression.GZip" "G"
228 , unqualify ''CIAscii "Data.Ascii"
229 , qualifyAll "Data.Ascii" "A"
230 , qualifyAll "Data.ByteString.Char8" "B"
231 , qualifyAll "Data.ByteString.Lazy.Internal" "L"
232 , qualifyAll "Data.Map" "M"
233 , qualifyAll "Data.Text" "T"
234 , unqualifyAll "Network.HTTP.Lucu.ETag" "Network.HTTP.Lucu"
235 , unqualifyAll "Network.HTTP.Lucu.Resource" "Network.HTTP.Lucu"
236 , unqualifyAll "Network.HTTP.Lucu.Resource.Internal" "Network.HTTP.Lucu"
237 , unqualifyAll "Network.HTTP.Lucu.MIMEParams" "Network.HTTP.Lucu"
238 , unqualifyAll "Network.HTTP.Lucu.MIMEType" "Network.HTTP.Lucu"
239 , unqualify 'when "Control.Monad"
240 , unqualify '(%) "Data.Ratio"
241 , unqualify ''DiffTime "Data.Time"
242 , unqualifyIn 'ModifiedJulianDay ''Day "Data.Time"
243 , unqualifyIn 'UTCTime ''UTCTime "Data.Time"
244 , unqualifyIn 'False ''Bool "Prelude"
245 , unqualifyIn 'Just ''Maybe "Prelude"
246 , unqualify 'fromRational "Prelude"
249 pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc
250 pprInput i modName symName
251 = do decls ← runQ $ sequence [ resourceDecl i symName
257 let (decls', mods) = rewriteNames rules decls
258 return $ vcat [ header i
259 , moduleDecl modName symName
262 , vcat $ intersperse (text "") $ map ppr decls'