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.Monoid
  24 import Data.Ratio
  25 import Data.Time
  26 import Language.Haskell.TH.Lib
  27 import Language.Haskell.TH.Ppr
  28 import Language.Haskell.TH.PprLib
  29 import Language.Haskell.TH.Syntax
  30 import Network.HTTP.Lucu.ETag
  31 import Network.HTTP.Lucu.Implant
  32 import Network.HTTP.Lucu.Implant.Rewrite
  33 import Network.HTTP.Lucu.MIMEType
  34 import Network.HTTP.Lucu.OrphanInstances ()
  35 import Network.HTTP.Lucu.Resource
  36 import Prelude hiding (head)
  37 import Prelude.Unicode
  38
  39 header ∷ Input → Doc
  40 header i@(Input {..})
  41     = vcat [ text "{- DO NOT EDIT THIS FILE."
  42            , nest 3 $
  43              vcat [ text "This file is automatically generated by lucu-implant-file."
  44                   , text ""
  45                   , text "           Source:" <+> if iPath ≡ "-" then
  46                                                       text "(stdin)"
  47                                                   else
  48                                                       text iPath
  49                   , hsep [ text "  Original Length:"
  50                          , integer (originalLen i)
  51                          , text "bytes"
  52                          ]
  53                   , if useGZip i then
  54                         vcat [ hsep [ text "Compressed Length:"
  55                                     , integer (gzippedLen i)
  56                                     , text "bytes"
  57                                     ]
  58                              , text "      Compression: gzip"
  59                              ]
  60                     else
  61                         text "      Compression: disabled"
  62                   , text "        MIME Type:" <+> mimeTypeToDoc iType
  63                   , text "             ETag:" <+> eTagToDoc iETag
  64                   , text "    Last Modified:" <+> text (show iLastMod)
  65                   ]
  66            , text " -}"
  67            , text "{-# LANGUAGE MagicHash #-}"
  68            ]
  69     where
  70       eTagToDoc ∷ ETag → Doc
  71       eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag
  72
  73       mimeTypeToDoc ∷ MIMEType → Doc
  74       mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
  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                        ]