X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FImplant%2FPrettyPrint.hs;h=c79b4d4b004c5526bd5f605f1c2324389fa3391c;hp=027003d2b07bb551c5e06ff93ff316747f84cf0e;hb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;hpb=4e41b11200285142757434e9d67e17ed20fae455 diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs index 027003d..c79b4d4 100644 --- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs +++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs @@ -4,7 +4,10 @@ , RecordWildCards , TemplateHaskell , UnicodeSyntax + , ViewPatterns #-} +-- |An internal module for generating Haskell modules eith an +-- arbitrary file implanted. module Network.HTTP.Lucu.Implant.PrettyPrint ( pprInput ) @@ -14,19 +17,22 @@ import Control.Monad import Data.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.List (intersperse) +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 @@ -68,27 +74,50 @@ header i@(Input {..}) 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" @@ -110,14 +139,14 @@ gzipEncoding = mkName "gzipEncoding" 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 = [] @@ -132,39 +161,38 @@ resourceE i = [| emptyResource { 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] @@ -176,7 +204,7 @@ eTagDecl (Input {..}) 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] @@ -189,13 +217,37 @@ binDecl ∷ 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.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 @@ -204,7 +256,7 @@ pprInput i modName 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