id = instToVar inst
instToVar :: Inst -> Var
-instToVar (LitInst nm _ ty _) = mkLocalId nm ty
-instToVar (Method id _ _ _ _) = id
-instToVar (Dict nm pred _)
+instToVar (LitInst {tci_name = nm, tci_ty = ty})
+ = mkLocalId nm ty
+instToVar (Method {tci_id = id})
+ = id
+instToVar (Dict {tci_name = nm, tci_pred = pred})
| isEqPred pred = Var.mkTyVar nm (mkPredTy pred)
| otherwise = mkLocalId nm (mkPredTy pred)
-instLoc (Dict _ _ loc) = loc
-instLoc (Method _ _ _ _ loc) = loc
-instLoc (LitInst _ _ _ loc) = loc
+instLoc inst = tci_loc inst
-dictPred (Dict _ pred _ ) = pred
-dictPred inst = pprPanic "dictPred" (ppr inst)
+dictPred (Dict {tci_pred = pred}) = pred
+dictPred inst = pprPanic "dictPred" (ppr inst)
-getDictClassTys (Dict _ pred _) = getClassPredTys pred
+getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
+getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst)
-- fdPredsOfInst is used to get predicates that contain functional
-- dependencies *or* might do so. The "might do" part is because
-- Leaving these in is really important for the call to fdPredsOfInsts
-- in TcSimplify.inferLoop, because the result is fed to 'grow',
-- which is supposed to be conservative
-fdPredsOfInst (Dict _ pred _) = [pred]
-fdPredsOfInst (Method _ _ _ theta _) = theta
-fdPredsOfInst other = [] -- LitInsts etc
+fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
+fdPredsOfInst (Method {tci_theta = theta}) = theta
+fdPredsOfInst other = [] -- LitInsts etc
fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts
-isInheritableInst (Dict _ pred _) = isInheritablePred pred
-isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
-isInheritableInst other = True
+isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred
+isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
+isInheritableInst other = True
ipNamesOfInsts :: [Inst] -> [Name]
-- NB: ?x and %x get different Names
ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
-ipNamesOfInst (Dict _ (IParam n _) _) = [ipNameName n]
-ipNamesOfInst (Method _ _ _ theta _) = [ipNameName n | IParam n _ <- theta]
-ipNamesOfInst other = []
+ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
+ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
+ipNamesOfInst other = []
tyVarsOfInst :: Inst -> TcTyVarSet
-tyVarsOfInst (LitInst _ _ ty _) = tyVarsOfType ty
-tyVarsOfInst (Dict _ pred _) = tyVarsOfPred pred
-tyVarsOfInst (Method _ id tys _ _) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
- -- The id might have free type variables; in the case of
- -- locally-overloaded class methods, for example
+tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
+tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
+tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+ -- The id might have free type variables; in the case of
+ -- locally-overloaded class methods, for example
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
~~~~~~~~~~
\begin{code}
isDict :: Inst -> Bool
-isDict (Dict _ _ _) = True
-isDict other = False
+isDict (Dict {}) = True
+isDict other = False
isClassDict :: Inst -> Bool
-isClassDict (Dict _ pred _) = isClassPred pred
-isClassDict other = False
+isClassDict (Dict {tci_pred = pred}) = isClassPred pred
+isClassDict other = False
isTyVarDict :: Inst -> Bool
-isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
-isTyVarDict other = False
+isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
+isTyVarDict other = False
isIPDict :: Inst -> Bool
-isIPDict (Dict _ pred _) = isIPPred pred
-isIPDict other = False
+isIPDict (Dict {tci_pred = pred}) = isIPPred pred
+isIPDict other = False
isMethod :: Inst -> Bool
isMethod (Method {}) = True
isMethod other = False
isMethodFor :: TcIdSet -> Inst -> Bool
-isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
-isMethodFor ids inst = False
+isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
+isMethodFor ids inst = False
\end{code}
newDictBndr inst_loc pred
= do { uniq <- newUnique
; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred
- ; return (Dict name pred inst_loc) }
+ ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
----------------
instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
instCallDicts loc (pred : preds)
= do { uniq <- newUnique
; let name = mkPredName uniq (instLocSrcLoc loc) pred
- dict = Dict name pred loc
+ dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
; (dicts, co_fn) <- instCallDicts loc preds
; return (dict:dicts, co_fn <.> WpApp (instToId dict)) }
-------------
cloneDict :: Inst -> TcM Inst -- Only used for linear implicit params
-cloneDict (Dict nm ty loc) = newUnique `thenM` \ uniq ->
- returnM (Dict (setNameUnique nm uniq) ty loc)
+cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
+ ; return (dict {tci_name = setNameUnique nm uniq}) }
+cloneDict other = pprPanic "cloneDict" (ppr other)
-- For vanilla implicit parameters, there is only one in scope
-- at any time, so we used to use the name of the implicit parameter itself
let
pred = IParam ip_name ty
name = mkPredName uniq (instLocSrcLoc inst_loc) pred
- dict = Dict name pred inst_loc
+ dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
in
returnM (mapIPName (\n -> instToId dict) ip_name, dict)
\end{code}
let
(theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
- inst = Method meth_id id tys theta inst_loc
+ inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
+ tci_theta = theta, tci_loc = inst_loc}
loc = instLocSrcLoc inst_loc
in
returnM inst
\begin{code}
zonkInst :: Inst -> TcM Inst
-zonkInst (Dict name pred loc)
+zonkInst dict@(Dict { tci_pred = pred})
= zonkTcPredType pred `thenM` \ new_pred ->
- returnM (Dict name new_pred loc)
+ returnM (dict {tci_pred = new_pred})
-zonkInst (Method m id tys theta loc)
+zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta})
= zonkId id `thenM` \ new_id ->
-- Essential to zonk the id in case it's a local variable
-- Can't use zonkIdOcc because the id might itself be
zonkTcTypes tys `thenM` \ new_tys ->
zonkTcThetaType theta `thenM` \ new_theta ->
- returnM (Method m new_id new_tys new_theta loc)
+ returnM (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
+ -- No need to zonk the tci_id
-zonkInst (LitInst nm lit ty loc)
+zonkInst lit@(LitInst {tci_ty = ty})
= zonkTcType ty `thenM` \ new_ty ->
- returnM (LitInst nm lit new_ty loc)
+ returnM (lit {tci_ty = new_ty})
zonkInsts insts = mappM zonkInst insts
\end{code}
pprInst, pprInstInFull :: Inst -> SDoc
-- Debugging: print the evidence :: type
-pprInst (LitInst nm lit ty loc) = ppr nm <+> dcolon <+> ppr ty
-pprInst (Dict nm pred loc) = ppr nm <+> dcolon <+> pprPred pred
+pprInst (LitInst {tci_name = nm, tci_ty = ty}) = ppr nm <+> dcolon <+> ppr ty
+pprInst (Dict {tci_name = nm, tci_pred = pred}) = ppr nm <+> dcolon <+> pprPred pred
-pprInst m@(Method inst_id id tys theta loc)
+pprInst (Method {tci_id = inst_id, tci_oid = id, tci_tys = tys})
= ppr inst_id <+> dcolon <+>
braces (sep [ppr id <+> ptext SLIT("at"),
brackets (sep (map pprParendType tys))])
= sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))]
tidyInst :: TidyEnv -> Inst -> Inst
-tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc
-tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc
-tidyInst env (Method u id tys theta loc) = Method u id (tidyTypes env tys) theta loc
+tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
+tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
+tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
-- This function doesn't assume that the tyvars are in scope
-- Methods
-lookupInst inst@(Method _ id tys theta loc)
+lookupInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
= do { (dicts, dict_app) <- instCallDicts loc theta
; let co_fn = dict_app <.> mkWpTyApps tys
; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
-- [Same shortcut as in newOverloadedLit, but we
-- may have done some unification by now]
-lookupInst inst@(LitInst _nm (HsIntegral i from_integer_name) ty loc)
+lookupInst (LitInst {tci_lit = HsIntegral i from_integer_name, tci_ty = ty, tci_loc = loc})
| Just expr <- shortCutIntLit i ty
= returnM (GenInst [] (noLoc expr)) -- GenInst, not SimpleInst, because
-- expr may be a constructor application
(mkHsApp (L (instLocSrcSpan loc)
(HsVar (instToId method_inst))) integer_lit))
-lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
+lookupInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty, tci_loc = loc})
| Just expr <- shortCutFracLit f ty
= returnM (GenInst [] (noLoc expr))
(HsVar (instToId method_inst))) rat_lit))
-- Dictionaries
-lookupInst (Dict _ pred loc)
+lookupInst (Dict {tci_pred = pred, tci_loc = loc})
= do { mb_result <- lookupPred pred
; case mb_result of {
Nothing -> return NoInstance ;
\begin{code}
data Inst
- = Dict
- Name
- TcPredType
- InstLoc
-
- | Method
- Id
-
- TcId -- The overloaded function
- -- This function will be a global, local, or ClassOpId;
- -- inside instance decls (only) it can also be an InstId!
- -- The id needn't be completely polymorphic.
- -- You'll probably find its name (for documentation purposes)
- -- inside the InstOrigin
-
- [TcType] -- The types to which its polymorphic tyvars
- -- should be instantiated.
- -- These types must saturate the Id's foralls.
-
- TcThetaType -- The (types of the) dictionaries to which the function
- -- must be applied to get the method
+ = Dict {
+ tci_name :: Name,
+ tci_pred :: TcPredType,
+ tci_loc :: InstLoc
+ }
+
+ | Method {
+ tci_id :: TcId, -- The Id for the Inst
- InstLoc
+ tci_oid :: TcId, -- The overloaded function
+ -- This function will be a global, local, or ClassOpId;
+ -- inside instance decls (only) it can also be an InstId!
+ -- The id needn't be completely polymorphic.
+ -- You'll probably find its name (for documentation purposes)
+ -- inside the InstOrigin
- -- INVARIANT 1: in (Method u f tys theta tau loc)
- -- type of (f tys dicts(from theta)) = tau
+ tci_tys :: [TcType], -- The types to which its polymorphic tyvars
+ -- should be instantiated.
+ -- These types must saturate the Id's foralls.
+
+ tci_theta :: TcThetaType,
+ -- The (types of the) dictionaries to which the function
+ -- must be applied to get the method
- -- INVARIANT 2: tau must not be of form (Pred -> Tau)
+ tci_loc :: InstLoc
+ }
+ -- INVARIANT 1: in (Method m f tys theta tau loc)
+ -- type of m = type of (f tys dicts(from theta))
+
+ -- INVARIANT 2: type of m must not be of form (Pred -> Tau)
-- Reason: two methods are considered equal if the
-- base Id matches, and the instantiating types
-- match. The TcThetaType should then match too.
-- This only bites in the call to tcInstClassOp in TcClassDcl.mkMethodBind
- | LitInst
- Name
- (HsOverLit Name) -- The literal from the occurrence site
- -- INVARIANT: never a rebindable-syntax literal
- -- Reason: tcSyntaxName does unification, and we
- -- don't want to deal with that during tcSimplify,
- -- when resolving LitInsts
- TcType -- The type at which the literal is used
- InstLoc
+ | LitInst {
+ tci_name :: Name,
+ tci_lit :: HsOverLit Name, -- The literal from the occurrence site
+ -- INVARIANT: never a rebindable-syntax literal
+ -- Reason: tcSyntaxName does unification, and we
+ -- don't want to deal with that during tcSimplify,
+ -- when resolving LitInsts
+
+ tci_ty :: TcType, -- The type at which the literal is used
+ tci_loc :: InstLoc
+ }
\end{code}
@Insts@ are ordered by their class/type info, rather than by their
EQ -> True
other -> False
-cmpInst (Dict _ pred1 _) (Dict _ pred2 _) = pred1 `tcCmpPred` pred2
-cmpInst (Dict _ _ _) other = LT
+cmpInst d1@(Dict {}) d2@(Dict {}) = tci_pred d1 `tcCmpPred` tci_pred d2
+cmpInst (Dict {}) other = LT
-cmpInst (Method _ _ _ _ _) (Dict _ _ _) = GT
-cmpInst (Method _ id1 tys1 _ _) (Method _ id2 tys2 _ _) = (id1 `compare` id2) `thenCmp` (tys1 `tcCmpTypes` tys2)
-cmpInst (Method _ _ _ _ _) other = LT
+cmpInst (Method {}) (Dict {}) = GT
+cmpInst m1@(Method {}) m2@(Method {}) = (tci_oid m1 `compare` tci_oid m2) `thenCmp`
+ (tci_tys m1 `tcCmpTypes` tci_tys m2)
+cmpInst (Method {}) other = LT
-cmpInst (LitInst _ _ _ _) (Dict _ _ _) = GT
-cmpInst (LitInst _ _ _ _) (Method _ _ _ _ _) = GT
-cmpInst (LitInst _ lit1 ty1 _) (LitInst _ lit2 ty2 _) = (lit1 `compare` lit2) `thenCmp` (ty1 `tcCmpType` ty2)
+cmpInst (LitInst {}) (Dict {}) = GT
+cmpInst (LitInst {}) (Method {}) = GT
+cmpInst l1@(LitInst {}) l2@(LitInst {}) = (tci_lit l1 `compare` tci_lit l2) `thenCmp`
+ (tci_ty l1 `tcCmpType` tci_ty l2)
\end{code}
projects / ghc-hetmet.git / commitdiff