diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2015-12-01 17:38:23 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2015-12-01 18:45:23 +0100 |
commit | 1e041b7382b6aa329e4ad9625439f811e0f27232 (patch) | |
tree | 91f4418553a1e6df072f56f43b5697d40c985b5f /compiler/hsSyn | |
parent | b432e2f39c095d8acbb0cfcc63bd08436c7a3e49 (diff) | |
download | haskell-1e041b7382b6aa329e4ad9625439f811e0f27232.tar.gz |
Refactor treatment of wildcards
This patch began as a modest refactoring of HsType and friends, to
clarify and tidy up exactly where quantification takes place in types.
Although initially driven by making the implementation of wildcards more
tidy (and fixing a number of bugs), I gradually got drawn into a pretty
big process, which I've been doing on and off for quite a long time.
There is one compiler performance regression as a result of all
this, in perf/compiler/T3064. I still need to look into that.
* The principal driving change is described in Note [HsType binders]
in HsType. Well worth reading!
* Those data type changes drive almost everything else. In particular
we now statically know where
(a) implicit quantification only (LHsSigType),
e.g. in instance declaratios and SPECIALISE signatures
(b) implicit quantification and wildcards (LHsSigWcType)
can appear, e.g. in function type signatures
* As part of this change, HsForAllTy is (a) simplified (no wildcards)
and (b) split into HsForAllTy and HsQualTy. The two contructors
appear when and only when the correponding user-level construct
appears. Again see Note [HsType binders].
HsExplicitFlag disappears altogether.
* Other simplifications
- ExprWithTySig no longer needs an ExprWithTySigOut variant
- TypeSig no longer needs a PostRn name [name] field
for wildcards
- PatSynSig records a LHsSigType rather than the decomposed
pieces
- The mysterious 'GenericSig' is now 'ClassOpSig'
* Renamed LHsTyVarBndrs to LHsQTyVars
* There are some uninteresting knock-on changes in Haddock,
because of the HsSyn changes
I also did a bunch of loosely-related changes:
* We already had type synonyms CoercionN/CoercionR for nominal and
representational coercions. I've added similar treatment for
TcCoercionN/TcCoercionR
mkWpCastN/mkWpCastN
All just type synonyms but jolly useful.
* I record-ised ForeignImport and ForeignExport
* I improved the (poor) fix to Trac #10896, by making
TcTyClsDecls.checkValidTyCl recover from errors, but adding a
harmless, abstract TyCon to the envt if so.
* I did some significant refactoring in RnEnv.lookupSubBndrOcc,
for reasons that I have (embarrassingly) now totally forgotten.
It had to do with something to do with import and export
Updates haddock submodule.
Diffstat (limited to 'compiler/hsSyn')
-rw-r--r-- | compiler/hsSyn/Convert.hs | 78 | ||||
-rw-r--r-- | compiler/hsSyn/HsBinds.hs | 73 | ||||
-rw-r--r-- | compiler/hsSyn/HsDecls.hs | 140 | ||||
-rw-r--r-- | compiler/hsSyn/HsExpr.hs | 48 | ||||
-rw-r--r-- | compiler/hsSyn/HsPat.hs | 8 | ||||
-rw-r--r-- | compiler/hsSyn/HsSyn.hs | 2 | ||||
-rw-r--r-- | compiler/hsSyn/HsTypes.hs | 502 | ||||
-rw-r--r-- | compiler/hsSyn/HsUtils.hs | 112 |
8 files changed, 560 insertions, 403 deletions
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 29dd48c86a..1fc4f09ad9 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -14,7 +14,6 @@ module Convert( convertToHsExpr, convertToPat, convertToHsDecls, thRdrNameGuesses ) where import HsSyn as Hs -import HsTypes ( mkHsForAllTy ) import qualified Class import RdrName import qualified Name @@ -173,10 +172,10 @@ cvtDec (TH.FunD nm cls) cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD (TypeSig [nm'] ty' PlaceHolder) } + ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) } cvtDec (TH.InfixD fx nm) - -- fixity signatures are allowed for variables, constructors, and types + -- Fixity signatures are allowed for variables, constructors, and types -- the renamer automatically looks for types during renaming, even when -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. @@ -229,7 +228,8 @@ cvtDec (ClassD ctxt cl tvs fds decs) ; at_defs <- mapM cvt_at_def ats' ; returnJustL $ TyClD $ ClassDecl { tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs' - , tcdFDs = fds', tcdSigs = sigs', tcdMeths = binds' + , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' + , tcdMeths = binds' , tcdATs = fams', tcdATDefs = at_defs, tcdDocs = [] , tcdFVs = placeHolderNames } -- no docs in TH ^^ @@ -247,9 +247,13 @@ cvtDec (InstanceD ctxt ty decs) ; unless (null fams') (failWith (mkBadDecMsg doc fams')) ; ctxt' <- cvtContext ctxt ; L loc ty' <- cvtType ty - ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] ctxt' $ L loc ty' + ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' } ; returnJustL $ InstD $ ClsInstD $ - ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing } + ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty' + , cid_binds = binds' + , cid_sigs = Hs.mkClassOpSigs sigs' + , cid_tyfam_insts = ats', cid_datafam_insts = adts' + , cid_overlap_mode = Nothing } } cvtDec (ForeignD ford) = do { ford' <- cvtForD ford @@ -319,21 +323,21 @@ cvtDec (TH.RoleAnnotD tc roles) cvtDec (TH.StandaloneDerivD cxt ty) = do { cxt' <- cvtContext cxt ; L loc ty' <- cvtType ty - ; let inst_ty' = L loc $ mkHsForAllTy Implicit [] cxt' $ L loc ty' + ; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' } ; returnJustL $ DerivD $ - DerivDecl { deriv_type = inst_ty', deriv_overlap_mode = Nothing } } + DerivDecl { deriv_type = mkLHsSigType inst_ty', deriv_overlap_mode = Nothing } } cvtDec (TH.DefaultSigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD $ GenericSig [nm'] ty' } + ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') } ---------------- cvtTySynEqn :: Located RdrName -> TySynEqn -> CvtM (LTyFamInstEqn RdrName) cvtTySynEqn tc (TySynEqn lhs rhs) = do { lhs' <- mapM cvtType lhs ; rhs' <- cvtType rhs ; returnL $ TyFamEqn { tfe_tycon = tc - , tfe_pats = mkHsWithBndrs lhs' + , tfe_pats = mkHsImplicitBndrs lhs' , tfe_rhs = rhs' } } ---------------- @@ -361,7 +365,7 @@ cvt_ci_decs doc decs cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr] -> CvtM ( LHsContext RdrName , Located RdrName - , LHsTyVarBndrs RdrName) + , LHsQTyVars RdrName) cvt_tycl_hdr cxt tc tvs = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc @@ -372,12 +376,12 @@ cvt_tycl_hdr cxt tc tvs cvt_tyinst_hdr :: TH.Cxt -> TH.Name -> [TH.Type] -> CvtM ( LHsContext RdrName , Located RdrName - , HsWithBndrs RdrName [LHsType RdrName]) + , HsImplicitBndrs RdrName [LHsType RdrName]) cvt_tyinst_hdr cxt tc tys = do { cxt' <- cvtContext cxt ; tc' <- tconNameL tc ; tys' <- mapM cvtType tys - ; return (cxt', tc', mkHsWithBndrs tys') } + ; return (cxt', tc', mkHsImplicitBndrs tys') } ------------------------------------------------------------------- -- Partitioning declarations @@ -419,13 +423,13 @@ cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys - ; returnL $ mkSimpleConDecl c' noExistentials cxt' (PrefixCon tys') } + ; returnL $ mkSimpleConDecl c' Nothing cxt' (PrefixCon tys') } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ mkSimpleConDecl c' noExistentials cxt' + ; returnL $ mkSimpleConDecl c' Nothing cxt' (RecCon (noLoc args')) } cvtConstr (InfixC st1 c st2) @@ -433,13 +437,14 @@ cvtConstr (InfixC st1 c st2) ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ mkSimpleConDecl c' noExistentials cxt' (InfixCon st1' st2') } + ; returnL $ mkSimpleConDecl c' Nothing cxt' (InfixCon st1' st2') } cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; L loc ctxt' <- cvtContext ctxt ; L _ con' <- cvtConstr con ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con')) + , con_explicit = True , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } } cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) @@ -459,21 +464,20 @@ cvt_id_arg (i, str, ty) , cd_fld_type = ty' , cd_fld_doc = Nothing}) } -cvtDerivs :: [TH.Name] -> CvtM (Maybe (Located [LHsType RdrName])) +cvtDerivs :: [TH.Name] -> CvtM (HsDeriving RdrName) cvtDerivs [] = return Nothing cvtDerivs cs = do { cs' <- mapM cvt_one cs ; return (Just (noLoc cs')) } where cvt_one c = do { c' <- tconName c - ; returnL $ HsTyVar (noLoc c') } + ; ty <- returnL $ HsTyVar (noLoc c') + ; return (mkLHsSigType ty) } cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName))) cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs ; ys' <- mapM tName ys ; returnL (map noLoc xs', map noLoc ys') } -noExistentials :: [LHsTyVarBndr RdrName] -noExistentials = [] ------------------------------------------ -- Foreign declarations @@ -498,7 +502,10 @@ cvtForD (ImportF callconv safety from nm ty) mk_imp impspec = do { nm' <- vNameL nm ; ty' <- cvtType ty - ; return (ForeignImport nm' ty' noForeignImportCoercionYet impspec) + ; return (ForeignImport { fd_name = nm' + , fd_sig_ty = mkLHsSigType ty' + , fd_co = noForeignImportCoercionYet + , fd_fi = impspec }) } safety' = case safety of Unsafe -> PlayRisky @@ -512,7 +519,10 @@ cvtForD (ExportF callconv as nm ty) (mkFastString as) (cvt_conv callconv))) (noLoc as) - ; return $ ForeignExport nm' ty' noForeignExportCoercionYet e } + ; return $ ForeignExport { fd_name = nm' + , fd_sig_ty = mkLHsSigType ty' + , fd_co = noForeignExportCoercionYet + , fd_fe = e } } cvt_conv :: TH.Callconv -> CCallConv cvt_conv TH.CCall = CCallConv @@ -547,11 +557,12 @@ cvtPragmaD (SpecialiseP nm ty inline phases) , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ SpecSig nm' [ty'] ip } + ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip } cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty - ; returnJustL $ Hs.SigD $ SpecInstSig "{-# SPECIALISE" ty' } + ; returnJustL $ Hs.SigD $ + SpecInstSig "{-# SPECIALISE" (mkLHsSigType ty') } cvtPragmaD (RuleP nm bndrs lhs rhs phases) = do { let nm' = mkFastString nm @@ -608,7 +619,7 @@ cvtRuleBndr (RuleVar n) cvtRuleBndr (TypedRuleVar n ty) = do { n' <- vNameL n ; ty' <- cvtType ty - ; return $ noLoc $ Hs.RuleBndrSig n' $ mkHsWithBndrs ty' } + ; return $ noLoc $ Hs.RuleBndrSig n' $ mkLHsSigWcType ty' } --------------------------------------------------- -- Declarations @@ -709,7 +720,7 @@ cvtl e = wrapL (cvt e) cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t - ; return $ ExprWithTySig e' t' PlaceHolder } + ; return $ ExprWithTySig e' (mkLHsSigWcType t') } cvt (RecConE c flds) = do { c' <- cNameL c ; flds' <- mapM (cvtFld mkFieldOcc) flds ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } @@ -952,7 +963,7 @@ cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs cvtp (ListP ps) = do { ps' <- cvtPats ps ; return $ ListPat ps' placeHolderType Nothing } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t - ; return $ SigPatIn p' (mkHsWithBndrs t') } + ; return $ SigPatIn p' (mkLHsSigWcType t') } cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p ; return $ ViewPat e' p' placeHolderType } @@ -980,7 +991,7 @@ cvtOpAppP x op y ----------------------------------------------------------- -- Types and type variables -cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsTyVarBndrs RdrName) +cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars RdrName) cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') } cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName) @@ -1045,8 +1056,15 @@ cvtTypeKind ty_str ty -> do { tvs' <- cvtTvs tvs ; cxt' <- cvtContext cxt ; ty' <- cvtType ty - ; returnL $ mkExplicitHsForAllTy (hsQTvBndrs tvs') cxt' ty' - } + ; loc <- getL + ; let hs_ty | null tvs = rho_ty + | otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvBndrs tvs' + , hst_body = rho_ty }) + rho_ty | null cxt = ty' + | otherwise = L loc (HsQualTy { hst_ctxt = cxt' + , hst_body = ty' }) + + ; return hs_ty } SigT ty ki -> do { ty' <- cvtType ty diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 978d36349a..25ce654ecd 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -447,7 +447,7 @@ plusHsValBinds _ _ getTypeSigNames :: HsValBinds a -> NameSet -- Get the names that have a user type sig getTypeSigNames (ValBindsOut _ sigs) - = mkNameSet [unLoc n | L _ (TypeSig names _ _) <- sigs, n <- names] + = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names] getTypeSigNames _ = panic "HsBinds.getTypeSigNames" @@ -627,9 +627,8 @@ data Sig name -- For details on above see note [Api annotations] in ApiAnnotation TypeSig - [Located name] -- LHS of the signature; e.g. f,g,h :: blah - (LHsType name) -- RHS of the signature - (PostRn name [Name]) -- Wildcards (both named and anonymous) of the RHS + [Located name] -- LHS of the signature; e.g. f,g,h :: blah + (LHsSigWcType name) -- RHS of the signature; can have wildcards -- | A pattern synonym type signature -- @@ -640,21 +639,20 @@ data Sig name -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | PatSynSig (Located name) - (HsExplicitFlag, LHsTyVarBndrs name) - (LHsContext name) -- Required context - (LHsContext name) -- Provided context - (LHsType name) - - -- | A type signature for a default method inside a class - -- - -- > default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool - -- - -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', - -- 'ApiAnnotation.AnnDcolon' - - -- For details on above see note [Api annotations] in ApiAnnotation - | GenericSig [Located name] (LHsType name) + | PatSynSig (Located name) (LHsSigType name) + -- P :: forall a b. Prov => Req => ty + + -- | A signature for a class method + -- False: ordinary class-method signauure + -- True: default class method signature + -- e.g. class C a where + -- op :: a -> a -- Ordinary + -- default op :: Eq a => a -> a -- Generic default + -- No wildcards allowed here + -- + -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', + -- 'ApiAnnotation.AnnDcolon' + | ClassOpSig Bool [Located name] (LHsSigType name) -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record @@ -700,11 +698,11 @@ data Sig name -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecSig (Located name) -- Specialise a function or datatype ... - [LHsType name] -- ... to these types - InlinePragma -- The pragma on SPECIALISE_INLINE form. - -- If it's just defaultInlinePragma, then we said - -- SPECIALISE, not SPECIALISE_INLINE + | SpecSig (Located name) -- Specialise a function or datatype ... + [LHsSigType name] -- ... to these types + InlinePragma -- The pragma on SPECIALISE_INLINE form. + -- If it's just defaultInlinePragma, then we said + -- SPECIALISE, not SPECIALISE_INLINE -- | A specialisation pragma for instance declarations only -- @@ -717,7 +715,7 @@ data Sig name -- 'ApiAnnotation.AnnInstance','ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecInstSig SourceText (LHsType name) + | SpecInstSig SourceText (LHsSigType name) -- Note [Pragma source text] in BasicTypes -- | A minimal complete definition pragma @@ -782,7 +780,7 @@ isVanillaLSig _ = False isTypeLSig :: LSig name -> Bool -- Type signatures isTypeLSig (L _(TypeSig {})) = True -isTypeLSig (L _(GenericSig {})) = True +isTypeLSig (L _(ClassOpSig {})) = True isTypeLSig (L _(IdSig {})) = True isTypeLSig _ = False @@ -812,7 +810,9 @@ isMinimalLSig _ = False hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = ptext (sLit "type signature") hsSigDoc (PatSynSig {}) = ptext (sLit "pattern synonym signature") -hsSigDoc (GenericSig {}) = ptext (sLit "default type signature") +hsSigDoc (ClassOpSig is_deflt _ _) + | is_deflt = ptext (sLit "default type signature") + | otherwise = ptext (sLit "class method signature") hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") hsSigDoc (InlineSig _ prag) = ppr (inlinePragmaSpec prag) <+> ptext (sLit "pragma") @@ -830,21 +830,26 @@ instance (OutputableBndr name) => Outputable (Sig name) where ppr sig = ppr_sig sig ppr_sig :: OutputableBndr name => Sig name -> SDoc -ppr_sig (TypeSig vars ty _wcs) = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) -ppr_sig (FixSig fix_sig) = ppr fix_sig +ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (ClassOpSig is_deflt vars ty) + | is_deflt = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) + | otherwise = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) +ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec (unLoc var) (interpp'SP ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var)) ppr_sig (SpecInstSig _ ty) = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty) ppr_sig (MinimalSig _ bf) = pragBrackets (pprMinimalSig bf) -ppr_sig (PatSynSig name (flag, qtvs) (L _ req) (L _ prov) ty) +ppr_sig (PatSynSig name sig_ty) = pprPatSynSig (unLoc name) False -- TODO: is_bindir - (pprHsForAll flag qtvs (noLoc [])) - (pprHsContextMaybe req) (pprHsContextMaybe prov) + (pprHsForAllTvs qtvs) + (pprHsContextMaybe (unLoc req)) + (pprHsContextMaybe (unLoc prov)) (ppr ty) + where + (qtvs, req, prov, ty) = splitLHsPatSynTy (hsSigType sig_ty) pprPatSynSig :: (OutputableBndr name) => name -> Bool -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc -> SDoc diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index f75fff10af..b8612ed2be 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -19,7 +19,8 @@ -- @InstDecl@, @DefaultDecl@ and @ForeignDecl@. module HsDecls ( -- * Toplevel declarations - HsDecl(..), LHsDecl, HsDataDefn(..), + HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, + -- ** Class or type declarations TyClDecl(..), LTyClDecl, TyClGroup(..), tyClGroupConcat, mkTyClGroup, @@ -481,10 +482,10 @@ data TyClDecl name -- 'ApiAnnotation.AnnEqual', -- For details on above see note [Api annotations] in ApiAnnotation - SynDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type + SynDecl { tcdLName :: Located name -- ^ Type constructor + , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type -- these include outer binders - , tcdRhs :: LHsType name -- ^ RHS of type declaration + , tcdRhs :: LHsType name -- ^ RHS of type declaration , tcdFVs :: PostRn name NameSet } | -- | @data@ declaration @@ -497,7 +498,7 @@ data TyClDecl name -- For details on above see note [Api annotations] in ApiAnnotation DataDecl { tcdLName :: Located name -- ^ Type constructor - , tcdTyVars :: LHsTyVarBndrs name -- ^ Type variables; for an associated type + , tcdTyVars :: LHsQTyVars name -- ^ Type variables; for an associated type -- these include outer binders -- Eg class T a where -- type F a :: * @@ -509,7 +510,7 @@ data TyClDecl name | ClassDecl { tcdCtxt :: LHsContext name, -- ^ Context... tcdLName :: Located name, -- ^ Name of the class - tcdTyVars :: LHsTyVarBndrs name, -- ^ Class type variables + tcdTyVars :: LHsQTyVars name, -- ^ Class type variables tcdFDs :: [Located (FunDep (Located name))], -- ^ Functional deps tcdSigs :: [LSig name], -- ^ Methods' signatures @@ -548,7 +549,6 @@ tyClGroupConcat = concatMap group_tyclds mkTyClGroup :: [LTyClDecl name] -> TyClGroup name mkTyClGroup decls = TyClGroup { group_tyclds = decls, group_roles = [] } - -- Simple classifiers for TyClDecl -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -613,7 +613,7 @@ tyClDeclLName decl = tcdLName decl tcdName :: TyClDecl name -> name tcdName = unLoc . tyClDeclLName -tyClDeclTyVars :: TyClDecl name -> LHsTyVarBndrs name +tyClDeclTyVars :: TyClDecl name -> LHsQTyVars name tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs tyClDeclTyVars d = tcdTyVars d @@ -685,7 +685,7 @@ instance OutputableBndr name => Outputable (TyClGroup name) where pp_vanilla_decl_head :: OutputableBndr name => Located name - -> LHsTyVarBndrs name + -> LHsQTyVars name -> HsContext name -> SDoc pp_vanilla_decl_head thing tyvars context @@ -796,7 +796,7 @@ type LFamilyDecl name = Located (FamilyDecl name) data FamilyDecl name = FamilyDecl { fdInfo :: FamilyInfo name -- type/data, closed/open , fdLName :: Located name -- type constructor - , fdTyVars :: LHsTyVarBndrs name -- type variables + , fdTyVars :: LHsQTyVars name -- type variables , fdResultSig :: LFamilyResultSig name -- result signature , fdInjectivityAnn :: Maybe (LInjectivityAnn name) -- optional injectivity ann } @@ -960,26 +960,31 @@ data HsDataDefn name -- The payload of a data type defn -- For @data T a where { T1 :: T a }@ -- the 'LConDecls' all have 'ResTyGADT'. - dd_derivs :: Maybe (Located [LHsType name]) - -- ^ Derivings; @Nothing@ => not specified, - -- @Just []@ => derive exactly what is asked - -- - -- These "types" must be of form - -- @ - -- forall ab. C ty1 ty2 - -- @ - -- Typically the foralls and ty args are empty, but they - -- are non-empty for the newtype-deriving case - -- - -- - 'ApiAnnotation.AnnKeywordId' : - -- 'ApiAnnotation.AnnDeriving', - -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + dd_derivs :: HsDeriving name -- ^ Optional 'deriving' claues -- For details on above see note [Api annotations] in ApiAnnotation } deriving( Typeable ) deriving instance (DataId id) => Data (HsDataDefn id) +type HsDeriving name = Maybe (Located [LHsSigType name]) + -- ^ The optional 'deriving' clause of a data declaration + -- + -- @Nothing@ => not specified, + -- @Just []@ => derive exactly what is asked + -- + -- It's a 'LHsSigType' because, with Generalised Newtype + -- Deriving, we can mention type variables that aren't + -- bound by the date type. e.g. + -- data T b = ... deriving( C [a] ) + -- should producd a derived instance for (C [a] (T b)) + -- + -- The payload of the Maybe is Located so that we have a + -- place to hang the API annotations: + -- - 'ApiAnnotation.AnnKeywordId' : + -- 'ApiAnnotation.AnnDeriving', + -- 'ApiAnnotation.AnnOpen','ApiAnnotation.AnnClose' + data NewOrData = NewType -- ^ @newtype Blah ...@ | DataType -- ^ @data Blah ...@ @@ -1021,17 +1026,28 @@ data ConDecl name -- the user-callable wrapper Id. -- It is a list to deal with GADT constructors of the form -- T1, T2, T3 :: <payload> - , con_explicit :: HsExplicitFlag - -- ^ Is there an user-written forall? (cf. 'HsTypes.HsForAllTy') - , con_qvars :: LHsTyVarBndrs name + , con_explicit :: Bool + -- ^ Is there an user-written forall? + -- For ResTyH98, "explicit" means something like: + -- data T = forall a. MkT { x :: a -> a } + -- For ResTyGADT, "explicit" means something like + -- data T where { MkT :: forall a. <blah> } + + , con_qvars :: LHsQTyVars name -- ^ Type variables. Depending on 'con_res' this describes the -- following entities -- -- - ResTyH98: the constructor's *existential* type variables + -- e.g. data T a = forall b. MkT b (b->a) + -- con_qvars = {b} + -- -- - ResTyGADT: *all* the constructor's quantified type variables + -- e.g. data T a where + -- MkT :: forall a b. b -> (b->a) -> T a + -- con_qvars = {a,b} -- - -- If con_explicit is Implicit, then con_qvars is irrelevant + -- If con_explicit is False, then con_qvars is irrelevant -- until after renaming. , con_cxt :: LHsContext name @@ -1087,9 +1103,9 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context Nothing -> empty Just kind -> dcolon <+> ppr kind pp_derivings = case derivings of - Nothing -> empty - Just (L _ ds) -> hsep [ptext (sLit "deriving"), - parens (interpp'SP ds)] + Nothing -> empty + Just (L _ ds) -> hsep [ ptext (sLit "deriving") + , parens (interpp'SP ds)] instance OutputableBndr name => Outputable (HsDataDefn name) where ppr d = pp_data_defn (\_ -> ptext (sLit "Naked HsDataDefn")) d @@ -1112,7 +1128,7 @@ pprConDecl (ConDecl { con_names = [L _ con] -- NB: non-GADT means 1 con , con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = details , con_res = ResTyH98, con_doc = doc }) - = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details] + = sep [ppr_mbDoc doc, ppr_con_forall expl tvs cxt, ppr_details details] where ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con @@ -1124,7 +1140,7 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = PrefixCon arg_tys , con_res = ResTyGADT _ res_ty, con_doc = doc }) = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+> - sep [pprHsForAll expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] + sep [ppr_con_forall expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] where mk_fun_ty a b = noLoc (HsFunTy a b) @@ -1132,7 +1148,7 @@ pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs , con_cxt = cxt, con_details = RecCon fields , con_res = ResTyGADT _ res_ty, con_doc = doc }) = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon - <+> pprHsForAll expl tvs cxt, + <+> ppr_con_forall expl tvs cxt, pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty] pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} }) @@ -1145,6 +1161,14 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT { -- than one constructor, which should indeed be impossible pprConDecl (ConDecl { con_names = cons }) = pprPanic "pprConDecl" (ppr cons) +ppr_con_forall :: OutputableBndr name => Bool -> LHsQTyVars name + -> LHsContext name -> SDoc +ppr_con_forall explicit_forall qtvs (L _ ctxt) + | explicit_forall + = pprHsForAllTvs (hsQTvBndrs qtvs) <+> pprHsContext ctxt + | otherwise + = pprHsContext ctxt + ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) @@ -1183,12 +1207,12 @@ type LTyFamInstEqn name = Located (TyFamInstEqn name) type LTyFamDefltEqn name = Located (TyFamDefltEqn name) -type HsTyPats name = HsWithBndrs name [LHsType name] +type HsTyPats name = HsImplicitBndrs name [LHsType name] -- ^ Type patterns (with kind and type bndrs) -- See Note [Family instance declaration binders] type TyFamInstEqn name = TyFamEqn name (HsTyPats name) -type TyFamDefltEqn name = TyFamEqn name (LHsTyVarBndrs name) +type TyFamDefltEqn name = TyFamEqn name (LHsQTyVars name) -- See Note [Type family instance declarations in HsSyn] -- | One equation in a type family instance declaration @@ -1244,9 +1268,9 @@ deriving instance (DataId name) => Data (DataFamInstDecl name) type LClsInstDecl name = Located (ClsInstDecl name) data ClsInstDecl name = ClsInstDecl - { cid_poly_ty :: LHsType name -- Context => Class Instance-type - -- Using a polytype means that the renamer conveniently - -- figures out the quantified type variables for us. + { cid_poly_ty :: LHsSigType name -- Context => Class Instance-type + -- Using a polytype means that the renamer conveniently + -- figures out the quantified type variables for us. , cid_binds :: LHsBinds name -- Class methods , cid_sigs :: [LSig name] -- User-supplied pragmatic info , cid_tyfam_insts :: [LTyFamInstDecl name] -- Type family instances @@ -1344,7 +1368,7 @@ pp_fam_inst_lhs :: OutputableBndr name -> HsTyPats name -> HsContext name -> SDoc -pp_fam_inst_lhs thing (HsWB { hswb_cts = typats }) context -- explicit type patterns +pp_fam_inst_lhs thing (HsIB { hsib_body = typats }) context -- explicit type patterns = hsep [ pprHsContext context, pprPrefixOcc (unLoc thing) , hsep (map (pprParendHsType.unLoc) typats)] @@ -1404,7 +1428,7 @@ instDeclDataFamInsts inst_decls type LDerivDecl name = Located (DerivDecl name) data DerivDecl name = DerivDecl - { deriv_type :: LHsType name + { deriv_type :: LHsSigType name , deriv_overlap_mode :: Maybe (Located OverlapMode) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose', @@ -1466,14 +1490,17 @@ instance (OutputableBndr name) type LForeignDecl name = Located (ForeignDecl name) data ForeignDecl name - = ForeignImport (Located name) -- defines this name - (LHsType name) -- sig_ty - (PostTc name Coercion) -- rep_ty ~ sig_ty - ForeignImport - | ForeignExport (Located name) -- uses this name - (LHsType name) -- sig_ty - (PostTc name Coercion) -- sig_ty ~ rep_ty - ForeignExport + = ForeignImport + { fd_name :: Located name -- defines this name + , fd_sig_ty :: LHsSigType name -- sig_ty + , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty + , fd_fi :: ForeignImport } + + | ForeignExport + { fd_name :: Located name -- uses this name + , fd_sig_ty :: LHsSigType name -- sig_ty + , fd_co :: PostTc name Coercion -- rep_ty ~ sig_ty + , fd_fe :: ForeignExport } -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForeign', -- 'ApiAnnotation.AnnImport','ApiAnnotation.AnnExport', @@ -1481,6 +1508,7 @@ data ForeignDecl name -- For details on above see note [Api annotations] in ApiAnnotation deriving (Typeable) + deriving instance (DataId name) => Data (ForeignDecl name) {- In both ForeignImport and ForeignExport: @@ -1543,10 +1571,10 @@ data ForeignExport = CExport (Located CExportSpec) -- contains the calling -- instance OutputableBndr name => Outputable (ForeignDecl name) where - ppr (ForeignImport n ty _ fimport) = - hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n) - 2 (dcolon <+> ppr ty) - ppr (ForeignExport n ty _ fexport) = + ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport }) + = hang (ptext (sLit "foreign import") <+> ppr fimport <+> ppr n) + 2 (dcolon <+> ppr ty) + ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) = hang (ptext (sLit "foreign export") <+> ppr fexport <+> ppr n) 2 (dcolon <+> ppr ty) @@ -1621,7 +1649,7 @@ flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls type LRuleBndr name = Located (RuleBndr name) data RuleBndr name = RuleBndr (Located name) - | RuleBndrSig (Located name) (HsWithBndrs name (LHsType name)) + | RuleBndrSig (Located name) (LHsSigWcType name) -- ^ -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnDcolon','ApiAnnotation.AnnClose' @@ -1630,7 +1658,7 @@ data RuleBndr name deriving (Typeable) deriving instance (DataId name) => Data (RuleBndr name) -collectRuleBndrSigTys :: [RuleBndr name] -> [HsWithBndrs name (LHsType name)] +collectRuleBndrSigTys :: [RuleBndr name] -> [LHsSigWcType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] instance OutputableBndr name => Outputable (RuleDecls name) where @@ -1709,7 +1737,7 @@ data VectDecl name | HsVectClassOut -- post type-checking Class | HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now - (LHsType name) + (LHsSigType name) | HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now ClsInst deriving (Typeable) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 7106b068a8..127d87a3ec 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -321,16 +321,13 @@ data HsExpr id -- For details on above see note [Api annotations] in ApiAnnotation | ExprWithTySig (LHsExpr id) - (LHsType id) - (PostRn id [Name]) -- After renaming, the list of Names - -- contains the named and unnamed - -- wildcards brought in scope by the - -- signature + (LHsSigWcType id) - | ExprWithTySigOut -- TRANSLATION + | ExprWithTySigOut -- Post typechecking (LHsExpr id) - (LHsType Name) -- Retain the signature for - -- round-tripping purposes + (LHsSigWcType Name) -- Retain the signature, + -- as HsSigType Name, for + -- round-tripping purposes -- | Arithmetic sequence -- @@ -571,28 +568,21 @@ So we use Nothing to mean "use the old built-in typing rule". Note [Record Update HsWrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -There is a wrapper in RecordUpd which is used for the *required* constraints for -pattern synonyms. This wrapper is created in the typechecking and is then -directly used in the desugaring without modification. +There is a wrapper in RecordUpd which is used for the *required* +constraints for pattern synonyms. This wrapper is created in the +typechecking and is then directly used in the desugaring without +modification. For example, if we have the record pattern synonym P, + pattern P :: (Show a) => a -> Maybe a + pattern P{x} = Just x -``` -pattern P :: (Show a) => a -> Maybe a -pattern P{x} = Just x - -foo = (Just True) { x = False } -``` - + foo = (Just True) { x = False } then `foo` desugars to something like - -``` -P x = P False -``` - -hence we need to provide the correct dictionaries to P on the RHS so that we can -build the expression. + foo = case Just True of + P x -> P False +hence we need to provide the correct dictionaries to P's matcher on +the RHS so that we can build the expression. Note [Located RdrNames] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -604,6 +594,7 @@ in the ParsedSource. There are unfortunately enough differences between the ParsedSource and the RenamedSource that the API Annotations cannot be used directly with RenamedSource, so this allows a simple mapping to be used based on the location. +>>>>>>> origin/master -} instance OutputableBndr id => Outputable (HsExpr id) where @@ -751,7 +742,7 @@ ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds }) ppr_expr (RecordUpd { rupd_expr = aexp, rupd_flds = rbinds }) = hang (pprLExpr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds)))) -ppr_expr (ExprWithTySig expr sig _) +ppr_expr (ExprWithTySig expr sig) = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) ppr_expr (ExprWithTySigOut expr sig) @@ -979,7 +970,7 @@ data HsCmd id -- For details on above see note [Api annotations] in ApiAnnotation - | HsCmdCast TcCoercion -- A simpler version of HsWrap in HsExpr + | HsCmdCast TcCoercionN -- A simpler version of HsWrap in HsExpr (HsCmd id) -- If cmd :: arg1 --> res -- co :: arg1 ~ arg2 -- Then (HsCmdCast co cmd) :: arg2 --> res @@ -1147,6 +1138,7 @@ data Match id body m_type :: (Maybe (LHsType id)), -- A type signature for the result of the match -- Nothing after typechecking + -- NB: No longer supported m_grhss :: (GRHSs id body) } deriving (Typeable) deriving instance (Data body,DataId id) => Data (Match id body) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 320956261e..24ef065e2a 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -157,6 +157,8 @@ data Pat id pat_binds :: TcEvBinds, -- Bindings involving those dictionaries pat_args :: HsConPatDetails id, pat_wrap :: HsWrapper -- Extra wrapper to pass to the matcher + -- Only relevant for pattern-synonyms; + -- ignored for data cons } ------------ View patterns --------------- @@ -199,9 +201,9 @@ data Pat id -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SigPatIn (LPat id) -- Pattern with a type signature - (HsWithBndrs id (LHsType id)) -- Signature can bind both - -- kind and type vars + | SigPatIn (LPat id) -- Pattern with a type signature + (LHsSigWcType id) -- Signature can bind both + -- kind and type vars | SigPatOut (LPat id) -- Pattern with a type signature Type diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index d084dc2f7c..72525b2519 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -40,7 +40,7 @@ import HsImpExp import HsLit import PlaceHolder import HsPat -import HsTypes hiding ( mkHsForAllTy ) +import HsTypes import BasicTypes ( Fixity, WarningTxt ) import HsUtils import HsDoc diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index eda643c43c..cd8f20342c 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -20,9 +20,11 @@ module HsTypes ( HsType(..), LHsType, HsKind, LHsKind, HsTyOp,LHsTyOp, HsTyVarBndr(..), LHsTyVarBndr, - LHsTyVarBndrs(..), - HsWithBndrs(..), - HsTupleSort(..), HsExplicitFlag(..), + LHsQTyVars(..), + HsImplicitBndrs(..), + HsWildCardBndrs(..), + LHsSigType, LHsSigWcType, LHsWcType, + HsTupleSort(..), HsContext, LHsContext, HsTyWrapper(..), HsTyLit(..), @@ -44,23 +46,23 @@ module HsTypes ( wildCardName, sameWildCard, sameNamedWildCard, isAnonWildCard, isNamedWildCard, + mkHsImplicitBndrs, mkHsWildCardBndrs, hsImplicitBody, + mkEmptyImplicitBndrs, mkEmptyWildCardBndrs, mkHsQTvs, hsQTvBndrs, isHsKindedTyVar, hsTvbAllKinded, - mkExplicitHsForAllTy, mkImplicitHsForAllTy, mkQualifiedHsForAllTy, - mkHsForAllTy, - flattenTopLevelLHsForAllTy,flattenTopLevelHsForAllTy, - flattenHsForAllTyKeepAnns, - hsExplicitTvs, - hsTyVarName, mkHsWithBndrs, hsLKiTyVarNames, - hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, + hsScopedTvs, hsWcScopedTvs, dropWildCards, + hsTyVarName, hsLKiTyVarNames, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, + splitLHsInstDeclTy, getLHsInstDeclClass_maybe, + splitLHsPatSynTy, + splitLHsForAllTy, splitLHsQualTy, splitLHsSigmaTy, + splitLHsClassTy_maybe, + splitHsFunType, splitHsAppTys, hsTyGetAppHead_maybe, + mkHsAppTys, mkHsOpTy, + ignoreParens, hsSigType, hsSigWcType, hsLTyVarBndrsToTypes, - splitLHsInstDeclTy_maybe, - splitHsClassTy_maybe, splitLHsClassTy_maybe, - splitHsFunType, - splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy, - ignoreParens, -- Printing - pprParendHsType, pprHsForAll, pprHsForAllExtra, + pprParendHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra, pprHsContext, pprHsContextNoArrow, pprHsContextMaybe ) where @@ -81,15 +83,15 @@ import SrcLoc import StaticFlags import Outputable import FastString -import Lexer ( AddAnn, mkParensApiAnn ) import Maybes( isJust ) import Data.Data hiding ( Fixity ) import Data.Maybe ( fromMaybe ) #if __GLASGOW_HASKELL__ < 709 -import Data.Monoid hiding ((<>)) +-- SPJ temp +-- import Data.Monoid hiding((<>)) #endif -#if __GLASGOW_HASKELL__ > 710 +#if __GLASGOW_HASKELL > 710 import Data.Semigroup ( Semigroup ) import qualified Data.Semigroup as Semigroup #endif @@ -132,6 +134,52 @@ renamer can decorate it with the variables bound by the pattern ('a' in the first example, 'k' in the second), assuming that neither of them is in scope already See also Note [Kind and type-variable binders] in RnTypes + +Note [HsType binders] +~~~~~~~~~~~~~~~~~~~~~ +The system fr recording type and kind-variable binders in HsTypes +is a bit complicated. Here's how it works. + +* In a HsType, + HsForAllTy represents an /explicit, user-written/ 'forall' + e.g. forall a b. ... + HsQualTy reprsents an /explicit, user-written/ context + e.g. (Eq a, Show a) => ... + The context can be empty if that's what the user wrote + These constructors reprsents what the user wrote, no more + and no less. + +* HsTyVarBndr describes a quantified type variable written by the + user. For example + f :: forall a (b :: *). blah + here 'a' and '(b::*)' are each a HsTyVarBndr. A HsForAllTy has + a list of LHsTyVarBndrs. + +* HsImplicitBndrs is a wrapper that gives the implicitly-quantified + kind and type variables of the wrapped thing. It is filled in by + the renamer. For example, if the + user writes + f :: a -> a + the HsImplicitBinders binds the 'a' (not a HsForAllTy!). + NB: this implicit quantification is purely lexical: we bind any + type or kind variables that are not in scope. The type checker + may subsequently quantify over further kind variables. + +* HsWildCardBndrs is a wrapper that binds the wildcard variables + of the wrapped thing. It is filled in by the renamer + f :: _a -> _ + The enclosing HsWildCardBndrs binds the wildcards _a and _. + +* The explicit presence of these wrappers specifies, in the HsSyn, + exactly where implicit quantification is allowed, and where + wildcards are allowed. + +* LHsQTyVars is used in data/class declarations, where the user gives + explicit *type* variable bindings, but we need to implicitly bind + *kind* variables. For example + class C (a :: k -> *) where ... + The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars + -} type LHsContext name = Located (HsContext name) @@ -153,45 +201,42 @@ type LHsKind name = Located (HsKind name) -- For details on above see note [Api annotations] in ApiAnnotation -------------------------------------------------- --- LHsTyVarBndrs --- The quantified binders in a HsForallTy +-- LHsQTyVars +-- The explicitly-quantified binders in a data/type declaration type LHsTyVarBndr name = Located (HsTyVarBndr name) + -- See Note [HsType binders] -data LHsTyVarBndrs name - = HsQTvs { hsq_kvs :: [Name] -- Kind variables +data LHsQTyVars name -- See Note [HsType binders] + = HsQTvs { hsq_kvs :: PostRn name [Name] -- Kind variables , hsq_tvs :: [LHsTyVarBndr name] -- Type variables -- See Note [HsForAllTy tyvar binders] } deriving( Typeable ) -deriving instance (DataId name) => Data (LHsTyVarBndrs name) -mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsTyVarBndrs RdrName --- Just at RdrName because in the Name variant we should know just --- what the kind-variable binders are; and we don't --- We put an empty list (rather than a panic) for the kind vars so --- that the pretty printer works ok on them. -mkHsQTvs tvs = HsQTvs { hsq_kvs = [], hsq_tvs = tvs } +deriving instance (DataId name) => Data (LHsQTyVars name) -emptyHsQTvs :: LHsTyVarBndrs name -- Use only when you know there are no kind binders -emptyHsQTvs = HsQTvs { hsq_kvs = [], hsq_tvs = [] } +mkHsQTvs :: [LHsTyVarBndr RdrName] -> LHsQTyVars RdrName +mkHsQTvs tvs = HsQTvs { hsq_kvs = PlaceHolder, hsq_tvs = tvs } -hsQTvBndrs :: LHsTyVarBndrs name -> [LHsTyVarBndr name] +hsQTvBndrs :: LHsQTyVars name -> [LHsTyVarBndr name] hsQTvBndrs = hsq_tvs +{- #if __GLASGOW_HASKELL__ > 710 instance Semigroup (LHsTyVarBndrs name) where HsQTvs kvs1 tvs1 <> HsQTvs kvs2 tvs2 = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2) #endif -instance Monoid (LHsTyVarBndrs name) where - mempty = emptyHsQTvs +instance Monoid (LHsQTyVars name) where + mempty = mkHsQTvs [] mappend (HsQTvs kvs1 tvs1) (HsQTvs kvs2 tvs2) = HsQTvs (kvs1 ++ kvs2) (tvs1 ++ tvs2) +-} ------------------------------------------------ --- HsWithBndrs +-- HsImplicitBndrs -- Used to quantify the binders of a type in cases -- when a HsForAll isn't appropriate: -- * Patterns in a type/data family instance (HsTyPats) @@ -199,20 +244,96 @@ instance Monoid (LHsTyVarBndrs name) where -- * Pattern type signatures (SigPatIn) -- In the last of these, wildcards can happen, so we must accommodate them -data HsWithBndrs name thing - = HsWB { hswb_cts :: thing -- Main payload (type or list of types) - , hswb_kvs :: PostRn name [Name] -- Kind vars - , hswb_tvs :: PostRn name [Name] -- Type vars - , hswb_wcs :: PostRn name [Name] -- Wild cards +data HsImplicitBndrs name thing -- See Note [HsType binders] + = HsIB { hsib_kvs :: PostRn name [Name] -- Implicitly-bound kind vars + , hsib_tvs :: PostRn name [Name] -- Implicitly-bound type vars + , hsib_body :: thing -- Main payload (type or list of types) } deriving (Typeable) + +data HsWildCardBndrs name thing -- See Note [HsType binders] + = HsWC { hswc_wcs :: PostRn name [Name] + -- Wild cards, both named and anonymous + + , hswc_ctx :: Maybe SrcSpan + -- Indicates whether hswc_body has an + -- extra-constraint wildcard, and if so where + -- e.g. (Eq a, _) => a -> a + -- NB: the wildcard stays in HsQualTy inside the type! + -- So for pretty printing purposes you can ignore + -- hswc_ctx + + , hswc_body :: thing -- Main payload (type or list of types) + } + deriving( Typeable ) + deriving instance (Data name, Data thing, Data (PostRn name [Name])) - => Data (HsWithBndrs name thing) + => Data (HsImplicitBndrs name thing) -mkHsWithBndrs :: thing -> HsWithBndrs RdrName thing -mkHsWithBndrs x = HsWB { hswb_cts = x, hswb_kvs = PlaceHolder - , hswb_tvs = PlaceHolder - , hswb_wcs = PlaceHolder } +deriving instance (Data name, Data thing, Data (PostRn name [Name])) + => Data (HsWildCardBndrs name thing) + +type LHsSigType name = HsImplicitBndrs name (LHsType name) -- Implicit only +type LHsWcType name = HsWildCardBndrs name (LHsType name) -- Wildcard only +type LHsSigWcType name = HsImplicitBndrs name (LHsWcType name) -- Both + +-- See Note [Representing type signatures] + +hsImplicitBody :: HsImplicitBndrs name thing -> thing +hsImplicitBody (HsIB { hsib_body = body }) = body + +hsSigType :: LHsSigType name -> LHsType name +hsSigType = hsImplicitBody + +hsSigWcType :: LHsSigWcType name -> LHsType name +hsSigWcType sig_ty = hswc_body (hsib_body sig_ty) + +dropWildCards :: LHsSigWcType name -> LHsSigType name +-- Drop the wildcard part of a LHsSigWcType +dropWildCards sig_ty = sig_ty { hsib_body = hsSigWcType sig_ty } + +{- Note [Representing type signatures] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +HsSigType is used to represent an explicit user type signature +such as f :: a -> a + or g (x :: a -> a) = x + +A HsSigType is just a HsImplicitBndrs wrapping a LHsType. + * The HsImplicitBndrs binds the /implicitly/ quantified tyvars + * The LHsType binds the /explictly/ quantified tyvars + +E.g. For a signature like + f :: forall (a::k). blah +we get + HsIB { hsib_kvs = [k] + , hsib_tvs = [] + , hsib_body = HsForAllTy { hst_bndrs = [(a::*)] + , hst_body = blah } +The implicit kind variable 'k' is bound by the HsIB; +the explictly forall'd tyvar 'a' is bounnd by the HsForAllTy +-} + +mkHsImplicitBndrs :: thing -> HsImplicitBndrs RdrName thing +mkHsImplicitBndrs x = HsIB { hsib_body = x + , hsib_kvs = PlaceHolder + , hsib_tvs = PlaceHolder } + +mkHsWildCardBndrs :: thing -> HsWildCardBndrs RdrName thing +mkHsWildCardBndrs x = HsWC { hswc_body = x + , hswc_wcs = PlaceHolder + , hswc_ctx = Nothing } + +-- Add empty binders. This is a bit suspicious; what if +-- the wrapped thing had free type variables? +mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs Name thing +mkEmptyImplicitBndrs x = HsIB { hsib_body = x + , hsib_kvs = [] + , hsib_tvs = [] } + +mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs Name thing +mkEmptyWildCardBndrs x = HsWC { hswc_body = x + , hswc_wcs = [] + , hswc_ctx = Nothing } -------------------------------------------------- @@ -254,27 +375,22 @@ isHsKindedTyVar (UserTyVar {}) = False isHsKindedTyVar (KindedTyVar {}) = True -- | Do all type variables in this 'LHsTyVarBndr' come with kind annotations? -hsTvbAllKinded :: LHsTyVarBndrs name -> Bool +hsTvbAllKinded :: LHsQTyVars name -> Bool hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvBndrs data HsType name - = HsForAllTy HsExplicitFlag -- Renamer leaves this flag unchanged, to record the way - -- the user wrote it originally, so that the printer can - -- print it as the user wrote it - (Maybe SrcSpan) -- Indicates whether extra constraints may be inferred. - -- When Nothing, no, otherwise the location of the extra- - -- constraints wildcard is stored. For instance, for the - -- signature (Eq a, _) => a -> a -> Bool, this field would - -- be something like (Just 1:8), with 1:8 being line 1, - -- column 8. - (LHsTyVarBndrs name) - (LHsContext name) - (LHsType name) + = HsForAllTy -- See Note [HsType binders] + { hst_bndrs :: [LHsTyVarBndr name] -- Explicit, user-supplied 'forall a b c' + , hst_body :: LHsType name -- body type + } -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnForall', -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' - -- For details on above see note [Api annotations] in ApiAnnotation + | HsQualTy -- See Note [HsType binders] + { hst_ctxt :: LHsContext name -- Context C => blah + , hst_body :: LHsType name } + | HsTyVar (Located name) -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] @@ -439,7 +555,8 @@ mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2 data HsWildCardInfo name = AnonWildCard (PostRn name (Located Name)) - -- A anonymous wild card ('_'). A name is generated during renaming. + -- A anonymous wild card ('_'). A fresh Name is generated for + -- each individual anonymous wildcard during renaming | NamedWildCard (Located name) -- A named wild card ('_a'). deriving (Typeable) @@ -548,13 +665,6 @@ data HsTupleSort = HsUnboxedTuple | HsBoxedOrConstraintTuple deriving (Data, Typeable) -data HsExplicitFlag - = Explicit -- An explicit forall, eg f :: forall a. a-> a - | Implicit -- No explicit forall, eg f :: a -> a, or f :: Eq a => a -> a - | Qualified -- A *nested* occurrences of (ctxt => ty), with no explicit forall - -- e.g. f :: (Eq a => a -> a) -> Int - deriving (Data, Typeable) - type LConDeclField name = Located (ConDeclField name) -- ^ May have 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnComma' when -- in a list @@ -655,86 +765,38 @@ gives -- A valid type must have a for-all at the top of the type, or of the fn arg -- types -mkImplicitHsForAllTy :: LHsType RdrName -> HsType RdrName -mkExplicitHsForAllTy :: [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName -mkQualifiedHsForAllTy :: LHsContext RdrName -> LHsType RdrName -> HsType RdrName - --- | mkImplicitHsForAllTy is called when we encounter --- f :: type --- Wrap around a HsForallTy if one is not there already. -mkImplicitHsForAllTy (L _ (HsForAllTy exp extra tvs cxt ty)) - = HsForAllTy exp' extra tvs cxt ty - where - exp' = case exp of - Qualified -> Implicit - -- Qualified is used only for a nested forall, - -- this is now top level - _ -> exp -mkImplicitHsForAllTy ty = mkHsForAllTy Implicit [] (noLoc []) ty - -mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty -mkQualifiedHsForAllTy ctxt ty = mkHsForAllTy Qualified [] ctxt ty - --- |Smart constructor for HsForAllTy, which populates the extra-constraints --- field if a wildcard is present in the context. -mkHsForAllTy :: HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> HsType RdrName -mkHsForAllTy exp tvs ctxt ty - = HsForAllTy exp Nothing (mkHsQTvs tvs) ctxt ty - --- |When a sigtype is parsed, the type found is wrapped in an Implicit --- HsForAllTy via mkImplicitHsForAllTy, to ensure that a signature always has a --- forall at the outer level. For Api Annotations this nested structure is --- important to ensure that all `forall` and `.` locations are retained. From --- the renamer onwards this structure is flattened, to ease the renaming and --- type checking process. -flattenTopLevelLHsForAllTy :: LHsType name -> LHsType name -flattenTopLevelLHsForAllTy (L l ty) = L l (flattenTopLevelHsForAllTy ty) - -flattenTopLevelHsForAllTy :: HsType name -> HsType name -flattenTopLevelHsForAllTy (HsForAllTy exp extra tvs (L l []) ty) - = snd $ mk_forall_ty [] l exp extra tvs ty -flattenTopLevelHsForAllTy ty = ty - -flattenHsForAllTyKeepAnns :: HsType name -> ([AddAnn],HsType name) -flattenHsForAllTyKeepAnns (HsForAllTy exp extra tvs (L l []) ty) - = mk_forall_ty [] l exp extra tvs ty -flattenHsForAllTyKeepAnns ty = ([],ty) - --- mk_forall_ty makes a pure for-all type (no context) -mk_forall_ty :: [AddAnn] -> SrcSpan -> HsExplicitFlag -> Maybe SrcSpan - -> LHsTyVarBndrs name - -> LHsType name -> ([AddAnn],HsType name) -mk_forall_ty ann _ exp1 extra1 tvs1 (L _ (HsForAllTy exp2 extra qtvs2 ctxt ty)) - = (ann,HsForAllTy (exp1 `plus` exp2) (mergeExtra extra1 extra) - (tvs1 `mappend` qtvs2) ctxt ty) - where - -- Bias the merging of extra's to the top level, so that a single - -- wildcard context will prevail - mergeExtra (Just s) _ = Just s - mergeExtra _ e = e -mk_forall_ty ann l exp extra tvs (L lp (HsParTy ty)) - = mk_forall_ty (ann ++ mkParensApiAnn lp) l exp extra tvs ty -mk_forall_ty ann l exp extra tvs ty - = (ann,HsForAllTy exp extra tvs (L l []) ty) - -- Even if tvs is empty, we still make a HsForAll! - -- In the Implicit case, this signals the place to do implicit quantification - -- In the Explicit case, it prevents implicit quantification - -- (see the sigtype production in Parser.y) - -- so that (forall. ty) isn't implicitly quantified - -plus :: HsExplicitFlag -> HsExplicitFlag -> HsExplicitFlag -Qualified `plus` Qualified = Qualified -Explicit `plus` _ = Explicit -_ `plus` Explicit = Explicit -_ `plus` _ = Implicit - -- NB: Implicit `plus` Qualified = Implicit - -- so that f :: Eq a => a -> a ends up Implicit - --------------------- -hsExplicitTvs :: LHsType Name -> [Name] --- The explicitly-given forall'd type variables of a HsType -hsExplicitTvs (L _ (HsForAllTy Explicit _ tvs _ _)) = hsLKiTyVarNames tvs -hsExplicitTvs _ = [] +hsWcScopedTvs :: LHsSigWcType Name -> [Name] +-- Get the lexically-scoped type variables of a HsSigType +-- - the explicitly-given forall'd type variables +-- - the implicitly-bound kind variables +-- - the named wildcars; see Note [Scoping of named wildcards] +-- because they scope in the same way +hsWcScopedTvs sig_ty + | HsIB { hsib_kvs = kvs, hsib_body = sig_ty1 } <- sig_ty + , HsWC { hswc_wcs = nwcs, hswc_body = sig_ty2 } <- sig_ty1 + , (tvs, _) <- splitLHsForAllTy sig_ty2 + = kvs ++ nwcs ++ map hsLTyVarName tvs + +hsScopedTvs :: LHsSigType Name -> [Name] +-- Same as hsWcScopedTvs, but for a LHsSigType +hsScopedTvs sig_ty + | HsIB { hsib_kvs = kvs, hsib_body = sig_ty2 } <- sig_ty + , (tvs, _) <- splitLHsForAllTy sig_ty2 + = kvs ++ map hsLTyVarName tvs + +{- Note [Scoping of named wildcards] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f :: _a -> _a + f x = let g :: _a -> _a + g = ... + in ... + +Currently, for better or worse, the "_a" variables are all the same. So +although there is no explicit forall, the "_a" scopes over the definition. +I don't know if this is a good idea, but there it is. +-} --------------------- hsTyVarName :: HsTyVarBndr name -> name @@ -744,11 +806,11 @@ hsTyVarName (KindedTyVar (L _ n) _) = n hsLTyVarName :: LHsTyVarBndr name -> name hsLTyVarName = hsTyVarName . unLoc -hsLTyVarNames :: LHsTyVarBndrs name -> [name] +hsLTyVarNames :: LHsQTyVars name -> [name] -- Type variables only hsLTyVarNames qtvs = map hsLTyVarName (hsQTvBndrs qtvs) -hsLKiTyVarNames :: LHsTyVarBndrs Name -> [Name] +hsLKiTyVarNames :: LHsQTyVars Name -> [Name] -- Kind and type variables hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) = kvs ++ map hsLTyVarName tvs @@ -756,9 +818,6 @@ hsLKiTyVarNames (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) hsLTyVarLocName :: LHsTyVarBndr name -> Located name hsLTyVarLocName = fmap hsTyVarName -hsLTyVarLocNames :: LHsTyVarBndrs name -> [Located name] -hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs) - -- | Convert a LHsTyVarBndr to an equivalent LHsType. Used in Template Haskell -- quoting for type family equations. hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name @@ -770,7 +829,7 @@ hsLTyVarBndrToType = fmap cvt -- | Convert a LHsTyVarBndrs to a list of types. Used in Template Haskell -- quoting for type family equations. Works on *type* variable only, no kind -- vars. -hsLTyVarBndrsToTypes :: LHsTyVarBndrs name -> [LHsType name] +hsLTyVarBndrsToTypes :: LHsQTyVars name -> [LHsType name] hsLTyVarBndrsToTypes (HsQTvs { hsq_tvs = tvbs }) = map hsLTyVarBndrToType tvbs --------------------- @@ -836,33 +895,62 @@ mkHsAppTys fun_ty (arg_ty:arg_tys) -- Add noLocs for inner nodes of the application; -- they are never used -splitLHsInstDeclTy_maybe - :: LHsType name - -> Maybe (LHsTyVarBndrs name, HsContext name, Located name, [LHsType name]) +splitLHsPatSynTy :: LHsType name + -> ( [LHsTyVarBndr name] + , LHsContext name -- Required + , LHsContext name -- Provided + , LHsType name) -- Body +splitLHsPatSynTy ty + | L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1 + , L _ (HsQualTy { hst_ctxt = prov, hst_body = ty3 }) <- ty2 + = (tvs, req, prov, ty3) + + | L _ (HsQualTy { hst_ctxt = req, hst_body = ty2 }) <- ty1 + = (tvs, req, noLoc [], ty2) + + | otherwise + = (tvs, noLoc [], noLoc [], ty1) + where + (tvs, ty1) = splitLHsForAllTy ty + +splitLHsSigmaTy :: LHsType name -> ([LHsTyVarBndr name], LHsContext name, LHsType name) +splitLHsSigmaTy ty + | (tvs, ty1) <- splitLHsForAllTy ty + , (ctxt, ty2) <- splitLHsQualTy ty1 + = (tvs, ctxt, ty2) + +splitLHsForAllTy :: LHsType name -> ([LHsTyVarBndr name], LHsType name) +splitLHsForAllTy (L _ (HsForAllTy { hst_bndrs = tvs, hst_body = body })) = (tvs, body) +splitLHsForAllTy body = ([], body) + +splitLHsQualTy :: LHsType name -> (LHsContext name, LHsType name) +splitLHsQualTy (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body })) = (ctxt, body) +splitLHsQualTy body = (noLoc [], body) + +splitLHsInstDeclTy + :: LHsSigType Name + -> ([Name], LHsContext Name, LHsType Name) -- Split up an instance decl type, returning the pieces -splitLHsInstDeclTy_maybe inst_ty = do - let (tvs, cxt, ty) = splitLHsForAllTy inst_ty - (cls, tys) <- splitLHsClassTy_maybe ty - return (tvs, cxt, cls, tys) - -splitLHsForAllTy - :: LHsType name - -> (LHsTyVarBndrs name, HsContext name, LHsType name) -splitLHsForAllTy poly_ty - = case unLoc poly_ty of - HsParTy ty -> splitLHsForAllTy ty - HsForAllTy _ _ tvs cxt ty -> (tvs, unLoc cxt, ty) - _ -> (emptyHsQTvs, [], poly_ty) - -- The type vars should have been computed by now, even if they were implicit - -splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name]) -splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty) +splitLHsInstDeclTy (HsIB { hsib_kvs = ikvs, hsib_tvs = itvs + , hsib_body = inst_ty }) + = (ikvs ++ itvs, cxt, body_ty) + -- Return implicitly bound type and kind vars + -- For an instance decl, all of them are in scope + where + (cxt, body_ty) = splitLHsQualTy inst_ty -splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) ---- Watch out.. in ...deriving( Show )... we use this on ---- the list of partially applied predicates in the deriving, ---- so there can be zero args. +getLHsInstDeclClass_maybe :: LHsSigType name -> Maybe (Located name) +-- Works on (HsSigType RdrName) +getLHsInstDeclClass_maybe inst_ty + = do { let (_, tau) = splitLHsQualTy (hsSigType inst_ty) + ; (cls, _) <- splitLHsClassTy_maybe tau + ; return cls } +splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) +-- Watch out.. in ...deriving( Show )... we use this on +-- the list of partially applied predicates in the deriving, +-- so there can be zero args. +-- -- In TcDeriv we also use this to figure out what data type is being -- mentioned in a deriving (Generic (Foo bar baz)) declaration (i.e. "Foo"). splitLHsClassTy_maybe ty @@ -921,23 +1009,26 @@ instance (OutputableBndr name) => Outputable (HsType name) where instance Outputable HsTyLit where ppr = ppr_tylit -instance (OutputableBndr name) => Outputable (LHsTyVarBndrs name) where - ppr (HsQTvs { hsq_kvs = kvs, hsq_tvs = tvs }) - = sep [ ifPprDebug $ braces (interppSP kvs), interppSP tvs ] +instance (OutputableBndr name) + => Outputable (LHsQTyVars name) where + ppr (HsQTvs { hsq_tvs = tvs }) = interppSP tvs instance (OutputableBndr name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar n) = ppr n ppr (KindedTyVar n k) = parens $ hsep [ppr n, dcolon, ppr k] -instance (Outputable thing) => Outputable (HsWithBndrs name thing) where - ppr (HsWB { hswb_cts = ty }) = ppr ty +instance (Outputable thing) => Outputable (HsImplicitBndrs name thing) where + ppr (HsIB { hsib_body = ty }) = ppr ty + +instance (Outputable thing) => Outputable (HsWildCardBndrs name thing) where + ppr (HsWC { hswc_body = ty }) = ppr ty instance (Outputable name) => Outputable (HsWildCardInfo name) where ppr (AnonWildCard _) = char '_' ppr (NamedWildCard n) = ppr n -pprHsForAll :: OutputableBndr name => HsExplicitFlag -> LHsTyVarBndrs name -> LHsContext name -> SDoc -pprHsForAll exp = pprHsForAllExtra exp Nothing +pprHsForAll :: OutputableBndr name => [LHsTyVarBndr name] -> LHsContext name -> SDoc +pprHsForAll = pprHsForAllExtra Nothing -- | Version of 'pprHsForAll' that can also print an extra-constraints -- wildcard, e.g. @_ => a -> Bool@ or @(Show a, _) => a -> String@. This @@ -946,16 +1037,18 @@ pprHsForAll exp = pprHsForAllExtra exp Nothing -- function for this is needed, as the extra-constraints wildcard is removed -- from the actual context and type, and stored in a separate field, thus just -- printing the type will not print the extra-constraints wildcard. -pprHsForAllExtra :: OutputableBndr name => HsExplicitFlag -> Maybe SrcSpan -> LHsTyVarBndrs name -> LHsContext name -> SDoc -pprHsForAllExtra exp extra qtvs cxt - | show_forall = forall_part <+> pprHsContextExtra show_extra (unLoc cxt) - | otherwise = pprHsContextExtra show_extra (unLoc cxt) +pprHsForAllExtra :: OutputableBndr name => Maybe SrcSpan -> [LHsTyVarBndr name] -> LHsContext name -> SDoc +pprHsForAllExtra extra qtvs cxt + = pprHsForAllTvs qtvs <+> pprHsContextExtra show_extra (unLoc cxt) where - show_extra = isJust extra - show_forall = opt_PprStyle_Debug - || (not (null (hsQTvBndrs qtvs)) && is_explicit) - is_explicit = case exp of {Explicit -> True; Implicit -> False; Qualified -> False} - forall_part = forAllLit <+> ppr qtvs <> dot + show_extra = isJust extra + +pprHsForAllTvs :: OutputableBndr name => [LHsTyVarBndr name] -> SDoc +pprHsForAllTvs qtvs + | show_forall = forAllLit <+> interppSP qtvs <> dot + | otherwise = empty + where + show_forall = opt_PprStyle_Debug || not (null qtvs) pprHsContext :: (OutputableBndr name) => HsContext name -> SDoc pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe @@ -970,12 +1063,15 @@ pprHsContextMaybe cxt = Just $ parens (interpp'SP cxt) -- True <=> print an extra-constraints wildcard, e.g. @(Show a, _) =>@ pprHsContextExtra :: (OutputableBndr name) => Bool -> HsContext name -> SDoc -pprHsContextExtra False = pprHsContext -pprHsContextExtra True - = \ctxt -> case ctxt of - [] -> char '_' <+> darrow - _ -> parens (sep (punctuate comma ctxt')) <+> darrow - where ctxt' = map ppr ctxt ++ [char '_'] +pprHsContextExtra show_extra ctxt + | not show_extra + = pprHsContext ctxt + | null ctxt + = char '_' <+> darrow + | otherwise + = parens (sep (punctuate comma ctxt')) <+> darrow + where + ctxt' = map ppr ctxt ++ [char '_'] pprConDeclFields :: OutputableBndr name => [LConDeclField name] -> SDoc pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields))) @@ -1018,9 +1114,13 @@ ppr_mono_lty :: (OutputableBndr name) => TyPrec -> LHsType name -> SDoc ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: (OutputableBndr name) => TyPrec -> HsType name -> SDoc -ppr_mono_ty ctxt_prec (HsForAllTy exp extra tvs ctxt ty) +ppr_mono_ty ctxt_prec (HsForAllTy { hst_bndrs = tvs, hst_body = ty }) + = maybeParen ctxt_prec FunPrec $ + sep [pprHsForAllTvs tvs, ppr_mono_lty TopPrec ty] + +ppr_mono_ty ctxt_prec (HsQualTy { hst_ctxt = L _ ctxt, hst_body = ty }) = maybeParen ctxt_prec FunPrec $ - sep [pprHsForAllExtra exp extra tvs ctxt, ppr_mono_lty TopPrec ty] + sep [pprHsContext ctxt, ppr_mono_lty TopPrec ty] ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 62aabe34fa..19996fd0f1 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -23,14 +23,14 @@ module HsUtils( mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo, - coToHsWrapper, coToHsWrapperR, mkHsDictLet, mkHsLams, + mkHsDictLet, mkHsLams, mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, mkLHsPar, mkHsCmdCast, nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - toHsType, toHsKind, + toLHsSigWcType, -- * Constructing general big tuples -- $big_tuples @@ -52,6 +52,7 @@ module HsUtils( -- Types mkHsAppTy, userHsTyVarBndrs, + mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts @@ -91,12 +92,13 @@ import HsTypes import HsLit import PlaceHolder +import TcType( tcSplitForAllTys, tcSplitPhiTy ) import TcEvidence import RdrName import Var +import Type( isPredTy ) +import Kind( isKind ) import TypeRep -import TcType -import Kind import DataCon import Name import NameSet @@ -516,48 +518,67 @@ chunkify xs {- ************************************************************************ * * - Converting a Type to an HsType RdrName + LHsSigType and LHsSigWcType * * -************************************************************************ +********************************************************************* -} -This is needed to implement GeneralizedNewtypeDeriving. --} +mkLHsSigType :: LHsType RdrName -> LHsSigType RdrName +mkLHsSigType ty = mkHsImplicitBndrs ty -toHsType :: Type -> LHsType RdrName -toHsType ty - | [] <- tvs_only - , [] <- theta - = to_hs_type tau - | otherwise - = noLoc $ - mkExplicitHsForAllTy (map mk_hs_tvb tvs_only) - (noLoc $ map toHsType theta) - (to_hs_type tau) +mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName +mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty) +mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName] +-- Convert TypeSig to ClassOpSig +-- The former is what is parsed, but the latter is +-- what we need in class/instance declarations +mkClassOpSigs sigs + = map fiddle sigs where - (tvs, theta, tau) = tcSplitSigmaTy ty - tvs_only = filter isTypeVar tvs + fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty)) + fiddle sig = sig - to_hs_type (TyVarTy tv) = nlHsTyVar (getRdrName tv) - to_hs_type (AppTy t1 t2) = nlHsAppTy (toHsType t1) (toHsType t2) - to_hs_type (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map toHsType args') +toLHsSigWcType :: Type -> LHsSigWcType RdrName +-- ^ Converting a Type to an HsType RdrName +-- This is needed to implement GeneralizedNewtypeDeriving. +-- +-- Note that we use 'getRdrName' extensively, which +-- generates Exact RdrNames rather than strings. +toLHsSigWcType ty + = mkLHsSigWcType (go ty) + where + go :: Type -> LHsType RdrName + go ty@(ForAllTy {}) + | (tvs, tau) <- tcSplitForAllTys ty + = noLoc (HsForAllTy { hst_bndrs = map go_tv tvs + , hst_body = go tau }) + go ty@(FunTy arg _) + | isPredTy arg + , (theta, tau) <- tcSplitPhiTy ty + = noLoc (HsQualTy { hst_ctxt = noLoc (map go theta) + , hst_body = go tau }) + go (FunTy arg res) = nlHsFunTy (go arg) (go res) + go (TyVarTy tv) = nlHsTyVar (getRdrName tv) + go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2) + go (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) + go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) + go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args') where args' = filterOut isKind args -- Source-language types have _implicit_ kind arguments, -- so we must remove them here (Trac #8563) - to_hs_type (FunTy arg res) = ASSERT( not (isConstraintKind (typeKind arg)) ) - nlHsFunTy (toHsType arg) (toHsType res) - to_hs_type t@(ForAllTy {}) = pprPanic "toHsType" (ppr t) - to_hs_type (LitTy (NumTyLit n)) = noLoc $ HsTyLit (HsNumTy "" n) - to_hs_type (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s) - mk_hs_tvb tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) - (toHsKind (tyVarKind tv)) + go_tv :: TyVar -> LHsTyVarBndr RdrName + go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv)) + (go (tyVarKind tv)) -toHsKind :: Kind -> LHsKind RdrName -toHsKind = toHsType ---------- HsWrappers: type args, dict args, casts --------- +{- ********************************************************************* +* * + --------- HsWrappers: type args, dict args, casts --------- +* * +********************************************************************* -} + mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e) @@ -567,35 +588,26 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e mkHsWrapCo :: TcCoercionN -- A Nominal coercion a ~N b -> HsExpr id -> HsExpr id -mkHsWrapCo co e = mkHsWrap (coToHsWrapper co) e +mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e mkHsWrapCoR :: TcCoercionR -- A Representational coercion a ~R b -> HsExpr id -> HsExpr id -mkHsWrapCoR co e = mkHsWrap (coToHsWrapperR co) e +mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e -mkLHsWrapCo :: TcCoercion -> LHsExpr id -> LHsExpr id +mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e) mkHsCmdCast :: TcCoercion -> HsCmd id -> HsCmd id mkHsCmdCast co cmd | isTcReflCo co = cmd | otherwise = HsCmdCast co cmd -coToHsWrapper :: TcCoercion -> HsWrapper -- A Nominal coercion -coToHsWrapper co | isTcReflCo co = idHsWrapper - | otherwise = mkWpCast (mkTcSubCo co) - -coToHsWrapperR :: TcCoercion -> HsWrapper -- A Representational coercion -coToHsWrapperR co | isTcReflCo co = idHsWrapper - | otherwise = mkWpCast co - mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = CoPat co_fn p ty --- input coercion is Nominal -mkHsWrapPatCo :: TcCoercion -> Pat id -> Type -> Pat id +mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat (mkWpCast (mkTcSubCo co)) pat ty + | otherwise = CoPat (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr @@ -869,8 +881,8 @@ hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name] hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name , tcdSigs = sigs, tcdATs = ats })) = (L loc cls_name : - [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ - [ L mem_loc mem_name | L mem_loc (TypeSig ns _ _) <- sigs, L _ mem_name <- ns ] + [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ + [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ] , []) hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn @@ -880,7 +892,7 @@ hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name] -- See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls = [ L decl_loc n - | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls] + | L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls] |