Mon Nov 20 20:50:09 UTC 2017

Repository : ssh://git@git.haskell.org/haddock

On branches: 2.17.3.1-spanfix,alexbiehl-patch-1,ghc-8.0,ghc-8.0-facebook,ghc-head,ghc-head1,haddock-quick,headdock-library-1.4.5,ie_avails,issue-303,issue-475,master,pr-filter-maps,pr/cabal-desc,travis,v2.16,v2.17,v2.17.3,v2.18,wip-located-module-as,wip/D2418,wip/T11080-open-data-kinds,wip/T11258,wip/T11430,wip/T12105,wip/T12105-2,wip/T12942,wip/T13163,wip/T3384,wip/embelleshed-rdr,wip/new-tree-one-param,wip/rae,wip/remove-frames,wip/remove-frames1,wip/revert-ttg-2017-11-20,wip/ttg-2017-10-13,wip/ttg-2017-10-31,wip/ttg-2017-11-06,wip/ttg2-2017-11-10,wip/ttg3-2017-11-12,wip/ttg4-constraints-2017-11-13
Link       : http://git.haskell.org/haddock.git/commitdiff/9edfaa67b6e4c80df43497f24133530d9a822dc6

>---------------------------------------------------------------

commit 9edfaa67b6e4c80df43497f24133530d9a822dc6
Author: Łukasz Hanuszczak <lukasz.hanuszczak at gmail.com>
Date:   Fri Jul 17 13:57:28 2015 +0200

    Create scaffolding of a framework for renaming specialized types.


>---------------------------------------------------------------

9edfaa67b6e4c80df43497f24133530d9a822dc6
 haddock-api/haddock-api.cabal                      |  1 +
 .../src/Haddock/Backends/Xhtml/Specialize.hs       | 97 +++++++++++++++++++++-
 2 files changed, 97 insertions(+), 1 deletion(-)

diff --git a/haddock-api/haddock-api.cabal b/haddock-api/haddock-api.cabal
index abe5adb..2090c53 100644
--- a/haddock-api/haddock-api.cabal
+++ b/haddock-api/haddock-api.cabal
@@ -43,6 +43,7 @@ library
     , filepath
     , directory
     , containers
+    , transformers
     , deepseq
     , array
     , xhtml >= 3000.2 && < 3000.3
diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs b/haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs
index 50cce3d..1a8446e 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

