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