aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Backends
diff options
context:
space:
mode:
authorƁukasz Hanuszczak <lukasz.hanuszczak@gmail.com>2015-07-17 13:57:28 +0200
committerMateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>2015-08-21 18:22:30 +0100
commit9edfaa67b6e4c80df43497f24133530d9a822dc6 (patch)
tree0f58574a3bec62bbdec40f24691f7f67b3748a2c /haddock-api/src/Haddock/Backends
parent6be6ca76e9163569ad3bed1441cb9fcfa7df0cec (diff)
Create scaffolding of a framework for renaming specialized types.
Diffstat (limited to 'haddock-api/src/Haddock/Backends')
-rw-r--r--haddock-api/src/Haddock/Backends/Xhtml/Specialize.hs97
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