aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Haddock/Backends/Hoogle.hs2
-rw-r--r--src/Haddock/Convert.hs32
-rw-r--r--src/Haddock/Interface/Create.hs2
-rw-r--r--src/Haddock/Interface/Rename.hs7
-rw-r--r--src/Haddock/Utils.hs8
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.