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.Foldable
  22 import Data.List
  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.Resource
  34 import Network.HTTP.Lucu.Utils
  35 import Prelude.Unicode
  36
  37 header ∷ Input → Doc
  38 header i@(Input {..})
  39     = vcat [ text "{- DO NOT EDIT THIS FILE."
  40            , nest 3 $
  41              vcat [ text "This file is automatically generated by lucu-implant-file."
  42                   , text ""
  43                   , text "           Source:" <+> if iPath ≡ "-" then
  44                                                       text "(stdin)"
  45                                                   else
  46                                                       text iPath
  47                   , hsep [ text "  Original Length:"
  48                          , integer (originalLen i)
  49                          , text "bytes"
  50                          ]
  51                   , if useGZip i then
  52                         vcat [ hsep [ text "Compressed Length:"
  53                                     , integer (gzippedLen i)
  54                                     , text "bytes"
  55                                     ]
  56                              , text "      Compression: gzip"
  57                              ]
  58                     else
  59                         text "      Compression: disabled"
  60                   , text "        MIME Type:" <+> mimeTypeToDoc iType
  61                   , text "             ETag:" <+> eTagToDoc iETag
  62                   , text "    Last Modified:" <+> text (show iLastMod)
  63                   ]
  64            , text " -}"
  65            , text "{-# LANGUAGE MagicHash #-}"
  66            ]
  67     where
  68       eTagToDoc ∷ ETag → Doc
  69       eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag
  70
  71       mimeTypeToDoc ∷ MIMEType → Doc
  72       mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
  73
  74 moduleDecl ∷ ModName → Name → Doc
  75 moduleDecl modName symName
  76     = text "module" <+> text (modString modName) $+$
  77       nest 4 (vcat [ lparen <+> ppr symName
  78                    , rparen
  79                    , text "where"
  80                    ])
  81
  82 importDecls ∷ Imports ImportOp → Doc
  83 importDecls = vcat ∘ map pprImport ∘ toList
  84
  85 pprImport ∷ ImportOp → Doc
  86 pprImport (QualifiedImp {..})
  87     = hsep [ text "import"
  88            , text "qualified"
  89            , text (modString impModule)
  90            , text "as"
  91            , text (modString impAlias)
  92            ]
  93 pprImport (UnqualifiedImp {impNames = Nothing, ..})
  94     = hsep [ text "import"
  95            , text (modString impModule)
  96            ]
  97 pprImport (UnqualifiedImp {impNames = Just ns, ..})
  98     = hsep [ text "import"
  99            , text (modString impModule)
 100            , hcat [ lparen
 101                   , sep $ punctuate comma
 102                         $ map (uncurry pprImpName)
 103                         $ toList ns
 104                   , rparen
 105                   ]
 106            ]
 107     where
 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]
 113           | otherwise   = text o
 114
 115       needParen ∷ String → Bool
 116       needParen (head → c)
 117           | isPunctuation c = True
 118           | isSymbol      c = True
 119           | otherwise       = False
 120
 121 entityTag ∷ Name
 122 entityTag = mkName "entityTag"
 123
 124 lastModified ∷ Name
 125 lastModified = mkName "lastModified"
 126
 127 contentType ∷ Name
 128 contentType = mkName "contentType"
 129
 130 rawData ∷ Name
 131 rawData = mkName "rawData"
 132
 133 gzippedData ∷ Name
 134 gzippedData = mkName "gzippedData"
 135
 136 gzipEncoding ∷ Name
 137 gzipEncoding = mkName "gzipEncoding"
 138
 139 resourceDecl ∷ Input → Name → Q [Dec]
 140 resourceDecl i symName
 141     = sequence [ sigD symName [t| ResourceDef |]
 142                , valD (varP symName) (normalB (resourceE i)) decls
 143                ]
 144     where
 145       decls ∷ [Q Dec]
 146       decls | useGZip i
 147                 = [ sigD gzipEncoding [t| CIAscii |]
 148                   , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) []
 149                   ]
 150             | otherwise
 151                 = []
 152
 153 resourceE ∷ Input → Q Exp
 154 resourceE i = [| emptyResource {
 155                    resGet  = $(resGetE  i)
 156                  , resHead = $(resHeadE i)
 157                  }
 158                |]
 159
 160 resGetE ∷ Input → Q Exp
 161 resGetE i
 162     | useGZip i
 163         = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
 164                        setContentType $(varE contentType)
 165
 166                        gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
 167                        if gzipAllowed then
 168                            do setContentEncoding [$(varE gzipEncoding)]
 169                               putChunks $(varE gzippedData)
 170                        else
 171                            putChunks (decompress $(varE gzippedData))
 172                   )
 173            |]
 174     | otherwise
 175         = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
 176                        setContentType $(varE contentType)
 177                        putChunks $(varE rawData)
 178                   )
 179            |]
 180
 181 resHeadE ∷ Input → Q Exp
 182 resHeadE i
 183     | useGZip i
 184         = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
 185                        setContentType $(varE contentType)
 186
 187                        gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
 188                        when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
 189                   )
 190            |]
 191     | otherwise
 192         = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
 193                        setContentType $(varE contentType)
 194                   )
 195            |]
 196
 197 eTagDecl ∷ Input → Q [Dec]
 198 eTagDecl (Input {..})
 199     = sequence [ sigD entityTag [t| ETag |]
 200                , valD (varP entityTag) (normalB (lift iETag)) []
 201                ]
 202
 203 lastModDecl ∷ Input → Q [Dec]
 204 lastModDecl (Input {..})
 205     = sequence [ sigD lastModified [t| UTCTime |]
 206                , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) []
 207                ]
 208
 209 contTypeDecl ∷ Input → Q [Dec]
 210 contTypeDecl (Input {..})
 211     = sequence [ sigD contentType [t| MIMEType |]
 212                , valD (varP contentType) (normalB (lift iType)) []
 213                ]
 214
 215 binDecl ∷ Input → Q [Dec]
 216 binDecl i@(Input {..})
 217     | useGZip i
 218         = sequence [ sigD gzippedData [t| L.ByteString |]
 219                    , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) []
 220                    ]
 221     | otherwise
 222         = sequence [ sigD rawData [t| L.ByteString |]
 223                    , valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
 224                    ]
 225
 226 rules ∷ Rules
 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"
 247         ]
 248
 249 pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc
 250 pprInput i modName symName
 251     = do decls ← runQ $ sequence [ resourceDecl i symName
 252                                  , eTagDecl i
 253                                  , lastModDecl i
 254                                  , contTypeDecl i
 255                                  , binDecl i
 256                                  ]
 257          let (decls', mods) = rewriteNames rules decls
 258          return $ vcat [ header i
 259                        , moduleDecl modName symName
 260                        , importDecls mods
 261                        , text ""
 262                        , vcat $ intersperse (text "") $ map ppr decls'
 263                        ]