X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FImplant%2FRewrite.hs;h=e4ec8322f753ac8284dab224af85a3bf17ad8113;hp=37fbfbb45c1b657566fae58662d598f8891ebe7e;hb=cc074d0ce3f7df2544bc2baddca4e7730ecdf0a0;hpb=4e41b11200285142757434e9d67e17ed20fae455

diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs
index 37fbfbb..e4ec832 100644
--- a/Network/HTTP/Lucu/Implant/Rewrite.hs
+++ b/Network/HTTP/Lucu/Implant/Rewrite.hs
@@ -1,129 +1,205 @@
 {-# LANGUAGE
-    UnicodeSyntax
+    FlexibleInstances
+  , GeneralizedNewtypeDeriving
+  , RecordWildCards
+  , UnicodeSyntax
   #-}
+-- |An internal module for rewriting 'Name's in Template Haskell AST.
 module Network.HTTP.Lucu.Implant.Rewrite
-    ( ModMap
+    ( NamePat(..)
+    , RewriteOp(..)
+
+    , Imports
+    , ImportOp(..)
+
+    , Rules
+    , RewriteRule(..)
+    , qualifyAll
+    , unqualify
+    , unqualifyIn
+    , unqualifyAll
+
     , rewriteNames
     )
     where
 import Control.Applicative
 import Control.Monad.State
 import Data.Data
-import Data.Generics.Aliases
+import Data.Foldable
+import Data.Generics.Aliases hiding (GT)
 import Data.Generics.Schemes
-import Data.Map (Map)
-import qualified Data.Map as M
+import Data.Monoid
 import Data.Monoid.Unicode
+import Data.Set (Set)
+import qualified Data.Set as S
 import Language.Haskell.TH.Syntax
+import Prelude
 import Prelude.Unicode
 
--- FIXME: Document at least these data types.
-type ModMap    = Map ModName (Maybe ModName)
-data RewriteTo = Qual (Maybe ModName) ModName | UnQual (Maybe ModName)
-
-rewriteNames ∷ Data d ⇒ d → (d, ModMap)
-rewriteNames
-    = flip runState (∅) ∘ gmapM (everywhereM (mkM rewriteName))
-
-rewriteName ∷ (Functor m, Monad m)
-            ⇒ Name
-            → StateT ModMap m Name
-rewriteName (Name o fl) = Name o <$> rewriteNameFlavour fl
-
-rewriteNameFlavour ∷ (Functor m, Monad m)
-                   ⇒ NameFlavour
-                   → StateT ModMap m NameFlavour
-rewriteNameFlavour fl
-    = case getModName fl of
-        Nothing → return fl
-        Just m  → do let r = M.lookup m modules
-                     insertIntoModMap m r
-                     return $ setModName r fl
-
-insertIntoModMap ∷ Monad m
-                 ⇒ ModName
-                 → Maybe RewriteTo
-                 → StateT ModMap m ()
-insertIntoModMap _ (Just (Qual   (Just m) m')) = modify $ M.insert m (Just m')
-insertIntoModMap m (Just (Qual   Nothing  m')) = modify $ M.insert m (Just m')
-insertIntoModMap _ (Just (UnQual (Just m)   )) = modify $ M.insert m Nothing
-insertIntoModMap _ (Just (UnQual Nothing    )) = return ()
-insertIntoModMap m Nothing                     = modify $ M.insert m Nothing
-
-getModName ∷ NameFlavour → Maybe ModName
-getModName (NameQ     m) = Just m
-getModName (NameG _ _ m) = Just m
-getModName _             = Nothing
-
-setModName ∷ Maybe RewriteTo → NameFlavour → NameFlavour
-setModName (Just (Qual _ m)) (NameQ _    ) = NameQ m
-setModName (Just (Qual _ m)) (NameG _ _ _) = NameQ m
-setModName (Just (UnQual _)) (NameQ _    ) = NameS
-setModName (Just (UnQual _)) (NameG _ _ _) = NameS
-setModName Nothing           (NameQ _    ) = NameS
-setModName Nothing           (NameG _ _ _) = NameS
-setModName _ _ = error "setModName: internal error"
-
-modules ∷ Map ModName RewriteTo
-modules
-    = M.fromList
-      [ ( mkModName "Codec.Compression.GZip"
-        , Qual Nothing $ mkModName "G"
-        )
-      , ( mkModName "Data.Ascii"
-        , Qual Nothing $ mkModName "A"
-        )
-      , ( mkModName "Data.ByteString.Char8"
-        , Qual Nothing $ mkModName "B"
-        )
-      , ( mkModName "Data.ByteString.Lazy.Internal"
-        , Qual Nothing $ mkModName "L"
-        )
-      , ( mkModName "Data.ByteString.Unsafe"
-        , Qual Nothing $ mkModName "B"
-        )
-      , ( mkModName "Data.Map"
-        , Qual Nothing $ mkModName "M"
-        )
-      , ( mkModName "Data.Maybe"
-        , UnQual Nothing
-        )
-      , ( mkModName "Data.Text"
-        , Qual Nothing $ mkModName "T"
-        )
-      , ( mkModName "Data.Time.Calendar.Days"
-        , UnQual $ Just $ mkModName "Data.Time"
-        )
-      , ( mkModName "Data.Time.Clock.Scale"
-        , UnQual $ Just $ mkModName "Data.Time"
-        )
-      , ( mkModName "Data.Time.Clock.UTC"
-        , UnQual $ Just $ mkModName "Data.Time"
-        )
-      , ( mkModName "GHC.Base"
-        , UnQual Nothing
-        )
-      , ( mkModName "GHC.Bool"
-        , UnQual Nothing
-        )
-      , ( mkModName "GHC.IO"
-        -- for 'unsafePerformIO', but rather problematic...
-        , UnQual $ Just $ mkModName "System.IO.Unsafe"
-        )
-      , ( mkModName "GHC.Real"
-        -- for '%', but rather problematic...
-        , UnQual $ Just $ mkModName "Data.Ratio"
-        )
-      , ( mkModName "Network.HTTP.Lucu.ETag"
-        , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
-        )
-      , ( mkModName "Network.HTTP.Lucu.MIMEType"
-        , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
-        )
-      , ( mkModName "Network.HTTP.Lucu.Resource"
-        , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
-        )
-      , ( mkModName "Network.HTTP.Lucu.Resource.Internal"
-        , UnQual $ Just $ mkModName "Network.HTTP.Lucu"
-        )
-      ]
+-- |Pattern for 'Name's. 'Just' represents a perfect matching pattern,
+-- and 'Nothing' represensts a wildcard.
+data NamePat
+    = NamePat !(Maybe ModName) !(Maybe OccName)
+
+-- |Instruction for rewriting 'Name's.
+data RewriteOp
+    = Identity
+    | Unqualify
+    | Qualify !ModName
+
+-- |A 'Set' of modules and names to be imported.
+newtype Imports α = Imports (Set α)
+    deriving Foldable
+
+-- |Instruction for declaring module imports.
+data ImportOp
+    = -- |> import qualified M as A
+      QualifiedImp {
+        impModule ∷ !ModName
+      , impAlias  ∷ !ModName
+      }
+      -- |> import M
+      --
+      -- or
+      --
+      -- > import M (a, b, c, ...)
+    | UnqualifiedImp {
+        impModule ∷ !ModName
+      , impNames  ∷ !(Maybe (Set (NameSpace, OccName)))
+      }
+    deriving Eq
+
+-- |List of 'RewriteRule's.
+type Rules = [RewriteRule]
+
+-- |Instruction for rewriting 'Name's and declaring module imports.
+data RewriteRule
+    = RewriteRule {
+        rrPat  ∷ !NamePat
+      , rrOp   ∷ !RewriteOp
+      , rrImps ∷ !(Imports ImportOp)
+      }
+
+instance Ord ImportOp where
+    α `compare` β
+        | impModule α < impModule β = LT
+        | impModule α > impModule β = GT
+        | otherwise
+            = case (α, β) of
+                (QualifiedImp   {}, QualifiedImp   {})
+                    → impAlias α `compare` impAlias β
+                (QualifiedImp   {}, _                )
+                    → GT
+                (UnqualifiedImp {}, UnqualifiedImp {})
+                    → impNames α `compare` impNames β
+                (UnqualifiedImp {}, _                )
+                    → LT
+
+instance Monoid (Imports ImportOp) where
+    mempty
+        = Imports (∅)
+    mappend (Imports α) (Imports β)
+        = Imports (foldl' insertImp α β)
+
+insertImp ∷ Set ImportOp → ImportOp → Set ImportOp
+insertImp α qi@(QualifiedImp   {}) = S.insert qi α
+insertImp α ui@(UnqualifiedImp {})
+    = case find sameMod α of
+        Nothing  → S.insert ui α
+        Just ui' → S.insert (merge ui') (S.delete ui' α)
+    where
+      sameMod ∷ ImportOp → Bool
+      sameMod ui'@(UnqualifiedImp {})
+          = impModule ui ≡ impModule ui'
+      sameMod _
+          = False
+
+      merge ∷ ImportOp → ImportOp
+      merge ui'
+          = case (impNames ui, impNames ui') of
+              (Nothing, _      ) → ui
+              (_      , Nothing) → ui'
+              (Just s , Just s') → ui { impNames = Just (s ⊕ s') }
+
+-- |@'qualifyAll' module alias@: qualify every symbols defined in
+-- @module@ with @alias@.
+qualifyAll ∷ String → String → RewriteRule
+qualifyAll m a
+    = let pat = NamePat (Just (mkModName m)) Nothing
+          rop = Qualify (mkModName a)
+          iop = QualifiedImp (mkModName m) (mkModName a)
+      in
+        RewriteRule pat rop (Imports (S.singleton iop))
+
+-- |@'unqualify' name module@: unqualify the symbol @name@ with
+-- importing @module@.
+unqualify ∷ Name → String → RewriteRule
+unqualify (Name o _) m
+    = let pat = NamePat Nothing (Just o)
+          iop = UnqualifiedImp (mkModName m)
+                $ Just
+                $ S.singleton (VarName, o)
+      in
+        RewriteRule pat Unqualify (Imports (S.singleton iop))
+
+-- |@'unqualifyIn' name tycl module@: unqualify a constructor, field
+-- name, or whatever resides in the type or class @tycl@ with
+-- importing @module@.
+unqualifyIn ∷ Name → Name → String → RewriteRule
+unqualifyIn (Name name _) (Name tycl _) m
+    = let pat = NamePat Nothing (Just name)
+          iop = UnqualifiedImp (mkModName m)
+                $ Just
+                $ S.singleton (TcClsName, tycl)
+      in
+        RewriteRule pat Unqualify (Imports (S.singleton iop))
+
+-- |@'unqualifyAll' origMod impMod@: unqualify every symbols
+-- defined in @origMod@ with importing @impMod@.
+unqualifyAll ∷ String → String → RewriteRule
+unqualifyAll origMod impMod
+    = let pat = NamePat (Just (mkModName origMod)) Nothing
+          iop = UnqualifiedImp (mkModName impMod) Nothing
+      in
+        RewriteRule pat Unqualify (Imports (S.singleton iop))
+
+-- |@'rewriteNames' rules d@ rewrites each and every 'Name's included
+-- in @d@ according to the name-rewriting @rules@ while at the same
+-- time building a set of modules to be imported.
+rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports ImportOp)
+rewriteNames rules = flip runState (∅) ∘ gmapM (everywhereM (mkM f))
+    where
+      f ∷ (Functor m, Monad m) ⇒ Name → StateT (Imports ImportOp) m Name
+      f n = case findRule rules n of
+              Nothing → fail $ "No rules matches to name: " ⧺ showName n
+              Just r  → applyRule r n
+
+findRule ∷ Rules → Name → Maybe RewriteRule
+findRule _  (Name _  NameS       ) = Just identityRule
+findRule rs (Name o (NameQ     m)) = find (matchPat m o ∘ rrPat) rs
+findRule _  (Name _ (NameU _    )) = Just identityRule
+findRule rs (Name o (NameG _ _ m)) = find (matchPat m o ∘ rrPat) rs
+findRule _  _                      = Nothing
+
+identityRule ∷ RewriteRule
+identityRule = RewriteRule {
+                 rrPat  = NamePat Nothing Nothing
+               , rrOp   = Identity
+               , rrImps = (∅)
+               }
+
+matchPat ∷ ModName → OccName → NamePat → Bool
+matchPat m o (NamePat mp op)
+    = maybe True (≡ m) mp ∧ maybe True (≡ o) op
+
+applyRule ∷ (Functor m, Monad m)
+          ⇒ RewriteRule
+          → Name
+          → StateT (Imports ImportOp) m Name
+applyRule (RewriteRule {..}) n
+    = modify (⊕ rrImps) *> pure (rewrite rrOp n)
+
+rewrite ∷ RewriteOp → Name → Name
+rewrite Identity    n          = n
+rewrite Unqualify   (Name o _) = Name o NameS
+rewrite (Qualify m) (Name o _) = Name o (NameQ m)