early in the hierarchy), but also in HsSyn.
\begin{code}
-data IPName name
- = Dupable name -- ?x: you can freely duplicate this implicit parameter
- | Linear name -- %x: you must use the splitting function to duplicate it
+newtype IPName name = IPName name -- ?x
deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map
-- (used in HscTypes.OrigIParamCache)
-
ipNameName :: IPName name -> name
-ipNameName (Dupable n) = n
-ipNameName (Linear n) = n
+ipNameName (IPName n) = n
mapIPName :: (a->b) -> IPName a -> IPName b
-mapIPName f (Dupable n) = Dupable (f n)
-mapIPName f (Linear n) = Linear (f n)
+mapIPName f (IPName n) = IPName (f n)
instance Outputable name => Outputable (IPName name) where
- ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters
- ppr (Linear n) = char '%' <> ppr n -- Splittable implicit parameters
+ ppr (IPName n) = char '?' <> ppr n -- Ordinary implicit parameters
\end{code}
mkLocMessage, debugTraceMsg )
import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
import Type ( Type, tyVarsOfType, coreEqType,
- splitFunTy_maybe, mkTyVarTys,
+ splitFunTy_maybe,
splitForAllTy_maybe, splitTyConApp_maybe,
isUnLiftedType, typeKind, mkForAllTy, mkFunTy,
isUnboxedTupleType, isSubKind,
substTyWith, emptyTvSubst, extendTvInScope,
- TvSubst, TvSubstEnv, mkTvSubst, setTvSubstEnv, substTy,
- extendTvSubst, composeTvSubst, substTyVarBndr, isInScope,
- getTvSubstEnv, getTvInScope, mkTyVarTy )
-import Coercion ( Coercion, coercionKind, coercionKindPredTy )
+ TvSubst, substTy,
+ extendTvSubst, substTyVarBndr, isInScope,
+ getTvInScope )
+import Coercion ( coercionKind, coercionKindPredTy )
import TyCon ( isPrimTyCon, isNewTyCon )
import BasicTypes ( RecFlag(..), Boxity(..), isNonRec )
import StaticFlags ( opt_PprStyle_Debug )
; checkKinds tyvar arg_ty
; return (substTyWith [tyvar] [arg_ty] body) }
-lintTyApps fun_ty [] = return fun_ty
-
-lintTyApps fun_ty (arg_ty : arg_tys) =
- do { fun_ty' <- lintTyApp fun_ty arg_ty
- ; lintTyApps fun_ty' arg_tys }
-
checkKinds tyvar arg_ty
-- Arg type might be boxed for a function with an uncommitted
-- tyvar; notably this is used so that we can give
#include "HsVersions.h"
-import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, CoreBind,
+import CoreSyn ( Expr(..), Bind(..), CoreExpr, CoreBind,
CoreRule(..), hasUnfolding, noUnfolding
)
import CoreFVs ( exprFreeVars )
import Unique ( Unique )
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply )
import Var ( Var, Id, TyVar, isTyVar )
-import Maybes ( orElse, isNothing )
+import Maybes ( orElse )
import Outputable
import PprCore () -- Instances
import Util ( mapAccumL )
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
-import TyCon ( isNewTyCon )
import Coercion ( Coercion )
import Name ( Name )
import OccName ( OccName )
import Literal ( Literal, mkMachInt )
-import DataCon ( DataCon, dataConWorkId, dataConTag, dataConTyCon,
- dataConWrapId )
+import DataCon ( DataCon, dataConWorkId, dataConTag )
import BasicTypes ( Activation )
import FastString
import Outputable
HsWrapper, pprHsWrapper )
-- others:
-import Type ( Type, pprParendType )
-import Var ( TyVar, Id )
+import Var ( Id )
import Name ( Name )
import BasicTypes ( IPName, Boxity, tupleParens, Arity, Fixity(..) )
import SrcLoc ( Located(..), unLoc )
import Class ( DefMeth(..) )
import CostCentre
import StaticFlags ( opt_HiVersion, v_Build_tag )
-import Type ( Kind,
- isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind,
- isArgTypeKind, isUbxTupleKind, liftedTypeKind,
- unliftedTypeKind, openTypeKind, argTypeKind,
- ubxTupleKind, mkArrowKind, splitFunTy_maybe )
import Panic
import Binary
import Util
return (Fixity aa ab)
instance (Binary name) => Binary (IPName name) where
- put_ bh (Dupable aa) = do
- putByte bh 0
- put_ bh aa
- put_ bh (Linear ab) = do
- putByte bh 1
- put_ bh ab
- get bh = do
- h <- getByte bh
- case h of
- 0 -> do aa <- get bh
- return (Dupable aa)
- _ -> do ab <- get bh
- return (Linear ab)
+ put_ bh (IPName aa) = put_ bh aa
+ get bh = do aa <- get bh
+ return (IPName aa)
-------------------------------------------------------------------------
-- Types from: Demand
import IfaceEnv ( newImplicitBinder )
import TcRnMonad
-import DataCon ( DataCon, isNullarySrcDataCon, dataConUnivTyVars,
- mkDataCon, dataConFieldLabels, dataConInstOrigArgTys,
- dataConTyCon )
+import DataCon ( DataCon, isNullarySrcDataCon,
+ mkDataCon, dataConFieldLabels, dataConInstOrigArgTys )
import Var ( tyVarKind, TyVar, Id )
import VarSet ( isEmptyVarSet, intersectVarSet, elemVarSet )
import TysWiredIn ( unitTy )
import Name ( Name )
import OccName ( mkDataConWrapperOcc, mkDataConWorkerOcc,
mkClassTyConOcc, mkClassDataConOcc,
- mkSuperDictSelOcc, mkNewTyCoOcc, mkInstTyTcOcc,
+ mkSuperDictSelOcc, mkNewTyCoOcc,
mkInstTyCoOcc )
import MkId ( mkDataConIds, mkRecordSelId, mkDictSelId )
import Class ( mkClass, Class( classTyCon), FunDep, DefMeth(..) )
import TyCon ( mkSynTyCon, mkAlgTyCon, visibleDataCons,
tyConStupidTheta, tyConDataCons, isNewTyCon,
mkClassTyCon, TyCon( tyConTyVars ),
- isRecursiveTyCon, tyConArity, AlgTyConRhs(..),
+ isRecursiveTyCon, AlgTyConRhs(..),
SynTyConRhs(..), newTyConRhs, AlgTyConParent(..) )
import Type ( mkArrowKinds, liftedTypeKind, typeKind,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred,
splitTyConApp_maybe, splitAppTy_maybe,
getTyVar_maybe,
- mkPredTys, mkTyVarTys, ThetaType, Type, Kind,
+ mkPredTys, mkTyVarTys, ThetaType, Type,
TyThing(..),
- substTyWith, zipTopTvSubst, substTheta, mkForAllTys,
- mkTyConApp, mkTyVarTy )
+ substTyWith, zipTopTvSubst, substTheta )
import Coercion ( mkNewTypeCoercion, mkDataInstCoercion )
import Outputable
import List ( nub )
import TysWiredIn ( tupleTyCon, tupleCon )
import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..),
IfaceExport, OrigNameCache )
-import Type ( mkOpenTvSubst, substTy )
import TyCon ( TyCon, tyConName )
import DataCon ( dataConWorkId, dataConName )
-import Var ( TyVar, Id, varName, setIdType, idType )
+import Var ( TyVar, Id, varName )
import Name ( Name, nameUnique, nameModule,
nameOccName, nameSrcLoc,
getOccName, nameParent_maybe,
isWiredInName, mkIPName,
mkExternalName, mkInternalName )
import NameSet ( NameSet, emptyNameSet, addListToNameSet )
-import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv, occNameFS,
- lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList )
+import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, occNameFS,
+ lookupOccEnv, unitOccEnv, extendOccEnv )
import PrelNames ( gHC_PRIM, dATA_TUP )
import Module ( Module, emptyModuleEnv, ModuleName, modulePackageId,
lookupModuleEnv, extendModuleEnv_C, mkModule )
import IfaceType
import NewDemand ( StrictSig, pprIfaceStrictSig )
-import TcType ( deNoteType )
import Class ( FunDep, DefMeth, pprFundeps )
import OccName ( OccName, parenSymOcc, occNameFS,
OccSet, unionOccSets, unitOccSet, occSetElts )
import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM )
-import Name ( Name, NamedThing(..), nameOccName, isExternalName )
import CostCentre ( CostCentre, pprCostCentreCore )
import Literal ( Literal )
import ForeignCall ( ForeignCall )
import BasicTypes ( Arity, Activation(..), StrictnessMark, OverlapFlag,
- RecFlag(..), Boxity(..),
- isAlwaysActive, tupleParens )
+ RecFlag(..), Boxity(..), tupleParens )
import Outputable
import FastString
-import Maybes ( catMaybes )
-import Util ( lengthIs )
infixl 3 &&&
infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
#include "HsVersions.h"
-import Type ( Kind )
-import Coercion ( Coercion )
import TypeRep ( TyThing(..), Type(..), PredType(..), ThetaType,
unliftedTypeKindTyConName, openTypeKindTyConName,
ubxTupleKindTyConName, argTypeKindTyConName,
- liftedTypeKindTyConName, isLiftedTypeKind )
+ liftedTypeKindTyConName )
import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity, tyConName )
import Var ( isId, tyVarKind, idType )
import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName )
<0,glaexts> {
\? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid }
- \% @varid / { ifExtension ipEnabled } { skip_one_varid ITsplitipvarid }
}
<glaexts> {
| ITqconsym (FastString,FastString)
| ITdupipvarid FastString -- GHC extension: implicit param: ?x
- | ITsplitipvarid FastString -- GHC extension: implicit param: %x
| ITpragma StringBuffer
QCONSYM { L _ (ITqconsym _) }
IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension
- IPSPLITVARID { L _ (ITsplitipvarid _) } -- GHC extension
CHAR { L _ (ITchar _) }
STRING { L _ (ITstring _) }
dbind : ipvar '=' exp { LL (IPBind (unLoc $1) $3) }
ipvar :: { Located (IPName RdrName) }
- : IPDUPVARID { L1 (Dupable (mkUnqual varName (getIPDUPVARID $1))) }
- | IPSPLITVARID { L1 (Linear (mkUnqual varName (getIPSPLITVARID $1))) }
+ : IPDUPVARID { L1 (IPName (mkUnqual varName (getIPDUPVARID $1))) }
-----------------------------------------------------------------------------
-- Deprecations
getQVARSYM (L _ (ITqvarsym x)) = x
getQCONSYM (L _ (ITqconsym x)) = x
getIPDUPVARID (L _ (ITdupipvarid x)) = x
-getIPSPLITVARID (L _ (ITsplitipvarid x)) = x
getCHAR (L _ (ITchar x)) = x
getSTRING (L _ (ITstring x)) = x
getINTEGER (L _ (ITinteger x)) = x
import PrimOp ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag )
import DataCon ( DataCon )
import Id ( Id, idName )
-import MkId ( mkPrimOpId, wiredInIds )
import MkId -- All of it, for re-export
import Name ( nameOccName )
import TysPrim ( primTyCons )
-- MonadFix
monadFixClassName, mfixName,
- -- Splittable class
- splittableClassName, splitName,
-
-- Other classes
randomClassName, randomGenClassName, monadPlusClassName,
-- PrelST module
runSTRepName = varQual gHC_ST FSLIT("runSTRep") runSTRepIdKey
--- The "split" Id for splittable implicit parameters
-splittableClassName = clsQual gLA_EXTS FSLIT("Splittable") splittableClassKey
-splitName = methName splittableClassName FSLIT("split") splitIdKey
-
-- Recursive-do notation
monadFixClassName = clsQual mONAD_FIX FSLIT("MonadFix") monadFixClassKey
mfixName = methName monadFixClassName FSLIT("mfix") mfixIdKey
typeable7ClassKey = mkPreludeClassUnique 27
monadFixClassKey = mkPreludeClassUnique 28
-splittableClassKey = mkPreludeClassUnique 29
monadPlusClassKey = mkPreludeClassUnique 30
randomClassKey = mkPreludeClassUnique 31
failIOIdKey = mkPreludeMiscIdUnique 44
nullAddrIdKey = mkPreludeMiscIdUnique 46
voidArgIdKey = mkPreludeMiscIdUnique 47
-splitIdKey = mkPreludeMiscIdUnique 48
fstIdKey = mkPreludeMiscIdUnique 49
sndIdKey = mkPreludeMiscIdUnique 50
otherwiseIdKey = mkPreludeMiscIdUnique 51
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isDict, isClassDict, isMethod,
- isLinearInst, linearInstType, isIPDict, isInheritableInst,
+ isIPDict, isInheritableInst,
isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
mkPredTy, mkTyVarTys,
tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
- isClassPred, isTyVarClassPred, isLinearPred,
+ isClassPred, isTyVarClassPred,
getClassPredTys, mkPredName,
isInheritablePred, isIPPred,
tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy,
isMethodFor :: TcIdSet -> Inst -> Bool
isMethodFor ids (Method uniq id tys _ loc) = id `elemVarSet` ids
isMethodFor ids inst = False
-
-isLinearInst :: Inst -> Bool
-isLinearInst (Dict _ pred _) = isLinearPred pred
-isLinearInst other = False
- -- We never build Method Insts that have
- -- linear implicit paramters in them.
- -- Hence no need to look for Methods
- -- See TcExpr.tcId
-
-linearInstType :: Inst -> TcType -- %x::t --> t
-linearInstType (Dict _ (IParam _ ty) _) = ty
\end{code}
mkTyVarTys, mkFunTys,
tcMultiSplitSigmaTy, tcSplitFunTysN,
tcSplitTyConApp_maybe,
- isSigmaTy, mkFunTy, mkTyConApp, isLinearPred,
+ isSigmaTy, mkFunTy, mkTyConApp,
exactTyVarsOfType, exactTyVarsOfTypes,
zipTopTvSubst, zipOpenTvSubst, substTys, substTyVar
)
= do { co_fn <- instCall orig tys theta
; go False (HsWrap co_fn fun) prs }
- -- Hack Alert (want_method_inst)!
-- See Note [No method sharing]
- -- If f :: (%x :: T) => Int -> Int
- -- Then if we have two separate calls, (f 3, f 4), we cannot
- -- make a method constraint that then gets shared, thus:
- -- let m = f %x in (m 3, m 4)
- -- because that loses the linearity of the constraint.
- -- The simplest thing to do is never to construct a method constraint
- -- in the first place that has a linear implicit parameter in it.
- want_method_inst theta = not (null theta) -- Overloaded
- && not (any isLinearPred theta) -- Not linear
+ want_method_inst theta = not (null theta) -- Overloaded
&& not opt_NoMethodSharing
- -- See Note [No method sharing] below
\end{code}
Note [Multiple instantiation]
-%
+ %
% (c) The AQUA Project, Glasgow University, 1996-1998
%
\section[TcHsSyn]{Specialisations of the @HsSyn@ syntax for the typechecker}
-------------------------------------------------------------------------
mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b)
-mapIPNameTc f (Dupable n) = f n `thenM` \ r -> returnM (Dupable r)
-mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r)
+mapIPNameTc f (IPName n) = f n `thenM` \ r -> returnM (IPName r)
\end{code}
availName, IsBootInterface, Deprecations )
import Packages ( PackageId )
import Type ( Type, pprTyThingCategory )
-import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst,
+import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo,
TcPredType, TcKind, tcCmpPred, tcCmpType,
tcCmpTypes, pprSkolInfo )
import InstEnv ( Instance, InstEnv )
-import FamInstEnv ( FamInst, FamInstEnv )
+import FamInstEnv ( FamInstEnv )
import IOEnv
import RdrName ( GlobalRdrEnv, LocalRdrEnv )
import Name ( Name )
import SrcLoc ( SrcSpan, SrcLoc, Located, srcSpanStart )
import VarSet ( IdSet )
import ErrUtils ( Messages, Message )
-import UniqFM ( UniqFM )
import UniqSupply ( UniqSupply )
import BasicTypes ( IPName )
import Util ( thenCmp )
import {-# SOURCE #-} TcUnify( unifyType )
import HsSyn ( HsBind(..), HsExpr(..), LHsExpr, mkWpTyApps,
- HsWrapper(..), (<.>), nlHsTyApp, emptyLHsBinds )
-import TcHsSyn ( mkHsApp )
+ HsWrapper(..), (<.>), emptyLHsBinds )
import TcRnMonad
import Inst ( lookupInst, LookupInstResult(..),
tyVarsOfInst, fdPredsOfInsts,
- isDict, isClassDict, isLinearInst, linearInstType,
+ isDict, isClassDict,
isMethodFor, isMethod,
- instToId, tyVarsOfInsts, cloneDict,
+ instToId, tyVarsOfInsts,
ipNamesOfInsts, ipNamesOfInst, dictPred,
fdPredsOfInst,
- newDictBndrs, newDictBndrsO, tcInstClassOp,
+ newDictBndrs, newDictBndrsO,
getDictClassTys, isTyVarDict, instLoc,
zonkInst, tidyInsts, tidyMoreInsts,
pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs,
isInheritableInst, pprDictsTheta
)
-import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders,
+import TcEnv ( tcGetGlobalTyVars, findGlobals, pprBinders,
lclEnvElts, tcMetaTy )
import InstEnv ( lookupInstEnv, classInstances, pprInstances )
import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, zonkTcPredType )
import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, tidyPred,
- mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar,
+ mkClassPred, isOverloadedTy, isSkolemTyVar,
mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys,
tyVarsOfPred, tcEqType, pprPred, mkPredTy, tcIsTyVarTy )
import TcIface ( checkWiredInTyCon )
-import Id ( idType, mkUserLocal )
+import Id ( idType )
import Var ( TyVar )
import TyCon ( TyCon )
-import Name ( Name, getOccName, getSrcLoc )
+import Name ( Name )
import NameSet ( NameSet, mkNameSet, elemNameSet )
import Class ( classBigSig, classKey )
import FunDeps ( oclose, grow, improve, pprEquation )
import PrelInfo ( isNumericClass, isStandardClass )
-import PrelNames ( splitName, fstName, sndName, integerTyConName,
+import PrelNames ( integerTyConName,
showClassKey, eqClassKey, ordClassKey )
import Type ( zipTopTvSubst, substTheta, substTy )
-import TysWiredIn ( pairTyCon, doubleTy, doubleTyCon )
+import TysWiredIn ( doubleTy, doubleTyCon )
import ErrUtils ( Message )
import BasicTypes ( TopLevelFlag, isNotTopLevel )
import VarSet
| Given TcId -- Used for dictionaries for which we have a binding
-- e.g. those "given" in a signature
- Bool -- True <=> actually consumed (splittable IPs only)
| Rhs -- Used when there is a RHS
(LHsExpr TcId) -- The RHS
[Inst] -- Insts free in the RHS; we need these too
- | Linear -- Splittable Insts only.
- Int -- The Int is always 2 or more; indicates how
- -- many copies are required
- Inst -- The splitter
- Avail -- Where the "master copy" is
-
- | LinRhss -- Splittable Insts only; this is used only internally
- -- by extractResults, where a Linear
- -- is turned into an LinRhss
- [LHsExpr TcId] -- A supply of suitable RHSs
-
pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)]
| (inst,avail) <- fmToList avails ]
pprAvail IsFree = text "Free"
pprAvail Irred = text "Irred"
-pprAvail (Given x b) = text "Given" <+> ppr x <+>
- if b then text "(used)" else empty
+pprAvail (Given x) = text "Given" <+> ppr x
pprAvail (Rhs rhs bs) = text "Rhs" <+> ppr rhs <+> braces (ppr bs)
-pprAvail (Linear n i a) = text "Linear" <+> ppr n <+> braces (ppr i) <+> ppr a
-pprAvail (LinRhss rhss) = text "LinRhss" <+> ppr rhss
\end{code}
Extracting the bindings from a bunch of Avails.
Just IsFree -> go (add_free avails w) binds irreds (w:frees) ws
Just Irred -> go (add_given avails w) binds (w:irreds) frees ws
- Just (Given id _) -> go avails new_binds irreds frees ws
- where
+ Just (Given id) -> go avails new_binds irreds frees ws
+ where
new_binds | id == instToId w = binds
| otherwise = addBind binds w (L (instSpan w) (HsVar id))
-- The sought Id can be one of the givens, via a superclass chain
where
new_binds = addBind binds w rhs
- Just (Linear n split_inst avail) -- Transform Linear --> LinRhss
- -> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) ->
- split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) ->
- go (addToFM avails w (LinRhss rhss))
- (binds `unionBags` binds')
- irreds' frees' (split_inst : w : ws)
-
- Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss
- -> go new_avails new_binds irreds frees ws
- where
- new_binds = addBind binds w rhs
- new_avails = addToFM avails w (LinRhss rhss)
-
- -- get_root is just used for Linear
- get_root irreds frees (Given id _) w = returnM (irreds, frees, id)
- get_root irreds frees Irred w = cloneDict w `thenM` \ w' ->
- returnM (w':irreds, frees, instToId w')
- get_root irreds frees IsFree w = cloneDict w `thenM` \ w' ->
- returnM (irreds, w':frees, instToId w')
-
- add_given avails w = addToFM avails w (Given (instToId w) True)
+ add_given avails w = addToFM avails w (Given (instToId w))
add_free avails w | isMethod w = avails
| otherwise = add_given avails w
-- t1=t3; but alas, the binding for t2 (which mentions t1)
-- will continue to float out!
-split :: Int -> TcId -> TcId -> Inst
- -> TcM (TcDictBinds, [LHsExpr TcId])
--- (split n split_id root_id wanted) returns
--- * a list of 'n' expressions, all of which witness 'avail'
--- * a bunch of auxiliary bindings to support these expressions
--- * one or zero insts needed to witness the whole lot
--- (maybe be zero if the initial Inst is a Given)
---
--- NB: 'wanted' is just a template
-
-split n split_id root_id wanted
- = go n
- where
- ty = linearInstType wanted
- pair_ty = mkTyConApp pairTyCon [ty,ty]
- id = instToId wanted
- occ = getOccName id
- loc = getSrcLoc id
- span = instSpan wanted
-
- go 1 = returnM (emptyBag, [L span $ HsVar root_id])
-
- go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) ->
- expand n rhss `thenM` \ (binds2, rhss') ->
- returnM (binds1 `unionBags` binds2, rhss')
-
- -- (expand n rhss)
- -- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings
- -- e.g. expand 3 [rhs1, rhs2]
- -- = ( { x = split rhs1 },
- -- [fst x, snd x, rhs2] )
- expand n rhss
- | n `rem` 2 == 0 = go rhss -- n is even
- | otherwise = go (tail rhss) `thenM` \ (binds', rhss') ->
- returnM (binds', head rhss : rhss')
- where
- go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') ->
- returnM (listToBag binds', concat rhss')
-
- do_one rhs = newUnique `thenM` \ uniq ->
- tcLookupId fstName `thenM` \ fst_id ->
- tcLookupId sndName `thenM` \ snd_id ->
- let
- x = mkUserLocal occ uniq pair_ty loc
- in
- returnM (L span (VarBind x (mk_app span split_id rhs)),
- [mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x])
-
-mk_fs_app span id ty var = nlHsTyApp id [ty,ty] `mkHsApp` (L span (HsVar var))
-
-mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs)
-
addBind binds inst rhs = binds `unionBags` unitBag (L (instLocSrcSpan (instLoc inst))
(VarBind (instToId inst) rhs))
instSpan wanted = instLocSrcSpan (instLoc wanted)
reduce stack try_me wanted avails
-- It's the same as an existing inst, or a superclass thereof
| Just avail <- isAvailable avails wanted
- = if isLinearInst wanted then
- addLinearAvailable avails avail wanted `thenM` \ (avails', wanteds') ->
- reduceList stack try_me wanteds' avails'
- else
- returnM avails -- No op for non-linear things
+ = returnM avails
| otherwise
= case try_me wanted of {
-- *not* by unique. So
-- d1::C Int == d2::C Int
-addLinearAvailable :: Avails -> Avail -> Inst -> TcM (Avails, [Inst])
-addLinearAvailable avails avail wanted
- -- avails currently maps [wanted -> avail]
- -- Extend avails to reflect a neeed for an extra copy of avail
-
- | Just avail' <- split_avail avail
- = returnM (addToFM avails wanted avail', [])
-
- | otherwise
- = tcLookupId splitName `thenM` \ split_id ->
- tcInstClassOp (instLoc wanted) split_id
- [linearInstType wanted] `thenM` \ split_inst ->
- returnM (addToFM avails wanted (Linear 2 split_inst avail), [split_inst])
-
- where
- split_avail :: Avail -> Maybe Avail
- -- (Just av) if there's a modified version of avail that
- -- we can use to replace avail in avails
- -- Nothing if there isn't, so we need to create a Linear
- split_avail (Linear n i a) = Just (Linear (n+1) i a)
- split_avail (Given id used) | not used = Just (Given id True)
- | otherwise = Nothing
- split_avail Irred = Nothing
- split_avail IsFree = Nothing
- split_avail other = pprPanic "addLinearAvailable" (ppr avail $$ ppr wanted $$ ppr avails)
-
-------------------------
addFree :: Avails -> Inst -> TcM Avails
-- When an Inst is tossed upstairs as 'free' we nevertheless add it
avail = Rhs rhs_expr wanteds
addGiven :: Avails -> Inst -> TcM Avails
-addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given) False)
+addGiven avails given = addAvailAndSCs AddSCs avails given (Given (instToId given))
-- Always add superclasses for 'givens'
--
-- No ASSERT( not (given `elemFM` avails) ) because in an instance
is_given :: Inst -> Bool
is_given sc_dict = case lookupFM avails sc_dict of
- Just (Given _ _) -> True -- Given is cheaper than superclass selection
- other -> False
+ Just (Given _) -> True -- Given is cheaper than superclass selection
+ other -> False
\end{code}
Note [SUPERCLASS-LOOP 2]
isClassPred, isTyVarClassPred, isEqPred,
mkDictTy, tcSplitPredTy_maybe,
isPredTy, isDictTy, tcSplitDFunTy, tcSplitDFunHead, predTyUnique,
- mkClassPred, isInheritablePred, isLinearPred, isIPPred, mkPredName,
+ mkClassPred, isInheritablePred, isIPPred, mkPredName,
dataConsStupidTheta, isRefineableTy,
---------------------------------
import OccName ( OccName, mkDictOcc, mkOccName, tvName )
import PrelNames -- Lots (e.g. in isFFIArgumentTy)
import TysWiredIn ( unitTyCon, charTyCon, listTyCon )
-import BasicTypes ( IPName(..), Arity, ipNameName )
+import BasicTypes ( Arity, ipNameName )
import SrcLoc ( SrcLoc, SrcSpan )
import Util ( equalLength )
import Maybes ( maybeToBool, expectJust, mapCatMaybes )
-- which can be free in g's rhs, and shared by both calls to g
isInheritablePred (ClassP _ _) = True
isInheritablePred other = False
-
-isLinearPred :: TcPredType -> Bool
-isLinearPred (IParam (Linear n) _) = True
-isLinearPred other = False
\end{code}
--------------------- Equality predicates ---------------------------------