Better name-rewriting engine

[Lucu.git] / Network / HTTP / Lucu / Implant / PrettyPrint.hs

diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs
index 027003d2b07bb551c5e06ff93ff316747f84cf0e..ecdb4fe8aed35dacc39f1f4234060d366cc1a070 100644 (file)
--- 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,15 +17,17 @@ import Control.Monad
 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
@@ -68,27 +73,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 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"
@@ -132,39 +160,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]
@@ -196,6 +223,29 @@ binDecl i@(Input {..})
                    , 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
@@ -204,7 +254,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