From bc5756d062bbc5cad5d4fa60798435ed020c518e Mon Sep 17 00:00:00 2001 From: nand Date: Tue, 11 Feb 2014 11:52:48 +0100 Subject: 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 --- src/Haddock/Backends/LaTeX.hs | 22 +++++++++++----------- src/Haddock/Backends/Xhtml.hs | 2 +- src/Haddock/Backends/Xhtml/Decl.hs | 30 +++++++++++++++--------------- src/Haddock/Convert.hs | 10 +++++++--- src/Haddock/Interface/Rename.hs | 5 +++-- src/Haddock/Types.hs | 6 +++--- 6 files changed, 40 insertions(+), 35 deletions(-) (limited to 'src') 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 -- cgit v1.2.3