Improve display of poly-kinded type operators

This now displays them as (==) k a b c ... to mirror GHC's behavior,
instead of the old (k == a) b c ... which was just wrong.

Signed-off-by: Mateusz Kowalczyk <fuuzetsu@fuuzetsu.co.uk>

6 files changed, 40 insertions, 35 deletions

diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs
index 2185340b..24e8b7c8 100644
--- a/src/Haddock/Backends/LaTeX.hs
+++ b/src/Haddock/Backends/LaTeX.hs
@@ -560,10 +560,10 @@ ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead
 
 
 ppInstHead :: Bool -> InstHead DocName -> LaTeX
-ppInstHead unicode (n, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ts unicode
-ppInstHead unicode (n, ts, TypeInst rhs) = keyword "type"
-  <+> ppAppNameTypes n ts unicode <+> equals <+> ppType unicode rhs
-ppInstHead _unicode (_n, _ts, DataInst _dd) =
+ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode
+ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type"
+  <+> ppAppNameTypes n ks ts unicode <+> equals <+> ppType unicode rhs
+ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) =
   error "data instances not supported by --latex yet"
 
 lookupAnySubdoc :: (Eq name1) =>
@@ -749,27 +749,27 @@ ppDataHeader _ _ = error "ppDataHeader: illegal argument"
 --------------------------------------------------------------------------------
 
 
--- | Print an application of a DocName and a list of HsTypes
-ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> LaTeX
-ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode)
+-- | Print an application of a DocName and two lists of HsTypes (kinds, types)
+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX
+ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode)
 
 
 -- | Print an application of a DocName and a list of Names
 ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX
 ppAppDocNameNames _summ n ns =
-  ppTypeApp n ns (ppBinder . nameOccName . getName) ppSymName
+  ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName
 
 
 -- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
-ppTypeApp n (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX
+ppTypeApp n [] (t1:t2:rest) ppDN ppT
   | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
   | operator                    = opApp
   where
     operator = isNameSym . getName $ n
     opApp = ppT t1 <+> ppDN n <+> ppT t2
 
-ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)
+ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts)
 
 
 -------------------------------------------------------------------------------
diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs
index 53b106a2..77ff35b2 100644
--- a/src/Haddock/Backends/Xhtml.hs
+++ b/src/Haddock/Backends/Xhtml.hs
@@ -605,7 +605,7 @@ ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html
 ppTyClBinderWithVarsMini mdl decl =
   let n = tcdName decl
       ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above
-  in ppTypeApp n ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
+  in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName
 
 
 ppModuleContents :: Qualification -> [ExportItem DocName] -> Html
diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs
index 9180c3c3..85eee248 100644
--- a/src/Haddock/Backends/Xhtml/Decl.hs
+++ b/src/Haddock/Backends/Xhtml/Decl.hs
@@ -235,7 +235,7 @@ ppTyFam summary associated links instances loc doc decl unicode qual
     -- Individual equation of a closed type family
     ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs
                             , tfie_pats = HsWB { hswb_cts = ts }}
-      = ( ppAppNameTypes (unLoc n) (map unLoc ts) unicode qual
+      = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual
           <+> equals <+> ppType unicode qual (unLoc rhs)
         , Nothing, [] )
 
@@ -270,31 +270,31 @@ ppDataBinderWithVars summ decl =
 --------------------------------------------------------------------------------
 
 
--- | Print an application of a DocName and a list of HsTypes
-ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Qualification -> Html
-ppAppNameTypes n ts unicode qual =
-    ppTypeApp n ts (ppDocName qual . Just) (ppParendType unicode qual)
+-- | Print an application of a DocName and two lists of HsTypes (kinds, types)
+ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> Qualification -> Html
+ppAppNameTypes n ks ts unicode qual =
+    ppTypeApp n ks ts (ppDocName qual . Just) (ppParendType unicode qual)
 
 
 -- | Print an application of a DocName and a list of Names
 ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html
 ppAppDocNameNames summ n ns =
-    ppTypeApp n ns ppDN ppTyName
+    ppTypeApp n [] ns ppDN ppTyName
   where
     ppDN is_infix = ppBinderFixity is_infix summ . nameOccName . getName
     ppBinderFixity True = ppBinderInfix
     ppBinderFixity False = ppBinder
 
 -- | General printing of type applications
-ppTypeApp :: DocName -> [a] -> (Bool -> DocName -> Html) -> (a -> Html) -> Html
-ppTypeApp n (t1:t2:rest) ppDN ppT
+ppTypeApp :: DocName -> [a] -> [a] -> (Bool -> DocName -> Html) -> (a -> Html) -> Html
+ppTypeApp n [] (t1:t2:rest) ppDN ppT
   | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest)
   | operator                    = opApp
   where
     operator = isNameSym . getName $ n
     opApp = ppT t1 <+> ppDN True n <+> ppT t2
 
-ppTypeApp n ts ppDN ppT = ppDN False n <+> hsep (map ppT ts)
+ppTypeApp n ks ts ppDN ppT = ppDN False n <+> hsep (map ppT $ ks ++ ts)
 
 
 -------------------------------------------------------------------------------
@@ -426,13 +426,13 @@ ppInstances instances baseName unicode qual
     instName = getOccString $ getName baseName
     instDecl :: DocInstance DocName -> SubDecl
     instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])
-    instHead (n, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
-        <+> ppAppNameTypes n ts unicode qual
-    instHead (n, ts, TypeInst rhs) = keyword "type"
-        <+> ppAppNameTypes n ts unicode qual
+    instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual
+        <+> ppAppNameTypes n ks ts unicode qual
+    instHead (n, ks, ts, TypeInst rhs) = keyword "type"
+        <+> ppAppNameTypes n ks ts unicode qual
         <+> equals <+> ppType unicode qual rhs
-    instHead (n, ts, DataInst dd) = keyword "data"
-        <+> ppAppNameTypes n ts unicode qual
+    instHead (n, ks, ts, DataInst dd) = keyword "data"
+        <+> ppAppNameTypes n ks ts unicode qual
         <+> ppShortDataDecl False True dd unicode qual
 
 lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2
diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs
index d9bb0fcf..3670473d 100644
--- a/src/Haddock/Convert.hs
+++ b/src/Haddock/Convert.hs
@@ -21,7 +21,7 @@ import HsSyn
 import TcType ( tcSplitSigmaTy )
 import TypeRep
 import Type(isStrLitTy)
-import Kind ( splitKindFunTys, synTyConResKind )
+import Kind ( splitKindFunTys, synTyConResKind, isKind )
 import Name
 import Var
 import Class
@@ -371,18 +371,22 @@ synifyKindSig :: Kind -> LHsKind Name
 synifyKindSig k = synifyType WithinType k
 
 synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name
-synifyInstHead (_, preds, cls, ts) =
+synifyInstHead (_, preds, cls, types) =
   ( getName cls
+  , map (unLoc . synifyType WithinType) ks
   , map (unLoc . synifyType WithinType) ts
   , ClassInst $ map (unLoc . synifyType WithinType) preds
   )
+  where (ks,ts) = break (not . isKind) types
 
 -- Convert a family instance, this could be a type family or data family
 synifyFamInst :: FamInst -> InstHead Name
 synifyFamInst fi =
   ( fi_fam fi
-  , map (unLoc . synifyType WithinType) $ fi_tys fi
+  , map (unLoc . synifyType WithinType) ks
+  , map (unLoc . synifyType WithinType) ts
   , case fi_flavor fi of
       SynFamilyInst -> TypeInst . unLoc . synifyType WithinType $ fi_rhs fi
       DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c
   )
+  where (ks,ts) = break (not . isKind) $ fi_tys fi
diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs
index de23e9b5..59b11854 100644
--- a/src/Haddock/Interface/Rename.hs
+++ b/src/Haddock/Interface/Rename.hs
@@ -258,14 +258,15 @@ renameLContext (L loc context) = do
 
 
 renameInstHead :: InstHead Name -> RnM (InstHead DocName)
-renameInstHead (className, types, rest) = do
+renameInstHead (className, k, types, rest) = do
   className' <- rename className
+  k' <- mapM renameType k
   types' <- mapM renameType types
   rest' <- case rest of
     ClassInst cs -> ClassInst <$> mapM renameType cs
     TypeInst  ts -> TypeInst  <$> renameType ts
     DataInst  dd -> DataInst  <$> renameTyClD dd
-  return (className', types', rest')
+  return (className', k', types', rest')
 
 
 renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName)
diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs
index 0e7f83af..a3d731af 100644
--- a/src/Haddock/Types.hs
+++ b/src/Haddock/Types.hs
@@ -290,9 +290,9 @@ instance OutputableBndr a => Outputable (InstType a) where
 -- | An instance head that may have documentation.
 type DocInstance name = (InstHead name, Maybe (Doc name))
 
--- | The head of an instance. Consists of a class name, a list of parameters
--- and an instance type
-type InstHead name = (name, [HsType name], InstType name)
+-- | The head of an instance. Consists of a class name, a list of kind
+-- parameters, a list of type parameters and an instance type
+type InstHead name = (name, [HsType name], [HsType name], InstType name)
 
 -----------------------------------------------------------------------------
 -- * Documentation comments