\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
-module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2, tcMethodBind, badMethodErr ) where
+module TcClassDcl ( kcClassDecl, tcClassDecl1, tcClassDecls2,
+ tcMethodBind, checkFromThisClass
+ ) where
#include "HsVersions.h"
InPat(..), HsBinds(..), GRHSs(..),
HsExpr(..), HsLit(..), HsType(..), pprClassAssertion,
unguardedRHS, andMonoBinds, andMonoBindList, getTyVarName,
- isClassDecl, isClassOpSig
+ isClassDecl, isClassOpSig, collectMonoBinders
)
import HsPragmas ( ClassPragmas(..) )
-import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..), StrictnessMark(..) )
+import BasicTypes ( NewOrData(..), TopLevelFlag(..), RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl, RenamedClassPragmas,
RenamedClassOpSig, RenamedMonoBinds,
RenamedContext, RenamedHsDecl, RenamedSig
tcLookupClass, tcLookupTy, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
tcExtendLocalValEnv
)
-import TcBinds ( tcBindWithSigs, tcPragmaSigs )
+import TcBinds ( tcBindWithSigs, tcSpecSigs )
import TcUnify ( unifyKinds )
import TcMonad
import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope,
)
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcTyVarBndr, tcGetTyVar )
-import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
+import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
import FieldLabel ( firstFieldLabelTag )
-import Bag ( unionManyBags )
+import Bag ( unionManyBags, bagToList )
import Class ( mkClass, classBigSig, Class )
import CmdLineOpts ( opt_GlasgowExts, opt_WarnMissingMethods )
-import MkId ( mkSuperDictSelId, mkDataConId,
- mkMethodSelId, mkDefaultMethodId
- )
-import DataCon ( mkDataCon )
+import MkId ( mkDictSelId, mkDataConId, mkDefaultMethodId )
+import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id,
getIdUnfolding, idType, idName
)
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
-import Name ( Name, isLocallyDefined, NamedThing(..) )
+import Name ( Name, nameOccName, isLocallyDefined, NamedThing(..) )
+import NameSet ( emptyNameSet )
import Outputable
import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy,
mkSigmaTy, mkForAllTys, Type, ThetaType,
import Util
import Maybes ( seqMaybe )
import FiniteMap ( lookupWithDefaultFM )
-
-
--- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
-tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo,
- noIdInfo)
\end{code}
\begin{code}
kcClassDecl (ClassDecl context class_name
tyvar_names class_sigs def_methods pragmas
- tycon_name datacon_name src_loc)
+ tycon_name datacon_name sc_sel_names src_loc)
= -- CHECK ARITY 1 FOR HASKELL 1.4
checkTc (opt_GlasgowExts || length tyvar_names == 1)
(classArityErr class_name) `thenTc_`
tcClassDecl1 rec_env rec_inst_mapper rec_vrcs
(ClassDecl context class_name
tyvar_names class_sigs def_methods pragmas
- tycon_name datacon_name src_loc)
+ tycon_name datacon_name sc_sel_names src_loc)
= -- LOOK THINGS UP IN THE ENVIRONMENT
tcLookupTy class_name `thenTc` \ (class_kind, _, AClass rec_class) ->
tcExtendTopTyVarScope class_kind tyvar_names $ \ tyvars _ ->
-- CHECK THE CONTEXT
-- traceTc (text "tcClassCtxt" <+> ppr class_name) `thenTc_`
- tcClassContext class_name rec_class tyvars context pragmas
+ tcClassContext class_name rec_class tyvars context sc_sel_names
`thenTc` \ (sc_theta, sc_tys, sc_sel_ids) ->
-- traceTc (text "tcClassCtxt done" <+> ppr class_name) `thenTc_`
other -> DataType
dict_con = mkDataCon datacon_name
- [NotMarkedStrict | _ <- dict_component_tys]
+ [notMarkedStrict | _ <- dict_component_tys]
[{- No labelled fields -}]
tyvars
[{-No context-}]
\begin{code}
tcClassContext :: Name -> Class -> [TyVar]
-> RenamedContext -- class context
- -> RenamedClassPragmas -- pragmas for superclasses
+ -> [Name] -- Names for superclass selectors
-> TcM s (ThetaType, -- the superclass context
[Type], -- types of the superclass dictionaries
[Id]) -- superclass selector Ids
-tcClassContext class_name rec_class rec_tyvars context pragmas
+tcClassContext class_name rec_class rec_tyvars context sc_sel_names
= -- Check the context.
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
let
sc_tys = [mkDictTy sc tys | (sc,tys) <- sc_theta]
+ sc_sel_ids = zipWithEqual "tcClassContext" mk_super_id sc_sel_names sc_tys
in
-
- -- Make super-class selector ids
- -- We number them off, 1, 2, 3 etc so that we can construct
- -- names for the selectors. Thus
- -- class (C a, C b) => D a b where ...
- -- gives superclass selectors
- -- D_sc1, D_sc2
- -- (We used to call them D_C, but now we can have two different
- -- superclasses both called C!)
- mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..]) `thenTc` \ sc_sel_ids ->
-
-- Done
returnTc (sc_theta, sc_tys, sc_sel_ids)
where
rec_tyvar_tys = mkTyVarTys rec_tyvars
- mk_super_id ((super_class, tys), index)
- = tcGetUnique `thenNF_Tc` \ uniq ->
- let
- ty = mkForAllTys rec_tyvars $
- mkFunTy (mkDictTy rec_class rec_tyvar_tys) (mkDictTy super_class tys)
- in
- returnTc (mkSuperDictSelId uniq rec_class index ty)
+ mk_super_id name dict_ty
+ = mkDictSelId name rec_class ty
+ where
+ ty = mkForAllTys rec_tyvars $
+ mkFunTy (mkDictTy rec_class rec_tyvar_tys) dict_ty
check_constraint (c, tys) = checkTc (all is_tyvar tys)
(superClassErr class_name (c, tys))
local_ty
-- Build the selector id and default method id
- sel_id = mkMethodSelId op_name rec_clas global_ty
+ sel_id = mkDictSelId op_name rec_clas global_ty
maybe_dm_id = case maybe_dm_name of
Nothing -> Nothing
Just dm_name -> let
-> NF_TcM s (LIE, TcMonoBinds)
tcClassDecl2 (ClassDecl context class_name
- tyvar_names class_sigs default_binds pragmas _ _ src_loc)
+ tyvar_names class_sigs default_binds pragmas _ _ _ src_loc)
| not (isLocallyDefined class_name)
= returnNF_Tc (emptyLIE, EmptyMonoBinds)
(tyvars, sc_theta, sc_sel_ids, op_sel_ids, defm_ids) = classBigSig clas
-- The selector binds are already in the selector Id's unfoldings
--- sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id))
--- | sel_id <- sc_sel_ids ++ op_sel_ids,
--- isLocallyDefined sel_id
--- ]
---
--- final_sel_binds = andMonoBindList sel_binds
+ sel_binds = [ CoreMonoBind sel_id (getUnfoldingTemplate (getIdUnfolding sel_id))
+ | sel_id <- sc_sel_ids ++ op_sel_ids
+ ]
in
-- Generate bindings for the default methods
tcDefaultMethodBinds clas default_binds `thenTc` \ (const_insts, meth_binds) ->
- returnTc (const_insts, meth_binds)
--- final_sel_binds `AndMonoBinds` meth_binds)
--- Leave 'em out for now. They always get inlined anyway. SLPJ June '98
+ returnTc (const_insts,
+ meth_binds `AndMonoBinds` andMonoBindList sel_binds)
\end{code}
%************************************************************************
tcDefaultMethodBinds clas default_binds
= -- Construct suitable signatures
- tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, inst_env) ->
+ tcInstTyVars tyvars `thenNF_Tc` \ (clas_tyvars, inst_tys, _) ->
+
+ -- Check that the default bindings come from this class
+ checkFromThisClass clas op_sel_ids default_binds `thenNF_Tc_`
-- Typecheck the default bindings
let
clas_tyvars'
[this_dict_id]
abs_bind_stuff
+ emptyNameSet -- No inlines (yet)
(dict_binds `andMonoBinds` andMonoBindList defm_binds)
in
returnTc (const_lie, full_binds)
origin = ClassDeclOrigin
\end{code}
+\begin{code}
+checkFromThisClass :: Class -> [Id] -> RenamedMonoBinds -> NF_TcM s ()
+checkFromThisClass clas op_sel_ids mono_binds
+ = mapNF_Tc check_from_this_class bndrs `thenNF_Tc_`
+ returnNF_Tc ()
+ where
+ check_from_this_class (bndr, loc)
+ | nameOccName bndr `elem` sel_names = returnNF_Tc ()
+ | otherwise = tcAddSrcLoc loc $
+ addErrTc (badMethodErr bndr clas)
+ sel_names = map getOccName op_sel_ids
+ bndrs = bagToList (collectMonoBinders mono_binds)
+\end{code}
+
+
@tcMethodBind@ is used to type-check both default-method and
instance-decl method declarations. We must type-check methods one at a
time, because their signatures may have different contexts and
warnTc (opt_WarnMissingMethods && no_user_bind && no_user_default)
(omittedMethodWarn sel_id clas) `thenNF_Tc_`
- -- Check the pragmas
- tcExtendLocalValEnv [(meth_name, meth_id)] (
- tcPragmaSigs meth_prags
- ) `thenTc` \ (prag_info_fn, prag_binds1, prag_lie) ->
-
-- Check the bindings; first add inst_tyvars to the envt
-- so that we don't quantify over them in nested places
-- The *caller* put the class/inst decl tyvars into the envt
tcExtendGlobalTyVars (mkVarSet inst_tyvars) (
tcAddErrCtxt (methodCtxt sel_id) $
- tcBindWithSigs NotTopLevel meth_bind [sig_info]
- NonRecursive prag_info_fn
+ tcBindWithSigs NotTopLevel meth_bind
+ [sig_info] meth_prags NonRecursive
) `thenTc` \ (binds, insts, _) ->
+ tcExtendLocalValEnv [(meth_name, meth_id)] (
+ tcSpecSigs meth_prags
+ ) `thenTc` \ (prag_binds1, prag_lie) ->
+
-- The prag_lie for a SPECIALISE pragma will mention the function
-- itself, so we have to simplify them away right now lest they float
-- outwards!
-- Find the prags for this method, and replace the
-- selector name with the method name
find_prags meth_name [] = []
- find_prags meth_name (SpecSig name ty spec loc : prags)
- | name == sel_name = SpecSig meth_name ty spec loc : find_prags meth_name prags
+ find_prags meth_name (SpecSig name ty loc : prags)
+ | name == sel_name = SpecSig meth_name ty loc : find_prags meth_name prags
find_prags meth_name (InlineSig name loc : prags)
| name == sel_name = InlineSig meth_name loc : find_prags meth_name prags
find_prags meth_name (NoInlineSig name loc : prags)
import HsSyn ( HsDecl(..), InstDecl(..),
HsBinds(..), MonoBinds(..),
HsExpr(..), InPat(..), HsLit(..), Sig(..),
- collectMonoBinders, andMonoBindList
+ andMonoBindList
)
import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedHsDecl )
import TcHsSyn ( TcMonoBinds,
maybeBoxedPrimType
)
-import TcBinds ( tcPragmaSigs )
-import TcClassDcl ( tcMethodBind, badMethodErr )
+import TcBinds ( tcSpecSigs )
+import TcClassDcl ( tcMethodBind, checkFromThisClass )
import TcMonad
import RnMonad ( RnNameSupply, Fixities )
import Inst ( Inst, InstOrigin(..),
import TcType ( TcTyVar, zonkTcTyVarBndr )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
- foldBag, bagToList, Bag
+ foldBag, Bag
)
import CmdLineOpts ( opt_GlasgowExts, opt_AllowUndecidableInstances )
import Class ( classBigSig, Class )
-import Var ( setIdInfo, idName, idType, Id, TyVar )
+import Var ( idName, idType, Id, TyVar )
import DataCon ( isNullaryDataCon, dataConArgTys, dataConId )
import Maybes ( maybeToBool, catMaybes, expectJust )
import MkId ( mkDictFunId )
-import Module ( Module )
-import Name ( nameOccName, isLocallyDefined, NamedThing(..) )
-import PrelVals ( eRROR_ID )
+import Module ( ModuleName )
+import Name ( isLocallyDefined, NamedThing(..) )
+import NameSet ( emptyNameSet )
+import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint )
import SrcLoc ( SrcLoc )
import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
splitSigmaTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy_maybe, unUsgTy,
splitAlgTyConApp_maybe,
- tyVarsOfTypes, substTopTheta
+ tyVarsOfTypes
)
-import VarEnv ( zipVarEnv )
+import Subst ( mkTopTyVarSubst, substTheta )
import VarSet ( mkVarSet, varSetElems )
import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
\begin{code}
tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids
-> [RenamedHsDecl]
- -> Module -- module name for deriving
+ -> ModuleName -- module name for deriving
-> Fixities
-> RnNameSupply -- for renaming derivings
-> TcM s (Bag InstInfo,
tcInstDecls1 unf_env decls mod_name fixs rn_name_supply
= -- Do the ordinary instance declarations
- mapNF_Tc (tcInstDecl1 unf_env mod_name)
+ mapNF_Tc (tcInstDecl1 unf_env)
[inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
let
decl_inst_info = unionManyBags inst_info_bags
returnTc (full_inst_info, deriv_binds)
-tcInstDecl1 :: ValueEnv -> Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
-tcInstDecl1 unf_env mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
+tcInstDecl1 unf_env (InstDecl poly_ty binds uprags dfun_name src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc emptyBag) $
tcAddSrcLoc src_loc $
returnNF_Tc []
) `thenNF_Tc_`
- -- Make the dfun id and constant-method ids
+ -- Make the dfun id
let
dfun_id = mkDictFunId dfun_name clas tyvars inst_tys theta
op_sel_ids, defm_ids) = classBigSig clas
-- Instantiate the theta found in the original instance decl
- inst_decl_theta' = substTopTheta (zipVarEnv inst_tyvars (mkTyVarTys inst_tyvars'))
- inst_decl_theta
+ inst_decl_theta' = substTheta (mkTopTyVarSubst inst_tyvars (mkTyVarTys inst_tyvars'))
+ inst_decl_theta
-- Instantiate the super-class context with inst_tys
- sc_theta' = substTopTheta (zipVarEnv class_tyvars inst_tys') sc_theta
+ sc_theta' = substTheta (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
in
-- Create dictionary Ids from the specified instance contexts.
newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) ->
newDicts origin [(clas,inst_tys')] `thenNF_Tc` \ (this_dict, [this_dict_id]) ->
-- Check that all the method bindings come from this class
- let
- check_from_this_class (bndr, loc)
- | nameOccName bndr `elem` sel_names = returnNF_Tc ()
- | otherwise = tcAddSrcLoc loc $
- addErrTc (badMethodErr bndr clas)
- sel_names = map getOccName op_sel_ids
- bndrs = bagToList (collectMonoBinders monobinds)
- in
- mapNF_Tc check_from_this_class bndrs `thenNF_Tc_`
+ checkFromThisClass clas op_sel_ids monobinds `thenNF_Tc_`
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
tcExtendGlobalValEnv (catMaybes defm_ids) (
(op_sel_ids `zip` defm_ids)
)) `thenTc` \ (method_binds_s, insts_needed_s, meth_lies_w_ids) ->
- -- Deal with SPECIALISE instance pragmas
+ -- Deal with SPECIALISE instance pragmas by making them
+ -- look like SPECIALISE pragmas for the dfun
let
- dfun_prags = [Sig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
+ dfun_prags = [SpecSig (idName dfun_id) ty loc | SpecInstSig ty loc <- uprags]
in
tcExtendGlobalValEnv [dfun_id] (
- tcPragmaSigs dfun_prags
- ) `thenTc` \ (prag_info_fn, prag_binds, prag_lie) ->
+ tcSpecSigs dfun_prags
+ ) `thenTc` \ (prag_binds, prag_lie) ->
-- Check the overloading constraints of the methods and superclasses
dict_bind = VarMonoBind this_dict_id dict_rhs
method_binds = andMonoBindList method_binds_s
- final_dfun_id = setIdInfo dfun_id (prag_info_fn (idName dfun_id))
- -- Pretty truesome
main_bind
= AbsBinds
zonked_inst_tyvars
dfun_arg_dicts_ids
- [(inst_tyvars', final_dfun_id, this_dict_id)]
+ [(inst_tyvars', dfun_id, this_dict_id)]
+ emptyNameSet -- No inlines (yet)
(lie_binds1 `AndMonoBinds`
lie_binds2 `AndMonoBinds`
method_binds `AndMonoBinds`
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
-module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType,
+module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind,
tcContext, tcHsTyVar, kcHsTyVar,
tcExtendTyVarScope, tcExtendTopTyVarScope,
- TcSigInfo(..), tcTySig, mkTcSig, noSigs, maybeSig,
+ TcSigInfo(..), tcTySig, mkTcSig, maybeSig,
checkSigTyVars, sigCtxt, sigPatCtxt
) where
mkSigmaTy, mkDictTy, mkTyConApp, mkAppTys, splitForAllTys, splitRhoTy,
boxedTypeKind, unboxedTypeKind, tyVarsOfType,
mkArrowKinds, getTyVar_maybe, getTyVar,
- tidyOpenType, tidyOpenTypes, tidyTyVar, fullSubstTy
+ tidyOpenType, tidyOpenTypes, tidyTyVar
)
-import Id ( mkUserId, idName, idType, idFreeTyVars )
+import Subst ( mkTopTyVarSubst, substTy )
+import Id ( mkVanillaId, idName, idType, idFreeTyVars )
import Var ( TyVar, mkTyVar )
import VarEnv
import VarSet
tc_type ty `thenTc` \ ty' ->
forkNF_Tc (zonkTcTypeToType ty')
+tcHsTopTypeKind :: RenamedHsType -> TcM s (TcKind, Type)
+tcHsTopTypeKind ty
+ = -- tcAddErrCtxt (typeCtxt ty) $
+ tc_type_kind ty `thenTc` \ (kind, ty') ->
+ forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ zonked_ty ->
+ returnNF_Tc (kind, zonked_ty)
+
tcHsTopBoxedType :: RenamedHsType -> TcM s Type
tcHsTopBoxedType ty
= -- tcAddErrCtxt (typeCtxt ty) $
tc_type_kind (HsForAllTy (Just tv_names) context ty)
= tcExtendTyVarScope tv_names $ \ tyvars ->
tcContext context `thenTc` \ theta ->
- case theta of
- [] -> -- No context, so propagate body type
- tc_type_kind ty `thenTc` \ (kind, tau) ->
- returnTc (kind, mkSigmaTy tyvars [] tau)
-
- other -> -- Context; behave like a function type
- -- This matters. Return-unboxed-tuple analysis can
- -- give overloaded functions like
- -- f :: forall a. Num a => (# a->a, a->a #)
- -- And we want these to get through the type checker
-
- tc_type ty `thenTc` \ tau ->
- returnTc (boxedTypeKind, mkSigmaTy tyvars theta tau)
+ tc_type_kind ty `thenTc` \ (kind, tau) ->
+ let
+ body_kind | null theta = kind
+ | otherwise = boxedTypeKind
+ -- Context behaves like a function type
+ -- This matters. Return-unboxed-tuple analysis can
+ -- give overloaded functions like
+ -- f :: forall a. Num a => (# a->a, a->a #)
+ -- And we want these to get through the type checker
+ in
+ returnTc (body_kind, mkSigmaTy tyvars theta tau)
\end{code}
Help functions for type applications
maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name
| name == sig_name = Just sig
| otherwise = maybeSig sigs name
-
--- This little helper is useful to pass to tcPat
-noSigs :: Name -> Maybe TcId
-noSigs name = Nothing
\end{code}
tcTySig (Sig v ty src_loc)
= tcAddSrcLoc src_loc $
tcHsType ty `thenTc` \ sigma_tc_ty ->
- mkTcSig (mkUserId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
+ mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
returnTc sig
mkTcSig :: TcId -> SrcLoc -> NF_TcM s TcSigInfo
let
tyvar_tys' = mkTyVarTys tyvars'
- rho' = fullSubstTy (zipVarEnv tyvars tyvar_tys') emptyVarSet rho
+ rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho
+ -- mkTopTyVarSubst because the tyvars' are fresh
(theta', tau') = splitRhoTy rho'
-- This splitRhoTy tries hard to make sure that tau' is a type synonym
-- wherever possible, which can improve interface files.
projects / ghc-hetmet.git / commitdiff