From b6a12c0033d418f91e15a15b7ca257cdc65f08c0 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 21 Aug 2018 10:05:01 -0700 Subject: [PATCH 01/13] Better rendering of unboxed sums/tuples * adds space after/before the '#' marks * properly reify 'HsSumTy' in 'synifyType' --- haddock-api/src/Haddock/Backends/LaTeX.hs | 4 ++-- .../src/Haddock/Backends/Xhtml/Utils.hs | 2 +- haddock-api/src/Haddock/Convert.hs | 1 + html-test/src/UnboxedStuff.hs | 18 ++++++++++++++++++ latex-test/src/UnboxedStuff/UnboxedStuff.hs | 18 ++++++++++++++++++ 5 files changed, 40 insertions(+), 3 deletions(-) create mode 100644 html-test/src/UnboxedStuff.hs create mode 100644 latex-test/src/UnboxedStuff/UnboxedStuff.hs diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 93779544c5..ea233ab764 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -974,7 +974,7 @@ tupleParens _ = parenList sumParens :: [LaTeX] -> LaTeX -sumParens = ubxparens . hsep . punctuate (text " | ") +sumParens = ubxparens . hsep . punctuate (text " |") ------------------------------------------------------------------------------- @@ -1335,7 +1335,7 @@ ubxParenList = ubxparens . hsep . punctuate comma ubxparens :: LaTeX -> LaTeX -ubxparens h = text "(#" <> h <> text "#)" +ubxparens h = text "(#" <+> h <+> text "#)" nl :: LaTeX diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs index f88e104e26..562c015a72 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -175,7 +175,7 @@ ubxSumList = ubxparens . hsep . punctuate (toHtml " | ") ubxparens :: Html -> Html -ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" +ubxparens h = toHtml "(#" <+> h <+> toHtml "#)" dcolon, arrow, darrow, forallSymbol :: Bool -> Html diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 9b39fc26d9..b1a5038dbb 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -466,6 +466,7 @@ synifyType _ (TyConApp tc tys) ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType) vis_tys) + | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy noExt (synifyType WithinType ty) diff --git a/html-test/src/UnboxedStuff.hs b/html-test/src/UnboxedStuff.hs new file mode 100644 index 0000000000..bd1b1302da --- /dev/null +++ b/html-test/src/UnboxedStuff.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UnboxedSums, UnboxedTuples #-} +module UnboxedStuff where + +data X +data Y +data Z + +-- * Unboxed type constructors + +unboxedUnit :: (# #) -> (# #) +unboxedUnit = undefined + +unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) +unboxedTuple = undefined + +unboxedSum :: (# X | Y #) -> (# X | Y | Z #) +unboxedSum = undefined + diff --git a/latex-test/src/UnboxedStuff/UnboxedStuff.hs b/latex-test/src/UnboxedStuff/UnboxedStuff.hs new file mode 100644 index 0000000000..bd1b1302da --- /dev/null +++ b/latex-test/src/UnboxedStuff/UnboxedStuff.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE UnboxedSums, UnboxedTuples #-} +module UnboxedStuff where + +data X +data Y +data Z + +-- * Unboxed type constructors + +unboxedUnit :: (# #) -> (# #) +unboxedUnit = undefined + +unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) +unboxedTuple = undefined + +unboxedSum :: (# X | Y #) -> (# X | Y | Z #) +unboxedSum = undefined + From 7d455c7caa203e43f4515d941fdf889e8ddce2a5 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 21 Aug 2018 11:24:56 -0700 Subject: [PATCH 02/13] Handle promoted tuples in 'synifyType' When we have a fully applied promoted tuple, we can expand it out properly. --- haddock-api/src/Haddock/Convert.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index b1a5038dbb..6be614f911 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -467,6 +467,10 @@ synifyType _ (TyConApp tc tys) UnboxedTuple -> HsUnboxedTuple) (map (synifyType WithinType) vis_tys) | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys) + | Just dc <- isPromotedDataCon_maybe tc + , isTupleDataCon dc + , dataConSourceArity dc == length vis_tys + = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy noExt (synifyType WithinType ty) From 7ace2a659cf7216ef10cfbd7f0ef55426711b370 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 21 Aug 2018 22:08:40 -0700 Subject: [PATCH 03/13] Accept test cases --- hoogle-test/ref/Bug722/test.txt | 2 +- html-test/ref/UnboxedStuff.html | 196 +++++++++++++++++++ latex-test/ref/UnboxedStuff/UnboxedStuff.tex | 36 ++++ latex-test/ref/UnboxedStuff/haddock.sty | 57 ++++++ latex-test/ref/UnboxedStuff/main.tex | 11 ++ 5 files changed, 301 insertions(+), 1 deletion(-) create mode 100644 html-test/ref/UnboxedStuff.html create mode 100644 latex-test/ref/UnboxedStuff/UnboxedStuff.tex create mode 100644 latex-test/ref/UnboxedStuff/haddock.sty create mode 100644 latex-test/ref/UnboxedStuff/main.tex diff --git a/hoogle-test/ref/Bug722/test.txt b/hoogle-test/ref/Bug722/test.txt index 96f3747b8e..2f44ed8fb7 100644 --- a/hoogle-test/ref/Bug722/test.txt +++ b/hoogle-test/ref/Bug722/test.txt @@ -8,7 +8,7 @@ module Bug722 class Foo a (!@#) :: Foo a => a -> a -> a infixl 4 !@# -type family &* :: * -> * -> * +type family (&*) :: * -> * -> * infixr 3 &* data a :-& b (:^&) :: a -> b -> (:-&) a b diff --git a/html-test/ref/UnboxedStuff.html b/html-test/ref/UnboxedStuff.html new file mode 100644 index 0000000000..4c1196b9f4 --- /dev/null +++ b/html-test/ref/UnboxedStuff.html @@ -0,0 +1,196 @@ +UnboxedStuff
Safe HaskellSafe

UnboxedStuff

Synopsis

Documentation

data X #

data Y #

data Z #

Unboxed type constructors

unboxedUnit :: (# #) -> (# #) #

unboxedTuple :: (# X, Y #) -> (# X, Y, Z #) #

unboxedSum :: (# X | Y #) -> (# X | Y | Z #) #

\ No newline at end of file diff --git a/latex-test/ref/UnboxedStuff/UnboxedStuff.tex b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex new file mode 100644 index 0000000000..36d5c12b91 --- /dev/null +++ b/latex-test/ref/UnboxedStuff/UnboxedStuff.tex @@ -0,0 +1,36 @@ +\haddockmoduleheading{UnboxedStuff} +\label{module:UnboxedStuff} +\haddockbeginheader +{\haddockverb\begin{verbatim} +module UnboxedStuff ( + X, Y, Z, unboxedUnit, unboxedTuple, unboxedSum + ) where\end{verbatim}} +\haddockendheader + +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ X +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Y +\end{tabular}] +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +data\ Z +\end{tabular}] +\end{haddockdesc} +\section{Unboxed type constructors} +\begin{haddockdesc} +\item[ +unboxedUnit\ ::\ ({\char '43}\ {\char '43})\ ->\ ({\char '43}\ {\char '43}) +] +\item[ +unboxedTuple\ ::\ ({\char '43}\ X,\ Y\ {\char '43})\ ->\ ({\char '43}\ X,\ Y,\ Z\ {\char '43}) +] +\item[ +unboxedSum\ ::\ ({\char '43}\ X\ |\ Y\ {\char '43})\ ->\ ({\char '43}\ X\ |\ Y\ |\ Z\ {\char '43}) +] +\end{haddockdesc} \ No newline at end of file diff --git a/latex-test/ref/UnboxedStuff/haddock.sty b/latex-test/ref/UnboxedStuff/haddock.sty new file mode 100644 index 0000000000..6e031a98b6 --- /dev/null +++ b/latex-test/ref/UnboxedStuff/haddock.sty @@ -0,0 +1,57 @@ +% Default Haddock style definitions. To use your own style, invoke +% Haddock with the option --latex-style=mystyle. + +\usepackage{tabulary} % see below + +% make hyperlinks in the PDF, and add an expandabale index +\usepackage[pdftex,bookmarks=true]{hyperref} + +\newenvironment{haddocktitle} + {\begin{center}\bgroup\large\bfseries} + {\egroup\end{center}} +\newenvironment{haddockprologue}{\vspace{1in}}{} + +\newcommand{\haddockmoduleheading}[1]{\chapter{\texttt{#1}}} + +\newcommand{\haddockbeginheader}{\hrulefill} +\newcommand{\haddockendheader}{\noindent\hrulefill} + +% a little gap before the ``Methods'' header +\newcommand{\haddockpremethods}{\vspace{2ex}} + +% inserted before \\begin{verbatim} +\newcommand{\haddockverb}{\small} + +% an identifier: add an index entry +\newcommand{\haddockid}[1]{\haddocktt{#1}\index{#1@\texttt{#1}}} + +% The tabulary environment lets us have a column that takes up ``the +% rest of the space''. Unfortunately it doesn't allow +% the \end{tabulary} to be in the expansion of a macro, it must appear +% literally in the document text, so Haddock inserts +% the \end{tabulary} itself. +\newcommand{\haddockbeginconstrs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} +\newcommand{\haddockbeginargs}{\begin{tabulary}{\linewidth}{@{}llJ@{}}} + +\newcommand{\haddocktt}[1]{{\small \texttt{#1}}} +\newcommand{\haddockdecltt}[1]{{\small\bfseries \texttt{#1}}} + +\makeatletter +\newenvironment{haddockdesc} + {\list{}{\labelwidth\z@ \itemindent-\leftmargin + \let\makelabel\haddocklabel}} + {\endlist} +\newcommand*\haddocklabel[1]{\hspace\labelsep\haddockdecltt{#1}} +\makeatother + +% after a declaration, start a new line for the documentation. +% Otherwise, the documentation starts right after the declaration, +% because we're using the list environment and the declaration is the +% ``label''. I tried making this newline part of the label, but +% couldn't get that to work reliably (the space seemed to stretch +% sometimes). +\newcommand{\haddockbegindoc}{\hfill\\[1ex]} + +% spacing between paragraphs and no \parindent looks better +\parskip=10pt plus2pt minus2pt +\setlength{\parindent}{0cm} diff --git a/latex-test/ref/UnboxedStuff/main.tex b/latex-test/ref/UnboxedStuff/main.tex new file mode 100644 index 0000000000..e34c5f1402 --- /dev/null +++ b/latex-test/ref/UnboxedStuff/main.tex @@ -0,0 +1,11 @@ +\documentclass{book} +\usepackage{haddock} +\begin{document} +\begin{titlepage} +\begin{haddocktitle} + +\end{haddocktitle} +\end{titlepage} +\tableofcontents +\input{UnboxedStuff} +\end{document} \ No newline at end of file From b4526dcc0bc736cd32c6977ab43f1c187d163cdb Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 27 Aug 2018 14:15:25 -0700 Subject: [PATCH 04/13] Properly synify promoted list types We reconstruct promoted list literals whenever possible. That means that 'synifyType' produces '[Int, Bool, ()] instead of (Int ': (() ': (Bool ': ([] :: [Type])))) --- haddock-api/src/Haddock/Convert.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6be614f911..009b810914 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -37,7 +37,7 @@ import Type import TyCoRep import TysPrim ( alphaTyVars ) import TysWiredIn ( eqTyConName, listTyConName, liftedTypeKindTyConName - , unitTy ) + , unitTy, promotedNilDataCon, promotedConsDataCon ) import PrelNames ( hasKey, eqTyConKey, ipClassKey, tYPETyConKey , liftedRepDataConKey ) import Unique ( getUnique ) @@ -474,6 +474,16 @@ synifyType _ (TyConApp tc tys) -- ditto for lists | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy noExt (synifyType WithinType ty) + | tc == promotedNilDataCon, [] <- vis_tys + = noLoc $ HsExplicitListTy noExt Promoted [] + | tc == promotedConsDataCon + , [ty1, ty2] <- vis_tys + = let hTy = synifyType WithinType ty1 + in case synifyType WithinType ty2 of + tTy | L _ (HsExplicitListTy _ Promoted tTy') <- stripKindSig tTy + -> noLoc $ HsExplicitListTy noExt Promoted (hTy : tTy') + | otherwise + -> noLoc $ HsOpTy noExt hTy (noLoc $ getName tc) tTy -- ditto for implicit parameter tycons | tc `hasKey` ipClassKey , [name, ty] <- tys @@ -642,6 +652,10 @@ synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType k +stripKindSig :: LHsType GhcRn -> LHsType GhcRn +stripKindSig (L _ (HsKindSig _ t _)) = t +stripKindSig t = t + synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls From 307f33a3e5f6e92285407a1f04a2c237056be79f Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 3 Sep 2018 07:19:55 -0700 Subject: [PATCH 05/13] Only look at visible types when synifying a 'HsListTy' The other types are still looked at when considering whether to make a kind signature or not. --- haddock-api/src/Haddock/Convert.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 009b810914..9d602e134a 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -472,7 +472,7 @@ synifyType _ (TyConApp tc tys) , dataConSourceArity dc == length vis_tys = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys) -- ditto for lists - | getName tc == listTyConName, [ty] <- tys = + | getName tc == listTyConName, [ty] <- vis_tys = noLoc $ HsListTy noExt (synifyType WithinType ty) | tc == promotedNilDataCon, [] <- vis_tys = noLoc $ HsExplicitListTy noExt Promoted [] From ffcf6c259fa0ce1b54073da5327e791e696666af Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Mon, 3 Sep 2018 20:07:34 -0700 Subject: [PATCH 06/13] Various improvements to synifying Types * filter out more 'forall's in class decls/instance decls * extract default class methods too * filter out more 'forall's in pattern synonym decls --- haddock-api/src/Haddock/Convert.hs | 226 +++++++++++++++++------------ 1 file changed, 135 insertions(+), 91 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 9d602e134a..5904453ce9 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -17,7 +17,8 @@ module Haddock.Convert where -- instance heads, which aren't TyThings, so just export everything. import Bag ( emptyBag ) -import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) ) +import BasicTypes ( TupleSort(..), SourceText(..), LexicalFixity(..) + , DefMethSpec(..) ) import Class import CoAxiom import ConLike @@ -62,7 +63,7 @@ tyThingToLHsDecl t = case t of -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. - AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll i) + AnId i -> allOK $ SigD noExt (synifyIdSig ImplicitizeForAll [] i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) @@ -86,8 +87,9 @@ tyThingToLHsDecl t = case t of (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl , tcdSigs = noLoc (MinimalSig noExt NoSourceText . noLoc . fmap noLoc $ classMinimalDef cl) : - map (noLoc . synifyTcIdSig DeleteTopLevelQuantification) - (classMethods cl) + [ noLoc tcdSig + | clsOp <- classOpItems cl + , tcdSig <- synifyTcIdSig DeleteTopLevelQuantification clsOp ] , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon: , tcdATs = rights atFamDecls @@ -103,7 +105,7 @@ tyThingToLHsDecl t = case t of -- a data-constructor alone just gets rendered as a function: AConLike (RealDataCon dc) -> allOK $ SigD noExt (TypeSig noExt [synifyName dc] - (synifySigWcType ImplicitizeForAll (dataConUserType dc))) + (synifySigWcType ImplicitizeForAll [] (dataConUserType dc))) AConLike (PatSynCon ps) -> allOK . SigD noExt $ PatSynSig noExt [synifyName ps] (synifyPatSynSigType ps) @@ -115,10 +117,10 @@ synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc args_types_only = filterOutInvisibleTypes tc args - typats = map (synifyType WithinType) args_types_only + typats = map (synifyType WithinType []) args_types_only annot_typats = zipWith3 annotHsType (mkIsPolyTvs fam_tvs) args_types_only typats - hs_rhs = synifyType WithinType rhs + hs_rhs = synifyType WithinType [] rhs in HsIB { hsib_ext = map tyVarName tkvs , hsib_body = FamEqn { feqn_ext = noExt , feqn_tycon = name @@ -211,7 +213,7 @@ synifyTyCon coax tc , tcdLName = synifyName tc , tcdTyVars = synifyTyVars (tyConVisibleTyVars tc) , tcdFixity = Prefix - , tcdRhs = synifyType WithinType ty } + , tcdRhs = synifyType WithinType [] ty } | otherwise = -- (closed) newtype and data let @@ -315,7 +317,7 @@ synifyDataCon use_gadt_syntax dc = linear_tys = zipWith (\ty bang -> - let tySyn = synifyType WithinType ty + let tySyn = synifyType WithinType [] ty in case bang of (HsSrcBang _ NoSrcUnpack NoSrcStrict) -> tySyn bang' -> noLoc $ HsBangTy noExt bang' tySyn) @@ -343,7 +345,7 @@ synifyDataCon use_gadt_syntax dc = , con_qvars = synifyTyVars (univ_tvs ++ ex_tvs) , con_mb_cxt = Just ctx , con_args = hat - , con_res_ty = synifyType WithinType res_ty + , con_res_ty = synifyType WithinType [] res_ty , con_doc = Nothing } else return $ noLoc $ ConDeclH98 { con_ext = noExt @@ -358,14 +360,24 @@ synifyName :: NamedThing n => n -> Located Name synifyName n = L (srcLocSpan (getSrcLoc n)) (getName n) -synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyIdSig s i = TypeSig noExt [synifyName i] (synifySigWcType s (varType i)) +synifyIdSig + :: SynifyTypeState -- ^ what to do with a 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Id -- ^ the 'Id' from which to get the type signature + -> Sig GhcRn +synifyIdSig s vs i = TypeSig noExt [synifyName i] (synifySigWcType s vs (varType i)) -synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn -synifyTcIdSig s i = ClassOpSig noExt False [synifyName i] (synifySigType s (varType i)) +-- | Turn a 'ClassOpItem' into a list of signatures. The list returned is going +-- to contain the synified 'ClassOpSig' as well (when appropriate) a default +-- 'ClassOpSig'. +synifyTcIdSig :: SynifyTypeState -> ClassOpItem -> [Sig GhcRn] +synifyTcIdSig s (i, dm) = + [ ClassOpSig noExt False [synifyName i] (synifySigType s (varType i)) ] ++ + [ ClassOpSig noExt True [noLoc dn] (synifySigType s dt) + | Just (dn, GenericDM dt) <- [dm] ] synifyCtx :: [PredType] -> LHsContext GhcRn -synifyCtx = noLoc . map (synifyType WithinType) +synifyCtx = noLoc . map (synifyType WithinType []) synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn @@ -399,7 +411,7 @@ annotHsType _ _ hs_ty@(L _ (HsKindSig {})) = hs_ty annotHsType True ty hs_ty | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty = let ki = typeKind ty - hs_ki = synifyType WithinType ki + hs_ki = synifyType WithinType [] ki in noLoc (HsKindSig noExt hs_ty hs_ki) annotHsType _ _ hs_ty = hs_ty @@ -435,19 +447,24 @@ data SynifyTypeState synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn -- The empty binders is a bit suspicious; -- what if the type has free variables? -synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) +synifySigType s ty = mkEmptyImplicitBndrs (synifyType s [] ty) -synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn +synifySigWcType :: SynifyTypeState -> [TyVar] -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) -synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) +synifySigWcType s vs ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s vs ty)) synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType GhcRn -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) -synifyType _ (TyConApp tc tys) +-- | Convert a core type into an 'HsType'. +synifyType + :: SynifyTypeState -- ^ what to do with a 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the type to convert + -> LHsType GhcRn +synifyType _ _ (TyVarTy tv) = noLoc $ HsTyVar noExt NotPromoted $ noLoc (getName tv) +synifyType _ vs (TyConApp tc tys) = maybe_sig res_ty where res_ty :: LHsType GhcRn @@ -465,21 +482,21 @@ synifyType _ (TyConApp tc tys) BoxedTuple -> HsBoxedTuple ConstraintTuple -> HsConstraintTuple UnboxedTuple -> HsUnboxedTuple) - (map (synifyType WithinType) vis_tys) - | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType) vis_tys) + (map (synifyType WithinType vs) vis_tys) + | isUnboxedSumTyCon tc = noLoc $ HsSumTy noExt (map (synifyType WithinType vs) vis_tys) | Just dc <- isPromotedDataCon_maybe tc , isTupleDataCon dc , dataConSourceArity dc == length vis_tys - = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType) vis_tys) + = noLoc $ HsExplicitTupleTy noExt (map (synifyType WithinType vs) vis_tys) -- ditto for lists | getName tc == listTyConName, [ty] <- vis_tys = - noLoc $ HsListTy noExt (synifyType WithinType ty) + noLoc $ HsListTy noExt (synifyType WithinType vs ty) | tc == promotedNilDataCon, [] <- vis_tys = noLoc $ HsExplicitListTy noExt Promoted [] | tc == promotedConsDataCon , [ty1, ty2] <- vis_tys - = let hTy = synifyType WithinType ty1 - in case synifyType WithinType ty2 of + = let hTy = synifyType WithinType vs ty1 + in case synifyType WithinType vs ty2 of tTy | L _ (HsExplicitListTy _ Promoted tTy') <- stripKindSig tTy -> noLoc $ HsExplicitListTy noExt Promoted (hTy : tTy') | otherwise @@ -488,21 +505,21 @@ synifyType _ (TyConApp tc tys) | tc `hasKey` ipClassKey , [name, ty] <- tys , Just x <- isStrLitTy name - = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType ty) + = noLoc $ HsIParamTy noExt (noLoc $ HsIPName x) (synifyType WithinType vs ty) -- and equalities | tc `hasKey` eqTyConKey , [ty1, ty2] <- tys = noLoc $ HsOpTy noExt - (synifyType WithinType ty1) + (synifyType WithinType vs ty1) (noLoc eqTyConName) - (synifyType WithinType ty2) + (synifyType WithinType vs ty2) -- and infix type operators | isSymOcc (nameOccName (getName tc)) , ty1:ty2:tys_rest <- vis_tys = mk_app_tys (HsOpTy noExt - (synifyType WithinType ty1) + (synifyType WithinType vs ty1) (noLoc $ getName tc) - (synifyType WithinType ty2)) + (synifyType WithinType vs ty2)) tys_rest -- Most TyCons: | otherwise @@ -512,7 +529,7 @@ synifyType _ (TyConApp tc tys) mk_app_tys ty_app ty_args = foldl (\t1 t2 -> noLoc $ HsAppTy noExt t1 t2) (noLoc ty_app) - (map (synifyType WithinType) $ + (map (synifyType WithinType vs) $ filterOut isCoercionTy ty_args) vis_tys = filterOutInvisibleTypes tc tys @@ -523,7 +540,7 @@ synifyType _ (TyConApp tc tys) maybe_sig ty' | needs_kind_sig = let full_kind = typeKind (mkTyConApp tc tys) - full_kind' = synifyType WithinType full_kind + full_kind' = synifyType WithinType vs full_kind in noLoc $ HsKindSig noExt ty' full_kind' | otherwise = ty' @@ -541,62 +558,91 @@ synifyType _ (TyConApp tc tys) in not (subVarSet result_vars dropped_vars) -synifyType s (AppTy t1 (CoercionTy {})) = synifyType s t1 -synifyType _ (AppTy t1 t2) = let - s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 +synifyType s vs (AppTy t1 (CoercionTy {})) = synifyType s vs t1 +synifyType _ vs (AppTy t1 t2) = let + s1 = synifyType WithinType vs t1 + s2 = synifyType WithinType vs t2 in noLoc $ HsAppTy noExt s1 s2 -synifyType s funty@(FunTy t1 t2) - | isPredTy t1 = synifyForAllType s funty - | otherwise = let s1 = synifyType WithinType t1 - s2 = synifyType WithinType t2 +synifyType s vs funty@(FunTy t1 t2) + | isPredTy t1 = synifyForAllType s vs funty + | otherwise = let s1 = synifyType WithinType vs t1 + s2 = synifyType WithinType vs t2 in noLoc $ HsFunTy noExt s1 s2 -synifyType s forallty@(ForAllTy _tv _ty) = synifyForAllType s forallty +synifyType s vs forallty@(ForAllTy _tv _ty) = synifyForAllType s vs forallty -synifyType _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t -synifyType s (CastTy t _) = synifyType s t -synifyType _ (CoercionTy {}) = error "synifyType:Coercion" +synifyType _ _ (LitTy t) = noLoc $ HsTyLit noExt $ synifyTyLit t +synifyType s vs (CastTy t _) = synifyType s vs t +synifyType _ _ (CoercionTy {}) = error "synifyType:Coercion" -- | Process a 'Type' which starts with a forall or a constraint into -- an 'HsType' -synifyForAllType :: SynifyTypeState -> Type -> LHsType GhcRn -synifyForAllType s ty = +synifyForAllType + :: SynifyTypeState -- ^ what to do with the 'forall' + -> [TyVar] -- ^ free variables in the type to convert + -> Type -- ^ the forall type to convert + -> LHsType GhcRn +synifyForAllType s vs ty = let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx - , hst_xqual = noExt - , hst_body = synifyType WithinType tau } + , hst_xqual = noExt + , hst_body = synifyType WithinType tvs' tau } - sTy ts = HsForAllTy { hst_bndrs = ts - , hst_xforall = noExt - , hst_body = noLoc sPhi } + sTy = HsForAllTy { hst_bndrs = sTvs + , hst_xforall = noExt + , hst_body = noLoc sPhi } sTvs = map synifyTyVar tvs - no_kinds_needed = noKindTyVars tau - sTvs' = map (synifyTyVar' no_kinds_needed) tvs - -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall ctxTvs = tyCoVarsOfTypesWellScoped ctx restTvs = filter (\tv -> not (tv `elemVarSet` mkVarSet ctxTvs)) (tyCoVarsOfTypeWellScoped tau) - tvs' = ctxTvs ++ restTvs + tvs' = filter (`notElem` vs) (ctxTvs ++ restTvs) in case s of - DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tvs' tau -- Put a forall in if there are any type variables WithinType - | not (null tvs) -> noLoc (sTy sTvs) + | not (null tvs) -> noLoc sTy | otherwise -> noLoc sPhi - -- Put a forall in if there are any type variables which require - -- explicit kind annotations or if the inferred type variable order - -- would be different. - ImplicitizeForAll - | any (isHsKindedTyVar . unLoc) sTvs' -> noLoc (sTy sTvs') - | tvs' /= tvs -> noLoc (sTy sTvs') - | otherwise -> noLoc sPhi + ImplicitizeForAll -> implicitForAll vs tvs ctx (synifyType WithinType) tau + + +-- | Put a forall in if there are any type variables which require +-- explicit kind annotations or if the inferred type variable order +-- would be different. +implicitForAll + :: [TyVar] -- ^ free variables in the type to convert + -> [TyVar] -- ^ type variable binders in the forall + -> ThetaType -- ^ constraints right after the forall + -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type + -> Type -- ^ inner type + -> LHsType GhcRn +implicitForAll vs tvs ctx synInner tau + | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy + | tvs' /= tvs = noLoc sTy + | otherwise = noLoc sPhi + where + sPhi = HsQualTy { hst_ctxt = synifyCtx ctx + , hst_xqual = noExt + , hst_body = synInner (tvs' ++ vs) tau } + sTy = HsForAllTy { hst_bndrs = sTvs + , hst_xforall = noExt + , hst_body = noLoc sPhi } + + no_kinds_needed = noKindTyVars tau + sTvs = map (synifyTyVar' no_kinds_needed) tvs + + -- Figure out what the type variable order would be inferred in the + -- absence of an explicit forall + ctxTvs = tyCoVarsOfTypesWellScoped ctx + restTvs = filter (\tv -> not (tv `elemVarSet` mkVarSet ctxTvs)) + (tyCoVarsOfTypeWellScoped tau) + tvs' = filter (`notElem` vs) (ctxTvs ++ restTvs) + -- | Find the set of type variables whose kind signatures can be properly @@ -620,7 +666,7 @@ noKindTyVars ty , xsKinds `eqTypes` map typeKind xs , isLiftedTypeKind outKind -> unitVarSet var - _ -> emptyVarSet + _ -> noKindTyVars f in unionVarSets (func : args) noKindTyVars (ForAllTy _ t) = noKindTyVars t noKindTyVars (FunTy t1 t2) = noKindTyVars t1 `unionVarSet` noKindTyVars t2 @@ -628,40 +674,38 @@ noKindTyVars (CastTy t _) = noKindTyVars t noKindTyVars _ = emptyVarSet synifyPatSynType :: PatSyn -> LHsType GhcRn -synifyPatSynType ps = let - (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps - req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy] - -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", - -- i.e., an explicit empty context, which is what we need. This is not - -- possible by taking theta = [], as that will print no context at all - | otherwise = req_theta - sForAll [] s = s - sForAll tvs s = HsForAllTy { hst_bndrs = map synifyTyVar tvs - , hst_xforall = noExt - , hst_body = noLoc s } - sQual theta s = HsQualTy { hst_ctxt = synifyCtx theta - , hst_xqual = noExt - , hst_body = noLoc s } - sTau = unLoc $ synifyType WithinType $ mkFunTys arg_tys res_ty - in noLoc $ sForAll univ_tvs $ sQual req_theta' $ sForAll ex_tvs $ sQual prov_theta sTau +synifyPatSynType ps = + let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps + + -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", + -- i.e., an explicit empty context, which is what we need. This is not + -- possible by taking theta = [], as that will print no context at all + req_theta' | null req_theta + , not (null prov_theta && null ex_tvs) + = [unitTy] + | otherwise = req_theta + + in implicitForAll [] univ_tvs req_theta' + (\vs -> implicitForAll vs ex_tvs prov_theta (synifyType WithinType)) + (mkFunTys arg_tys res_ty) synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s synifyKindSig :: Kind -> LHsKind GhcRn -synifyKindSig k = synifyType WithinType k +synifyKindSig k = synifyType WithinType [] k stripKindSig :: LHsType GhcRn -> LHsType GhcRn stripKindSig (L _ (HsKindSig _ t _)) = t stripKindSig t = t synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn -synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead +synifyInstHead (vs, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls , ihdTypes = map unLoc annot_ts , ihdInstType = ClassInst - { clsiCtx = map (unLoc . synifyType WithinType) preds + { clsiCtx = map (unLoc . synifyType WithinType []) preds , clsiTyVars = synifyTyVars (tyConVisibleTyVars cls_tycon) , clsiSigs = map synifyClsIdSig $ classMethods cls , clsiAssocTys = do @@ -672,10 +716,10 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead where cls_tycon = classTyCon cls ts = filterOutInvisibleTypes cls_tycon types - ts' = map (synifyType WithinType) ts + ts' = map (synifyType WithinType vs) ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars cls_tycon) - synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification + synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification vs -- Convert a family instance, this could be a type family or data family synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) @@ -689,7 +733,7 @@ synifyFamInst fi opaque = do where ityp SynFamilyInst | opaque = return $ TypeInst Nothing ityp SynFamilyInst = - return . TypeInst . Just . unLoc $ synifyType WithinType fam_rhs + return . TypeInst . Just . unLoc $ synifyType WithinType [] fam_rhs ityp (DataFamilyInst c) = DataInst <$> synifyTyCon (Just $ famInstAxiom fi) c fam_tc = famInstTyCon fi @@ -711,7 +755,7 @@ synifyFamInst fi opaque = do = fam_lhs ts = filterOutInvisibleTypes fam_tc eta_expanded_lhs - synifyTypes = map (synifyType WithinType) + synifyTypes = map (synifyType WithinType []) ts' = synifyTypes ts annot_ts = zipWith3 annotHsType is_poly_tvs ts ts' is_poly_tvs = mkIsPolyTvs (tyConVisibleTyVars fam_tc) From 421fc783763f492a73b92985af620f0214d756f8 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 4 Sep 2018 07:35:56 -0700 Subject: [PATCH 07/13] Deduce proper order for type variables When deciding if we want to have an explicit 'forall', one of the things to check is if the deduced type variable order would match the explicit one. Turns out that we need to roll our own function for that. One example of where this got fixed in the Prelude: fst :: forall a b. (a, b) -> a turned back into fst :: (a, b) -> a --- haddock-api/src/Haddock/Convert.hs | 11 ++----- haddock-api/src/Haddock/GhcUtils.hs | 50 +++++++++++++++++++++++++++++ 2 files changed, 53 insertions(+), 8 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 5904453ce9..2bacb83413 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -49,6 +49,7 @@ import VarSet import Haddock.Types import Haddock.Interface.Specialize +import Haddock.GhcUtils ( orderedFVs ) @@ -595,10 +596,7 @@ synifyForAllType s vs ty = -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall - ctxTvs = tyCoVarsOfTypesWellScoped ctx - restTvs = filter (\tv -> not (tv `elemVarSet` mkVarSet ctxTvs)) - (tyCoVarsOfTypeWellScoped tau) - tvs' = filter (`notElem` vs) (ctxTvs ++ restTvs) + tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) in case s of DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tvs' tau @@ -638,10 +636,7 @@ implicitForAll vs tvs ctx synInner tau -- Figure out what the type variable order would be inferred in the -- absence of an explicit forall - ctxTvs = tyCoVarsOfTypesWellScoped ctx - restTvs = filter (\tv -> not (tv `elemVarSet` mkVarSet ctxTvs)) - (tyCoVarsOfTypeWellScoped tau) - tvs' = filter (`notElem` vs) (ctxTvs ++ restTvs) + tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index e7d8096955..89259f7418 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -21,6 +21,7 @@ import Control.Arrow import Haddock.Types( DocNameI ) import Exception +import FV import Outputable import Name import NameSet @@ -30,6 +31,9 @@ import HscTypes import GHC import Class import DynFlags +import Var ( TyVarBndr(..), TyVarBinder, tyVarKind ) +import VarSet ( VarSet, emptyVarSet ) +import TyCoRep ( Type(..) ) import HsTypes (HsType(..)) @@ -436,3 +440,49 @@ setStubDir f d = d{ stubDir = Just f setOutputDir f = setObjectDir f . setHiDir f . setStubDir f +------------------------------------------------------------------------------- +-- * Free variables of a 'Type' +------------------------------------------------------------------------------- + +-- | Get free type variables in a 'Type' in their order of appearance. +-- See [Ordering of implicit variables]. +orderedFVs + :: VarSet -- ^ free variables to ignore + -> [Type] -- ^ types to traverse (in order) looking for free variables + -> [TyVar] -- ^ free type variables, in the order they appear in +orderedFVs vs tys = + reverse . fst $ tyCoFVsOfTypes' tys (const True) vs ([], emptyVarSet) + + +-- See the "Free variables of types and coercions" section in 'TyCoRep', or +-- check out Note [Free variables of types]. The functions in this section +-- don't output type variables in the order they first appear in in the 'Type'. +-- +-- However, we want to reuse the very optimized traversal machinery there, so +-- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`. +-- All these do differently is traverse in a different order and ignore +-- coercion variables. + +-- | Just like 'tyCoFVsOfType', but traverses type variables in reverse order +-- of appearance. +tyCoFVsOfType' :: Type -> FV +tyCoFVsOfType' (TyVarTy v) a b c = (FV.unitFV v `unionFV` tyCoFVsOfType' (tyVarKind v)) a b c +tyCoFVsOfType' (TyConApp _ tys) a b c = tyCoFVsOfTypes' tys a b c +tyCoFVsOfType' (LitTy {}) a b c = emptyFV a b c +tyCoFVsOfType' (AppTy fun arg) a b c = (tyCoFVsOfType' arg `unionFV` tyCoFVsOfType' fun) a b c +tyCoFVsOfType' (FunTy arg res) a b c = (tyCoFVsOfType' res `unionFV` tyCoFVsOfType' arg) a b c +tyCoFVsOfType' (ForAllTy bndr ty) a b c = tyCoFVsBndr' bndr (tyCoFVsOfType' ty) a b c +tyCoFVsOfType' (CastTy ty _) a b c = (tyCoFVsOfType' ty) a b c +tyCoFVsOfType' (CoercionTy _ ) a b c = emptyFV a b c + +-- | Just like 'tyCoFVsOfTypes', but traverses type variables in reverse order +-- of appearance. +tyCoFVsOfTypes' :: [Type] -> FV +tyCoFVsOfTypes' (ty:tys) fv_cand in_scope acc = (tyCoFVsOfTypes' tys `unionFV` tyCoFVsOfType' ty) fv_cand in_scope acc +tyCoFVsOfTypes' [] fv_cand in_scope acc = emptyFV fv_cand in_scope acc + +-- | Just like 'tyCoFVsBndr', but traverses type variables in reverse order of +-- appearance. +tyCoFVsBndr' :: TyVarBinder -> FV -> FV +tyCoFVsBndr' (TvBndr tv _) fvs = FV.delFV tv fvs `unionFV` tyCoFVsOfType' (tyVarKind tv) + From 1c8d1522b007254db5cfdc7ea1f004d335f3b5c1 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 4 Sep 2018 07:50:59 -0700 Subject: [PATCH 08/13] Infer kinds in pattern syns based on kind of TyCon This is especially nice for bundled pattern synonyms, where the synonyms go back to looking (almost always) like plain constructors. In 'BundledPatterns', this renders pattern (:>) :: a -> Vec n a -> Vec (n + 1) a instead of pattern (:>) :: forall a (n :: Nat). a -> Vec n a -> Vec (n + 1) a since the kind of `n` can be inferred from its use in `Vec n a`. --- haddock-api/src/Haddock/Convert.hs | 39 ++++++++++++++++++------------ 1 file changed, 24 insertions(+), 15 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 2bacb83413..6440e5c4c0 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -51,6 +51,7 @@ import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs ) +import Data.Maybe ( maybeToList ) -- the main function here! yay! @@ -606,20 +607,21 @@ synifyForAllType s vs ty = | not (null tvs) -> noLoc sTy | otherwise -> noLoc sPhi - ImplicitizeForAll -> implicitForAll vs tvs ctx (synifyType WithinType) tau + ImplicitizeForAll -> implicitForAll [] vs tvs ctx (synifyType WithinType) tau -- | Put a forall in if there are any type variables which require -- explicit kind annotations or if the inferred type variable order -- would be different. implicitForAll - :: [TyVar] -- ^ free variables in the type to convert + :: [TyCon] -- ^ type constructors that determine their args kinds + -> [TyVar] -- ^ free variables in the type to convert -> [TyVar] -- ^ type variable binders in the forall -> ThetaType -- ^ constraints right after the forall -> ([TyVar] -> Type -> LHsType GhcRn) -- ^ how to convert the inner type -> Type -- ^ inner type -> LHsType GhcRn -implicitForAll vs tvs ctx synInner tau +implicitForAll tycons vs tvs ctx synInner tau | any (isHsKindedTyVar . unLoc) sTvs = noLoc sTy | tvs' /= tvs = noLoc sTy | otherwise = noLoc sPhi @@ -631,7 +633,7 @@ implicitForAll vs tvs ctx synInner tau , hst_xforall = noExt , hst_body = noLoc sPhi } - no_kinds_needed = noKindTyVars tau + no_kinds_needed = noKindTyVars tycons tau sTvs = map (synifyTyVar' no_kinds_needed) tvs -- Figure out what the type variable order would be inferred in the @@ -649,28 +651,35 @@ implicitForAll vs tvs ctx synInner tau -- -- * @f@ has a function kind whose final return has lifted type kind -- -noKindTyVars :: Type -> VarSet -noKindTyVars (TyVarTy var) +noKindTyVars + :: [TyCon] -- ^ type constructors that determine their args kinds + -> Type -- ^ type to inspect + -> VarSet -- ^ set of variables whose kinds can be inferred from uses in the type +noKindTyVars _ (TyVarTy var) | isLiftedTypeKind (tyVarKind var) = unitVarSet var -noKindTyVars ty +noKindTyVars ts ty | (f, xs) <- splitAppTys ty , not (null xs) - = let args = map noKindTyVars xs + = let args = map (noKindTyVars ts) xs func = case f of TyVarTy var | (xsKinds, outKind) <- splitFunTys (tyVarKind var) , xsKinds `eqTypes` map typeKind xs , isLiftedTypeKind outKind -> unitVarSet var - _ -> noKindTyVars f + TyConApp t ks | t `elem` ts + , all noFreeVarsOfType ks + -> mkVarSet [ v | TyVarTy v <- xs ] + _ -> noKindTyVars ts f in unionVarSets (func : args) -noKindTyVars (ForAllTy _ t) = noKindTyVars t -noKindTyVars (FunTy t1 t2) = noKindTyVars t1 `unionVarSet` noKindTyVars t2 -noKindTyVars (CastTy t _) = noKindTyVars t -noKindTyVars _ = emptyVarSet +noKindTyVars ts (ForAllTy _ t) = noKindTyVars ts t +noKindTyVars ts (FunTy t1 t2) = noKindTyVars ts t1 `unionVarSet` noKindTyVars ts t2 +noKindTyVars ts (CastTy t _) = noKindTyVars ts t +noKindTyVars _ _ = emptyVarSet synifyPatSynType :: PatSyn -> LHsType GhcRn synifyPatSynType ps = let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps + ts = maybeToList (tyConAppTyCon_maybe res_ty) -- HACK: a HsQualTy with theta = [unitTy] will be printed as "() =>", -- i.e., an explicit empty context, which is what we need. This is not @@ -680,8 +689,8 @@ synifyPatSynType ps = = [unitTy] | otherwise = req_theta - in implicitForAll [] univ_tvs req_theta' - (\vs -> implicitForAll vs ex_tvs prov_theta (synifyType WithinType)) + in implicitForAll ts [] univ_tvs req_theta' + (\vs -> implicitForAll ts vs ex_tvs prov_theta (synifyType WithinType)) (mkFunTys arg_tys res_ty) synifyTyLit :: TyLit -> HsTyLit From 05974a3cf2860bd4d2a46e44aed5f319b791639a Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Tue, 4 Sep 2018 09:07:47 -0700 Subject: [PATCH 09/13] Synify associated type defaults Class decls produced by 'tyThingToLHsDecl' now contain associated type defaults when appropriate. --- haddock-api/src/Haddock/Convert.hs | 36 +++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 6440e5c4c0..f8a284d61d 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -51,7 +51,7 @@ import Haddock.Types import Haddock.Interface.Specialize import Haddock.GhcUtils ( orderedFVs ) -import Data.Maybe ( maybeToList ) +import Data.Maybe ( catMaybes, maybeToList ) -- the main function here! yay! @@ -71,16 +71,32 @@ tyThingToLHsDecl t = case t of -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious - -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a) - extractFamilyDecl (FamDecl _ d) = return $ noLoc d + -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (FamilyDecl a) + extractFamilyDecl (FamDecl _ d) = return d extractFamilyDecl _ = Left "tyThingToLHsDecl: impossible associated tycon" - atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl] - atFamDecls = map extractFamilyDecl (rights atTyClDecls) - tyClErrors = lefts atTyClDecls - famDeclErrors = lefts atFamDecls - in withErrs (tyClErrors ++ famDeclErrors) . TyClD noExt $ ClassDecl + extractFamDefDecl :: FamilyDecl GhcRn -> Type -> TyFamDefltEqn GhcRn + extractFamDefDecl fd rhs = FamEqn + { feqn_ext = noExt + , feqn_tycon = fdLName fd + , feqn_pats = fdTyVars fd + , feqn_fixity = fdFixity fd + , feqn_rhs = synifyType WithinType [] rhs } + + extractAtItem + :: ClassATItem + -> Either ErrMsg (LFamilyDecl GhcRn, Maybe (LTyFamDefltEqn GhcRn)) + extractAtItem (ATI at_tc def) = do + tyDecl <- synifyTyCon Nothing at_tc + famDecl <- extractFamilyDecl tyDecl + let defEqnTy = fmap (noLoc . extractFamDefDecl famDecl . fst) def + pure (noLoc famDecl, defEqnTy) + + atTyClDecls = map extractAtItem (classATItems cl) + (atFamDecls, atDefFamDecls) = unzip (rights atTyClDecls) + + in withErrs (lefts atTyClDecls) . TyClD noExt $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (tyConVisibleTyVars (classTyCon cl)) @@ -94,8 +110,8 @@ tyThingToLHsDecl t = case t of , tcdSig <- synifyTcIdSig DeleteTopLevelQuantification clsOp ] , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon: - , tcdATs = rights atFamDecls - , tcdATDefs = [] --ignore associated type defaults + , tcdATs = atFamDecls + , tcdATDefs = catMaybes atDefFamDecls , tcdDocs = [] --we don't have any docs at this point , tcdCExt = placeHolderNamesTc } | otherwise From 0aaeba66e55ec32d2f3fc56f7d86b229cb02fe7c Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 5 Sep 2018 06:48:44 -0700 Subject: [PATCH 10/13] Extend variables in scope when synifying Fixes the 'Semigroup' method: stimes :: forall b. Integral b => b -> a -> a Into stimes :: Integral b => b -> a -> a --- haddock-api/src/Haddock/Convert.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index f8a284d61d..814a309242 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -603,7 +603,7 @@ synifyForAllType s vs ty = let (tvs, ctx, tau) = tcSplitSigmaTyPreserveSynonyms ty sPhi = HsQualTy { hst_ctxt = synifyCtx ctx , hst_xqual = noExt - , hst_body = synifyType WithinType tvs' tau } + , hst_body = synifyType WithinType (tvs' ++ vs) tau } sTy = HsForAllTy { hst_bndrs = sTvs , hst_xforall = noExt @@ -616,7 +616,7 @@ synifyForAllType s vs ty = tvs' = orderedFVs (mkVarSet vs) (ctx ++ [tau]) in case s of - DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tvs' tau + DeleteTopLevelQuantification -> synifyType ImplicitizeForAll (tvs' ++ vs) tau -- Put a forall in if there are any type variables WithinType From 25d3db503d156b47e0500bfb0527a6ee7a356dc8 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Wed, 5 Sep 2018 08:32:23 -0700 Subject: [PATCH 11/13] Add example of 'tyCoVarsOfTypeList's behaviour This should make it clearer why we need to define our copies of some of these functions. --- haddock-api/src/Haddock/GhcUtils.hs | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 89259f7418..805c537d12 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -458,6 +458,19 @@ orderedFVs vs tys = -- check out Note [Free variables of types]. The functions in this section -- don't output type variables in the order they first appear in in the 'Type'. -- +-- For example, 'tyCoVarsOfTypeList' reports an incorrect order for the type +-- of 'const :: a -> b -> a': +-- +-- >>> import Name +-- >>> import TyCoRep +-- >>> import TysPrim +-- >>> import Var +-- >>> a = TyVarTy alphaTyVar +-- >>> b = TyVarTy betaTyVar +-- >>> constTy = mkFunTys [a, b] a +-- >>> map (getOccString . tyVarName) (tyCoVarsOfTypeList constTy) +-- ["b","a"] +-- -- However, we want to reuse the very optimized traversal machinery there, so -- so we make our own `tyCoFVsOfType'`, `tyCoFVsBndr'`, and `tyCoVarsOfTypes'`. -- All these do differently is traverse in a different order and ignore From 3dcf333a5e229862e9f5c2187ac7788675e26a31 Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 7 Sep 2018 06:45:39 -0700 Subject: [PATCH 12/13] Move 'forall's left on pattern synonym sigs This fixes the empty forall on the 'pattern Blub'. Before: pattern Blub :: forall. () => forall x. Show x => x -> BlubType After: pattern Blub :: () => Show x => x -> BlubType --- haddock-api/src/Haddock/Convert.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 814a309242..950a7d3ee8 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -705,8 +705,8 @@ synifyPatSynType ps = = [unitTy] | otherwise = req_theta - in implicitForAll ts [] univ_tvs req_theta' - (\vs -> implicitForAll ts vs ex_tvs prov_theta (synifyType WithinType)) + in implicitForAll ts [] (univ_tvs ++ ex_tvs) req_theta' + (\vs -> implicitForAll ts vs [] prov_theta (synifyType WithinType)) (mkFunTys arg_tys res_ty) synifyTyLit :: TyLit -> HsTyLit From dece1475b734fe7c2a2041162edb439a26d64c4b Mon Sep 17 00:00:00 2001 From: Alec Theriault Date: Fri, 7 Sep 2018 06:58:03 -0700 Subject: [PATCH 13/13] Fix return kind of polykinded H98 types 'synifyDataTyConReturnKind' was behaving badly with kind signatures involving foralls and kind tyvars. Thankfully, 'TyCon's already have 'tyConResKind' for figuring out the return kind of type constructors. Consider `data (a :: *) >< b = Empty` with `-XPolyKinds`. Here is the header we generate: Before: data a >< (b :: k) :: forall k. Type -> k -> Type After: data a >< (b :: k) --- haddock-api/src/Haddock/Convert.hs | 17 ++++++++--------- 1 file changed, 8 insertions(+), 9 deletions(-) diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 950a7d3ee8..a645bb8245 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -278,26 +278,25 @@ synifyTyCon coax tc , tcdDExt = DataDeclRn False placeHolderNamesTc } dataConErrs -> Left $ unlines dataConErrs --- In this module, every TyCon being considered has come from an interface +-- | In this module, every TyCon being considered has come from an interface -- file. This means that when considering a data type constructor such as: -- --- data Foo (w :: *) (m :: * -> *) (a :: *) +-- > data Foo (w :: *) (m :: * -> *) (a :: *) -- -- Then its tyConKind will be (* -> (* -> *) -> * -> *). But beware! We are -- also rendering the type variables of Foo, so if we synify the tyConKind of -- Foo in full, we will end up displaying this in Haddock: -- --- data Foo (w :: *) (m :: * -> *) (a :: *) --- :: * -> (* -> *) -> * -> * +-- > data Foo (w :: *) (m :: * -> *) (a :: *) +-- > :: * -> (* -> *) -> * -> * -- --- Which is entirely wrong (#548). We only want to display the *return* kind, +-- Which is entirely wrong (#548). We only want to display the /return/ kind, -- which this function obtains. synifyDataTyConReturnKind :: TyCon -> Maybe (LHsKind GhcRn) synifyDataTyConReturnKind tc - = case splitFunTys (tyConKind tc) of - (_, ret_kind) - | isLiftedTypeKind ret_kind -> Nothing -- Don't bother displaying :: * - | otherwise -> Just (synifyKindSig ret_kind) + | isLiftedTypeKind ret_kind = Nothing -- Don't bother displaying :: * + | otherwise = Just (synifyKindSig ret_kind) + where ret_kind = tyConResKind tc synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity -> Maybe (LInjectivityAnn GhcRn)