Commit 72bd7f7b authored by Rik Steenkamp's avatar Rik Steenkamp Committed by Matthew Pickering

Improve printing of pattern synonym types

Add the function `pprPatSynType :: PatSyn -> SDoc` for printing pattern
synonym types, and remove the ambiguous `patSynType` function. Also,
the types in a `PatSyn` are now tidy.

Haddock submodule updated to reflect the removal of `patSynType` by
mpickering.

Fixes: #11213.

Reviewers: goldfire, simonpj, austin, mpickering, bgamari

Reviewed By: simonpj, mpickering

Subscribers: bollmann, simonpj, thomie

Differential Revision: https://phabricator.haskell.org/D1896

GHC Trac Issues: #11213
parent 38068913
......@@ -13,13 +13,13 @@ module PatSyn (
-- ** Type deconstruction
patSynName, patSynArity, patSynIsInfix,
patSynArgs, patSynType,
patSynArgs,
patSynMatcher, patSynBuilder,
patSynUnivTyBinders, patSynExTyVars, patSynExTyBinders, patSynSig,
patSynInstArgTys, patSynInstResTy, patSynFieldLabels,
patSynFieldType,
tidyPatSynIds
tidyPatSynIds, pprPatSynType
) where
#include "HsVersions.h"
......@@ -348,16 +348,6 @@ mkPatSyn name declared_infix
patSynName :: PatSyn -> Name
patSynName = psName
patSynType :: PatSyn -> Type
-- The full pattern type, used only in error messages
-- See Note [Pattern synonym signatures]
patSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
, psExTyVars = ex_tvs, psProvTheta = prov_theta
, psArgs = orig_args, psOrigResTy = orig_res_ty })
= mkSpecSigmaTy univ_tvs req_theta $ -- use mkSpecSigmaTy because it
mkSpecSigmaTy ex_tvs prov_theta $ -- prints better
mkFunTys orig_args orig_res_ty
-- | Should the 'PatSyn' be presented infix?
patSynIsInfix :: PatSyn -> Bool
patSynIsInfix = psInfix
......@@ -435,3 +425,16 @@ patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
= ASSERT2( length univ_tvs == length inst_tys
, text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
substTyWith univ_tvs inst_tys res_ty
-- | Print the type of a pattern synonym. The foralls are printed explicitly
pprPatSynType :: PatSyn -> SDoc
pprPatSynType (MkPatSyn { psUnivTyVars = univ_tvs, psReqTheta = req_theta
, psExTyVars = ex_tvs, psProvTheta = prov_theta
, psArgs = orig_args, psOrigResTy = orig_res_ty })
= sep [ pprForAllImplicit univ_tvs
, pprThetaArrowTy req_theta
, ppWhen insert_empty_ctxt $ parens empty <+> darrow
, pprType sigma_ty ]
where
sigma_ty = mkSpecSigmaTy ex_tvs prov_theta $ mkFunTys orig_args orig_res_ty
insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
......@@ -1567,9 +1567,10 @@ warnUnusedImportDecls gbl_env
warnMissingSignatures :: TcGblEnv -> RnM ()
warnMissingSignatures gbl_env
= do { let exports = availsToNameSet (tcg_exports gbl_env)
sig_ns = tcg_sigs gbl_env
all_binds = collectHsBindsBinders $ tcg_binds gbl_env
all_ps = tcg_patsyns gbl_env
sig_ns = tcg_sigs gbl_env
-- We use sig_ns to exclude top-level bindings that are generated by GHC
binds = collectHsBindsBinders $ tcg_binds gbl_env
pat_syns = tcg_patsyns gbl_env
-- Warn about missing signatures
-- Do this only when we we have a type to offer
......@@ -1584,27 +1585,32 @@ warnMissingSignatures gbl_env
| otherwise = return ()
add_warns flag
= forM_ binders
(\(name, ty) ->
do { env <- tcInitTidyEnv
; let (_, tidy_ty) = tidyOpenType env ty
; addWarnAt (Reason flag) (getSrcSpan name)
(get_msg name tidy_ty) })
binds = if warn_missing_sigs || warn_only_exported then all_binds else []
ps = if warn_pat_syns then all_ps else []
binders = filter pred $
[(patSynName p, patSynType p) | p <- ps ] ++
[(idName b, idType b) | b <- binds]
pred (name, _) = name `elemNameSet` sig_ns
&& (not warn_only_exported || name `elemNameSet` exports)
-- We use sig_ns to exclude top-level bindings that are
-- generated by GHC and that don't have signatures
get_msg name ty
= sep [ text "Top-level binding with no type signature:",
nest 2 $ pprPrefixName name <+> dcolon <+> ppr ty ]
= when warn_pat_syns
(mapM_ add_pat_syn_warn pat_syns) >>
when (warn_missing_sigs || warn_only_exported)
(mapM_ add_bind_warn binds)
where
add_pat_syn_warn p
= add_warn (patSynName p) (pprPatSynType p)
add_bind_warn id
= do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv?
; let name = idName id
(_, ty) = tidyOpenType env (idType id)
ty_msg = ppr ty
; add_warn name ty_msg }
add_warn name ty_msg
= when (name `elemNameSet` sig_ns && export_check name)
(addWarnAt (Reason flag) (getSrcSpan name)
(get_msg name ty_msg))
export_check name
= not warn_only_exported || name `elemNameSet` exports
get_msg name ty_msg
= sep [ text "Top-level binding with no type signature:",
nest 2 $ pprPrefixName name <+> dcolon <+> ty_msg ]
; add_sig_warns }
......
......@@ -28,6 +28,8 @@ import Panic
import Outputable
import FastString
import Var
import VarEnv( emptyTidyEnv )
import Type( tidyTyCoVarBndrs, tidyTypes, tidyType )
import Id
import IdInfo( RecSelParent(..))
import TcBinds
......@@ -411,12 +413,19 @@ tc_patsyn_finish lname dir is_infix lpat'
pat_ty field_labels
= do { -- Zonk everything. We are about to build a final PatSyn
-- so there had better be no unification variables in there
univ_tvs <- mapMaybeM zonkQuantifiedTyVar univ_tvs
; ex_tvs <- mapMaybeM zonkQuantifiedTyVar ex_tvs
; prov_theta <- zonkTcTypes prov_theta
; req_theta <- zonkTcTypes req_theta
; pat_ty <- zonkTcType pat_ty
; arg_tys <- zonkTcTypes arg_tys
univ_tvs' <- mapMaybeM zonkQuantifiedTyVar univ_tvs
; ex_tvs' <- mapMaybeM zonkQuantifiedTyVar ex_tvs
; prov_theta' <- zonkTcTypes prov_theta
; req_theta' <- zonkTcTypes req_theta
; pat_ty' <- zonkTcType pat_ty
; arg_tys' <- zonkTcTypes arg_tys
; let (env1, univ_tvs) = tidyTyCoVarBndrs emptyTidyEnv univ_tvs'
(env2, ex_tvs) = tidyTyCoVarBndrs env1 ex_tvs'
req_theta = tidyTypes env2 req_theta'
prov_theta = tidyTypes env2 prov_theta'
arg_tys = tidyTypes env2 arg_tys'
pat_ty = tidyType env2 pat_ty'
-- We need to update the univ and ex binders after zonking.
-- But zonking may have defaulted some erstwhile binders,
......
......@@ -139,7 +139,7 @@ import TyCon ( TyCon )
import Coercion ( Coercion, mkHoleCo )
import ConLike ( ConLike(..) )
import DataCon ( DataCon, dataConUserType, dataConOrigArgTys )
import PatSyn ( PatSyn, patSynType )
import PatSyn ( PatSyn, pprPatSynType )
import Id ( idName )
import PrelNames ( callStackTyConKey, ipClassKey )
import Unique ( hasKey )
......@@ -2669,7 +2669,7 @@ pprPatSkolInfo (RealDataCon dc)
pprPatSkolInfo (PatSynCon ps)
= sep [ text "a pattern with pattern synonym:"
, nest 2 $ ppr ps <+> dcolon
<+> pprType (patSynType ps) <> comma ]
<+> pprPatSynType ps <> comma ]
{- Note [Skolem info for pattern synonyms]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
{-# LANGUAGE PatternSynonyms, GADTs #-}
{-# OPTIONS_GHC -fwarn-missing-pattern-synonym-signatures #-}
{-
Test the printing of pattern synonym types (pprPatSynType)
We test all valid combinations of:
universal type variables yes/no
"required" context yes/no
existential type variables yes/no
"provided" context yes/no
-}
module T11213 where
data Ex where MkEx :: a -> Ex
data ExProv where MkExProv :: (Show a) => a -> ExProv
data UnivProv a where MkUnivProv :: (Show a) => a -> UnivProv a
pattern P <- True
pattern Pe x <- MkEx x
pattern Pu x <- x
pattern Pue x y <- (x, MkEx y)
pattern Pur x <- [x, 1]
pattern Purp x y <- ([x, 1], MkUnivProv y)
pattern Pure x y <- ([x, 1], MkEx y)
pattern Purep x y <- ([x, 1], MkExProv y)
pattern Pep x <- MkExProv x
pattern Pup x <- MkUnivProv x
pattern Puep x y <- (MkExProv x, y)
T11213.hs:19:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature: P :: Bool
T11213.hs:20:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature:
Pe :: () => forall a. a -> Ex
T11213.hs:21:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature: Pu :: forall t. t -> t
T11213.hs:22:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature:
Pue :: forall t. () => forall a. t -> a -> (t, Ex)
T11213.hs:23:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature:
Pur :: forall a. (Num a, Eq a) => a -> [a]
T11213.hs:24:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature:
Purp :: forall a t.
(Num a, Eq a) =>
Show t => a -> t -> ([a], UnivProv t)
T11213.hs:25:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature:
Pure :: forall a. (Num a, Eq a) => forall a1. a -> a1 -> ([a], Ex)
T11213.hs:26:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature:
Purep :: forall a.
(Num a, Eq a) =>
forall a1. Show a1 => a -> a1 -> ([a], ExProv)
T11213.hs:27:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature:
Pep :: () => forall a. Show a => a -> ExProv
T11213.hs:28:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature:
Pup :: forall t. () => Show t => t -> UnivProv t
T11213.hs:29:1: warning: [-Wmissing-pattern-synonym-signatures (in -Wall)]
Top-level binding with no type signature:
Puep :: forall t. () => forall a. Show a => a -> t -> (ExProv, t)
......@@ -44,6 +44,7 @@ test('export-record-selector', normal, compile, [''])
test('T10897', normal, multi_compile, ['T10897', [
('T10897a.hs','-c')
], '-v0'])
test('T11213', normal, compile, [''])
test('T11224b', normal, compile, [''])
test('MoreEx', normal, compile, [''])
test('T11283', normal, compile, [''])
......
Subproject commit bb994de1ab0c76d1aaf1e39c54158db2526d31f1
Subproject commit 3ddcbd6b8e6884bd95028381176eb33bee6896fb
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment