Create scaffolding of a framework for renaming specialized types.

1 files changed, 96 insertions, 1 deletions

diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 50cce3d5..1a8446ee 100644
--- a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
+++ b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
@@ -6,7 +6,7 @@
 module Haddock.Backends.Xhtml.Specialize
     ( specialize, specialize'
     , specializeTyVarBndrs
-    , sugar
+    , sugar, rename
     ) where
 
 
@@ -16,7 +16,13 @@ import GHC
 import Name
 
 import Control.Monad
+import Control.Monad.Trans.RWS
+
 import Data.Data
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 
 specialize :: (Eq name, Typeable name)
@@ -92,3 +98,92 @@ parseTupleArity ('(':commas) = do
     parseCommas ")" = Just 0
     parseCommas _ = Nothing
 parseTupleArity _ = Nothing
+
+
+rename :: Ord name => HsType name -> HsType name
+rename = fst . evalRWS undefined Map.empty . renameType -- TODO.
+
+
+type Rename name a = RWS (Set name) () (Map name name) a
+
+
+renameType :: Ord name => HsType name -> Rename name (HsType name)
+renameType (HsForAllTy ex mspan lbndrs lctx lt) = do
+    lbndrs' <- renameLTyVarBndrs lbndrs
+    HsForAllTy
+        <$> pure ex
+        <*> pure mspan
+        <*> pure lbndrs'
+        <*> located renameContext lctx
+        <*> renameLType lt
+renameType (HsTyVar name) = HsTyVar <$> renameName name
+renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
+renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
+renameType (HsListTy lt) = HsListTy <$> renameLType lt
+renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
+renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
+renameType (HsOpTy la lop lb) = HsOpTy
+    <$> renameLType la
+    <*> pure lop -- TODO.
+    <*> renameLType lb
+renameType (HsParTy lt) = HsParTy <$> renameLType lt
+renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
+renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
+renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
+renameType t@(HsQuasiQuoteTy _) = pure t -- TODO.
+renameType t@(HsSpliceTy _ _) = pure t -- TODO.
+renameType t@(HsDocTy _ _) = pure t -- TODO.
+renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
+renameType t@(HsRecTy _) = pure t -- TODO.
+renameType t@(HsCoreTy _) = pure t
+renameType t@(HsExplicitListTy _ _) = pure t -- TODO.
+renameType t@(HsExplicitTupleTy _ _) = pure t -- TODO.
+renameType t@(HsTyLit _) = pure t
+renameType (HsWrapTy wrap t) = HsWrapTy wrap <$> renameType t
+renameType HsWildcardTy = pure HsWildcardTy
+renameType t@(HsNamedWildcardTy _) = pure t -- TODO.
+
+
+renameLType :: Ord name => LHsType name -> Rename name (LHsType name)
+renameLType = located renameType
+
+
+renameLTyVarBndrs :: Ord name => LHsTyVarBndrs name -> Rename name (LHsTyVarBndrs name)
+renameLTyVarBndrs lbndrs = do
+    tys' <- mapM (located renameTyVarBndr) $ hsq_tvs lbndrs
+    pure $ lbndrs { hsq_tvs = tys' }
+
+
+renameContext :: Ord name => HsContext name -> Rename name (HsContext name)
+renameContext = mapM $ located renameType
+
+
+renameTyVarBndr :: Ord name => HsTyVarBndr name -> Rename name (HsTyVarBndr name)
+renameTyVarBndr (UserTyVar name) =
+    UserTyVar <$> renameNameBndr name
+renameTyVarBndr (KindedTyVar name kinds) =
+    KindedTyVar <$> located renameNameBndr name <*> pure kinds
+
+
+renameNameBndr :: Ord name => name -> Rename name name
+renameNameBndr name = do
+    fv <- ask
+    when (name `Set.member` fv) $
+        freshName name
+    renameName name
+
+
+renameName :: Ord name => name -> Rename name name
+renameName name = do
+    rnmap <- get
+    pure $ case Map.lookup name rnmap of
+        Just name' -> name'
+        Nothing -> name
+
+
+freshName :: Ord name => name -> Rename name ()
+freshName _ = pure () -- TODO.
+
+
+located :: Functor f => (a -> f b) -> Located a -> f (Located b)
+located f (L loc e) = L loc <$> f e