diff options
| -rw-r--r-- | src/Haddock/Backends/Hoogle.hs | 2 | ||||
| -rw-r--r-- | src/Haddock/Convert.hs | 32 | ||||
| -rw-r--r-- | src/Haddock/Interface/Create.hs | 2 | ||||
| -rw-r--r-- | src/Haddock/Interface/Rename.hs | 7 | ||||
| -rw-r--r-- | src/Haddock/Utils.hs | 8 |
5 files changed, 31 insertions, 20 deletions
diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index d176c9f7..78e81d11 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -141,7 +141,7 @@ ppClass x = out x{tcdSigs=[]} : addContext _ = error "expected TypeSig" f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d - f t = HsForAllTy Implicit (mkHsQTvs []) (reL [context]) (reL t) + f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (unL $ tcdLName x) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x))) diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index e2eb990b..b5b905e7 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -31,6 +31,7 @@ import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon ) import Bag ( emptyBag ) import SrcLoc ( Located, noLoc, unLoc ) +import Data.List( partition ) -- the main function here! yay! @@ -97,12 +98,14 @@ synifyTyCon tc | isFunTyCon tc || isPrimTyCon tc = TyDecl { tcdLName = synifyName tc , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: - mkHsQTvs $ zipWith - (\fakeTyVar realKind -> noLoc $ - KindedTyVar (getName fakeTyVar) - (synifyKindSig realKind)) - alphaTyVars --a, b, c... which are unfortunately all kind * - (fst . splitKindFunTys $ tyConKind tc) + let mk_hs_tv realKind fakeTyVar + = noLoc $ KindedTyVar (getName fakeTyVar) + (synifyKindSig realKind) + in HsQTvs { hsq_kvs = [] -- No kind polymorhism + , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + alphaTyVars --a, b, c... which are unfortunately all kind * + } + , tcdTyDefn = TyData { td_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , td_ctxt = noLoc [] @@ -231,15 +234,16 @@ synifyCtx = noLoc . map (synifyType WithinType) synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name -synifyTyVars tvs = mkHsQTvs (map synifyTyVar tvs) +synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs + , hsq_tvs = map synifyTyVar tvs } where - synifyTyVar tv = noLoc $ let - kind = tyVarKind tv - name = getName tv - in if isLiftedTypeKind kind - then UserTyVar name - else KindedTyVar name (synifyKindSig kind) - + (kvs, tvs) = partition isKindVar ktvs + synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name) + | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) + where + kind = tyVarKind tv + name = getName tv --states of what to do with foralls: data SynifyTypeState diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index f5b1e8d4..9db2dc69 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -660,7 +660,7 @@ extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of L _ (HsForAllTy expl tvs (L _ preds) ty) -> L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) - _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) + _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) where lctxt = noLoc . ctxt ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 5e819e59..0912d954 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -265,9 +265,10 @@ renameType t = case t of renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) -renameLTyVarBndrs qtvs - = do { tvs' <- mapM renameLTyVarBndr (hsQTvBndrs qtvs) - ; return (mkHsQTvs tvs') } +renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) + = do { tvs' <- mapM renameLTyVarBndr tvs + ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) renameLTyVarBndr (L loc (UserTyVar n)) diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index 3814b97e..4114b1db 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -13,7 +13,7 @@ module Haddock.Utils ( -- * Misc utilities - restrictTo, + restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, -- * Filename utilities @@ -172,6 +172,12 @@ restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name] restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ] +emptyHsQTvs :: LHsTyVarBndrs Name +-- This function is here, rather than in HsTypes, because it *renamed*, but +-- does not necessarily have all the rigt kind variables. It is used +-- in Haddock just for printing, so it doesn't matter +emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } + -------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. |