Network/HTTP/Lucu/Implant/PrettyPrint.hs

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