Merge remote-tracking branch 'origin/master' into imp-param-class

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)))

src/Haddock/Convert.hs

@@ -33,6 +33,7 @@ import TysWiredIn ( listTyConName, eqTyCon )
 import PrelNames (ipClassName)
 import Bag ( emptyBag )
 import SrcLoc ( Located, noLoc, unLoc )
+import Data.List( partition )
 
 
 -- the main function here! yay!
@@ -99,12 +100,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 []
@@ -233,15 +236,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

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

src/Haddock/Interface/Rename.hs

@@ -264,9 +264,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))

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.