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
21 import Data.Collections
22 import Data.Convertible.Base
23 import Data.List (intersperse)
27 import Language.Haskell.TH.Lib
28 import Language.Haskell.TH.Ppr
29 import Language.Haskell.TH.PprLib
30 import Language.Haskell.TH.Syntax
31 import Network.HTTP.Lucu.ETag
32 import Network.HTTP.Lucu.Implant
33 import Network.HTTP.Lucu.Implant.Rewrite
34 import Network.HTTP.Lucu.MIMEType
35 import Network.HTTP.Lucu.OrphanInstances ()
36 import Network.HTTP.Lucu.Resource
37 import Prelude hiding (head)
38 import Prelude.Unicode
42 = vcat [ text "{- DO NOT EDIT THIS FILE."
44 vcat [ text "This file is automatically generated by lucu-implant-file."
46 , text " Source:" <+> if iPath ≡ "-" then
50 , hsep [ text " Original Length:"
51 , integer (originalLen i)
55 vcat [ hsep [ text "Compressed Length:"
56 , integer (gzippedLen i)
59 , text " Compression: gzip"
62 text " Compression: disabled"
63 , text " MIME Type:" <+> mimeTypeToDoc iType
64 , text " ETag:" <+> eTagToDoc iETag
65 , text " Last Modified:" <+> text (show iLastMod)
68 , text "{-# LANGUAGE MagicHash #-}"
71 eTagToDoc ∷ ETag → Doc
72 eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ cs
74 mimeTypeToDoc ∷ MIMEType → Doc
75 mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
77 moduleDecl ∷ ModName → Name → Doc
78 moduleDecl modName symName
79 = text "module" <+> text (modString modName) $+$
80 nest 4 (vcat [ lparen <+> ppr symName
85 importDecls ∷ Imports → Doc
86 importDecls = vcat ∘ map pprImport ∘ fromFoldable
88 pprImport ∷ ImportOp → Doc
89 pprImport (QualifiedImp {..})
90 = hsep [ text "import"
92 , text (modString impModule)
94 , text (modString impAlias)
96 pprImport (UnqualifiedImp {impNames = Nothing, ..})
97 = hsep [ text "import"
98 , text (modString impModule)
100 pprImport (UnqualifiedImp {impNames = Just ns, ..})
101 = hsep [ text "import"
102 , text (modString impModule)
104 , sep $ punctuate comma
105 $ map (uncurry pprImpName)
111 pprImpName ∷ NameSpace → OccName → Doc
112 pprImpName TcClsName (occString → o)
113 = hcat [text o, text "(..)"]
114 pprImpName _ (occString → o)
115 | needParen o = hcat [lparen, text o, rparen]
118 needParen ∷ String → Bool
120 | isPunctuation c = True
125 entityTag = mkName "entityTag"
128 lastModified = mkName "lastModified"
131 contentType = mkName "contentType"
134 rawData = mkName "rawData"
137 gzippedData = mkName "gzippedData"
140 gzipEncoding = mkName "gzipEncoding"
142 resourceDecl ∷ Input → Name → Q [Dec]
143 resourceDecl i symName
144 = sequence [ sigD symName [t| Resource |]
145 , valD (varP symName) (normalB (resourceE i)) decls
150 = [ sigD gzipEncoding [t| CIAscii |]
151 , valD (varP gzipEncoding) (normalB (lift ("gzip" ∷ CIAscii))) []
156 resourceE ∷ Input → Q Exp
157 resourceE i = [| mempty {
158 resGet = $(resGetE i)
159 , resHead = $(resHeadE i)
163 resGetE ∷ Input → Q Exp
166 = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
167 setContentType $(varE contentType)
169 gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
171 do setContentEncoding [$(varE gzipEncoding)]
172 putChunks $(varE gzippedData)
174 putChunks (decompress $(varE gzippedData))
178 = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
179 setContentType $(varE contentType)
180 putChunks $(varE rawData)
184 resHeadE ∷ Input → Q Exp
187 = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
188 setContentType $(varE contentType)
190 gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
191 when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
195 = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
196 setContentType $(varE contentType)
200 eTagDecl ∷ Input → Q [Dec]
201 eTagDecl (Input {..})
202 = sequence [ sigD entityTag [t| ETag |]
203 , valD (varP entityTag) (normalB (lift iETag)) []
206 lastModDecl ∷ Input → Q [Dec]
207 lastModDecl (Input {..})
208 = sequence [ sigD lastModified [t| UTCTime |]
209 , valD (varP lastModified) (normalB (lift iLastMod)) []
212 contTypeDecl ∷ Input → Q [Dec]
213 contTypeDecl (Input {..})
214 = sequence [ sigD contentType [t| MIMEType |]
215 , valD (varP contentType) (normalB (lift iType)) []
218 binDecl ∷ Input → Q [Dec]
219 binDecl i@(Input {..})
221 = sequence [ sigD gzippedData [t| L.ByteString |]
222 , valD (varP gzippedData) (normalB (lift iGZipped)) []
225 = sequence [ sigD rawData [t| L.ByteString |]
226 , valD (varP rawData) (normalB (lift iRawData)) []
230 rules = [ qualifyAll "Codec.Compression.GZip" "G"
231 , unqualify ''CIAscii "Data.Ascii"
232 , qualifyAll "Data.Ascii" "A"
233 , qualifyAll "Data.ByteString.Char8" "B"
234 , qualifyAll "Data.ByteString.Lazy.Internal" "L"
235 , qualifyAll "Data.CaseInsensitive" "CI"
236 , qualifyAll "Data.Collections" "C"
237 , qualifyAll "Data.Text" "T"
238 , unqualifyAll "Network.HTTP.Lucu.ETag" "Network.HTTP.Lucu"
239 , unqualifyAll "Network.HTTP.Lucu.Resource" "Network.HTTP.Lucu"
240 , unqualifyAll "Network.HTTP.Lucu.Resource.Internal" "Network.HTTP.Lucu"
241 , unqualifyAll "Network.HTTP.Lucu.MIMEType" "Network.HTTP.Lucu"
242 , unqualify 'when "Control.Monad"
243 , unqualify 'mempty "Data.Monoid"
244 , unqualify '(%) "Data.Ratio"
245 , unqualify ''DiffTime "Data.Time"
246 , unqualifyIn 'ModifiedJulianDay ''Day "Data.Time"
247 , unqualifyIn 'UTCTime ''UTCTime "Data.Time"
248 , unqualifyIn 'False ''Bool "Prelude"
249 , unqualifyIn 'Just ''Maybe "Prelude"
250 , unqualify 'fromRational "Prelude"
253 pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc
254 pprInput i modName symName
255 = do decls ← runQ $ sequence [ resourceDecl i symName
261 let (decls', mods) = rewriteNames rules decls
262 return $ vcat [ header i
263 , moduleDecl modName symName
266 , vcat $ intersperse (text "") $ map ppr decls'