import {-# SOURCE #-} Subst( substTy, mkTyVarSubst )
import CmdLineOpts ( opt_DictsStrict )
-import Type ( Type, TauType, ClassContext,
+import Type ( Type, TauType, ThetaType,
mkForAllTys, mkFunTys, mkTyConApp,
- mkTyVarTys, mkDictTys,
+ mkTyVarTys, mkPredTys, getClassPredTys_maybe,
splitTyConApp_maybe
)
import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon,
-- These are ALWAYS THE SAME AS THE TYVARS
-- FOR THE PARENT TyCon. We occasionally rely on
-- this just to avoid redundant instantiation
- dcTheta :: ClassContext,
+ dcTheta :: ThetaType,
dcExTyVars :: [TyVar], -- Ditto for the context of the constructor,
- dcExTheta :: ClassContext, -- the existentially quantified stuff
+ dcExTheta :: ThetaType, -- the existentially quantified stuff
dcOrigArgTys :: [Type], -- Original argument types
-- (before unboxing and flattening of
\begin{code}
mkDataCon :: Name
-> [StrictnessMark] -> [FieldLabel]
- -> [TyVar] -> ClassContext
- -> [TyVar] -> ClassContext
+ -> [TyVar] -> ThetaType
+ -> [TyVar] -> ThetaType
-> [TauType] -> TyCon
-> Id -> Id
-> DataCon
(real_arg_stricts, strict_arg_tyss)
= unzip (zipWith (unbox_strict_arg_ty tycon) arg_stricts orig_arg_tys)
- rep_arg_tys = mkDictTys ex_theta ++ concat strict_arg_tyss
+ rep_arg_tys = mkPredTys ex_theta ++ concat strict_arg_tyss
ex_dict_stricts = map mk_dict_strict_mark ex_theta
-- Add a strictness flag for the existential dictionary arguments
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
-mk_dict_strict_mark (clas,tys)
- | opt_DictsStrict &&
- -- Don't mark newtype things as strict!
+mk_dict_strict_mark pred
+ | opt_DictsStrict, -- Don't mark newtype things as strict!
+ Just (clas,_) <- getClassPredTys_maybe pred,
isDataTyCon (classTyCon clas) = MarkedStrict
| otherwise = NotMarkedStrict
\end{code}
go (NotMarkedStrict : ss) = wwLazy : go ss
go (MarkedUnboxed con _ : ss) = go (dcRealStricts con ++ ss)
-dataConSig :: DataCon -> ([TyVar], ClassContext,
- [TyVar], ClassContext,
+dataConSig :: DataCon -> ([TyVar], ThetaType,
+ [TyVar], ThetaType,
[TauType], TyCon)
dataConSig (MkData {dcTyVars = tyvars, dcTheta = theta,
dcExTyVars = ex_tyvars}) inst_tys
= map (substTy (mkTyVarSubst (tyvars ++ ex_tyvars) inst_tys)) arg_tys
-dataConTheta :: DataCon -> ClassContext
+dataConTheta :: DataCon -> ThetaType
dataConTheta dc = dcTheta dc
-- And the same deal for the original arg tys:
import PrelNames ( pREL_ERR, pREL_GHC )
import PrelRules ( primOpRule )
import Rules ( addRule )
-import Type ( Type, ThetaType, mkDictTy, mkDictTys, mkTyConApp, mkTyVarTys,
+import Type ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, mkTyVarTys,
mkFunTys, mkFunTy, mkSigmaTy, splitSigmaTy,
isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
splitFunTys, splitForAllTys, mkPredTy
(tyvars, theta, ex_tyvars, ex_theta, orig_arg_tys, tycon) = dataConSig data_con
all_tyvars = tyvars ++ ex_tyvars
- dict_tys = mkDictTys theta
- ex_dict_tys = mkDictTys ex_theta
+ dict_tys = mkPredTys theta
+ ex_dict_tys = mkPredTys ex_theta
all_arg_tys = dict_tys ++ ex_dict_tys ++ orig_arg_tys
result_ty = mkTyConApp tycon (mkTyVarTys tyvars)
tycon_theta = tyConTheta tycon -- The context on the data decl
-- eg data (Eq a, Ord b) => T a b = ...
- dict_tys = [mkDictTy cls tys | (cls, tys) <- tycon_theta,
- needed_dict (cls, tys)]
+ dict_tys = [mkPredTy pred | pred <- tycon_theta,
+ needed_dict pred]
needed_dict pred = or [ pred `elem` (dataConTheta dc)
| (DataAlt dc, _, _) <- the_alts]
n_dict_tys = length dict_tys
= mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
- info = noCafNoTyGenIdInfo
- -- Type is wired-in (see comment at TcClassDcl.tcClassSig),
- -- so do not generalise it
{- 1 dec 99: disable the Mark Jones optimisation for the sake
of compatibility with Hugs.
-- Type stuff
mkTyVarSubst, mkTopTyVarSubst,
- substTy, substClasses, substTheta,
+ substTy, substTheta,
-- Expression stuff
substExpr, substIdInfo
)
import CoreFVs ( exprFreeVars )
import TypeRep ( Type(..), TyNote(..) ) -- friend
-import Type ( ThetaType, PredType(..), ClassContext,
+import Type ( ThetaType, PredType(..),
tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy
)
import VarSet
substTy subst ty | isEmptySubst subst = ty
| otherwise = subst_ty subst ty
-substClasses :: TyVarSubst -> ClassContext -> ClassContext
-substClasses subst theta
- | isEmptySubst subst = theta
- | otherwise = [(clas, map (subst_ty subst) tys) | (clas, tys) <- theta]
-
substTheta :: TyVarSubst -> ThetaType -> ThetaType
substTheta subst theta
| isEmptySubst subst = theta
| otherwise = map (substPred subst) theta
substPred :: TyVarSubst -> PredType -> PredType
-substPred subst (Class clas tys) = Class clas (map (subst_ty subst) tys)
-substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
+substPred subst (ClassP clas tys) = ClassP clas (map (subst_ty subst) tys)
+substPred subst (IParam n ty) = IParam n (subst_ty subst ty)
subst_ty subst ty
= go ty
NamedThing(..),
)
import Type ( repType, splitTyConApp_maybe,
- tyConAppTyCon, splitFunTys, splitForAllTys,
+ splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, splitAppTy, applyTy, funResultTy
)
#include "HsVersions.h"
import Class ( FunDep )
-import Type ( Type, Kind, PredType(..), ClassContext,
+import Type ( Type, Kind, ThetaType, PredType(..),
splitSigmaTy, liftedTypeKind
)
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
\begin{code}
type HsContext name = [HsPred name]
-data HsPred name = HsPClass name [HsType name]
- | HsPIParam name (HsType name)
+data HsPred name = HsClassP name [HsType name]
+ | HsIParam name (HsType name)
data HsType name
= HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures
(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
-mkHsDictTy cls tys = HsPredTy (HsPClass cls tys)
-mkHsIParamTy v ty = HsPredTy (HsPIParam v ty)
+mkHsDictTy cls tys = HsPredTy (HsClassP cls tys)
+mkHsIParamTy v ty = HsPredTy (HsIParam v ty)
data HsTyVarBndr name
= UserTyVar name
ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind
instance Outputable name => Outputable (HsPred name) where
- ppr (HsPClass clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
- ppr (HsPIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty]
+ ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
+ ppr (HsIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty]
pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
pprHsTyVarBndr name kind | kind == liftedTypeKind = ppr name
-- **! consider dropping usMany annotations ToDo KSW 2000-10
-toHsPred (Class cls tys) = HsPClass (getName cls) (map toHsType tys)
-toHsPred (IParam n ty) = HsPIParam (getName n) (toHsType ty)
+toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys)
+toHsPred (IParam n ty) = HsIParam (getName n) (toHsType ty)
-toHsContext :: ClassContext -> HsContext Name
-toHsContext cxt = [HsPClass (getName cls) (map toHsType tys) | (cls,tys) <- cxt]
+toHsContext :: ThetaType -> HsContext Name
+toHsContext theta = map toHsPred theta
toHsFDs :: [FunDep TyVar] -> [FunDep Name]
toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds]
eq_hsContext env a b = eqListBy (eq_hsPred env) a b
-------------------
-eq_hsPred env (HsPClass c1 tys1) (HsPClass c2 tys2)
+eq_hsPred env (HsClassP c1 tys1) (HsClassP c2 tys2)
= c1 == c2 && eq_hsTypes env tys1 tys2
-eq_hsPred env (HsPIParam n1 ty1) (HsPIParam n2 ty2)
+eq_hsPred env (HsIParam n1 ty1) (HsIParam n2 ty2)
= n1 == n2 && eq_hsType env ty1 ty2
eq_hsPred env _ _ = False
)
import Class ( Class, classTyCon )
import Type ( liftedTypeKind, openTypeKind, unliftedTypeKind,
- isUnLiftedType, isTyVarTy, mkTyVarTy,
+ isUnLiftedType, isTyVarTy, mkTyVarTy, predRepTy,
splitForAllTys, splitFunTys, applyTy, applyTys
)
import TypeRep ( Type(..) )
importsBinds binds = unionImpInfos (map importsBind binds)
importsBind :: StgBinding -> ImportsInfo
-importsBind (StgNonRec b rhs) = importsRhs rhs `unionImpInfo` importsVar b
-importsBind (StgRec pairs) = unionImpInfos (map (\(b,rhs) -> importsRhs rhs `unionImpInfo` importsVar b) pairs)
+importsBind (StgNonRec _ b rhs) = importsRhs rhs `unionImpInfo` importsVar b
+importsBind (StgRec _ pairs) = unionImpInfos (map (\(b,rhs) -> importsRhs rhs `unionImpInfo` importsVar b) pairs)
importsRhs (StgRhsCon _ con args) = importsDataCon con `unionImpInfo` importsStgArgs args
-importsRhs (StgRhsClosure _ _ srt _ upd args body) = importsExpr body `unionImpInfo` importsVars args
+importsRhs (StgRhsClosure _ _ _ upd args body) = importsExpr body `unionImpInfo` importsVars args
importsExpr :: StgExpr -> ImportsInfo
importsExpr (StgLit l) = emptyImpInfo
\begin{code}
ilxBindClosures :: IlxEnv -> StgBinding -> SDoc
-ilxBindClosures env (StgNonRec b rhs) = ilxRhsClosures env (b,rhs)
-ilxBindClosures env (StgRec pairs)
+ilxBindClosures env (StgNonRec _ b rhs) = ilxRhsClosures env (b,rhs)
+ilxBindClosures env (StgRec _ pairs)
= vcat (map (ilxRhsClosures new_env) pairs)
where
new_env = extendIlxEnvWithBinds env pairs
ilxRhsClosures env (bndr, StgRhsCon _ _ _)
= empty
-ilxRhsClosures env (bndr, StgRhsClosure _ _ _ fvs upd args rhs)
+ilxRhsClosures env (bndr, StgRhsClosure _ _ fvs upd args rhs)
= vcat [ilxExprClosures next_env rhs,
empty $$ line,
[(LocalSDoc (idType v, ilxEnvQualifyByExact env (ppr v) <> text "pin", True), Nothing)]
ilxCCallArgLocals _ _ | otherwise = []
-ilxBindLocals env (StgNonRec b rhs) = [(LocalId b,Just (env, rhs))]
-ilxBindLocals env (StgRec pairs) = map (\(x,y) -> (LocalId x,Just (env, y))) pairs
+ilxBindLocals env (StgNonRec _ b rhs) = [(LocalId b,Just (env, rhs))]
+ilxBindLocals env (StgRec _ pairs) = map (\(x,y) -> (LocalId x,Just (env, y))) pairs
ilxAltsLocals env (StgAlgAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxAlgAltLocals env alts)
ilxAltsLocals env (StgPrimAlts _ alts deflt) = ilxDefltLocals env deflt ++ concat (ilxMapPlaceAlts ilxPrimAltLocals env alts)
--BEGIN TEMPORARY
-- The following are versions of a peephole optimizations for "let t = \[] t2[fvs] in t"
-- I think would be subsumed by a general treatmenet of let-no-rec bindings??
-ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec bndr (StgRhsClosure _ _ _ fvs upd [] rhs)) (StgApp fun [])) sequel
+ilxExpr eenv@(IlxEEnv env _) (StgLet (StgNonRec _ bndr (StgRhsClosure _ _ fvs upd [] rhs)) (StgApp fun [])) sequel
| (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
= ilxExpr eenv rhs sequel
-ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec bndr (StgRhsClosure _ _ _ fvs upd [] rhs)) (StgApp fun [])) sequel
+ilxExpr eenv@(IlxEEnv env _) (StgLetNoEscape _ _ (StgNonRec _ bndr (StgRhsClosure _ _ fvs upd [] rhs)) (StgApp fun [])) sequel
| (bndr == fun && null (ilxExprLocals env rhs)) -- TO DO???
= ilxExpr eenv rhs sequel
--END TEMPORARY
where
known_clo =
case lookupIlxBindEnv env fun of
- Just (place, StgRhsClosure _ _ _ _ Updatable _ _) -> Nothing
- Just (place, StgRhsClosure _ _ _ fvs _ args _) -> Just (place,fun,args,fvs)
+ Just (place, StgRhsClosure _ _ _ Updatable _ _) -> Nothing
+ Just (place, StgRhsClosure _ _ fvs _ args _) -> Just (place,fun,args,fvs)
_ -> trace (show fun ++ " --> " ++ show (arityLowerBound (idArityInfo fun))) Nothing
-- Push as many arguments as ILX allows us to in one go.
text "stloc" <+> pprId bndr
]
-ilxRhs env rec (bndr, StgRhsClosure _ _ _ fvs upd args rhs)
+ilxRhs env rec (bndr, StgRhsClosure _ _ fvs upd args rhs)
= -- Assume .closure v<any A>(int64,!A) {
-- .apply <any B> (int32) (B) { ... }
-- }
ilxFixupRec env rec (bndr, StgRhsCon _ con args)
= text "// no recursive fixup"
-ilxFixupRec env rec (bndr, StgRhsClosure _ _ _ fvs upd args rhs)
+ilxFixupRec env rec (bndr, StgRhsClosure _ _ fvs upd args rhs)
= vcat [vcat (map fixFv rec)]
where
fixFv recid = if elem recid fvs then
-- Code for a top-level binding in a module
ilxPairs binds = concat (map ilxPairs1 binds)
-ilxPairs1 (StgNonRec bndr rhs) = [(bndr,rhs)]
-ilxPairs1 (StgRec pairs) = pairs
+ilxPairs1 (StgNonRec _ bndr rhs) = [(bndr,rhs)]
+ilxPairs1 (StgRec _ pairs) = pairs
-ilxRecIds1 (StgNonRec bndr rhs) = []
-ilxRecIds1 (StgRec pairs) = map fst pairs
+ilxRecIds1 (StgNonRec _ bndr rhs) = []
+ilxRecIds1 (StgRec _ pairs) = map fst pairs
---------------------------------------------
-- Code for a top-level binding in a module
ilxTopBind :: Module -> IlxEnv -> [(Id,StgRhs)] -> SDoc
---ilxTopBind mod env (StgNonRec bndr rhs) =
+--ilxTopBind mod env (StgNonRec _ bndr rhs) =
--ilxTopRhs env (bndr,rhs)
ilxTopBind mod env pairs =
vcat [text ".class" <+> pprId mod,
--ilxTopRhs mod env (bndr, _) | isVoidIlxRepId bndr
-- = empty
-ilxTopRhs mod env (bndr, StgRhsClosure _ _ _ fvs upd args rhs)
+ilxTopRhs mod env (bndr, StgRhsClosure _ _ fvs upd args rhs)
= vcat [vcat (map (pushId env) free_vs),
(if null free_non_ilx_tvs then empty else (ilxComment (text "ignored some higher order type arguments in application - code will be non verifiable...."))),
text "newclo" <+> pprIlxBoxedTyConApp env (ilxEnvQualifyByModule env (ppr bndr)) (map mkTyVarTy free_ilx_tvs),
pprFieldRef env (mod,ty,id)
= pprIlxTypeL env ty <+> moduleReference env mod <+> pprId mod <> text "::" <> pprId id
-ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _ _)
+ilxTopRhsStorage mod env (bndr, StgRhsClosure _ _ _ _ _ _)
= text ".field public static " <+> pprIlxTypeL env bndTy <+> pprId bndr
where
bndTy = idIlxRepType bndr
deepIlxRepType (AppTy f x) = AppTy (deepIlxRepType f) (deepIlxRepType x)
deepIlxRepType (ForAllTy b ty) = ForAllTy b (deepIlxRepType ty)
deepIlxRepType (NoteTy _ ty) = deepIlxRepType ty
+deepIlxRepType (PredTy p) = deepIlxRepType (predRepTy p)
deepIlxRepType ty@(TyVarTy tv) = ty
idIlxRepType id = deepIlxRepType (idType id)
import TmpFiles ( newTempName )
import IO ( IOMode(..), hClose, openFile, Handle )
+import IO ( hPutStr, stderr) -- Debugging
\end{code}
doOutput :: String -> (Handle -> IO ()) -> IO ()
doOutput filenm io_action
- = (do handle <- openFile filenm WriteMode
+ = (do hPutStr stderr ("Writing to" ++ filenm)
+ handle <- openFile filenm WriteMode
io_action handle
hClose handle)
`catch` (\err -> pprPanic "Failed to open or write code output file"
-----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.53 2001/03/06 15:00:25 rrt Exp $
+-- $Id: DriverPipeline.hs,v 1.54 2001/03/13 14:58:26 simonpj Exp $
--
-- GHC Driver
--
HscC -> newTempName (phaseInputExt HCc)
HscJava -> newTempName "java" -- ToDo
#ifdef ILX
- HscILX -> newTempName (phaseInputExt Ilx)
+ HscILX -> newTempName "ilx" -- ToDo
#endif
HscInterpreted -> return (error "no output file")
checkPred :: RdrNameHsType -> [RdrNameHsType]
-> P (HsPred RdrName)
checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t)
- = returnP (HsPClass t args)
+ = returnP (HsClassP t args)
checkPred (HsAppTy l r) args = checkPred l (r:args)
-checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty)
+checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty)
checkPred _ _ = parseError "Illegal class assertion"
checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType
extract_ctxt ctxt acc = foldr extract_pred acc ctxt
-extract_pred (HsPClass cls tys) acc = foldr extract_ty (cls : acc) tys
-extract_pred (HsPIParam n ty) acc = extract_ty ty acc
+extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys
+extract_pred (HsIParam n ty) acc = extract_ty ty acc
extract_tys tys = foldr extract_ty [] tys
import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTys,
mkArrowKinds, liftedTypeKind, unliftedTypeKind,
splitTyConApp_maybe, repType,
- TauType, ClassContext )
+ TauType, ThetaType )
import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique )
import PrelNames
import CmdLineOpts
name1 = mkWiredInName mod occ_name1 fn1_key
name2 = mkWiredInName mod occ_name2 fn2_key
-pcDataCon :: Name -> [TyVar] -> ClassContext -> [TauType] -> TyCon -> DataCon
+pcDataCon :: Name -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> DataCon
-- The unique is the first of two free uniques;
-- the first is used for the datacon itself and the worker;
-- the second is used for the wrapper.
| class ',' context_list1 { $1 : $3 }
class :: { HsPred RdrName }
-class : qcls_name atypes { (HsPClass $1 $2) }
- | ipvar_name '::' type { (HsPIParam $1 $3) }
+class : qcls_name atypes { (HsClassP $1 $2) }
+ | ipvar_name '::' type { (HsIParam $1 $3) }
types0 :: { [RdrNameHsType] {- Zero or more -} }
types0 : {- empty -} { [ ] }
-- You don't import or export implicit parameters,
-- so don't mention the IP names
-extractHsPredTyNames (HsPClass cls tys)
+extractHsPredTyNames (HsClassP cls tys)
= unitNameSet cls `unionNameSets` extractHsTyNames_s tys
-extractHsPredTyNames (HsPIParam n ty)
+extractHsPredTyNames (HsIParam n ty)
= extractHsTyNames ty
\end{code}
(naughtyCCallContextErr pred') `thenRn_`
returnRn pred'
- bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys
+ bad_pred (HsClassP clas _) = getUnique clas `elem` cCallishClassKeys
bad_pred other = False
-rnPred doc (HsPClass clas tys)
+rnPred doc (HsClassP clas tys)
= lookupOccRn clas `thenRn` \ clas_name ->
rnHsTypes doc tys `thenRn` \ tys' ->
- returnRn (HsPClass clas_name tys')
+ returnRn (HsClassP clas_name tys')
-rnPred doc (HsPIParam n ty)
+rnPred doc (HsIParam n ty)
= newIPName n `thenRn` \ name ->
rnHsType doc ty `thenRn` \ ty' ->
- returnRn (HsPIParam name ty')
+ returnRn (HsIParam name ty')
\end{code}
\begin{code}
ptext SLIT("in the context:")],
nest 4 (pprHsContext ctxt <+> ptext SLIT("..."))]
-naughtyCCallContextErr (HsPClass clas _)
+naughtyCCallContextErr (HsClassP clas _)
= sep [ptext SLIT("Can't use class") <+> quotes (ppr clas),
ptext SLIT("in a context")]
\end{code}
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
Inst,
- pprInst, pprInsts, pprInstsInFull, tidyInst, tidyInsts,
+ pprInst, pprInsts, pprInstsInFull, tidyInsts,
- newDictsFromOld, newDicts, newClassDicts,
+ newDictsFromOld, newDicts,
newMethod, newMethodWithGivenTy, newOverloadedLit,
newIPDict, tcInstId,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, instLoc, getDictClassTys,
getIPs,
- predsOfInsts,
+ predsOfInsts, predsOfInst,
lookupInst, lookupSimpleInst, LookupInstResult(..),
isTyVarDict, isStdClassTyVarDict, isMethodFor,
instBindingRequired, instCanBeGeneralised,
- zonkInst, zonkInsts,
+ zonkInst, zonkInsts,
instToId,
InstOrigin(..), InstLoc, pprInstLoc
import TcMonad
import TcEnv ( TcIdSet, tcGetInstEnv, tcLookupSyntaxId )
import InstEnv ( InstLookupResult(..), lookupInstEnv )
-import TcType ( TcThetaType, TcClassContext,
+import TcType ( TcThetaType,
TcType, TcTauType, TcTyVarSet,
- zonkTcType, zonkTcTypes,
+ zonkTcType, zonkTcTypes, zonkTcPredType,
zonkTcThetaType, tcInstTyVar, tcInstType
)
import CoreFVs ( idFreeTyVars )
import Class ( Class )
import Id ( Id, idType, mkUserLocal, mkSysLocal, mkLocalId )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
-import Name ( mkDictOcc, mkMethodOcc, getOccName, mkLocalName )
+import Name ( mkMethodOcc, getOccName )
import NameSet ( NameSet )
import PprType ( pprPred )
-import Type ( Type, PredType(..),
+import Type ( Type, PredType(..), ThetaType,
isTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys,
splitForAllTys, splitSigmaTy, funArgTy,
- splitMethodTy, splitRhoTy, classesOfPreds,
- tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
- tidyOpenType, tidyOpenTypes, predMentionsIPs
+ splitMethodTy, splitRhoTy,
+ tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
+ predMentionsIPs, isClassPred, isTyVarClassPred,
+ getClassPredTys, getClassPredTys_maybe, mkPredName,
+ tidyType, tidyTypes, tidyFreeTyVars
)
import Subst ( emptyInScopeSet, mkSubst,
- substTy, substClasses, mkTyVarSubst, mkTopTyVarSubst
+ substTy, substTheta, mkTyVarSubst, mkTopTyVarSubst
)
import Literal ( inIntRange )
import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) )
isIntegerTy
)
import PrelNames( fromIntegerName, fromRationalName )
-import Util ( thenCmp, zipWithEqual, mapAccumL )
+import Util ( thenCmp, zipWithEqual )
import Bag
import Outputable
\end{code}
instLoc (Method _ _ _ _ _ loc) = loc
instLoc (LitInst _ _ _ loc) = loc
-getDictClassTys (Dict _ (Class clas tys) _) = (clas, tys)
+getDictClassTys (Dict _ pred _) = getClassPredTys pred
predsOfInsts :: [Inst] -> [PredType]
predsOfInsts insts = concatMap predsOfInst insts
isDict other = False
isClassDict :: Inst -> Bool
-isClassDict (Dict _ (Class _ _) _) = True
-isClassDict other = False
+isClassDict (Dict _ pred _) = isClassPred pred
+isClassDict other = False
+
+isTyVarDict :: Inst -> Bool
+isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
+isTyVarDict other = False
isMethod :: Inst -> Bool
isMethod (Method _ _ _ _ _ _) = True
instMentionsIPs (Method _ _ _ theta _ _) ip_names = any (`predMentionsIPs` ip_names) theta
instMentionsIPs other ip_names = False
-isTyVarDict :: Inst -> Bool
-isTyVarDict (Dict _ (Class _ tys) _) = all isTyVarTy tys
-isTyVarDict other = False
-
-isStdClassTyVarDict (Dict _ (Class clas [ty]) _)
- = isStandardClass clas && isTyVarTy ty
-isStdClassTyVarDict other
- = False
+isStdClassTyVarDict (Dict _ pred _) = case getClassPredTys_maybe pred of
+ Just (clas, [ty]) -> isStandardClass clas && isTyVarTy ty
+ other -> False
\end{code}
Two predicates which deal with the case where class constraints don't
\begin{code}
instBindingRequired :: Inst -> Bool
-instBindingRequired (Dict _ (Class clas _) _) = not (isNoDictClass clas)
-instBindingRequired (Dict _ (IParam _ _) _) = False
-instBindingRequired other = True
+instBindingRequired (Dict _ (ClassP clas _) _) = not (isNoDictClass clas)
+instBindingRequired (Dict _ (IParam _ _) _) = False
+instBindingRequired other = True
instCanBeGeneralised :: Inst -> Bool
-instCanBeGeneralised (Dict _ (Class clas _) _) = not (isCcallishClass clas)
-instCanBeGeneralised other = True
+instCanBeGeneralised (Dict _ (ClassP clas _) _) = not (isCcallishClass clas)
+instCanBeGeneralised other = True
\end{code}
= tcGetInstLoc orig `thenNF_Tc` \ loc ->
newDictsAtLoc loc theta
-newClassDicts :: InstOrigin
- -> TcClassContext
- -> NF_TcM [Inst]
-newClassDicts orig theta = newDicts orig (map (uncurry Class) theta)
-
-newDictsFromOld :: Inst -> TcClassContext -> NF_TcM [Inst]
-newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc (map (uncurry Class) theta)
+newDictsFromOld :: Inst -> TcThetaType -> NF_TcM [Inst]
+newDictsFromOld (Dict _ _ loc) theta = newDictsAtLoc loc theta
-- Local function, similar to newDicts,
-- but with slightly different interface
= tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta)
where
- mk_dict uniq pred = Dict (mkLocalId (mk_dict_name uniq pred) (mkPredTy pred)) pred inst_loc
-
- mk_dict_name uniq (Class cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
- mk_dict_name uniq (IParam name ty) = name
+ mk_dict uniq pred = Dict (mkLocalId (mkPredName uniq loc pred) (mkPredTy pred)) pred inst_loc
newIPDict orig name ty
= tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
need, and it's a lot of extra work.
\begin{code}
-zonkPred :: TcPredType -> NF_TcM TcPredType
-zonkPred (Class clas tys)
- = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
- returnNF_Tc (Class clas new_tys)
-zonkPred (IParam n ty)
- = zonkTcType ty `thenNF_Tc` \ new_ty ->
- returnNF_Tc (IParam n new_ty)
-
zonkInst :: Inst -> NF_TcM Inst
zonkInst (Dict id pred loc)
- = zonkPred pred `thenNF_Tc` \ new_pred ->
+ = zonkTcPredType pred `thenNF_Tc` \ new_pred ->
returnNF_Tc (Dict id new_pred loc)
zonkInst (Method m id tys theta tau loc)
show_uniq u,
ppr (instToId m) -}]
-tidyPred :: TidyEnv -> TcPredType -> (TidyEnv, TcPredType)
-tidyPred env (Class clas tys)
- = (env', Class clas tys')
- where
- (env', tys') = tidyOpenTypes env tys
-tidyPred env (IParam n ty)
- = (env', IParam n ty')
- where
- (env', ty') = tidyOpenType env ty
+show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
-tidyInst :: TidyEnv -> Inst -> (TidyEnv, Inst)
-tidyInst env (LitInst u lit ty loc)
- = (env', LitInst u lit ty' loc)
- where
- (env', ty') = tidyOpenType env ty
+tidyInst :: TidyEnv -> Inst -> Inst
+tidyInst env (LitInst u lit ty loc) = LitInst u lit (tidyType env ty) loc
+tidyInst env (Dict u pred loc) = Dict u (tidyPred env pred) loc
+tidyInst env (Method u id tys theta tau loc) = Method u id (tidyTypes env tys) theta tau loc
-tidyInst env (Dict u pred loc)
- = (env', Dict u pred' loc)
+tidyInsts :: [Inst] -> (TidyEnv, [Inst])
+-- This function doesn't assume that the tyvars are in scope
+-- so it works like tidyOpenType, returning a TidyEnv
+tidyInsts insts
+ = (env, map (tidyInst env) insts)
where
- (env', pred') = tidyPred env pred
-
-tidyInst env (Method u id tys theta tau loc)
- = (env', Method u id tys' theta tau loc)
- -- Leave theta, tau alone cos we don't print them
- where
- (env', tys') = tidyOpenTypes env tys
-
-tidyInsts env insts = mapAccumL tidyInst env insts
-
-show_uniq u = ifPprDebug (text "{-" <> ppr u <> text "-}")
+ env = tidyFreeTyVars emptyTidyEnv (tyVarsOfInsts insts)
\end{code}
-- Dictionaries
-lookupInst dict@(Dict _ (Class clas tys) loc)
+lookupInst dict@(Dict _ (ClassP clas tys) loc)
= tcGetInstEnv `thenNF_Tc` \ inst_env ->
case lookupInstEnv inst_env clas tys of
\begin{code}
lookupSimpleInst :: Class
-> [Type] -- Look up (c,t)
- -> NF_TcM (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s
+ -> 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
FoundInst tenv dfun
- -> returnNF_Tc (Just (substClasses (mkSubst emptyInScopeSet tenv) theta'))
+ -> returnNF_Tc (Just (substTheta (mkSubst emptyInScopeSet tenv) theta))
where
(_, theta, _) = splitSigmaTy (idType dfun)
- theta' = classesOfPreds theta
other -> returnNF_Tc Nothing
\end{code}
tcExtendLocalValEnv, tcExtendTyVarEnv
)
import TcBinds ( tcBindWithSigs, tcSpecSigs )
-import TcMonoType ( tcHsRecType, tcRecClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
+import TcMonoType ( tcHsRecType, tcRecTheta, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcType ( TcType, TcTyVar, tcInstTyVars )
import TcMonad
import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
import NameSet ( emptyNameSet )
import Outputable
-import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,
+import Type ( Type, ThetaType, mkTyVarTys, mkPredTys, mkClassPred,
splitTyConApp_maybe, isTyVarTy
)
import Var ( TyVar )
-- MAKE THE CLASS DETAILS
let
(op_tys, op_items) = unzip sig_stuff
- sc_tys = mkDictTys sc_theta
+ sc_tys = mkPredTys sc_theta
dict_component_tys = sc_tys ++ op_tys
dict_con = mkDataCon datacon_name
tcSuperClasses :: RecFlag -> Bool -> Class
-> RenamedContext -- class context
-> [Name] -- Names for superclass selectors
- -> TcM (ClassContext, -- the superclass context
- [Id]) -- superclass selector Ids
+ -> TcM (ThetaType, -- the superclass context
+ [Id]) -- superclass selector Ids
tcSuperClasses is_rec gla_exts clas context sc_sel_names
- = -- Check the context.
+ = ASSERT( length context == length sc_sel_names )
+ -- Check the context.
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
-- For std Haskell check that the context constrains only tyvars
- (if gla_exts then
- returnTc ()
- else
- mapTc_ check_constraint context
- ) `thenTc_`
+ mapTc_ check_constraint context `thenTc_`
-- Context is already kind-checked
- tcRecClassContext is_rec context `thenTc` \ sc_theta ->
+ tcRecTheta is_rec context `thenTc` \ sc_theta ->
let
sc_sel_ids = [mkDictSelId sc_name clas | sc_name <- sc_sel_names]
in
returnTc (sc_theta, sc_sel_ids)
where
- check_constraint sc@(HsPClass c tys)
- = checkTc (all is_tyvar tys) (superClassErr clas sc)
+ check_constraint sc = checkTc (ok sc) (superClassErr clas sc)
+ ok (HsClassP c tys) | gla_exts = True
+ | otherwise = all is_tyvar tys
+ ok (HsIParam _ _) = False -- Never legal
is_tyvar (HsTyVar _) = True
is_tyvar other = False
import TcSimplify ( tcSimplifyCheckThetas )
import TysWiredIn ( integerTy, doubleTy )
-import Type ( Type )
+import Type ( Type, mkClassPred )
import PrelNames ( numClassName )
import Outputable
import HscTypes ( TyThing(..) )
tcAddErrCtxt defaultDeclCtxt $
tcSimplifyCheckThetas
[{- Nothing given -}]
- [ (num_class, [ty]) | ty <- tau_tys ] `thenTc_`
+ [ mkClassPred num_class [ty] | ty <- tau_tys ] `thenTc_`
returnTc tau_tys
tyConTheta, maybeTyConSingleCon, isDataTyCon,
isEnumerationTyCon, TyCon
)
-import Type ( TauType, PredType(..), mkTyVarTys, mkTyConApp,
- isUnLiftedType )
+import Type ( TauType, ThetaType, PredType, mkTyVarTys, mkTyConApp,
+ isUnLiftedType, mkClassPred )
import Var ( TyVar )
import PrelNames
import Util ( zipWithEqual, sortLt )
-- The Name is the name for the DFun we'll build
-- The tyvars bind all the variables in the RHS
-type DerivRhs = [(Class, [TauType])] -- Same as a ThetaType!
- --[PredType] -- ... | Class Class [Type==TauType]
-
+type DerivRhs = ThetaType
type DerivSoln = DerivRhs
\end{code}
offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys
mk_constraints data_con
- = [ (clas, [arg_ty])
+ = [ mkClassPred clas [arg_ty]
| arg_ty <- dataConArgTys data_con tyvar_tys,
not (isUnLiftedType arg_ty) -- No constraints for unlifted types?
]
-- They'll appear later, when we do the top-level extendInstEnvs
mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta
- = mkDictFunId dfun_name clas tyvars [mkTyConApp tycon (mkTyVarTys tyvars)]
- (map pair2PredType theta)
-
- pair2PredType (clas, tautypes) = Class clas tautypes
+ = mkDictFunId dfun_name clas tyvars
+ [mkTyConApp tycon (mkTyVarTys tyvars)]
+ theta
\end{code}
%************************************************************************
import IdInfo ( vanillaIdInfo )
import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
import VarSet
-import Type ( Type,
+import Type ( Type, ThetaType,
tyVarsOfTypes, splitDFunTy,
getDFunTyKey, tyConAppTyCon
)
import DataCon ( DataCon )
import TyCon ( TyCon )
-import Class ( Class, ClassOpItem, ClassContext )
+import Class ( Class, ClassOpItem )
import Name ( Name, OccName, NamedThing(..),
nameOccName, getSrcLoc, mkLocalName, isLocalName,
nameIsLocalOrFrom
-- This data type is used to help tie the knot
-- when type checking type and class declarations
data TyThingDetails = SynTyDetails Type
- | DataTyDetails ClassContext [DataCon] [Id]
- | ClassDetails ClassContext [Id] [ClassOpItem] DataCon
+ | DataTyDetails ThetaType [DataCon] [Id]
+ | ClassDetails ThetaType [Id] [ClassOpItem] DataCon
\end{code}
import Inst ( InstOrigin(..),
LIE, mkLIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
newOverloadedLit, newMethod, newIPDict,
- newDicts, newClassDicts,
+ newDicts,
instToId, tcInstId
)
import TcBinds ( tcBindsAndThen )
import Name ( Name )
import Type ( mkFunTy, mkAppTy, mkTyConTy,
splitFunTy_maybe, splitFunTys,
- mkTyConApp, splitSigmaTy,
+ mkTyConApp, splitSigmaTy, mkClassPred,
isTauTy, tyVarsOfType, tyVarsOfTypes,
isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
liftedTypeKind, openTypeKind, mkArrowKind,
tidyOpenType
)
import TyCon ( TyCon, tyConTyVars )
-import Subst ( mkTopTyVarSubst, substClasses, substTy )
+import Subst ( mkTopTyVarSubst, substTheta, substTy )
import VarSet ( elemVarSet )
import TysWiredIn ( boolTy, mkListTy, listTyCon )
import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon ->
let
new_arg_dict (arg, arg_ty)
- = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
- [(cCallableClass, [arg_ty])] `thenNF_Tc` \ arg_dicts ->
+ = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
+ [mkClassPred cCallableClass [arg_ty]] `thenNF_Tc` \ arg_dicts ->
returnNF_Tc arg_dicts -- Actually a singleton bag
result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
-- Construct the extra insts, which encode the
-- constraints on the argument and result types.
mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s ->
- newClassDicts result_origin [(cReturnableClass, [result_ty])] `thenNF_Tc` \ ccres_dict ->
+ newDicts result_origin [mkClassPred cReturnableClass [result_ty]] `thenNF_Tc` \ ccres_dict ->
returnTc (HsCCall lbl args' may_gc is_asm io_result_ty,
mkLIE (ccres_dict ++ concat ccarg_dicts_s) `plusLIE` args_lie)
\end{code}
let
(tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
inst_env = mkTopTyVarSubst tyvars result_inst_tys
- theta' = substClasses inst_env theta
+ theta' = substTheta inst_env theta
in
- newClassDicts RecordUpdOrigin theta' `thenNF_Tc` \ dicts ->
+ newDicts RecordUpdOrigin theta' `thenNF_Tc` \ dicts ->
-- Phew!
returnTc (RecordUpdOut record_expr' result_record_ty (map instToId dicts) rbinds',
tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
tcLit (HsLitLit s _) res_ty
= tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass ->
- newClassDicts (LitLitOrigin (_UNPK_ s))
- [(cCallableClass,[res_ty])] `thenNF_Tc` \ dicts ->
+ newDicts (LitLitOrigin (_UNPK_ s))
+ [mkClassPred cCallableClass [res_ty]] `thenNF_Tc` \ dicts ->
returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)
tcLit lit res_ty
import TcMonad
import TcType ( tcInstType )
import Inst ( InstOrigin(..),
- newDicts, newClassDicts, instToId,
+ newDicts, instToId,
LIE, mkLIE, emptyLIE, plusLIE, plusLIEs )
import TcDeriv ( tcDeriving )
import TcEnv ( TcEnv, tcExtendGlobalValEnv,
splitTyConApp_maybe, splitDictTy,
splitForAllTys,
tyVarsOfTypes, mkClassPred, mkTyVarTy,
- getClassTys_maybe
+ isTyVarClassPred, inheritablePred
)
-import Subst ( mkTopTyVarSubst, substClasses )
+import Subst ( mkTopTyVarSubst, substTheta )
import VarSet ( varSetElems )
import TysWiredIn ( genericTyCons, isFFIArgumentTy, isFFIImportResultTy )
import PrelNames ( cCallableClassKey, cReturnableClassKey, hasKey )
sel_names = [idName sel_id | (sel_id, _) <- op_items]
-- Instantiate the super-class context with inst_tys
- sc_theta' = substClasses (mkTopTyVarSubst class_tyvars inst_tys') sc_theta
+ 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
mapTc (addErrTc . badMethodErr clas) bad_bndrs `thenNF_Tc_`
-- Create dictionary Ids from the specified instance contexts.
- newClassDicts origin sc_theta' `thenNF_Tc` \ sc_dicts ->
- newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts ->
- newClassDicts origin [(clas,inst_tys')] `thenNF_Tc` \ [this_dict] ->
+ newDicts origin sc_theta' `thenNF_Tc` \ sc_dicts ->
+ newDicts origin dfun_theta' `thenNF_Tc` \ dfun_arg_dicts ->
+ newDicts origin [mkClassPred clas inst_tys'] `thenNF_Tc` \ [this_dict] ->
tcExtendTyVarEnvForMeths inst_tyvars inst_tyvars' (
tcExtendGlobalValEnv dm_ids (
[err | pred <- theta, err <- checkInstConstraint dflags pred]
checkInstConstraint dflags pred
- | dopt Opt_AllowUndecidableInstances dflags
- = []
+ -- Checks whether a predicate is legal in the
+ -- context of an instance declaration
+ | ok = []
+ | otherwise = [instConstraintErr pred]
+ where
+ ok = inheritablePred pred &&
+ (isTyVarClassPred pred || arbitrary_preds_ok)
- | Just (clas,tys) <- getClassTys_maybe pred,
- all isTyVarTy tys
- = []
+ arbitrary_preds_ok = dopt Opt_AllowUndecidableInstances dflags
- | otherwise
- = [instConstraintErr pred]
checkInstHead dflags theta clas inst_taus
| -- CCALL CHECK
module TcMonad(
TcType,
TcTauType, TcPredType, TcThetaType, TcRhoType,
- TcTyVar, TcTyVarSet, TcClassContext,
+ TcTyVar, TcTyVarSet,
TcKind,
TcM, NF_TcM, TcDown, TcEnv,
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
-import Class ( Class, ClassContext )
+import Class ( Class )
import Name ( Name )
import Var ( Id, TyVar, newMutTyVar, newSigTyVar, readMutTyVar, writeMutTyVar )
import VarEnv ( TidyEnv, emptyTidyEnv )
-- a cannot occur inside a MutTyVar in T; that is,
-- T is "flattened" before quantifying over a
-type TcClassContext = ClassContext
type TcPredType = PredType
type TcThetaType = ThetaType
type TcRhoType = RhoType
\begin{code}
module TcMonoType ( tcHsType, tcHsRecType, tcIfaceType,
tcHsSigType, tcHsLiftedSigType,
- tcRecClassContext, checkAmbiguity,
+ tcRecTheta, checkAmbiguity,
-- Kind checking
kcHsTyVar, kcHsTyVars, mkTyClTyVars,
mkArrowKinds, getTyVar_maybe, getTyVar, splitFunTy_maybe,
tidyOpenType, tidyOpenTypes, tidyTyVar, tidyTyVars,
tyVarsOfType, tyVarsOfPred, mkForAllTys,
- classesOfPreds, isUnboxedTupleType, isForAllTy
+ isUnboxedTupleType, isForAllTy, isIPPred
)
import PprType ( pprType, pprPred )
import Subst ( mkTopTyVarSubst, substTy )
import VarSet
import ErrUtils ( Message )
import TyCon ( TyCon, isSynTyCon, tyConArity, tyConKind )
-import Class ( ClassContext, classArity, classTyCon )
+import Class ( classArity, classTyCon )
import Name ( Name )
import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon )
import BasicTypes ( Boxity(..), RecFlag(..), isRec )
kcHsContext ctxt = mapTc_ kcHsPred ctxt
kcHsPred :: RenamedHsPred -> TcM ()
-kcHsPred pred@(HsPIParam name ty)
+kcHsPred pred@(HsIParam name ty)
= tcAddErrCtxt (appKindCtxt (ppr pred)) $
kcLiftedType ty
-kcHsPred pred@(HsPClass cls tys)
+kcHsPred pred@(HsClassP cls tys)
= tcAddErrCtxt (appKindCtxt (ppr pred)) $
kcClass cls `thenTc` \ kind ->
mapTc kcHsType tys `thenTc` \ arg_kinds ->
kind_check = kcHsContext ctxt `thenTc_` kcHsType ty
in
tcHsTyVars tv_names kind_check $ \ tyvars ->
- tc_context wimp_out ctxt `thenTc` \ theta ->
+ tcRecTheta wimp_out ctxt `thenTc` \ theta ->
-- Context behaves like a function type
-- This matters. Return-unboxed-tuple analysis can
Contexts
~~~~~~~~
\begin{code}
-tcRecClassContext :: RecFlag -> RenamedContext -> TcM ClassContext
+tcRecTheta :: RecFlag -> RenamedContext -> TcM ThetaType
-- Used when we are expecting a ClassContext (i.e. no implicit params)
-tcRecClassContext wimp_out context
- = tc_context wimp_out context `thenTc` \ theta ->
- returnTc (classesOfPreds theta)
+tcRecTheta wimp_out context = mapTc (tc_pred wimp_out) context
-tc_context :: RecFlag -> RenamedContext -> TcM ThetaType
-tc_context wimp_out context = mapTc (tc_pred wimp_out) context
-
-tc_pred wimp_out assn@(HsPClass class_name tys)
+tc_pred wimp_out assn@(HsClassP class_name tys)
= tcAddErrCtxt (appKindCtxt (ppr assn)) $
tc_arg_types wimp_out tys `thenTc` \ arg_tys ->
tcLookupGlobal class_name `thenTc` \ thing ->
case thing of
AClass clas -> checkTc (arity == n_tys) err `thenTc_`
- returnTc (Class clas arg_tys)
+ returnTc (ClassP clas arg_tys)
where
arity = classArity clas
n_tys = length tys
other -> failWithTc (wrongThingErr "class" (AGlobal thing) class_name)
-tc_pred wimp_out assn@(HsPIParam name ty)
+tc_pred wimp_out assn@(HsIParam name ty)
= tcAddErrCtxt (appKindCtxt (ppr assn)) $
tc_arg_type wimp_out ty `thenTc` \ arg_ty ->
returnTc (IParam name arg_ty)
not (ct_var `elemVarSet` extended_tau_vars)
is_free ct_var = not (ct_var `elem` forall_tyvars)
- check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_`
- checkTc (is_ip pred || not all_free) (freeErr pred sigma_ty)
+ check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_`
+ checkTc (isIPPred pred || not all_free) (freeErr pred sigma_ty)
where
ct_vars = varSetElems (tyVarsOfPred pred)
all_free = all is_free ct_vars
any_ambig = is_source_polytype && any is_ambig ct_vars
- is_ip (IParam _ _) = True
- is_ip _ = False
\end{code}
%************************************************************************
import TcMonad
import Inst ( InstOrigin(..),
emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId,
- newMethod, newOverloadedLit, newDicts, newClassDicts
+ newMethod, newOverloadedLit, newDicts
)
import Id ( mkLocalId )
import Name ( Name )
dataConSourceArity
)
import Type ( isTauTy, mkTyConApp, mkClassPred, liftedTypeKind )
-import Subst ( substTy, substClasses )
+import Subst ( substTy, substTheta )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
in
tcInstTyVars (ex_tvs ++ tvs) `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
let
- ex_theta' = substClasses tenv ex_theta
+ ex_theta' = substTheta tenv ex_theta
arg_tys' = map (substTy tenv) arg_tys
n_ex_tvs = length ex_tvs
ex_tvs' = take n_ex_tvs all_tvs'
result_ty = mkTyConApp tycon (drop n_ex_tvs ty_args')
in
- newClassDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts ->
+ newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts ->
-- Check overall type matches
unifyTauTy pat_ty result_ty `thenTc_`
module TcSimplify (
tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyCheck,
tcSimplifyToDicts, tcSimplifyIPs, tcSimplifyTop,
+
tcSimplifyThetas, tcSimplifyCheckThetas,
bindInstsOfLocalFuns
) where
import TcMonad
import Inst ( lookupInst, lookupSimpleInst, LookupInstResult(..),
- tyVarsOfInst, predsOfInsts,
+ tyVarsOfInst, predsOfInsts, predsOfInst,
isDict, isClassDict,
isStdClassTyVarDict, isMethodFor,
instToId, tyVarsOfInsts,
instBindingRequired, instCanBeGeneralised,
newDictsFromOld, instMentionsIPs,
- getDictClassTys, getIPs, isTyVarDict,
- instLoc, pprInst, zonkInst, tidyInst, tidyInsts,
+ getDictClassTys, isTyVarDict,
+ instLoc, pprInst, zonkInst, tidyInsts,
Inst, LIE, pprInsts, pprInstsInFull,
mkLIE, lieToList
)
import Id ( idType )
import Name ( Name )
import NameSet ( mkNameSet )
-import Class ( Class, classBigSig )
+import Class ( classBigSig )
import FunDeps ( oclose, grow, improve )
import PrelInfo ( isNumericClass, isCreturnableClass, isCcallishClass )
-import Type ( Type, ClassContext,
- mkTyVarTy, getTyVar,
- isTyVarTy, splitSigmaTy, tyVarsOfTypes
+import Type ( Type, ThetaType, PredType, mkClassPred,
+ mkTyVarTy, getTyVar, isTyVarClassPred,
+ splitSigmaTy, tyVarsOfPred,
+ getClassPredTys_maybe, isClassPred, isIPPred,
+ inheritablePred
)
-import Subst ( mkTopTyVarSubst, substClasses, substTy )
-import PprType ( pprClassPred )
+import Subst ( mkTopTyVarSubst, substTheta, substTy )
import TysWiredIn ( unitTy )
import VarSet
import FiniteMap
import Outputable
import ListSetOps ( equivClasses )
-import Util ( zipEqual, mapAccumL )
+import Util ( zipEqual )
import List ( partition )
import CmdLineOpts
\end{code}
\begin{code}
isFree qtvs inst
= not (tyVarsOfInst inst `intersectsVarSet` qtvs) -- Constrains no quantified vars
- && null (getIPs inst) -- And no implicit parameter involved
+ && all inheritablePred (predsOfInst inst) -- And no implicit parameter involved
-- (see "Notes on implicit parameters")
\end{code}
where
(clas, tys) = getDictClassTys dict
(tyvars, sc_theta, sc_sels, _) = classBigSig clas
- sc_theta' = substClasses (mkTopTyVarSubst tyvars tys) sc_theta
+ sc_theta' = substTheta (mkTopTyVarSubst tyvars tys) sc_theta
add_sc avails (sc_dict, sc_sel) -- Add it, and its superclasses
= case lookupFM avails sc_dict of
try_default (default_ty : default_tys)
= tryTc_ (try_default default_tys) $ -- If default_ty fails, we try
-- default_tys instead
- tcSimplifyCheckThetas [] thetas `thenTc` \ _ ->
+ tcSimplifyCheckThetas [] theta `thenTc` \ _ ->
returnTc default_ty
where
- thetas = classes `zip` repeat [default_ty]
+ theta = [mkClassPred clas [default_ty] | clas <- classes]
in
-- See if any default works, and if so bind the type variable to it
-- If not, add an AmbigErr
instance declarations.
\begin{code}
-tcSimplifyThetas :: ClassContext -- Wanted
- -> TcM ClassContext -- Needed
+tcSimplifyThetas :: ThetaType -- Wanted
+ -> TcM ThetaType -- Needed
tcSimplifyThetas wanteds
= doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts ->
-- we expect an instance here
-- For Haskell 98, check that all the constraints are of the form C a,
-- where a is a type variable
- bad_guys | glaExts = [ct | ct@(clas,tys) <- irreds,
- isEmptyVarSet (tyVarsOfTypes tys)]
- | otherwise = [ct | ct@(clas,tys) <- irreds,
- not (all isTyVarTy tys)]
+ bad_guys | glaExts = [pred | pred <- irreds,
+ isEmptyVarSet (tyVarsOfPred pred)]
+ | otherwise = [pred | pred <- irreds,
+ not (isTyVarClassPred pred)]
in
if null bad_guys then
returnTc irreds
whether it worked or not.
\begin{code}
-tcSimplifyCheckThetas :: ClassContext -- Given
- -> ClassContext -- Wanted
+tcSimplifyCheckThetas :: ThetaType -- Given
+ -> ThetaType -- Wanted
-> TcM ()
tcSimplifyCheckThetas givens wanteds
\begin{code}
-type AvailsSimple = FiniteMap (Class,[Type]) Bool
+type AvailsSimple = FiniteMap PredType Bool
-- True => irreducible
-- False => given, or can be derived from a given or from an irreducible
-reduceSimple :: ClassContext -- Given
- -> ClassContext -- Wanted
- -> NF_TcM ClassContext -- Irreducible
+reduceSimple :: ThetaType -- Given
+ -> ThetaType -- Wanted
+ -> NF_TcM ThetaType -- Irreducible
reduceSimple givens wanteds
= reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' ->
- returnNF_Tc [ct | (ct,True) <- fmToList givens_fm']
+ returnNF_Tc [pred | (pred,True) <- fmToList givens_fm']
where
givens_fm = foldl addNonIrred emptyFM givens
-reduce_simple :: (Int,ClassContext) -- Stack
+reduce_simple :: (Int,ThetaType) -- Stack
-> AvailsSimple
- -> ClassContext
+ -> ThetaType
-> NF_TcM AvailsSimple
reduce_simple (n,stack) avails wanteds
go avails (w:ws) = reduce_simple_help (n+1,w:stack) avails w `thenNF_Tc` \ avails' ->
go avails' ws
-reduce_simple_help stack givens wanted@(clas,tys)
+reduce_simple_help stack givens wanted
| wanted `elemFM` givens
= returnNF_Tc givens
- | otherwise
+ | Just (clas, tys) <- getClassPredTys_maybe wanted
= lookupSimpleInst clas tys `thenNF_Tc` \ maybe_theta ->
-
case maybe_theta of
Nothing -> returnNF_Tc (addSimpleIrred givens wanted)
Just theta -> reduce_simple stack (addNonIrred givens wanted) theta
-addSimpleIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
-addSimpleIrred givens ct@(clas,tys)
- = addSCs (addToFM givens ct True) ct
+ | otherwise
+ = returnNF_Tc (addSimpleIrred givens wanted)
+
+addSimpleIrred :: AvailsSimple -> PredType -> AvailsSimple
+addSimpleIrred givens pred
+ = addSCs (addToFM givens pred True) pred
-addNonIrred :: AvailsSimple -> (Class,[Type]) -> AvailsSimple
-addNonIrred givens ct@(clas,tys)
- = addSCs (addToFM givens ct False) ct
+addNonIrred :: AvailsSimple -> PredType -> AvailsSimple
+addNonIrred givens pred
+ = addSCs (addToFM givens pred False) pred
-addSCs givens ct@(clas,tys)
- = foldl add givens sc_theta
+addSCs givens pred
+ | not (isClassPred pred) = givens
+ | otherwise = foldl add givens sc_theta
where
+ Just (clas,tys) = getClassPredTys_maybe pred
(tyvars, sc_theta_tmpl, _, _) = classBigSig clas
- sc_theta = substClasses (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
+ sc_theta = substTheta (mkTopTyVarSubst tyvars tys) sc_theta_tmpl
- add givens ct@(clas, tys)
+ add givens ct
= case lookupFM givens ct of
Nothing -> -- Add it and its superclasses
addSCs (addToFM givens ct False) ct
= mapNF_Tc complain tidy_dicts
where
fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet
- (tidy_env, tidy_dicts) = tidyInsts emptyTidyEnv dicts
- complain d | not (null (getIPs d)) = addTopIPErr tidy_env d
+ (tidy_env, tidy_dicts) = tidyInsts dicts
+ complain d | any isIPPred (predsOfInst d) = addTopIPErr tidy_env d
| not (isTyVarDict d) ||
tyVarsOfInst d `subVarSet` fixed_tvs = addTopInstanceErr tidy_env d
| otherwise = addAmbigErr tidy_env d
addAmbigErrs dicts
= mapNF_Tc (addAmbigErr tidy_env) tidy_dicts
where
- (tidy_env, tidy_dicts) = tidyInsts emptyTidyEnv dicts
+ (tidy_env, tidy_dicts) = tidyInsts dicts
addAmbigErr tidy_env tidy_dict
= addInstErrTcM (instLoc tidy_dict)
where
-- Tidy them first
- (_, tidy_dicts) = mapAccumL tidyInst emptyTidyEnv dicts
+ (_, tidy_dicts) = tidyInsts dicts
-- Group the dictionaries by source location
groups = equivClasses cmp tidy_dicts
| otherwise
= ptext SLIT("Or add an instance declaration for") <+> quotes (pprInst tidy_dict)
- (tidy_env, tidy_dict:tidy_givens) = tidyInsts emptyTidyEnv (dict:givens)
+ (tidy_env, tidy_dict:tidy_givens) = tidyInsts (dict:givens)
-- Checks for the ambiguous case when we have overlapping instances
ambig_overlap | isClassDict dict
addInstErrTcM (instLoc dict) (tidy_env, doc)
-- Used for the ...Thetas variants; all top level
-addNoInstErr (c,ts)
- = addErrTc (ptext SLIT("No instance for") <+> quotes (pprClassPred c ts))
+addNoInstErr pred
+ = addErrTc (ptext SLIT("No instance for") <+> quotes (ppr pred))
reduceDepthErr n stack
= vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name])
-mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsPClass c _ <- ctxt])
+mkClassEdges decl@(ClassDecl {tcdCtxt = ctxt, tcdName = name}) = Just (decl, name, [c | HsClassP c _ <- ctxt])
mkClassEdges other_decl = Nothing
mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name])
import RnHsSyn ( RenamedTyClDecl, RenamedConDecl, RenamedContext )
import BasicTypes ( NewOrData(..), RecFlag, isRec )
-import TcMonoType ( tcHsRecType, tcHsTyVars, tcRecClassContext,
+import TcMonoType ( tcHsRecType, tcHsTyVars, tcRecTheta,
kcHsContext, kcHsSigType, kcHsLiftedSigType
)
import TcEnv ( tcExtendTyVarEnv,
)
import TcMonad
-import Class ( ClassContext )
import DataCon ( DataCon, mkDataCon, dataConFieldLabels, markedStrict,
notMarkedStrict, markedUnboxed, dataConRepType
)
import Name ( Name, NamedThing(..) )
import Outputable
import TyCon ( TyCon, isNewTyCon, tyConTyVars )
-import Type ( tyVarsOfTypes, splitFunTy, applyTys,
+import Type ( tyVarsOfTypes, tyVarsOfPred, splitFunTy, applyTys,
mkTyConApp, mkTyVarTys, mkForAllTys,
- splitAlgTyConApp_maybe, Type
+ splitAlgTyConApp_maybe, Type, ThetaType
)
import TysWiredIn ( unitTy )
import VarSet ( intersectVarSet, isEmptyVarSet )
tcExtendTyVarEnv tyvars $
-- Typecheck the pieces
- tcRecClassContext is_rec context `thenTc` \ ctxt ->
+ tcRecTheta is_rec context `thenTc` \ ctxt ->
mapTc (tcConDecl is_rec new_or_data tycon tyvars ctxt) con_decls `thenTc` \ data_cons ->
tcRecordSelectors is_rec unf_env tycon data_cons `thenTc` \ sel_ids ->
returnTc (tycon_name, DataTyDetails ctxt data_cons sel_ids)
-- going to remove the constructor while coercing it to a lifted type.
-tcConDecl :: RecFlag -> NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM DataCon
+tcConDecl :: RecFlag -> NewOrData -> TyCon -> [TyVar] -> ThetaType -> RenamedConDecl -> TcM DataCon
tcConDecl is_rec new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc)
= tcAddSrcLoc src_loc $
tcHsTyVars ex_tvs (kcConDetails new_or_data ex_ctxt details) $ \ ex_tyvars ->
- tcRecClassContext is_rec ex_ctxt `thenTc` \ ex_theta ->
+ tcRecTheta is_rec ex_ctxt `thenTc` \ ex_theta ->
case details of
VanillaCon btys -> tc_datacon ex_tyvars ex_theta btys
InfixCon bty1 bty2 -> tc_datacon ex_tyvars ex_theta [bty1,bty2]
= filter in_arg_tys ctxt
where
arg_tyvars = tyVarsOfTypes arg_tys
- in_arg_tys (clas,tys) = not $ isEmptyVarSet $
- tyVarsOfTypes tys `intersectVarSet` arg_tyvars
+ in_arg_tys pred = not $ isEmptyVarSet $
+ tyVarsOfPred pred `intersectVarSet` arg_tyvars
getBangStrictness (Banged _) = markedStrict
getBangStrictness (Unbanged _) = notMarkedStrict
newTyVarTys, -- Int -> Kind -> NF_TcM [TcType]
-----------------------------------------
- TcType, TcTauType, TcThetaType, TcRhoType, TcClassContext,
+ TcType, TcTauType, TcThetaType, TcRhoType,
-- Find the type to which a type variable is bound
tcPutTyVar, -- :: TcTyVar -> TcType -> NF_TcM TcType
--------------------------------
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars,
zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
+ zonkTcPredType,
zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv
zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta
zonkTcPredType :: TcPredType -> NF_TcM TcPredType
-zonkTcPredType (Class c ts) =
+zonkTcPredType (ClassP c ts) =
zonkTcTypes ts `thenNF_Tc` \ new_ts ->
- returnNF_Tc (Class c new_ts)
+ returnNF_Tc (ClassP c new_ts)
zonkTcPredType (IParam n t) =
zonkTcType t `thenNF_Tc` \ new_t ->
returnNF_Tc (IParam n new_t)
go ty `thenNF_Tc` \ ty' ->
returnNF_Tc (ForAllTy tyvar' ty')
- go_pred (Class c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
- returnNF_Tc (Class c tys')
+ go_pred (ClassP c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' ->
+ returnNF_Tc (ClassP c tys')
go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' ->
returnNF_Tc (IParam n ty')
-- Predicates
uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2))
| n1 == n2 = uTys t1 t1 t2 t2
-uTys _ (PredTy (Class c1 tys1)) _ (PredTy (Class c2 tys2))
+uTys _ (PredTy (ClassP c1 tys1)) _ (PredTy (ClassP c2 tys2))
| c1 == c2 = unifyTauTyLists tys1 tys2
-- Functions; just check the two parts
\begin{code}
module Class (
- Class, ClassOpItem, ClassPred, ClassContext, FunDep,
+ Class, ClassOpItem, FunDep,
DefMeth (..),
mkClass, classTyVars, classArity,
#include "HsVersions.h"
import {-# SOURCE #-} TyCon ( TyCon )
-import {-# SOURCE #-} TypeRep ( Type )
+import {-# SOURCE #-} TypeRep ( PredType )
import Var ( Id, TyVar )
import Name ( NamedThing(..), Name )
classTyVars :: [TyVar], -- The class type variables
classFunDeps :: [FunDep TyVar], -- The functional dependencies
- classSCTheta :: [(Class,[Type])], -- Immediate superclasses, and the
+ classSCTheta :: [PredType], -- Immediate superclasses, and the
classSCSels :: [Id], -- corresponding selector functions to
-- extract them from a dictionary of this
-- class
classTyCon :: TyCon -- The data type constructor for dictionaries
} -- of this class
-type ClassPred = (Class, [Type])
-type ClassContext = [ClassPred]
-
type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where ...
-- Here fun-deps are [([a,b],[c]), ([a,c],[b])]
\begin{code}
mkClass :: Name -> [TyVar]
-> [([TyVar], [TyVar])]
- -> [(Class,[Type])] -> [Id]
+ -> [PredType] -> [Id]
-> [ClassOpItem]
-> TyCon
-> Class
-- In our example, tv_fds will be [ ({x,y}, {z}), ({x,p},{q}) ]
-- Meaning "knowing x,y fixes z, knowing x,p fixes q"
tv_fds = [ (tyVarsOfTypes xs, tyVarsOfTypes ys)
- | Class cls tys <- preds, -- Ignore implicit params
+ | ClassP cls tys <- preds, -- Ignore implicit params
let (cls_tvs, cls_fds) = classTvsFds cls,
fd <- cls_fds,
let (xs,ys) = instFD fd cls_tvs tys
= -- For implicit parameters, all the types must match
[(emptyVarSet, ty, ty') | IParam _ ty' <- ips, ty /= ty']
-checkGroup inst_env clss@(Class cls tys : _)
+checkGroup inst_env clss@(ClassP cls tys : _)
= -- For classes life is more complicated
-- Suppose the class is like
-- classs C as | (l1 -> r1), (l2 -> r2), ... where ...
- -- Then FOR EACH PAIR (Class c tys1, Class c tys2) in the list clss
+ -- Then FOR EACH PAIR (ClassP c tys1, ClassP c tys2) in the list clss
-- we check whether
-- U l1[tys1/as] = U l2[tys2/as]
-- (where U is a unifier)
pairwise_eqns :: [Equation]
pairwise_eqns -- This group comes from pairwise comparison
= [ eqn | fd <- cls_fds,
- Class _ tys1 : rest <- tails clss,
- Class _ tys2 <- rest,
+ ClassP _ tys1 : rest <- tails clss,
+ ClassP _ tys2 <- rest,
eqn <- checkClsFD emptyVarSet fd cls_tvs tys1 tys2
]
instance_eqns -- This group comes from comparing with instance decls
= [ eqn | fd <- cls_fds,
(qtvs, tys1, _) <- cls_inst_env,
- Class _ tys2 <- clss,
+ ClassP _ tys2 <- clss,
eqn <- checkClsFD qtvs fd cls_tvs tys1 tys2
]
pprParendKind = pprParendType
pprPred :: PredType -> SDoc
-pprPred (Class clas tys) = pprClassPred clas tys
-pprPred (IParam n ty) = hsep [ptext SLIT("?") <> ppr n,
- ptext SLIT("::"), ppr ty]
+pprPred (ClassP clas tys) = pprClassPred clas tys
+pprPred (IParam n ty) = hsep [ptext SLIT("?") <> ppr n,
+ ptext SLIT("::"), ppr ty]
pprClassPred :: Class -> [Type] -> SDoc
pprClassPred clas tys = ppr clas <+> hsep (map pprParendType tys)
#include "HsVersions.h"
-import {-# SOURCE #-} TypeRep ( Type, Kind, SuperKind )
+import {-# SOURCE #-} TypeRep ( Type, PredType, Kind, SuperKind )
-- Should just be Type(Type), but this fails due to bug present up to
-- and including 4.02 involving slurping of hi-boot files. Bug is now fixed.
import {-# SOURCE #-} DataCon ( DataCon, isExistentialDataCon )
-import Class ( ClassContext )
import Var ( TyVar, Id )
import BasicTypes ( Arity, RecFlag(..), Boxity(..),
isBoxed, EP(..) )
tyConTyVars :: [TyVar],
tyConArgVrcs :: ArgVrcs,
- algTyConTheta :: ClassContext,
+ algTyConTheta :: [PredType],
dataCons :: [DataCon],
-- Its data constructors, with fully polymorphic types
\end{code}
\begin{code}
-tyConTheta :: TyCon -> ClassContext
+tyConTheta :: TyCon -> [PredType]
tyConTheta (AlgTyCon {algTyConTheta = theta}) = theta
-- should ask about anything else
\end{code}
isUTy, uaUTy, unUTy, liftUTy, mkUTyM,
isUsageKind, isUsage, isUTyVar,
- -- Predicates and the like
- mkDictTy, mkDictTys, mkPredTy, splitPredTy_maybe, predTyUnique,
- splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
-
mkSynTy, deNoteType,
repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, hoistForAllTys, isForAllTy,
- TauType, RhoType, SigmaType, PredType(..), ThetaType,
- ClassPred, ClassContext, mkClassPred,
- getClassTys_maybe, predMentionsIPs, classesOfPreds,
+ -- Predicates and the like
+ PredType(..), getClassPredTys_maybe, getClassPredTys,
+ isClassPred, isTyVarClassPred,
+ mkDictTy, mkPredTy, mkPredTys, splitPredTy_maybe, predTyUnique,
+ splitDictTy, splitDictTy_maybe, isDictTy, predRepTy, splitDFunTy,
+ mkClassPred, predMentionsIPs, inheritablePred, isIPPred, mkPredName,
+
+ -- Tau, Rho, Sigma
+ TauType, RhoType, SigmaType, ThetaType,
isTauTy, mkRhoTy, splitRhoTy, splitMethodTy,
mkSigmaTy, isSigmaTy, splitSigmaTy,
getDFunTyKey,
-- Tidying up for printing
tidyType, tidyTypes,
tidyOpenType, tidyOpenTypes,
- tidyTyVar, tidyTyVars,
- tidyTopType,
+ tidyTyVar, tidyTyVars, tidyFreeTyVars,
+ tidyTopType, tidyPred,
-- Seq
seqType, seqTypes
import VarEnv
import VarSet
-import Name ( NamedThing(..), OccName, mkLocalName, tidyOccName )
+import OccName ( mkDictOcc )
+import Name ( Name, NamedThing(..), OccName, mkLocalName, tidyOccName )
import NameSet
-import Class ( classTyCon, Class, ClassPred, ClassContext )
+import Class ( classTyCon, Class )
import TyCon ( TyCon,
isUnboxedTupleTyCon, isUnLiftedTyCon,
isFunTyCon, isDataTyCon, isNewTyCon, newTyConRep,
-- others
import Maybes ( maybeToBool )
-import SrcLoc ( noSrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc )
import PrimRep ( PrimRep(..) )
import Unique ( Unique, Uniquable(..) )
import Util ( mapAccumL, seqList, thenCmp )
deNoteType (UsageTy u ty) = UsageTy u (deNoteType ty)
deNotePred :: PredType -> PredType
-deNotePred (Class c tys) = Class c (map deNoteType tys)
-deNotePred (IParam n ty) = IParam n (deNoteType ty)
+deNotePred (ClassP c tys) = ClassP c (map deNoteType tys)
+deNotePred (IParam n ty) = IParam n (deNoteType ty)
\end{code}
Notes on type synonyms
%************************************************************************
%* *
-\subsection{Stuff to do with the source-language types}
-
-PredType and ThetaType are used in types for expressions and bindings.
-ClassPred and ClassContext are used in class and instance declarations.
+\subsection{Predicates}
%* *
%************************************************************************
\begin{code}
mkClassPred clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
- Class clas tys
+ ClassP clas tys
+
+isClassPred (ClassP clas tys) = True
+isClassPred other = False
+
+isIPPred (IParam _ _) = True
+isIPPred other = False
+
+isTyVarClassPred (ClassP clas tys) = all isTyVarTy tys
+isTyVarClassPred other = False
+
+getClassPredTys_maybe :: PredType -> Maybe (Class, [Type])
+getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys)
+getClassPredTys_maybe _ = Nothing
+
+getClassPredTys :: PredType -> (Class, [Type])
+getClassPredTys (ClassP clas tys) = (clas, tys)
+
+inheritablePred :: PredType -> Bool
+-- Can be inherited by a context. For example, consider
+-- f x = let g y = (?v, y+x)
+-- in (g 3 with ?v = 8,
+-- g 4 with ?v = 9)
+-- The point is that g's type must be quantifed over ?v:
+-- g :: (?v :: a) => a -> a
+-- but it doesn't need to be quantified over the Num a dictionary
+-- which can be free in g's rhs, and shared by both calls to g
+inheritablePred (ClassP _ _) = True
+inheritablePred other = False
+
+predMentionsIPs :: PredType -> NameSet -> Bool
+predMentionsIPs (IParam n _) ns = n `elemNameSet` ns
+predMentionsIPs other ns = False
mkDictTy :: Class -> [Type] -> Type
mkDictTy clas tys = UASSERT2( not (any isUTy tys), ppr clas <+> fsep (map pprType tys) )
- mkPredTy (Class clas tys)
-
-mkDictTys :: ClassContext -> [Type]
-mkDictTys cxt = [mkDictTy cls tys | (cls,tys) <- cxt]
+ mkPredTy (ClassP clas tys)
mkPredTy :: PredType -> Type
mkPredTy pred = PredTy pred
+mkPredTys :: ThetaType -> [Type]
+mkPredTys preds = map PredTy preds
+
predTyUnique :: PredType -> Unique
-predTyUnique (IParam n _) = getUnique n
-predTyUnique (Class clas tys) = getUnique clas
+predTyUnique (IParam n _) = getUnique n
+predTyUnique (ClassP clas tys) = getUnique clas
predRepTy :: PredType -> Type
-- Convert a predicate to its "representation type";
-- the type of evidence for that predicate, which is actually passed at runtime
-predRepTy (Class clas tys) = TyConApp (classTyCon clas) tys
-predRepTy (IParam n ty) = ty
+predRepTy (ClassP clas tys) = TyConApp (classTyCon clas) tys
+predRepTy (IParam n ty) = ty
isPredTy :: Type -> Bool
isPredTy (NoteTy _ ty) = isPredTy ty
isPredTy _ = False
isDictTy :: Type -> Bool
-isDictTy (NoteTy _ ty) = isDictTy ty
-isDictTy (PredTy (Class _ _)) = True
-isDictTy (UsageTy _ ty) = isDictTy ty
-isDictTy other = False
+isDictTy (NoteTy _ ty) = isDictTy ty
+isDictTy (PredTy (ClassP _ _)) = True
+isDictTy (UsageTy _ ty) = isDictTy ty
+isDictTy other = False
splitPredTy_maybe :: Type -> Maybe PredType
splitPredTy_maybe (NoteTy _ ty) = splitPredTy_maybe ty
splitDictTy :: Type -> (Class, [Type])
splitDictTy (NoteTy _ ty) = splitDictTy ty
-splitDictTy (PredTy (Class clas tys)) = (clas, tys)
+splitDictTy (PredTy (ClassP clas tys)) = (clas, tys)
splitDictTy_maybe :: Type -> Maybe (Class, [Type])
-splitDictTy_maybe (NoteTy _ ty) = Just (splitDictTy ty)
-splitDictTy_maybe (PredTy (Class clas tys)) = Just (clas, tys)
-splitDictTy_maybe other = Nothing
+splitDictTy_maybe (NoteTy _ ty) = splitDictTy_maybe ty
+splitDictTy_maybe (PredTy (ClassP clas tys)) = Just (clas, tys)
+splitDictTy_maybe other = Nothing
splitDFunTy :: Type -> ([TyVar], [PredType], Class, [Type])
-- Split the type of a dictionary function
case splitDictTy tau of { (clas, tys) ->
(tvs, theta, clas, tys) }}
-getClassTys_maybe :: PredType -> Maybe ClassPred
-getClassTys_maybe (Class clas tys) = Just (clas, tys)
-getClassTys_maybe _ = Nothing
-
-predMentionsIPs :: PredType -> NameSet -> Bool
-predMentionsIPs (IParam n _) ns = n `elemNameSet` ns
-predMentionsIPs other ns = False
-
-classesOfPreds :: ThetaType -> ClassContext
-classesOfPreds theta = [(clas,tys) | Class clas tys <- theta]
+mkPredName :: Unique -> SrcLoc -> PredType -> Name
+mkPredName uniq loc (ClassP cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
+mkPredName uniq loc (IParam name ty) = name
\end{code}
+%************************************************************************
+%* *
+\subsection{Tau, sigma and rho}
+%* *
+%************************************************************************
+
@isTauTy@ tests for nested for-alls.
\begin{code}
tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys
tyVarsOfPred :: PredType -> TyVarSet
-tyVarsOfPred (Class clas tys) = tyVarsOfTypes tys
-tyVarsOfPred (IParam n ty) = tyVarsOfType ty
+tyVarsOfPred (ClassP clas tys) = tyVarsOfTypes tys
+tyVarsOfPred (IParam n ty) = tyVarsOfType ty
tyVarsOfTheta :: ThetaType -> TyVarSet
tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet
where
name = tyVarName tyvar
+tidyTyVars :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
tidyTyVars env tyvars = mapAccumL tidyTyVar env tyvars
+tidyFreeTyVars :: TidyEnv -> TyVarSet -> TidyEnv
+-- Add the free tyvars to the env in tidy form,
+-- so that we can tidy the type they are free in
+tidyFreeTyVars env tyvars = foldl add env (varSetElems tyvars)
+ where
+ add env tv = fst (tidyTyVar env tv)
+
tidyType :: TidyEnv -> Type -> Type
tidyType env@(tidy_env, subst) ty
= go ty
go (TyConApp tycon tys) = let args = map go tys
in args `seqList` TyConApp tycon args
go (NoteTy note ty) = (NoteTy SAPPLY (go_note note)) SAPPLY (go ty)
- go (PredTy p) = PredTy (go_pred p)
+ go (PredTy p) = PredTy (tidyPred env p)
go (AppTy fun arg) = (AppTy SAPPLY (go fun)) SAPPLY (go arg)
go (FunTy fun arg) = (FunTy SAPPLY (go fun)) SAPPLY (go arg)
go (ForAllTy tv ty) = ForAllTy tvp SAPPLY (tidyType envp ty)
go_note (SynNote ty) = SynNote SAPPLY (go ty)
go_note note@(FTVNote ftvs) = note -- No need to tidy the free tyvars
- go_pred (Class c tys) = Class c (tidyTypes env tys)
- go_pred (IParam n ty) = IParam n (go ty)
-
tidyTypes env tys = map (tidyType env) tys
+
+tidyPred :: TidyEnv -> PredType -> PredType
+tidyPred env (ClassP clas tys) = ClassP clas (tidyTypes env tys)
+tidyPred env (IParam n ty) = IParam n (tidyType env ty)
\end{code}
tidyOpenType env ty
= (env', tidyType env' ty)
where
- env' = foldl go env (varSetElems (tyVarsOfType ty))
- go env tyvar = fst (tidyTyVar env tyvar)
+ env' = tidyFreeTyVars env (tyVarsOfType ty)
tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])
tidyOpenTypes env tys = mapAccumL tidyOpenType env tys
seqNote (FTVNote set) = sizeUniqSet set `seq` ()
seqPred :: PredType -> ()
-seqPred (Class c tys) = c `seq` seqTypes tys
-seqPred (IParam n ty) = n `seq` seqType ty
+seqPred (ClassP c tys) = c `seq` seqTypes tys
+seqPred (IParam n ty) = n `seq` seqType ty
\end{code}
-- Compare types as well as names for implicit parameters
-- This comparison is used exclusively (I think) for the
-- finite map built in TcSimplify
-cmpPred env (Class c1 tys1) (Class c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
-cmpPred env (IParam _ _) (Class _ _) = LT
-cmpPred env (Class _ _) (IParam _ _) = GT
+cmpPred env (ClassP c1 tys1) (ClassP c2 tys2) = (c1 `compare` c2) `thenCmp` (cmpTys env tys1 tys2)
+cmpPred env (IParam _ _) (ClassP _ _) = LT
+cmpPred env (ClassP _ _) (IParam _ _) = GT
\end{code}
_interface_ TypeRep 1
-_exports_ TypeRep Type Kind SuperKind ;
+_exports_ TypeRep Type PredType Kind SuperKind ;
_declarations_
1 data Type ;
+1 data PredType ;
1 type Kind = Type ;
1 type SuperKind = Type ;
__interface TypeRep 1 0 where
-__export TypeRep Type Kind SuperKind ;
+__export TypeRep Type PredType Kind SuperKind ;
1 data Type ;
+1 data PredType ;
1 type Kind = Type ;
1 type SuperKind = Type ;
Predicates are represented inside GHC by PredType:
\begin{code}
-data PredType = Class Class [Type]
+data PredType = ClassP Class [Type]
| IParam Name Type
\end{code}
projects / ghc-hetmet.git / commitdiff