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                        ]