diff options
24 files changed, 441 insertions, 294 deletions
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index a54f5e3d82..2e69ac00a5 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -277,10 +277,8 @@ data TyClDecl name pat tcdTyVars :: [HsTyVarBndr name], -- type variables tcdCons :: [ConDecl name], -- data constructors (empty if abstract) tcdNCons :: Int, -- Number of data constructors (valid even if type is abstract) - tcdDerivs :: Maybe [name], -- derivings; Nothing => not specified - -- (i.e., derive default); Just [] => derive - -- *nothing*; Just <list> => as you would - -- expect... + tcdDerivs :: Maybe (HsContext name), -- derivings; Nothing => not specified + -- Just [] => derive exactly what is asked tcdSysNames :: DataSysNames name, -- Generic converter functions tcdLoc :: SrcLoc } @@ -515,7 +513,7 @@ pp_tydecl pp_head pp_decl_rhs derivings pp_decl_rhs, case derivings of Nothing -> empty - Just ds -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)] + Just ds -> hsep [ptext SLIT("deriving"), ppr_hs_context ds] ]) \end{code} diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index b8aa2900e5..15bc03f0eb 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -18,7 +18,7 @@ module HsTypes ( , PostTcType, placeHolderType, -- Printing - , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr + , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr -- Equality over Hs things , EqHsEnv, emptyEqHsEnv, extendEqHsEnv, @@ -229,21 +229,17 @@ pprHsForAll tvs cxt ptext SLIT("forall") <+> interppSP tvs <> dot <+> -- **! ToDo: want to hide uvars from user, but not enough info -- in a HsTyVarBndr name (see PprType). KSW 2000-10. - (if null cxt then - empty - else - ppr_context cxt <+> ptext SLIT("=>") - ) + pprHsContext cxt else -- Used in interfaces ptext SLIT("__forall") <+> interppSP tvs <+> - ppr_context cxt <+> ptext SLIT("=>") + ppr_hs_context cxt <+> ptext SLIT("=>") pprHsContext :: (Outputable name) => HsContext name -> SDoc pprHsContext [] = empty -pprHsContext cxt = ppr_context cxt <+> ptext SLIT("=>") +pprHsContext cxt = ppr_hs_context cxt <+> ptext SLIT("=>") -ppr_context [] = empty -ppr_context cxt = parens (interpp'SP cxt) +ppr_hs_context [] = empty +ppr_hs_context cxt = parens (interpp'SP cxt) \end{code} \begin{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 5cf3ce3640..6fb17e8b7a 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -282,6 +282,7 @@ data DynFlag -- language opts | Opt_AllowOverlappingInstances | Opt_AllowUndecidableInstances + | Opt_AllowIncoherentInstances | Opt_GlasgowExts | Opt_Generics | Opt_NoImplicitPrelude diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index e785f454db..19f4d5c973 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.82 2001/12/10 14:08:14 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.83 2001/12/20 11:19:07 simonpj Exp $ -- -- Driver flags -- @@ -427,6 +427,7 @@ fFlags = [ ( "glasgow-exts", Opt_GlasgowExts ), ( "allow-overlapping-instances", Opt_AllowOverlappingInstances ), ( "allow-undecidable-instances", Opt_AllowUndecidableInstances ), + ( "allow-incoherent-instances", Opt_AllowIncoherentInstances ), ( "generics", Opt_Generics ) ] diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 5bd9e1630b..756aa6f5f3 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -135,8 +135,12 @@ where the object file will reside if/when it is created. A @ModIface@ plus a @ModDetails@ summarises everything we know about a compiled module. The @ModIface@ is the stuff *before* linking, -and can be written out to an interface file. The @ModDetails@ is after -linking; it is the "linked" form of the mi_decls field. +and can be written out to an interface file. (The @ModDetails@ is after +linking; it is the "linked" form of the mi_decls field.) + +When we *read* an interface file, we also construct a @ModIface@ from it, +except that the mi_decls part is empty; when reading we consolidate +the declarations into a single indexed map in the @PersistentRenamerState@. \begin{code} data ModIface @@ -514,6 +518,24 @@ type IsExported = Name -> Bool -- True for names that are exported from this mo %* * %************************************************************************ +The @PersistentCompilerState@ persists across successive calls to the +compiler. + + * A ModIface for each non-home-package module + + * An accumulated TypeEnv from all the modules in imported packages + + * An accumulated InstEnv from all the modules in imported packages + The point is that we don't want to keep recreating it whenever + we compile a new module. The InstEnv component of pcPST is empty. + (This means we might "see" instances that we shouldn't "really" see; + but the Haskell Report is vague on what is meant to be visible, + so we just take the easy road here.) + + * Ditto for rules + + * The persistent renamer state + \begin{code} data PersistentCompilerState = PCS { @@ -532,24 +554,12 @@ data PersistentCompilerState } \end{code} -The @PersistentRenamerState@ persists across successive calls to the -compiler. -It contains: +The persistent renamer state contains: + * A name supply, which deals with allocating unique names to (Module,OccName) original names, - * An accumulated TypeEnv from all the modules in imported packages - - * An accumulated InstEnv from all the modules in imported packages - The point is that we don't want to keep recreating it whenever - we compile a new module. The InstEnv component of pcPST is empty. - (This means we might "see" instances that we shouldn't "really" see; - but the Haskell Report is vague on what is meant to be visible, - so we just take the easy road here.) - - * Ditto for rules - * A "holding pen" for declarations that have been read out of interface files but not yet sucked in, renamed, and typechecked @@ -561,6 +571,9 @@ type PackageInstEnv = InstEnv data PersistentRenamerState = PRS { prsOrig :: !NameSupply, prsImpMods :: !ImportedModuleInfo, + + -- Holding pens for stuff that has been read in + -- but not yet slurped into the renamer prsDecls :: !DeclsMap, prsInsts :: !IfaceInsts, prsRules :: !IfaceRules diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index e120813599..6f20e83023 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -99,18 +99,19 @@ checkInstType t returnP (HsForAllTy Nothing [] dict_ty) checkContext :: RdrNameHsType -> P RdrNameContext -checkContext (HsTupleTy _ ts) +checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type = mapP (\t -> checkPred t []) ts `thenP` \ps -> returnP ps -checkContext (HsTyVar t) -- empty contexts are allowed + +checkContext (HsTyVar t) -- Empty context shows up as a unit type () | t == unitTyCon_RDR = returnP [] + checkContext t = checkPred t [] `thenP` \p -> returnP [p] -checkPred :: RdrNameHsType -> [RdrNameHsType] - -> P (HsPred RdrName) -checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) +checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName) +checkPred (HsTyVar t) args | not (isRdrTyVar t) = returnP (HsClassP t args) checkPred (HsAppTy l r) args = checkPred l (r:args) checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index a55b392482..746987f8ab 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.79 2001/11/29 13:47:10 simonpj Exp $ +$Id: Parser.y,v 1.80 2001/12/20 11:19:08 simonpj Exp $ Haskell grammar. @@ -538,7 +538,7 @@ sig_vars :: { [RdrName] } -- A ctype is a for-all type ctype :: { RdrNameHsType } : 'forall' tyvars '.' ctype { mkHsForAllTy (Just $2) [] $4 } - | context type { mkHsForAllTy Nothing $1 $2 } + | context '=>' type { mkHsForAllTy Nothing $1 $3 } -- A type of form (context => type) is an *implicit* HsForAllTy | type { $1 } @@ -620,8 +620,8 @@ constrs1 :: { [RdrNameConDecl] } | constr { [$1] } constr :: { RdrNameConDecl } - : srcloc forall context constr_stuff - { mkConDecl (fst $4) $2 $3 (snd $4) $1 } + : srcloc forall context '=>' constr_stuff + { mkConDecl (fst $5) $2 $3 (snd $5) $1 } | srcloc forall constr_stuff { mkConDecl (fst $3) $2 [] (snd $3) $1 } @@ -630,7 +630,7 @@ forall :: { [RdrNameHsTyVar] } | {- empty -} { [] } context :: { RdrNameContext } - : btype '=>' {% checkContext $1 } + : btype {% checkContext $1 } constr_stuff :: { (RdrName, RdrNameConDetails) } : btype {% mkVanillaCon $1 [] } @@ -658,15 +658,11 @@ stype :: { RdrNameBangType } : ctype { unbangedType $1 } | '!' atype { BangType MarkedUserStrict $2 } -deriving :: { Maybe [RdrName] } +deriving :: { Maybe RdrNameContext } : {- empty -} { Nothing } - | 'deriving' qtycls { Just [$2] } - | 'deriving' '(' ')' { Just [] } - | 'deriving' '(' dclasses ')' { Just (reverse $3) } - -dclasses :: { [RdrName] } - : dclasses ',' qtycls { $3 : $1 } - | qtycls { [$1] } + | 'deriving' context { Just $2 } + -- Glasgow extension: allow partial + -- applications in derivings ----------------------------------------------------------------------------- -- Value definitions diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index ca6b3d9674..7629070b58 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -212,7 +212,6 @@ mkClassDecl cxt cname tyvars fds sigs mbinds loc -- superclasses both called C!) new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names) --- mkTyData :: ?? mkTyData new_or_data context tname list_var list_con i maybe src = let t_occ = rdrNameOcc tname name1 = mkRdrUnqual (mkGenOcc1 t_occ) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 30ab686fdd..da3ed88df1 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -424,8 +424,12 @@ getImplicitModuleFVs mod_name decls -- Compiling a module || mod_name == pREL_MAIN_Name = unitFV ioTyConName | otherwise = emptyFVs + -- deriv_classes is now a list of HsTypes, so a "normal" one + -- appears as a (HsClassP c []). The non-normal ones for the new + -- newtype-deriving extension, and they don't require any + -- implicit names, so we can silently filter them out. deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls, - cls <- deriv_classes, + HsClassP cls [] <- deriv_classes, occ <- lookupWithDefaultUFM derivingOccurrences [] cls ] -- ubiquitous_names are loaded regardless, because diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 4479aa9ac0..fbf9e790a5 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -612,7 +612,11 @@ lookupFixityRn name -- loadHomeInterface, and consulting the Ifaces that comes back -- from that, because the interface file for the Name might not -- have been loaded yet. Why not? Suppose you import module A, - -- which exports a function 'f', which is defined in module B. + -- which exports a function 'f', thus; + -- module CurrentModule where + -- import A( f ) + -- module A( f ) where + -- import B( f ) -- Then B isn't loaded right away (after all, it's possible that -- nothing from B will be used). When we come across a use of -- 'f', we need to know its fixity, and it's then, and only diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 452754f5d1..660feca789 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -129,7 +129,10 @@ tyClDeclFVs (IfaceSig {tcdType = ty, tcdIdInfo = id_infos}) tyClDeclFVs (TyData {tcdCtxt = context, tcdTyVars = tyvars, tcdCons = condecls, tcdDerivs = derivings}) = delFVs (map hsTyVarName tyvars) $ - extractHsCtxtTyNames context `plusFV` + extractHsCtxtTyNames context `plusFV` + (case derivings of + Nothing -> emptyFVs + Just ds -> extractHsCtxtTyNames ds) `plusFV` plusFVs (map conDeclFVs condecls) tyClDeclFVs (TySynonym {tcdTyVars = tyvars, tcdSynRhs = ty}) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 3d246fff56..b8071b3560 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -290,11 +290,12 @@ rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_n rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = nconstrs, - tcdLoc = src_loc, tcdSysNames = sys_names}) + tcdDerivs = derivs, tcdLoc = src_loc, tcdSysNames = sys_names}) = pushSrcLocRn src_loc $ lookupTopBndrRn tycon `thenRn` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenRn` \ context' -> + rn_derivs derivs `thenRn` \ derivs' -> checkDupOrQualNames data_doc con_names `thenRn_` -- Check that there's at least one condecl, @@ -311,11 +312,14 @@ rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, mapRn lookupSysBinder sys_names `thenRn` \ sys_names' -> returnRn (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', tcdTyVars = tyvars', tcdCons = condecls', tcdNCons = nconstrs, - tcdDerivs = Nothing, tcdLoc = src_loc, tcdSysNames = sys_names'}) + tcdDerivs = derivs', tcdLoc = src_loc, tcdSysNames = sys_names'}) where data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls + rn_derivs Nothing = returnRn Nothing + rn_derivs (Just ds) = rnContext data_doc ds `thenRn` \ ds' -> returnRn (Just ds') + rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc}) = pushSrcLocRn src_loc $ lookupTopBndrRn name `thenRn` \ name' -> @@ -400,13 +404,6 @@ rnClassOp clas clas_fds sig@(ClassOpSig op dm_stuff ty locn) finishSourceTyClDecl :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars) -- Used for source file decls only -- Renames the default-bindings of a class decl - -- the derivings of a data decl -finishSourceTyClDecl (TyData {tcdDerivs = Just derivs, tcdLoc = src_loc}) -- Derivings in here - rn_ty_decl -- Everything else is here - = pushSrcLocRn src_loc $ - mapRn rnDeriv derivs `thenRn` \ derivs' -> - returnRn (rn_ty_decl {tcdDerivs = Just derivs'}, mkNameSet derivs') - finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- Get mbinds from here rn_cls_decl@(ClassDecl {tcdName = cls, tcdTyVars = tyvars}) -- Everything else is here -- There are some default-method bindings (abeit possibly empty) so @@ -436,7 +433,7 @@ finishSourceTyClDecl (ClassDecl {tcdMeths = Just mbinds, tcdLoc = src_loc}) -- G meth_doc = text "In the default-methods for class" <+> ppr (tcdName rn_cls_decl) finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) - -- Not a class or data type declaration + -- Not a class declaration \end{code} @@ -447,15 +444,6 @@ finishSourceTyClDecl _ tycl_decl = returnRn (tycl_decl, emptyFVs) %********************************************************* \begin{code} -rnDeriv :: RdrName -> RnMS Name -rnDeriv cls - = lookupOccRn cls `thenRn` \ clas_name -> - checkRn (getUnique clas_name `elem` derivableClassKeys) - (derivingNonStdClassErr clas_name) `thenRn_` - returnRn clas_name -\end{code} - -\begin{code} conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) conDeclName (ConDecl n _ _ _ _ l) = (n,l) @@ -702,11 +690,9 @@ validRuleLhs foralls lhs %********************************************************* \begin{code} -derivingNonStdClassErr clas - = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")] - badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] + badRuleLhsErr name lhs = sep [ptext SLIT("Rule") <+> ptext name <> colon, nest 4 (ptext SLIT("Illegal left-hand side:") <+> ppr lhs)] diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 6144532c94..c3ae96505c 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -592,8 +592,9 @@ lookupInst :: Inst -- Dictionaries lookupInst dict@(Dict _ (ClassP clas tys) loc) - = tcGetInstEnv `thenNF_Tc` \ inst_env -> - case lookupInstEnv inst_env clas tys of + = getDOptsTc `thenNF_Tc` \ dflags -> + tcGetInstEnv `thenNF_Tc` \ inst_env -> + case lookupInstEnv dflags inst_env clas tys of FoundInst tenv dfun_id -> let @@ -670,8 +671,9 @@ lookupSimpleInst :: Class -> NF_TcM (Maybe ThetaType) -- Here are the needed (c,t)s lookupSimpleInst clas tys - = tcGetInstEnv `thenNF_Tc` \ inst_env -> - case lookupInstEnv inst_env clas tys of + = getDOptsTc `thenNF_Tc` \ dflags -> + tcGetInstEnv `thenNF_Tc` \ inst_env -> + case lookupInstEnv dflags inst_env clas tys of FoundInst tenv dfun -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta)) where diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index ee364ac237..9bc4540cf4 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -13,7 +13,7 @@ module TcDeriv ( tcDeriving ) where import HsSyn ( HsBinds(..), MonoBinds(..), TyClDecl(..), collectLocatedMonoBinders ) import RdrHsSyn ( RdrNameMonoBinds ) -import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl ) +import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl, RenamedHsPred ) import CmdLineOpts ( DynFlag(..), DynFlags ) import TcMonad @@ -22,6 +22,7 @@ import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo, ) import TcGenDeriv -- Deriv stuff import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv ) +import TcMonoType ( tcHsPred ) import TcSimplify ( tcSimplifyThetas ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) @@ -29,29 +30,33 @@ import RnEnv ( bindLocatedLocalsRn ) import RnMonad ( renameDerivedCode, thenRn, mapRn, returnRn ) import HscTypes ( DFunId, PersistentRenamerState ) -import BasicTypes ( Fixity ) -import Class ( className, classKey, Class ) +import BasicTypes ( Fixity, NewOrData(..) ) +import Class ( className, classKey, classTyVars, Class ) import ErrUtils ( dumpIfSet_dyn, Message ) import MkId ( mkDictFunId ) -import DataCon ( dataConArgTys, isNullaryDataCon, isExistentialDataCon ) +import DataCon ( dataConRepArgTys, isNullaryDataCon, isExistentialDataCon ) import PrelInfo ( needsDataDeclCtxtClassKeys ) import Maybes ( maybeToBool, catMaybes ) import Module ( Module ) import Name ( Name, getSrcLoc, nameUnique ) import RdrName ( RdrName ) -import TyCon ( tyConTyVars, tyConDataCons, +import TyCon ( tyConTyVars, tyConDataCons, tyConArity, newTyConRep, tyConTheta, maybeTyConSingleCon, isDataTyCon, isEnumerationTyCon, TyCon ) -import TcType ( ThetaType, mkTyVarTys, mkTyConApp, - isUnLiftedType, mkClassPred ) -import Var ( TyVar ) +import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, getClassPredTys_maybe, + isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, + tcSplitTyConApp_maybe ) +import Var ( TyVar, tyVarKind ) +import VarSet ( mkVarSet, subVarSet ) import PrelNames import Util ( zipWithEqual, sortLt ) import ListSetOps ( removeDups, assoc ) import Outputable +import Maybe ( isJust ) import List ( nub ) +import FastString ( FastString ) \end{code} %************************************************************************ @@ -187,17 +192,37 @@ tcDeriving :: PersistentRenamerState -> TcM ([InstInfo], -- The generated "instance decls". RenamedHsBinds) -- Extra generated bindings -tcDeriving prs mod inst_env_in get_fixity tycl_decls +tcDeriving prs mod inst_env get_fixity tycl_decls = recoverTc (returnTc ([], EmptyBinds)) $ -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". - makeDerivEqns tycl_decls `thenTc` \ eqns -> - if null eqns then - returnTc ([], EmptyBinds) - else + makeDerivEqns tycl_decls `thenTc` \ (ordinary_eqns, inst_info2) -> + + deriveOrdinaryStuff mod prs inst_env get_fixity + ordinary_eqns `thenTc` \ (inst_info1, binds) -> + let + inst_info = inst_info2 ++ inst_info1 -- info2 usually empty + in + + getDOptsTc `thenNF_Tc` \ dflags -> + ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info binds)) `thenTc_` + + returnTc (inst_info, binds) + + where + ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc + ddump_deriving inst_infos extra_binds + = vcat (map pprInstInfo inst_infos) $$ ppr extra_binds + - -- Take the equation list and solve it, to deliver a list of +----------------------------------------- +deriveOrdinaryStuff mod prs inst_env_in get_fixity [] -- Short cut + = returnTc ([], EmptyBinds) + +deriveOrdinaryStuff mod prs inst_env_in get_fixity eqns + = -- Take the equation list and solve it, to deliver a list of -- solutions, a.k.a. the contexts for the instance decls -- required for the corresponding equations. solveDerivEqns inst_env_in eqns `thenTc` \ new_dfuns -> @@ -207,11 +232,10 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls -- generate extra not-one-inst-decl-specific binds, notably -- "con2tag" and/or "tag2con" functions. We do these -- separately. - gen_taggery_Names new_dfuns `thenTc` \ nm_alist_etc -> tcGetEnv `thenNF_Tc` \ env -> - getDOptsTc `thenTc` \ dflags -> + getDOptsTc `thenNF_Tc` \ dflags -> let extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list @@ -228,20 +252,11 @@ tcDeriving prs mod inst_env_in get_fixity tycl_decls mapRn rn_meths method_binds_s `thenRn` \ rn_method_binds_s -> returnRn (rn_method_binds_s, rn_extra_binds) ) - new_inst_infos = zipWith gen_inst_info new_dfuns rn_method_binds_s in - - ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" - (ddump_deriving new_inst_infos rn_extra_binds)) `thenTc_` - returnTc (new_inst_infos, rn_extra_binds) - where - ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc - ddump_deriving inst_infos extra_binds - = vcat (map pprInstInfo inst_infos) $$ ppr extra_binds - where + where -- Make a Real dfun instead of the dummy one we have so far gen_inst_info :: DFunId -> RenamedMonoBinds -> InstInfo gen_inst_info dfun binds @@ -274,68 +289,138 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: [RenamedTyClDecl] -> TcM [DerivEqn] +makeDerivEqns :: [RenamedTyClDecl] + -> TcM ([DerivEqn], -- Ordinary derivings + [InstInfo]) -- Special newtype derivings makeDerivEqns tycl_decls - = mapTc mk_eqn derive_these `thenTc` \ maybe_eqns -> - returnTc (catMaybes maybe_eqns) + = mapAndUnzipTc mk_eqn derive_these `thenTc` \ (maybe_ordinaries, maybe_newtypes) -> + returnTc (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) where ------------------------------------------------------------------ - derive_these :: [(Name, Name)] - -- Find the (Class,TyCon) pairs that must be `derived' + derive_these :: [(NewOrData, Name, RenamedHsPred)] + -- Find the (nd, TyCon, Pred) pairs that must be `derived' -- NB: only source-language decls have deriving, no imported ones do - derive_these = [ (clas,tycon) - | TyData {tcdName = tycon, tcdDerivs = Just classes} <- tycl_decls, - clas <- nub classes ] + derive_these = [ (nd, tycon, pred) + | TyData {tcdND = nd, tcdName = tycon, tcdDerivs = Just preds} <- tycl_decls, + pred <- preds ] ------------------------------------------------------------------ - mk_eqn :: (Name, Name) -> NF_TcM (Maybe DerivEqn) - -- we swizzle the tyvars and datacons out of the tycon + mk_eqn :: (NewOrData, Name, RenamedHsPred) -> NF_TcM (Maybe DerivEqn, Maybe InstInfo) + -- We swizzle the tyvars and datacons out of the tycon -- to make the rest of the equation - mk_eqn (clas_name, tycon_name) - = tcLookupClass clas_name `thenNF_Tc` \ clas -> - tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> - let - clas_key = classKey clas - tyvars = tyConTyVars tycon - tyvar_tys = mkTyVarTys tyvars - ty = mkTyConApp tycon tyvar_tys - data_cons = tyConDataCons tycon - locn = getSrcLoc tycon - constraints = extra_constraints ++ concat (map mk_constraints data_cons) + mk_eqn (new_or_data, tycon_name, pred) + = tcLookupTyCon tycon_name `thenNF_Tc` \ tycon -> + tcAddSrcLoc (getSrcLoc tycon) $ + tcAddErrCtxt (derivCtxt tycon) $ + tcHsPred pred `thenTc` \ pred' -> + case getClassPredTys_maybe pred' of + Nothing -> bale_out (malformedPredErr tycon pred) + Just (clas, tys) -> mk_eqn_help new_or_data tycon clas tys - -- "extra_constraints": see notes above about contexts on data decls - extra_constraints - | offensive_class = tyConTheta tycon - | otherwise = [] + ------------------------------------------------------------------ + mk_eqn_help DataType tycon clas tys + | Just err <- chk_out clas tycon tys + = bale_out (derivingThingErr clas tys tycon tyvars err) + | otherwise + = new_dfun_name clas tycon `thenNF_Tc` \ dfun_name -> + returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing) + where + tyvars = tyConTyVars tycon + data_cons = tyConDataCons tycon + constraints = extra_constraints ++ + [ mkClassPred clas [arg_ty] + | data_con <- tyConDataCons tycon, + arg_ty <- dataConRepArgTys data_con, + -- Use the same type variables + -- as the type constructor, + -- hence no need to instantiate + not (isUnLiftedType arg_ty) -- No constraints for unlifted types? + ] - offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys - - mk_constraints data_con - = [ mkClassPred clas [arg_ty] - | arg_ty <- dataConArgTys data_con tyvar_tys, - not (isUnLiftedType arg_ty) -- No constraints for unlifted types? - ] - in - case chk_out clas tycon of - Just err -> tcAddSrcLoc (getSrcLoc tycon) $ - addErrTc err `thenNF_Tc_` - returnNF_Tc Nothing - Nothing -> newDFunName clas [ty] locn `thenNF_Tc` \ dfun_name -> - returnNF_Tc (Just (dfun_name, clas, tycon, tyvars, constraints)) + + -- "extra_constraints": see notes above about contexts on data decls + extra_constraints | offensive_class = tyConTheta tycon + | otherwise = [] + + offensive_class = classKey clas `elem` needsDataDeclCtxtClassKeys + + + mk_eqn_help NewType tycon clas [] + | clas `hasKey` readClassKey || clas `hasKey` showClassKey + = mk_eqn_help DataType tycon clas [] -- Use the generate-full-code mechanism for Read and Show + + mk_eqn_help NewType tycon clas tys + = doptsTc Opt_GlasgowExts `thenTc` \ gla_exts -> + if not gla_exts then -- Not glasgow-exts? + mk_eqn_help DataType tycon clas tys -- revert to ordinary mechanism + else if not can_derive then + bale_out cant_derive_err + else + new_dfun_name clas tycon `thenNF_Tc` \ dfun_name -> + returnTc (Nothing, Just (NewTypeDerived (mk_dfun dfun_name))) + where + -- Here is the plan for newtype derivings. We see + -- newtype T a1...an = T (t ak...an) deriving (C1...Cm) + -- where aj...an do not occur free in t, and the Ci are *partial applications* of + -- classes with the last parameter missing + -- + -- We generate the instances + -- instance Ci (t ak...aj) => Ci (T a1...aj) + -- where T a1...aj is the partial application of the LHS of the correct kind + -- + -- Running example: newtype T s a = MkT (ST s a) deriving( Monad ) + kind = tyVarKind (last (classTyVars clas)) + -- Kind of the thing we want to instance + -- e.g. argument kind of Monad, *->* + (arg_kinds, _) = tcSplitFunTys kind + n_args_to_drop = length arg_kinds + -- Want to drop 1 arg from (T s a) and (ST s a) + -- to get instance Monad (ST s) => Monad (T s) + + (tyvars, rep_ty) = newTyConRep tycon + maybe_rep_app = tcSplitTyConApp_maybe rep_ty + Just (rep_tc, rep_ty_args) = maybe_rep_app + + n_tyvars_to_keep = tyConArity tycon - n_args_to_drop + tyvars_to_keep = ASSERT( n_tyvars_to_keep >= 0 && n_tyvars_to_keep <= length tyvars ) + take n_tyvars_to_keep tyvars -- Kind checking should ensure this + + n_args_to_keep = tyConArity rep_tc - n_args_to_drop + args_to_keep = ASSERT( n_args_to_keep >= 0 && n_args_to_keep <= length rep_ty_args ) + take n_args_to_keep rep_ty_args + + ctxt_pred = mkClassPred clas (tys ++ [mkTyConApp rep_tc args_to_keep]) + + mk_dfun dfun_name = mkDictFunId dfun_name clas tyvars + (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)] ) + [ctxt_pred] + + -- We can only do this newtype deriving thing if: + can_derive = isJust maybe_rep_app -- The rep type is a type constructor app + && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep) + -- and the tyvars are all in scope + + cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep + SLIT("too hard for cunning newtype deriving") + + + bale_out err = addErrTc err `thenNF_Tc_` returnNF_Tc (Nothing, Nothing) ------------------------------------------------------------------ - chk_out :: Class -> TyCon -> Maybe Message - chk_out clas tycon - | clas `hasKey` enumClassKey && not is_enumeration = bog_out nullary_why - | clas `hasKey` boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why - | clas `hasKey` ixClassKey && not is_enumeration_or_single = bog_out single_nullary_why - | null data_cons = bog_out no_cons_why - | any isExistentialDataCon data_cons = Just (existentialErr clas tycon) - | otherwise = Nothing + chk_out :: Class -> TyCon -> [TcType] -> Maybe FastString + chk_out clas tycon tys + | not (null tys) = Just non_std_why + | not (getUnique clas `elem` derivableClassKeys) = Just non_std_why + | clas `hasKey` enumClassKey && not is_enumeration = Just nullary_why + | clas `hasKey` boundedClassKey && not is_enumeration_or_single = Just single_nullary_why + | clas `hasKey` ixClassKey && not is_enumeration_or_single = Just single_nullary_why + | null data_cons = Just no_cons_why + | any isExistentialDataCon data_cons = Just existential_why + | otherwise = Nothing where data_cons = tyConDataCons tycon is_enumeration = isEnumerationTyCon tycon @@ -345,8 +430,13 @@ makeDerivEqns tycl_decls single_nullary_why = SLIT("one constructor data type or type with all nullary constructors expected") nullary_why = SLIT("data type with all nullary constructors expected") no_cons_why = SLIT("type has no data constructors") + non_std_why = SLIT("not a derivable class") + existential_why = SLIT("it has existentially-quantified constructor(s)") - bog_out why = Just (derivingThingErr clas tycon why) +new_dfun_name clas tycon -- Just a simple wrapper + = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon) + -- The type passed to newDFunName is only used to generate + -- a suitable string; hence the empty type arg list \end{code} %************************************************************************ @@ -402,7 +492,7 @@ solveDerivEqns inst_env_in orig_eqns iterateOnce current_solns = -- Extend the inst info from the explicit instance decls -- with the current set of solutions, giving a - getDOptsTc `thenTc` \ dflags -> + getDOptsTc `thenNF_Tc` \ dflags -> let (new_dfuns, inst_env) = add_solns dflags inst_env_in orig_eqns current_solns in @@ -611,17 +701,15 @@ gen_taggery_Names dfuns \end{code} \begin{code} -derivingThingErr :: Class -> TyCon -> FAST_STRING -> Message - -derivingThingErr clas tycon why - = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr clas)], - hsep [ptext SLIT("for the type"), quotes (ppr tycon)], +derivingThingErr clas tys tycon tyvars why + = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)], parens (ptext why)] + where + pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)]) -existentialErr clas tycon - = sep [ptext SLIT("Can't derive any instances for type") <+> quotes (ppr tycon), - ptext SLIT("because it has existentially-quantified constructor(s)")] +malformedPredErr tycon pred = ptext SLIT("Illegal deriving item") <+> ppr pred derivCtxt tycon = ptext SLIT("When deriving classes for") <+> quotes (ppr tycon) \end{code} + diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index b2fe7d9e30..744fb42661 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -495,6 +495,12 @@ The InstInfo type summarises the information in an instance declaration instance c => k (t tvs) where b +It is used just for *local* instance decls (not ones from interface files). +But local instance decls includes + - derived ones + - generic ones +as well as explicit user written ones. + \begin{code} data InstInfo = InstInfo { @@ -503,8 +509,13 @@ data InstInfo iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances } -pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)), - nest 4 (ppr (iBinds info))] + | NewTypeDerived { -- Used for deriving instances of newtypes, where the + -- witness dictionary is identical to the argument dictionary + -- Hence no bindings. + iDFunId :: DFunId -- The dfun id + } + +pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))] simpleInstInfoTy :: InstInfo -> Type simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index ebfd83f195..da180d8394 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -142,7 +142,7 @@ tcPragExpr unf_env name in_scope_vars expr -- Check for type consistency in the unfolding tcGetSrcLoc `thenNF_Tc` \ src_loc -> - getDOptsTc `thenTc` \ dflags -> + getDOptsTc `thenNF_Tc` \ dflags -> case lintUnfolding dflags src_loc in_scope_vars core_expr' of (Nothing,_) -> returnTc (Just core_expr') -- ignore warnings (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 77d65918dd..3b3237c6e0 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -24,14 +24,13 @@ import TcHsSyn ( TcMonoBinds, mkHsConApp ) import TcBinds ( tcSpecSigs ) import TcClassDcl ( tcMethodBind, badMethodErr ) import TcMonad -import TcMType ( tcInstSigTyVars, checkValidTheta, checkValidInstHead, instTypeErr, +import TcMType ( tcInstSigType, checkValidTheta, checkValidInstHead, instTypeErr, UserTypeCtxt(..), SourceTyCtxt(..) ) -import TcType ( tcSplitDFunTy, mkClassPred, mkTyVarTy, mkTyVarTys, - tcSplitSigmaTy, tcSplitPredTy_maybe, getClassPredTys, +import TcType ( mkClassPred, mkTyVarTy, mkTyVarTys, tcSplitForAllTys, + tcSplitSigmaTy, getClassPredTys, tcSplitPredTy_maybe, TyVarDetails(..) ) -import Inst ( InstOrigin(..), - newDicts, instToId, +import Inst ( InstOrigin(..), newDicts, instToId, LIE, mkLIE, emptyLIE, plusLIE, plusLIEs ) import TcDeriv ( tcDeriving ) import TcEnv ( TcEnv, tcExtendGlobalValEnv, @@ -47,33 +46,31 @@ import TcSimplify ( tcSimplifyCheck ) import HscTypes ( HomeSymbolTable, DFunId, ModDetails(..), PackageInstEnv, PersistentRenamerState ) - import Subst ( substTy, substTheta ) import DataCon ( classDataCon ) import Class ( Class, classBigSig ) import Var ( idName, idType ) import VarSet ( emptyVarSet ) import Id ( setIdLocalExported ) -import MkId ( mkDictFunId ) +import MkId ( mkDictFunId, unsafeCoerceId, eRROR_ID ) import FunDeps ( checkInstFDs ) import Generics ( validGenericInstanceType ) import Module ( Module, foldModuleEnv ) import Name ( getSrcLoc ) import NameSet ( unitNameSet, emptyNameSet, nameSetToList ) -import PrelInfo ( eRROR_ID ) import TyCon ( TyCon ) import Subst ( mkTopTyVarSubst, substTheta ) import TysWiredIn ( genericTyCons ) import Name ( Name ) import SrcLoc ( SrcLoc ) import Unique ( Uniquable(..) ) -import Util ( lengthExceeds ) +import Util ( lengthExceeds, isSingleton ) import BasicTypes ( NewOrData(..), Fixity ) import ErrUtils ( dumpIfSet_dyn ) import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc, - assocElts, extendAssoc_C, - equivClassesByUniq, minusList + assocElts, extendAssoc_C, equivClassesByUniq, minusList ) +import Maybe ( catMaybes ) import List ( partition ) import Outputable \end{code} @@ -178,8 +175,8 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls (imported_inst_ds, local_inst_ds) = partition isIfaceInstDecl inst_decls in -- (1) Do the ordinary instance declarations - mapNF_Tc tcInstDecl1 local_inst_ds `thenNF_Tc` \ local_inst_infos -> - mapNF_Tc tcInstDecl1 imported_inst_ds `thenNF_Tc` \ imported_inst_infos -> + mapNF_Tc tcLocalInstDecl1 local_inst_ds `thenNF_Tc` \ local_inst_infos -> + mapNF_Tc tcImportedInstDecl1 imported_inst_ds `thenNF_Tc` \ imported_dfuns -> -- (2) Instances from generic class declarations getGenericInstances clas_decls `thenTc` \ generic_inst_info -> @@ -192,14 +189,13 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity this_mod decls -- e) generic instances inst_env4 -- The result of (b) replaces the cached InstEnv in the PCS let - local_inst_info = concat local_inst_infos - imported_inst_info = concat imported_inst_infos - hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst + local_inst_info = catMaybes local_inst_infos + hst_dfuns = foldModuleEnv ((++) . md_insts) [] hst in -- pprTrace "tcInstDecls" (vcat [ppr imported_dfuns, ppr hst_dfuns]) $ - addInstInfos inst_env0 imported_inst_info `thenNF_Tc` \ inst_env1 -> + addInstDFuns inst_env0 imported_dfuns `thenNF_Tc` \ inst_env1 -> addInstDFuns inst_env1 hst_dfuns `thenNF_Tc` \ inst_env2 -> addInstInfos inst_env2 local_inst_info `thenNF_Tc` \ inst_env3 -> addInstInfos inst_env3 generic_inst_info `thenNF_Tc` \ inst_env4 -> @@ -223,7 +219,7 @@ addInstInfos inst_env infos = addInstDFuns inst_env (map iDFunId infos) addInstDFuns :: InstEnv -> [DFunId] -> NF_TcM InstEnv addInstDFuns inst_env dfuns - = getDOptsTc `thenTc` \ dflags -> + = getDOptsTc `thenNF_Tc` \ dflags -> let (inst_env', errs) = extendInstEnv dflags inst_env dfuns in @@ -235,12 +231,28 @@ addInstDFuns inst_env dfuns \end{code} \begin{code} -tcInstDecl1 :: RenamedInstDecl -> NF_TcM [InstInfo] --- Deal with a single instance declaration --- Type-check all the stuff before the "where" -tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) - = -- Prime error recovery, set source location - recoverNF_Tc (returnNF_Tc []) $ +tcImportedInstDecl1 :: RenamedInstDecl -> NF_TcM DFunId + -- An interface-file instance declaration + -- Should be in scope by now, because we should + -- have sucked in its interface-file definition + -- So it will be replete with its unfolding etc +tcImportedInstDecl1 decl@(InstDecl poly_ty binds uprags (Just dfun_name) src_loc) + = tcLookupId dfun_name + + +tcLocalInstDecl1 :: RenamedInstDecl + -> NF_TcM (Maybe InstInfo) -- Nothing if there was an error + -- A source-file instance declaration + -- Type-check all the stuff before the "where" + -- + -- We check for respectable instance type, and context + -- but only do this for non-imported instance decls. + -- Imported ones should have been checked already, and may indeed + -- contain something illegal in normal Haskell, notably + -- instance CCallable [Char] +tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags Nothing src_loc) + = -- Prime error recovery, set source location + recoverNF_Tc (returnNF_Tc Nothing) $ tcAddSrcLoc src_loc $ tcAddErrCtxt (instDeclCtxt poly_ty) $ @@ -250,30 +262,14 @@ tcInstDecl1 decl@(InstDecl poly_ty binds uprags maybe_dfun_name src_loc) tcHsType poly_ty `thenTc` \ poly_ty' -> let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty' - (clas,inst_tys) = case tcSplitPredTy_maybe tau of { Just st -> getClassPredTys st } - -- The checkValidInstHead makes sure these splits succeed in - (case maybe_dfun_name of - Nothing -> -- A source-file instance declaration - -- Check for respectable instance type, and context - -- but only do this for non-imported instance decls. - -- Imported ones should have been checked already, and may indeed - -- contain something illegal in normal Haskell, notably - -- instance CCallable [Char] - checkValidTheta InstThetaCtxt theta `thenTc_` - checkValidInstHead tau `thenTc_` - checkTc (checkInstFDs theta clas inst_tys) - (instTypeErr (pprClassPred clas inst_tys) msg) `thenTc_` - newDFunName clas inst_tys src_loc `thenTc` \ dfun_name -> - returnTc (mkDictFunId dfun_name clas tyvars inst_tys theta) - - Just dfun_name -> -- An interface-file instance declaration - -- Should be in scope by now, because we should - -- have sucked in its interface-file definition - -- So it will be replete with its unfolding etc - tcLookupId dfun_name - ) `thenNF_Tc` \ dfun_id -> - returnTc [InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = uprags }] + checkValidTheta InstThetaCtxt theta `thenTc_` + checkValidInstHead tau `thenTc` \ (clas,inst_tys) -> + checkTc (checkInstFDs theta clas inst_tys) + (instTypeErr (pprClassPred clas inst_tys) msg) `thenTc_` + newDFunName clas inst_tys src_loc `thenNF_Tc` \ dfun_name -> + returnTc (Just (InstInfo { iDFunId = mkDictFunId dfun_name clas tyvars inst_tys theta, + iBinds = binds, iPrags = uprags })) where msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class")) \end{code} @@ -319,7 +315,7 @@ getGenericInstances class_decls if null gen_inst_info then returnTc [] else - getDOptsTc `thenTc` \ dflags -> + getDOptsTc `thenNF_Tc` \ dflags -> ioToTc (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances" (vcat (map pprInstInfo gen_inst_info))) `thenNF_Tc_` @@ -413,12 +409,10 @@ mkGenericInstance clas loc (hs_ty, binds) newDFunName clas [inst_ty] loc `thenNF_Tc` \ dfun_name -> let inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] - inst_tys = [inst_ty] - dfun_id = mkDictFunId dfun_name clas tyvars inst_tys inst_theta + dfun_id = mkDictFunId dfun_name clas tyvars [inst_ty] inst_theta in - returnTc (InstInfo { iDFunId = dfun_id, - iBinds = binds, iPrags = [] }) + returnTc (InstInfo { iDFunId = dfun_id, iBinds = binds, iPrags = [] }) \end{code} @@ -511,27 +505,34 @@ First comes the easy case of a non-local instance decl. \begin{code} -tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds) --- tcInstDecl2 is called *only* on InstInfos +tcInstDecl2 :: InstInfo -> TcM (LIE, TcMonoBinds) + +tcInstDecl2 (NewTypeDerived { iDFunId = dfun_id }) + = tcInstSigType InstTv (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') -> + newDicts InstanceDeclOrigin dfun_theta' `thenNF_Tc` \ rep_dicts -> + let + rep_dict_id = ASSERT( isSingleton rep_dicts ) + instToId (head rep_dicts) -- Derived newtypes have just one dict arg + + body = TyLam inst_tyvars' $ + DictLam [rep_dict_id] $ + (HsVar unsafeCoerceId `TyApp` [idType rep_dict_id, inst_head']) + `HsApp` + (HsVar rep_dict_id) + in + returnTc (emptyLIE, VarMonoBind dfun_id body) -tcInstDecl2 (InstInfo { iDFunId = dfun_id, - iBinds = monobinds, iPrags = uprags }) +tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = monobinds, iPrags = uprags }) = -- Prime error recovery recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc (getSrcLoc dfun_id) $ tcAddErrCtxt (instDeclCtxt (toHsType (idType dfun_id))) $ -- Instantiate the instance decl with tc-style type variables + tcInstSigType InstTv (idType dfun_id) `thenNF_Tc` \ (inst_tyvars', dfun_theta', inst_head') -> let - (inst_tyvars, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id) - in - tcInstSigTyVars InstTv inst_tyvars `thenNF_Tc` \ inst_tyvars' -> - let - tenv = mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars') - inst_tys' = map (substTy tenv) inst_tys - dfun_theta' = substTheta tenv dfun_theta - origin = InstanceDeclOrigin - + Just pred = tcSplitPredTy_maybe inst_head' + (clas, inst_tys') = getClassPredTys pred (class_tyvars, sc_theta, _, op_items) = classBigSig clas sel_names = [idName sel_id | (sel_id, _) <- op_items] @@ -540,7 +541,9 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta -- Find any definitions in monobinds that aren't from the class - bad_bndrs = collectMonoBinders monobinds `minusList` sel_names + bad_bndrs = collectMonoBinders monobinds `minusList` sel_names + (inst_tyvars, _) = tcSplitForAllTys (idType dfun_id) + origin = InstanceDeclOrigin in -- Check that all the method bindings come from this class mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_` diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index 832ee9c24d..07166d8b72 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -20,7 +20,7 @@ module TcMType ( -------------------------------- -- Instantiation tcInstTyVar, tcInstTyVars, - tcInstSigTyVars, tcInstType, + tcInstSigTyVars, tcInstType, tcInstSigType, tcSplitRhoTyM, -------------------------------- @@ -63,7 +63,7 @@ import TcType ( TcType, TcThetaType, TcTauType, TcPredType, isFFIArgumentTy, isFFIImportResultTy ) import Subst ( Subst, mkTopTyVarSubst, substTy ) -import Class ( classArity, className ) +import Class ( Class, classArity, className ) import TyCon ( TyCon, mkPrimTyCon, isSynTyCon, isUnboxedTupleTyCon, tyConArity, tyConName ) import PrimRep ( PrimRep(VoidRep) ) @@ -227,6 +227,28 @@ tcInstType ty (theta, tau) = tcSplitRhoTy (substTy tenv rho) -- Used to be tcSplitRhoTyM in returnNF_Tc (tyvars', theta, tau) + + +tcInstSigType :: TyVarDetails -> Type -> NF_TcM ([TcTyVar], TcThetaType, TcType) +-- Very similar to tcInstSigType, but uses signature type variables +-- Also, somewhat arbitrarily, don't deal with the monomorphic case so efficiently +tcInstSigType tv_details poly_ty + = let + (tyvars, rho) = tcSplitForAllTys poly_ty + in + tcInstSigTyVars tv_details tyvars `thenNF_Tc` \ tyvars' -> + -- Make *signature* type variables + + let + tyvar_tys' = mkTyVarTys tyvars' + rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho + -- mkTopTyVarSubst because the tyvars' are fresh + + (theta', tau') = tcSplitRhoTy rho' + -- This splitRhoTy tries hard to make sure that tau' is a type synonym + -- wherever possible, which can improve interface files. + in + returnNF_Tc (tyvars', theta', tau') \end{code} @@ -856,7 +878,8 @@ check_source_ty dflags ctxt pred@(ClassP cls tys) = -- Class predicates are valid in all contexts mapTc_ check_arg_type tys `thenTc_` checkTc (arity == n_tys) arity_err `thenTc_` - checkTc (all tyvar_head tys || arby_preds_ok) (predTyVarErr pred) + checkTc (all tyvar_head tys || arby_preds_ok) + (predTyVarErr pred $$ how_to_allow) where class_name = className cls @@ -870,6 +893,11 @@ check_source_ty dflags ctxt pred@(ClassP cls tys) InstThetaCtxt -> dopt Opt_AllowUndecidableInstances dflags other -> dopt Opt_GlasgowExts dflags + how_to_allow = case ctxt of + InstHeadCtxt -> empty -- Should not happen + InstThetaCtxt -> parens undecidableMsg + other -> parens (ptext SLIT("Use -fglasgow-exts to permit this")) + check_source_ty dflags SigmaCtxt (IParam _ ty) = check_arg_type ty -- Implicit parameters only allows in type -- signatures; not in instance decls, superclasses etc @@ -921,7 +949,7 @@ compiled elsewhere). In these cases, we let them go through anyway. We can also have instances for functions: @instance Foo (a -> b) ...@. \begin{code} -checkValidInstHead :: Type -> TcM () +checkValidInstHead :: Type -> TcM (Class, [TcType]) checkValidInstHead ty -- Should be a source type = case tcSplitPredTy_maybe ty of { @@ -934,7 +962,8 @@ checkValidInstHead ty -- Should be a source type getDOptsTc `thenNF_Tc` \ dflags -> mapTc_ check_arg_type tys `thenTc_` - check_inst_head dflags clas tys + check_inst_head dflags clas tys `thenTc_` + returnTc (clas, tys) }} check_inst_head dflags clas tys @@ -980,7 +1009,9 @@ check_tyvars dflags clas tys | otherwise = failWithTc (instTypeErr (pprClassPred clas tys) msg) where msg = parens (ptext SLIT("There must be at least one non-type-variable in the instance head") - $$ ptext SLIT("Use -fallow-undecidable-instances to lift this restriction")) + $$ undecidableMsg) + +undecidableMsg = ptext SLIT("Use -fallow-undecidable-instances to permit this") \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 2aee9fb47f..11cb6bdab9 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -590,11 +590,11 @@ popErrCtxt down = case tc_ctxt down of [] -> down m : ms -> down{tc_ctxt = ms} -doptsTc :: DynFlag -> TcM Bool +doptsTc :: DynFlag -> NF_TcM Bool doptsTc dflag (TcDown{tc_dflags=dflags}) env_down = return (dopt dflag dflags) -getDOptsTc :: TcM DynFlags +getDOptsTc :: NF_TcM DynFlags getDOptsTc (TcDown{tc_dflags=dflags}) env_down = return dflags \end{code} diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 4445b91f49..ef9a43ba3e 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -4,7 +4,7 @@ \section[TcMonoType]{Typechecking user-specified @MonoTypes@} \begin{code} -module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, +module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred, UserTypeCtxt(..), -- Kind checking @@ -28,7 +28,7 @@ import TcEnv ( tcExtendTyVarEnv, tcLookup, tcLookupGlobal, tcInLocalScope, TyThing(..), TcTyThing(..), tcExtendKindEnv ) -import TcMType ( newKindVar, tcInstSigTyVars, zonkKindEnv, +import TcMType ( newKindVar, zonkKindEnv, tcInstSigType, checkValidType, UserTypeCtxt(..), pprUserTypeCtxt ) import TcUnify ( unifyKind, unifyOpenTypeKind ) @@ -41,8 +41,8 @@ import TcType ( Type, Kind, SourceType(..), ThetaType, TyVarDetails(..), liftedTypeKind, unliftedTypeKind, mkArrowKind, mkArrowKinds, tcSplitFunTy_maybe ) - import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToId ) + import Subst ( mkTopTyVarSubst, substTy ) import Id ( mkLocalId, idName, idType ) import Var ( TyVar, mkTyVar, tyVarKind ) @@ -321,18 +321,27 @@ kcAppKind fun_kind arg_kind --------------------------- -kcHsContext ctxt = mapTc_ kcHsPred ctxt +kc_pred :: RenamedHsPred -> TcM TcKind -- Does *not* check for a saturated + -- application (reason: used from TcDeriv) +kc_pred pred@(HsIParam name ty) + = kcHsType ty + +kc_pred pred@(HsClassP cls tys) + = kcClass cls `thenTc` \ kind -> + mapTc kcHsType tys `thenTc` \ arg_kinds -> + newKindVar `thenNF_Tc` \ kv -> + unifyKind kind (mkArrowKinds arg_kinds kv) `thenTc_` + returnTc kv -kcHsPred :: RenamedHsPred -> TcM () -kcHsPred pred@(HsIParam name ty) - = tcAddErrCtxt (appKindCtxt (ppr pred)) $ - kcLiftedType ty +--------------------------- +kcHsContext ctxt = mapTc_ kcHsPred ctxt -kcHsPred pred@(HsClassP cls tys) +kcHsPred pred -- Checks that the result is of kind liftedType = tcAddErrCtxt (appKindCtxt (ppr pred)) $ - kcClass cls `thenTc` \ kind -> - mapTc kcHsType tys `thenTc` \ arg_kinds -> - unifyKind kind (mkArrowKinds arg_kinds liftedTypeKind) + kc_pred pred `thenTc` \ kind -> + unifyKind liftedTypeKind kind `thenTc_` + returnTc () + --------------------------- kcTyVar name -- Could be a tyvar or a tycon @@ -468,6 +477,10 @@ tc_fun_type name arg_tys Contexts ~~~~~~~~ \begin{code} +tcHsPred pred = kc_pred pred `thenTc_` tc_pred pred + -- Is happy with a partial application, e.g. (ST s) + -- Used from TcDeriv + tc_pred assn@(HsClassP class_name tys) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ tc_types tys `thenTc` \ arg_tys -> @@ -571,30 +584,16 @@ mkTcSig poly_id src_loc -- the tyvars *do* get unified with something, we want to carry on -- typechecking the rest of the program with the function bound -- to a pristine type, namely sigma_tc_ty - let - (tyvars, rho) = tcSplitForAllTys (idType poly_id) - in - tcInstSigTyVars SigTv tyvars `thenNF_Tc` \ tyvars' -> - -- Make *signature* type variables - - let - tyvar_tys' = mkTyVarTys tyvars' - rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho - -- mkTopTyVarSubst because the tyvars' are fresh - - (theta', tau') = tcSplitRhoTy rho' - -- This splitRhoTy tries hard to make sure that tau' is a type synonym - -- wherever possible, which can improve interface files. - in + tcInstSigType SigTv (idType poly_id) `thenNF_Tc` \ (tyvars', theta', tau') -> + newMethodWithGivenTy SignatureOrigin - poly_id - tyvar_tys' - theta' tau' `thenNF_Tc` \ inst -> + poly_id + (mkTyVarTys tyvars') + theta' tau' `thenNF_Tc` \ inst -> -- We make a Method even if it's not overloaded; no harm - returnNF_Tc (TySigInfo name poly_id tyvars' theta' tau' (instToId inst) [inst] src_loc) - where - name = idName poly_id + returnNF_Tc (TySigInfo (idName poly_id) poly_id tyvars' theta' tau' + (instToId inst) [inst] src_loc) \end{code} diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 7d5e823f91..0c40272c61 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -222,7 +222,10 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty = tcAddErrCtxt (patCtxt pat) $ -- Check the constructor itself - tcConstructor pat name pat_ty `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) -> + tcConstructor pat name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) -> + + -- Check overall type matches (c.f. tcConPat) + tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req1) -> let -- Don't use zipEqual! If the constructor isn't really a record, then -- dataConFieldLabels will be empty (and each field in the pattern @@ -232,10 +235,10 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty in -- Check the fields - tc_fields field_tys rpats `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) -> + tc_fields field_tys rpats `thenTc` \ (rpats', lie_req2, tvs, ids, lie_avail2) -> returnTc (RecPat data_con pat_ty ex_tvs dicts rpats', - lie_req, + lie_req1 `plusLIE` lie_req2, listToBag ex_tvs `unionBags` tvs, ids, lie_avail1 `plusLIE` lie_avail2) @@ -371,7 +374,7 @@ tcPats tc_bndr (ty:tys) (pat:pats) ------------------------------------------------------ \begin{code} -tcConstructor pat con_name pat_ty +tcConstructor pat con_name = -- Check that it's a constructor tcLookupDataCon con_name `thenNF_Tc` \ data_con -> @@ -393,10 +396,7 @@ tcConstructor pat con_name pat_ty in newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts -> - -- Check overall type matches - unifyTauTy pat_ty result_ty `thenTc_` - - returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys') + returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys', result_ty) \end{code} ------------------------------------------------------ @@ -405,7 +405,12 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty = tcAddErrCtxt (patCtxt pat) $ -- Check the constructor itself - tcConstructor pat con_name pat_ty `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') -> + tcConstructor pat con_name `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) -> + + -- Check overall type matches. + -- The pat_ty might be a for-all type, in which + -- case we must instantiate to match + tcSubPat con_res_ty pat_ty `thenTc` \ (co_fn, lie_req1) -> -- Check correct arity let @@ -416,11 +421,11 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty (arityErr "Constructor" data_con con_arity no_of_args) `thenTc_` -- Check arguments - tcPats tc_bndr arg_pats arg_tys' `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) -> + tcPats tc_bndr arg_pats arg_tys `thenTc` \ (arg_pats', lie_req2, tvs, ids, lie_avail2) -> - returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats', - lie_req, - listToBag ex_tvs' `unionBags` tvs, + returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs dicts arg_pats', + lie_req1 `plusLIE` lie_req2, + listToBag ex_tvs `unionBags` tvs, ids, lie_avail1 `plusLIE` lie_avail2) \end{code} diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 8af99244fd..9229fcbd26 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -1923,7 +1923,8 @@ complainCheck doc givens irreds -- the given set as an optimisation addNoInstanceErrs what_doc givens dicts - = tcGetInstEnv `thenNF_Tc` \ inst_env -> + = getDOptsTc `thenNF_Tc` \ dflags -> + tcGetInstEnv `thenNF_Tc` \ inst_env -> let (tidy_env1, tidy_givens) = tidyInsts givens (tidy_env2, tidy_dicts) = tidyMoreInsts tidy_env1 dicts @@ -1968,7 +1969,7 @@ addNoInstanceErrs what_doc givens dicts ambig_overlap = any ambig_overlap1 dicts ambig_overlap1 dict | isClassDict dict - = case lookupInstEnv inst_env clas tys of + = case lookupInstEnv dflags inst_env clas tys of NoMatch ambig -> ambig other -> False | otherwise = False diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index c56cb3d823..e2d2a931a2 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -130,7 +130,7 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to \begin{code} tcGroup :: RecTcEnv -> Module -> SCC RenamedTyClDecl -> TcM TcEnv tcGroup unf_env this_mod scc - = getDOptsTc `thenTc` \ dflags -> + = getDOptsTc `thenNF_Tc` \ dflags -> -- Step 1 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds -> diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index d7fac2e869..4f36597c58 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -244,8 +244,9 @@ the env is kept ordered, the first match must be the only one. The thing we are looking up can have an arbitrary "flexi" part. \begin{code} -lookupInstEnv :: InstEnv -- The envt - -> Class -> [Type] -- Key +lookupInstEnv :: DynFlags + -> InstEnv -- The envt + -> Class -> [Type] -- What we are looking for -> InstLookupResult data InstLookupResult @@ -269,7 +270,7 @@ data InstLookupResult -- it as ambiguous case in the hope of giving a better error msg. -- See the notes above from Jeff Lewis -lookupInstEnv env key_cls key_tys +lookupInstEnv dflags env key_cls key_tys = find (classInstEnv env key_cls) where key_vars = tyVarsOfTypes key_tys @@ -283,8 +284,12 @@ lookupInstEnv env key_cls key_tys -- predicate might match this instance -- [see notes about overlapping instances above] case unifyTyListsX (key_vars `unionVarSet` tpl_tyvars) key_tys tpl of - Nothing -> find rest - Just _ -> NoMatch (any_match rest) + Just _ | not (dopt Opt_AllowIncoherentInstances dflags) + -> NoMatch (any_match rest) + -- If we allow incoherent instances we don't worry about the + -- test and just blaze on anyhow. Requested by John Hughes. + other -> find rest + Just (subst, leftovers) -> ASSERT( null leftovers ) FoundInst subst dfun_id |