, RecordWildCards
, TemplateHaskell
, UnicodeSyntax
+ , ViewPatterns
#-}
+-- |An internal module for generating Haskell modules eith an
+-- arbitrary file implanted.
module Network.HTTP.Lucu.Implant.PrettyPrint
( pprInput
)
where
import Codec.Compression.GZip
import Control.Monad
-import Data.Ascii (CIAscii)
+import Data.Ascii (Ascii, CIAscii)
import qualified Data.Ascii as A
import qualified Data.ByteString.Lazy as L
-import Data.List
-import qualified Data.Map as M
+import Data.Char
+import Data.Collections
+import Data.Convertible.Utils
+import Data.List (intersperse)
+import Data.Monoid
+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.OrphanInstances ()
import Network.HTTP.Lucu.Resource
-import Network.HTTP.Lucu.Utils
+import Prelude hiding (head)
import Prelude.Unicode
header ∷ Input → Doc
]
where
eTagToDoc ∷ ETag → Doc
- eTagToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printETag
+ eTagToDoc = text ∘ convertSuccessVia ((⊥) ∷ Ascii)
mimeTypeToDoc ∷ MIMEType → Doc
mimeTypeToDoc = text ∘ A.toString ∘ A.fromAsciiBuilder ∘ printMIMEType
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 → Doc
+importDecls = vcat ∘ map pprImport ∘ fromFoldable
-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)
+ $ fromFoldable 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"
resourceDecl ∷ Input → Name → Q [Dec]
resourceDecl i symName
- = sequence [ sigD symName [t| ResourceDef |]
+ = sequence [ sigD symName [t| Resource |]
, valD (varP symName) (normalB (resourceE i)) decls
]
where
decls ∷ [Q Dec]
decls | useGZip i
= [ sigD gzipEncoding [t| CIAscii |]
- , valD (varP gzipEncoding) (normalB (liftCIAscii "gzip")) []
+ , valD (varP gzipEncoding) (normalB (lift ("gzip" ∷ CIAscii))) []
]
| otherwise
= []
resourceE ∷ Input → Q Exp
-resourceE i = [| emptyResource {
+resourceE i = [| mempty {
resGet = $(resGetE i)
, resHead = $(resHeadE i)
}
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]
lastModDecl ∷ Input → Q [Dec]
lastModDecl (Input {..})
= sequence [ sigD lastModified [t| UTCTime |]
- , valD (varP lastModified) (normalB (liftUTCTime iLastMod)) []
+ , valD (varP lastModified) (normalB (lift iLastMod)) []
]
contTypeDecl ∷ Input → Q [Dec]
binDecl i@(Input {..})
| useGZip i
= sequence [ sigD gzippedData [t| L.ByteString |]
- , valD (varP gzippedData) (normalB (liftLazyByteString iGZipped)) []
+ , valD (varP gzippedData) (normalB (lift iGZipped)) []
]
| otherwise
= sequence [ sigD rawData [t| L.ByteString |]
- , valD (varP rawData) (normalB (liftLazyByteString iRawData)) []
+ , valD (varP rawData) (normalB (lift 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.CaseInsensitive" "CI"
+ , qualifyAll "Data.Collections" "C"
+ , 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.MIMEType" "Network.HTTP.Lucu"
+ , unqualify 'when "Control.Monad"
+ , unqualify 'mempty "Data.Monoid"
+ , 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
projects / Lucu.git / blobdiff