, RecordWildCards
, TemplateHaskell
, UnicodeSyntax
+ , ViewPatterns
#-}
+-- |An internal module for generating Haskell modules eith an
+-- arbitrary file implanted.
module Network.HTTP.Lucu.Implant.PrettyPrint
( pprInput
)
import Data.Ascii (CIAscii)
import qualified Data.Ascii as A
import qualified Data.ByteString.Lazy as L
+import Data.Char
+import Data.Foldable
import Data.List
-import qualified Data.Map as M
+import Data.Ratio
import Data.Time
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.PprLib
import Language.Haskell.TH.Syntax
import Network.HTTP.Lucu.ETag
-import Network.HTTP.Lucu.Implant.Input
+import Network.HTTP.Lucu.Implant
import Network.HTTP.Lucu.Implant.Rewrite
import Network.HTTP.Lucu.MIMEType
import Network.HTTP.Lucu.Resource
moduleDecl ∷ ModName → Name → Doc
moduleDecl modName symName
- = hsep [ text "module"
- , text (modString modName)
- , lparen
- , ppr symName
- , rparen
- , text "where"
- ]
+ = text "module" <+> text (modString modName) $+$
+ nest 4 (vcat [ lparen <+> ppr symName
+ , rparen
+ , text "where"
+ ])
+
+importDecls ∷ Imports ImportOp → Doc
+importDecls = vcat ∘ map pprImport ∘ toList
-importDecls ∷ ModMap → Doc
-importDecls = vcat ∘ map f ∘ M.toAscList
+pprImport ∷ ImportOp → Doc
+pprImport (QualifiedImp {..})
+ = hsep [ text "import"
+ , text "qualified"
+ , text (modString impModule)
+ , text "as"
+ , text (modString impAlias)
+ ]
+pprImport (UnqualifiedImp {impNames = Nothing, ..})
+ = hsep [ text "import"
+ , text (modString impModule)
+ ]
+pprImport (UnqualifiedImp {impNames = Just ns, ..})
+ = hsep [ text "import"
+ , text (modString impModule)
+ , hcat [ lparen
+ , sep $ punctuate comma
+ $ map (uncurry pprImpName)
+ $ toList ns
+ , rparen
+ ]
+ ]
where
- f ∷ (ModName, Maybe ModName) → Doc
- f (m, Nothing) = hsep [ text "import"
- , text (modString m)
- ]
- f (m, Just m') = hsep [ text "import"
- , text "qualified"
- , text (modString m)
- , text "as"
- , text (modString m')
- ]
+ pprImpName ∷ NameSpace → OccName → Doc
+ pprImpName TcClsName (occString → o)
+ = hcat [text o, text "(..)"]
+ pprImpName _ (occString → o)
+ | needParen o = hcat [lparen, text o, rparen]
+ | otherwise = text o
+
+ needParen ∷ String → Bool
+ needParen (head → c)
+ | isPunctuation c = True
+ | isSymbol c = True
+ | otherwise = False
entityTag ∷ Name
entityTag = mkName "entityTag"
resGetE ∷ Input → Q Exp
resGetE i
| useGZip i
- = [| Just $
- do foundEntity $(varE entityTag) $(varE lastModified)
- setContentType $(varE contentType)
-
- gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
- if gzipAllowed then
- do setContentEncoding [$(varE gzipEncoding)]
- putChunks $(varE gzippedData)
- else
- putChunks (decompress $(varE gzippedData))
+ = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
+ setContentType $(varE contentType)
+
+ gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
+ if gzipAllowed then
+ do setContentEncoding [$(varE gzipEncoding)]
+ putChunks $(varE gzippedData)
+ else
+ putChunks (decompress $(varE gzippedData))
+ )
|]
| otherwise
- = [| Just $
- do foundEntity $(varE entityTag) $(varE lastModified)
- setContentType $(varE contentType)
- putChunks $(varE rawData)
+ = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
+ setContentType $(varE contentType)
+ putChunks $(varE rawData)
+ )
|]
resHeadE ∷ Input → Q Exp
resHeadE i
| useGZip i
- = [| Just $
- do foundEntity $(varE entityTag) $(varE lastModified)
- setContentType $(varE contentType)
+ = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
+ setContentType $(varE contentType)
- gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
- when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
+ gzipAllowed ← isEncodingAcceptable $(varE gzipEncoding)
+ when gzipAllowed (setContentEncoding [$(varE gzipEncoding)])
+ )
|]
| otherwise
- = [| Just $
- do foundEntity $(varE entityTag)
- $(varE lastModified)
- setContentType $(varE contentType)
+ = [| Just ( do foundEntity $(varE entityTag) $(varE lastModified)
+ setContentType $(varE contentType)
+ )
|]
eTagDecl ∷ Input → Q [Dec]
, valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
]
+rules ∷ Rules
+rules = [ qualifyAll "Codec.Compression.GZip" "G"
+ , unqualify ''CIAscii "Data.Ascii"
+ , qualifyAll "Data.Ascii" "A"
+ , qualifyAll "Data.ByteString.Char8" "B"
+ , qualifyAll "Data.ByteString.Lazy.Internal" "L"
+ , qualifyAll "Data.Map" "M"
+ , qualifyAll "Data.Text" "T"
+ , unqualifyAll "Network.HTTP.Lucu.ETag" "Network.HTTP.Lucu"
+ , unqualifyAll "Network.HTTP.Lucu.Resource" "Network.HTTP.Lucu"
+ , unqualifyAll "Network.HTTP.Lucu.Resource.Internal" "Network.HTTP.Lucu"
+ , unqualifyAll "Network.HTTP.Lucu.MIMEParams" "Network.HTTP.Lucu"
+ , unqualifyAll "Network.HTTP.Lucu.MIMEType" "Network.HTTP.Lucu"
+ , unqualify 'when "Control.Monad"
+ , unqualify '(%) "Data.Ratio"
+ , unqualify ''DiffTime "Data.Time"
+ , unqualifyIn 'ModifiedJulianDay ''Day "Data.Time"
+ , unqualifyIn 'UTCTime ''UTCTime "Data.Time"
+ , unqualifyIn 'False ''Bool "Prelude"
+ , unqualifyIn 'Just ''Maybe "Prelude"
+ , unqualify 'fromRational "Prelude"
+ ]
+
pprInput ∷ Quasi m ⇒ Input → ModName → Name → m Doc
pprInput i modName symName
= do decls ← runQ $ sequence [ resourceDecl i symName
, contTypeDecl i
, binDecl i
]
- let (decls', mods) = rewriteNames decls
+ let (decls', mods) = rewriteNames rules decls
return $ vcat [ header i
, moduleDecl modName symName
, importDecls mods