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
}
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}
, PostTcType, placeHolderType,
-- Printing
- , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr
+ , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr
-- Equality over Hs things
, EqHsEnv, emptyEqHsEnv, extendEqHsEnv,
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}
-- language opts
| Opt_AllowOverlappingInstances
| Opt_AllowUndecidableInstances
+ | Opt_AllowIncoherentInstances
| Opt_GlasgowExts
| Opt_Generics
| Opt_NoImplicitPrelude
{-# 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
--
( "glasgow-exts", Opt_GlasgowExts ),
( "allow-overlapping-instances", Opt_AllowOverlappingInstances ),
( "allow-undecidable-instances", Opt_AllowUndecidableInstances ),
+ ( "allow-incoherent-instances", Opt_AllowIncoherentInstances ),
( "generics", Opt_Generics )
]
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
%* *
%************************************************************************
+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 {
}
\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
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
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)
{-
-----------------------------------------------------------------------------
-$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.
-- 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 }
| 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 }
| {- empty -} { [] }
context :: { RdrNameContext }
- : btype '=>' {% checkContext $1 }
+ : btype {% checkContext $1 }
constr_stuff :: { (RdrName, RdrNameConDetails) }
: btype {% mkVanillaCon $1 [] }
: 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
-- 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)
|| 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
-- 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
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})
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,
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' ->
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
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}
%*********************************************************
\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)
%*********************************************************
\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)]
-- 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
-> 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
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
)
import TcGenDeriv -- Deriv stuff
import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv )
+import TcMonoType ( tcHsPred )
import TcSimplify ( tcSimplifyThetas )
import RnBinds ( rnMethodBinds, rnTopMonoBinds )
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}
%************************************************************************
-> 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 ->
-- 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
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
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
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}
%************************************************************************
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
\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}
+
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 {
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
-- 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)
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,
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}
(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 ->
-- 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 ->
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
\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) $
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}
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_`
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}
\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]
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_`
--------------------------------
-- Instantiation
tcInstTyVar, tcInstTyVars,
- tcInstSigTyVars, tcInstType,
+ tcInstSigTyVars, tcInstType, tcInstSigType,
tcSplitRhoTyM,
--------------------------------
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) )
(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}
= -- 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
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
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 {
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
| 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}
[] -> 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}
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
-module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta,
+module TcMonoType ( tcHsSigType, tcHsType, tcIfaceType, tcHsTheta, tcHsPred,
UserTypeCtxt(..),
-- Kind checking
tcInLocalScope,
TyThing(..), TcTyThing(..), tcExtendKindEnv
)
-import TcMType ( newKindVar, tcInstSigTyVars, zonkKindEnv,
+import TcMType ( newKindVar, zonkKindEnv, tcInstSigType,
checkValidType, UserTypeCtxt(..), pprUserTypeCtxt
)
import TcUnify ( unifyKind, unifyOpenTypeKind )
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 )
---------------------------
-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
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 ->
-- 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}
= 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
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)
------------------------------------------------------
\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 ->
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}
------------------------------------------------------
= 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
(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}
-- 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
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
\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 ->
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
-- 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
-- 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
projects / ghc-hetmet.git / commitdiff