]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Implant/PrettyPrint.hs
Fixed lots of bugs
[Lucu.git] / Network / HTTP / Lucu / Implant / PrettyPrint.hs
1 {-# LANGUAGE
2     DoAndIfThenElse
3   , OverloadedStrings
4   , RecordWildCards
5   , TemplateHaskell
6   , UnicodeSyntax
7   , ViewPatterns
8   #-}
9 -- |An internal module for generating Haskell modules eith an
10 -- arbitrary file implanted.
11 module Network.HTTP.Lucu.Implant.PrettyPrint
12     ( pprInput
13     )
14     where
15 import Codec.Compression.GZip
16 import Control.Monad
17 import Data.Ascii (CIAscii)
18 import qualified Data.Ascii as A
19 import qualified Data.ByteString.Lazy as L
20 import Data.Char
21 import Data.Collections
22 import Data.List (intersperse)
23 import Data.Ratio
24 import Data.Time
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.OrphanInstances ()
34 import Network.HTTP.Lucu.Resource
35 import Prelude hiding (head)
36 import Prelude.Unicode
37
38 header ∷ Input → Doc
39 header i@(Input {..})
40     = vcat [ text "{- DO NOT EDIT THIS FILE."
41            , nest 3 $
42              vcat [ text "This file is automatically generated by lucu-implant-file."
43                   , text ""
44                   , text "           Source:" <+> if iPath ≡ "-" then
45                                                       text "(stdin)"
46                                                   else
47                                                       text iPath
48                   , hsep [ text "  Original Length:"
49                          , integer (originalLen i)
50                          , text "bytes"
51                          ]
52                   , if useGZip i then
53                         vcat [ hsep [ text "Compressed Length:"
54                                     , integer (gzippedLen i)
55                                     , text "bytes"
56                                     ]
57                              , text "      Compression: gzip"
58                              ]
59                     else
60                         text "      Compression: disabled"
61                   , text "        MIME Type:" <+> mimeTypeToDoc iType
62                   , text "             ETag:" <+> eTagToDoc iETag
63                   , text "    Last Modified:" <+> text (show iLastMod)
64                   ]
65            , text " -}"
66            , text "{-# LANGUAGE MagicHash #-}"
67            ]
68     where
69       eTagToDoc ∷ ETag → Doc
70       eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag
71
72       mimeTypeToDoc ∷ MIMEType → Doc
73       mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
74
75 moduleDecl ∷ ModName → Name → Doc
76 moduleDecl modName symName
77     = text "module" <+> text (modString modName) $+$
78       nest 4 (vcat [ lparen <+> ppr symName
79                    , rparen
80                    , text "where"
81                    ])
82
83 importDecls ∷ Imports → Doc
84 importDecls = vcat ∘ map pprImport ∘ fromFoldable
85
86 pprImport ∷ ImportOp → Doc
87 pprImport (QualifiedImp {..})
88     = hsep [ text "import"
89            , text "qualified"
90            , text (modString impModule)
91            , text "as"
92            , text (modString impAlias)
93            ]
94 pprImport (UnqualifiedImp {impNames = Nothing, ..})
95     = hsep [ text "import"
96            , text (modString impModule)
97            ]
98 pprImport (UnqualifiedImp {impNames = Just ns, ..})
99     = hsep [ text "import"
100            , text (modString impModule)
101            , hcat [ lparen
102                   , sep $ punctuate comma
103                         $ map (uncurry pprImpName)
104                         $ fromFoldable ns
105                   , rparen
106                   ]
107            ]
108     where
109       pprImpName ∷ NameSpace → OccName → Doc
110       pprImpName TcClsName (occString → o)
111           = hcat [text o, text "(..)"]
112       pprImpName _         (occString → o)
113           | needParen o = hcat [lparen, text o, rparen]
114           | otherwise   = text o
115
116       needParen ∷ String → Bool
117       needParen (head → c)
118           | isPunctuation c = True
119           | isSymbol      c = True
120           | otherwise       = False
121
122 entityTag ∷ Name
123 entityTag = mkName "entityTag"
124
125 lastModified ∷ Name
126 lastModified = mkName "lastModified"
127
128 contentType ∷ Name
129 contentType = mkName "contentType"
130
131 rawData ∷ Name
132 rawData = mkName "rawData"
133
134 gzippedData ∷ Name
135 gzippedData = mkName "gzippedData"
136
137 gzipEncoding ∷ Name
138 gzipEncoding = mkName "gzipEncoding"
139
140 resourceDecl ∷ Input → Name → Q [Dec]
141 resourceDecl i symName
142     = sequence [ sigD symName [t| ResourceDef |]
143                , valD (varP symName) (normalB (resourceE i)) decls
144                ]
145     where
146       decls ∷ [Q Dec]
147       decls | useGZip i
148                 = [ sigD gzipEncoding [t| CIAscii |]
149                   , valD (varP gzipEncoding) (normalB (lift ("gzip" ∷ CIAscii))) []
150                   ]
151             | otherwise
152                 = []
153
154 resourceE ∷ Input → Q Exp
155 resourceE i = [| emptyResource {
156                    resGet  = $(resGetE  i)
157                  , resHead = $(resHeadE i)
158                  }
159                |]
160
161 resGetE ∷ Input → Q Exp
162 resGetE i
163     | useGZip i
164         = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
165                        setContentType $(varE contentType)
166
167                        gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
168                        if gzipAllowed then
169                            do setContentEncoding [$(varE gzipEncoding)]
170                               putChunks $(varE gzippedData)
171                        else
172                            putChunks (decompress $(varE gzippedData))
173                   )
174            |]
175     | otherwise
176         = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
177                        setContentType $(varE contentType)
178                        putChunks $(varE rawData)
179                   )
180            |]
181
182 resHeadE ∷ Input → Q Exp
183 resHeadE i
184     | useGZip i
185         = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
186                        setContentType $(varE contentType)
187
188                        gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
189                        when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
190                   )
191            |]
192     | otherwise
193         = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
194                        setContentType $(varE contentType)
195                   )
196            |]
197
198 eTagDecl ∷ Input → Q [Dec]
199 eTagDecl (Input {..})
200     = sequence [ sigD entityTag [t| ETag |]
201                , valD (varP entityTag) (normalB (lift iETag)) []
202                ]
203
204 lastModDecl ∷ Input → Q [Dec]
205 lastModDecl (Input {..})
206     = sequence [ sigD lastModified [t| UTCTime |]
207                , valD (varP lastModified) (normalB (lift iLastMod)) []
208                ]
209
210 contTypeDecl ∷ Input → Q [Dec]
211 contTypeDecl (Input {..})
212     = sequence [ sigD contentType [t| MIMEType |]
213                , valD (varP contentType) (normalB (lift iType)) []
214                ]
215
216 binDecl ∷ Input → Q [Dec]
217 binDecl i@(Input {..})
218     | useGZip i
219         = sequence [ sigD gzippedData [t| L.ByteString |]
220                    , valD (varP gzippedData) (normalB (lift iGZipped)) []
221                    ]
222     | otherwise
223         = sequence [ sigD rawData [t| L.ByteString |]
224                    , valD (varP rawData) (normalB (lift iRawData)) []
225                    ]
226
227 rules ∷ Rules
228 rules = [ qualifyAll   "Codec.Compression.GZip"              "G"
229         , unqualify    ''CIAscii                             "Data.Ascii"
230         , qualifyAll   "Data.Ascii"                          "A"
231         , qualifyAll   "Data.ByteString.Char8"               "B"
232         , qualifyAll   "Data.ByteString.Lazy.Internal"       "L"
233         , qualifyAll   "Data.CaseInsensitive"                "CI"
234         , qualifyAll   "Data.Collections"                    "C"
235         , qualifyAll   "Data.Text"                           "T"
236         , unqualifyAll "Network.HTTP.Lucu.ETag"              "Network.HTTP.Lucu"
237         , unqualifyAll "Network.HTTP.Lucu.Resource"          "Network.HTTP.Lucu"
238         , unqualifyAll "Network.HTTP.Lucu.Resource.Internal" "Network.HTTP.Lucu"
239         , unqualifyAll "Network.HTTP.Lucu.MIMEParams"        "Network.HTTP.Lucu"
240         , unqualifyAll "Network.HTTP.Lucu.MIMEType"          "Network.HTTP.Lucu"
241         , unqualify    'when                                 "Control.Monad"
242         , unqualify    '(%)                                  "Data.Ratio"
243         , unqualify    ''DiffTime                            "Data.Time"
244         , unqualifyIn  'ModifiedJulianDay  ''Day             "Data.Time"
245         , unqualifyIn  'UTCTime            ''UTCTime         "Data.Time"
246         , unqualifyIn  'False              ''Bool            "Prelude"
247         , unqualifyIn  'Just               ''Maybe           "Prelude"
248         , unqualify    'fromRational                         "Prelude"
249         ]
250
251 pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc
252 pprInput i modName symName
253     = do decls ← runQ $ sequence [ resourceDecl i symName
254                                  , eTagDecl i
255                                  , lastModDecl i
256                                  , contTypeDecl i
257                                  , binDecl i
258                                  ]
259          let (decls', mods) = rewriteNames rules decls
260          return $ vcat [ header i
261                        , moduleDecl modName symName
262                        , importDecls mods
263                        , text ""
264                        , vcat $ intersperse (text "") $ map ppr decls'
265                        ]