compiler/typecheck/Inst.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 The @Inst@ type: dictionaries or method instances
   7
   8 \begin{code}
   9 {-# OPTIONS -w #-}
  10 -- The above warning supression flag is a temporary kludge.
  11 -- While working on this module you are encouraged to remove it and fix
  12 -- any warnings in the module. See
  13 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  14 -- for details
  15
  16 module Inst (
  17         Inst,
  18
  19         pprInstances, pprDictsTheta, pprDictsInFull,    -- User error messages
  20         showLIE, pprInst, pprInsts, pprInstInFull,      -- Debugging messages
  21
  22         tidyInsts, tidyMoreInsts,
  23
  24         newDictBndr, newDictBndrs, newDictBndrsO,
  25         instCall, instStupidTheta,
  26         cloneDict,
  27         shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
  28         newMethod, newMethodFromName, newMethodWithGivenTy,
  29         tcInstClassOp,
  30         tcSyntaxName, isHsVar,
  31
  32         tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
  33         ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
  34         getDictClassTys, dictPred,
  35
  36         lookupSimpleInst, LookupInstResult(..),
  37         tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
  38
  39         isAbstractableInst, isEqInst,
  40         isDict, isClassDict, isMethod, isImplicInst,
  41         isIPDict, isInheritableInst, isMethodOrLit,
  42         isTyVarDict, isMethodFor,
  43
  44         zonkInst, zonkInsts,
  45         instToId, instToVar, instType, instName, instToDictBind,
  46         addInstToDictBind,
  47
  48         InstOrigin(..), InstLoc, pprInstLoc,
  49
  50         mkWantedCo, mkGivenCo,
  51         fromWantedCo, fromGivenCo,
  52         eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
  53         finalizeEqInst, writeWantedCoercion,
  54         eqInstType, updateEqInstCoercion,
  55         eqInstCoercion, eqInstTys
  56     ) where
  57
  58 #include "HsVersions.h"
  59
  60 import {-# SOURCE #-}   TcExpr( tcPolyExpr )
  61 import {-# SOURCE #-}   TcUnify( boxyUnify, unifyType )
  62
  63 import FastString
  64 import HsSyn
  65 import TcHsSyn
  66 import TcRnMonad
  67 import TcEnv
  68 import InstEnv
  69 import FunDeps
  70 import TcMType
  71 import TcType
  72 import Type
  73 import TypeRep
  74 import Class
  75 import Unify
  76 import Module
  77 import Coercion
  78 import HscTypes
  79 import CoreFVs
  80 import DataCon
  81 import Id
  82 import Name
  83 import NameSet
  84 import Literal
  85 import Var      ( Var, TyVar )
  86 import qualified Var
  87 import VarEnv
  88 import VarSet
  89 import TysWiredIn
  90 import PrelNames
  91 import BasicTypes
  92 import SrcLoc
  93 import DynFlags
  94 import Bag
  95 import Maybes
  96 import Util
  97 import Unique
  98 import Outputable
  99 import Data.List
 100 import TypeRep
 101 import Class
 102
 103 import Control.Monad
 104 \end{code}
 105
 106
 107 Selection
 108 ~~~~~~~~~
 109 \begin{code}
 110 instName :: Inst -> Name
 111 instName (EqInst {tci_name = name}) = name
 112 instName inst = Var.varName (instToVar inst)
 113
 114 instToId :: Inst -> TcId
 115 instToId inst = WARN( not (isId id), ppr inst )
 116               id
 117               where
 118                 id = instToVar inst
 119
 120 instToVar :: Inst -> Var
 121 instToVar (LitInst {tci_name = nm, tci_ty = ty})
 122   = mkLocalId nm ty
 123 instToVar (Method {tci_id = id})
 124   = id
 125 instToVar (Dict {tci_name = nm, tci_pred = pred})
 126   | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
 127   | otherwise     = mkLocalId nm (mkPredTy pred)
 128 instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
 129                        tci_wanted = wanteds})
 130   = mkLocalId nm (mkImplicTy tvs givens wanteds)
 131 instToVar i@(EqInst {})
 132   = eitherEqInst i id (\(TyVarTy covar) -> covar)
 133
 134 instType :: Inst -> Type
 135 instType (LitInst {tci_ty = ty})  = ty
 136 instType (Method {tci_id = id})   = idType id
 137 instType (Dict {tci_pred = pred}) = mkPredTy pred
 138 instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)
 139                                                (tci_wanted imp)
 140 -- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
 141 instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
 142
 143 mkImplicTy tvs givens wanteds   -- The type of an implication constraint
 144   = ASSERT( all isAbstractableInst givens )
 145     -- pprTrace "mkImplicTy" (ppr givens) $
 146     -- See [Equational Constraints in Implication Constraints]
 147     let dict_wanteds = filter (not . isEqInst) wanteds
 148     in
 149       mkForAllTys tvs $
 150       mkPhiTy (map dictPred givens) $
 151       if isSingleton dict_wanteds then
 152         instType (head dict_wanteds)
 153       else
 154         mkTupleTy Boxed (length dict_wanteds) (map instType dict_wanteds)
 155
 156 dictPred (Dict {tci_pred = pred}) = pred
 157 dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
 158 dictPred inst                     = pprPanic "dictPred" (ppr inst)
 159
 160 getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred
 161 getDictClassTys inst                     = pprPanic "getDictClassTys" (ppr inst)
 162
 163 -- fdPredsOfInst is used to get predicates that contain functional
 164 -- dependencies *or* might do so.  The "might do" part is because
 165 -- a constraint (C a b) might have a superclass with FDs
 166 -- Leaving these in is really important for the call to fdPredsOfInsts
 167 -- in TcSimplify.inferLoop, because the result is fed to 'grow',
 168 -- which is supposed to be conservative
 169 fdPredsOfInst (Dict {tci_pred = pred})       = [pred]
 170 fdPredsOfInst (Method {tci_theta = theta})   = theta
 171 fdPredsOfInst (ImplicInst {tci_given = gs,
 172                            tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws)
 173 fdPredsOfInst (LitInst {})                   = []
 174 fdPredsOfInst (EqInst {})                    = []
 175
 176 fdPredsOfInsts :: [Inst] -> [PredType]
 177 fdPredsOfInsts insts = concatMap fdPredsOfInst insts
 178
 179 isInheritableInst (Dict {tci_pred = pred})     = isInheritablePred pred
 180 isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta
 181 isInheritableInst other                        = True
 182
 183
 184 ---------------------------------
 185 -- Get the implicit parameters mentioned by these Insts
 186 -- NB: the results of these functions are insensitive to zonking
 187
 188 ipNamesOfInsts :: [Inst] -> [Name]
 189 ipNamesOfInst  :: Inst   -> [Name]
 190 ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
 191
 192 ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
 193 ipNamesOfInst (Method {tci_theta = theta})   = [ipNameName n | IParam n _ <- theta]
 194 ipNamesOfInst other                          = []
 195
 196 ---------------------------------
 197 tyVarsOfInst :: Inst -> TcTyVarSet
 198 tyVarsOfInst (LitInst {tci_ty = ty})  = tyVarsOfType  ty
 199 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
 200 tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
 201                                  -- The id might have free type variables; in the case of
 202                                  -- locally-overloaded class methods, for example
 203 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
 204   = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
 205     `minusVarSet` mkVarSet tvs
 206     `unionVarSet` unionVarSets (map varTypeTyVars tvs)
 207                 -- Remember the free tyvars of a coercion
 208 tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
 209
 210 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 211 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
 212
 213
 214 --------------------------
 215 instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
 216 instToDictBind inst rhs
 217   = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
 218
 219 addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
 220 addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
 221 \end{code}
 222
 223 Predicates
 224 ~~~~~~~~~~
 225 \begin{code}
 226
 227 isAbstractableInst :: Inst -> Bool
 228 isAbstractableInst inst = isDict inst || isEqInst inst
 229
 230 isEqInst :: Inst -> Bool
 231 isEqInst (EqInst {}) = True
 232 isEqInst other       = False
 233
 234 isDict :: Inst -> Bool
 235 isDict (Dict {}) = True
 236 isDict other     = False
 237
 238 isClassDict :: Inst -> Bool
 239 isClassDict (Dict {tci_pred = pred}) = isClassPred pred
 240 isClassDict other                    = False
 241
 242 isTyVarDict :: Inst -> Bool
 243 isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
 244 isTyVarDict other                    = False
 245
 246 isIPDict :: Inst -> Bool
 247 isIPDict (Dict {tci_pred = pred}) = isIPPred pred
 248 isIPDict other                    = False
 249
 250 isImplicInst (ImplicInst {}) = True
 251 isImplicInst other           = False
 252
 253 isMethod :: Inst -> Bool
 254 isMethod (Method {}) = True
 255 isMethod other       = False
 256
 257 isMethodFor :: TcIdSet -> Inst -> Bool
 258 isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
 259 isMethodFor ids inst                    = False
 260
 261 isMethodOrLit :: Inst -> Bool
 262 isMethodOrLit (Method {})  = True
 263 isMethodOrLit (LitInst {}) = True
 264 isMethodOrLit other        = False
 265 \end{code}
 266
 267
 268 %************************************************************************
 269 %*                                                                      *
 270 \subsection{Building dictionaries}
 271 %*                                                                      *
 272 %************************************************************************
 273
 274 -- newDictBndrs makes a dictionary at a binding site
 275 -- instCall makes a dictionary at an occurrence site
 276 --      and throws it into the LIE
 277
 278 \begin{code}
 279 ----------------
 280 newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
 281 newDictBndrsO orig theta = do { loc <- getInstLoc orig
 282                               ; newDictBndrs loc theta }
 283
 284 newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
 285 newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
 286
 287 newDictBndr :: InstLoc -> TcPredType -> TcM Inst
 288 newDictBndr inst_loc pred@(EqPred ty1 ty2)
 289   = do { uniq <- newUnique
 290         ; let name = mkPredName uniq inst_loc pred
 291         ; return (EqInst {tci_name  = name,
 292                           tci_loc   = inst_loc,
 293                           tci_left  = ty1,
 294                           tci_right = ty2,
 295                           tci_co    = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))})
 296        }
 297 newDictBndr inst_loc pred
 298   = do  { uniq <- newUnique
 299         ; let name = mkPredName uniq inst_loc pred
 300         ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) }
 301
 302 ----------------
 303 instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
 304 -- Instantiate the constraints of a call
 305 --      (instCall o tys theta)
 306 -- (a) Makes fresh dictionaries as necessary for the constraints (theta)
 307 -- (b) Throws these dictionaries into the LIE
 308 -- (c) Returns an HsWrapper ([.] tys dicts)
 309
 310 instCall orig tys theta
 311   = do  { loc <- getInstLoc orig
 312         ; dict_app <- instCallDicts loc theta
 313         ; return (dict_app <.> mkWpTyApps tys) }
 314
 315 ----------------
 316 instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
 317 -- Similar to instCall, but only emit the constraints in the LIE
 318 -- Used exclusively for the 'stupid theta' of a data constructor
 319 instStupidTheta orig theta
 320   = do  { loc <- getInstLoc orig
 321         ; _co <- instCallDicts loc theta        -- Discard the coercion
 322         ; return () }
 323
 324 ----------------
 325 instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
 326 -- Instantiates the TcTheta, puts all constraints thereby generated
 327 -- into the LIE, and returns a HsWrapper to enclose the call site.
 328 -- This is the key place where equality predicates
 329 -- are unleashed into the world
 330 instCallDicts loc [] = return idHsWrapper
 331
 332 -- instCallDicts loc (EqPred ty1 ty2 : preds)
 333 --   = do  { unifyType ty1 ty2  -- For now, we insist that they unify right away
 334 --                              -- Later on, when we do associated types,
 335 --                              -- unifyType :: Type -> Type -> TcM ([Inst], Coercion)
 336 --      ; (dicts, co_fn) <- instCallDicts loc preds
 337 --      ; return (dicts, co_fn <.> WpTyApp ty1) }
 338 --      -- We use type application to apply the function to the
 339 --      -- coercion; here ty1 *is* the appropriate identity coercion
 340
 341 instCallDicts loc (EqPred ty1 ty2 : preds)
 342   = do  { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
 343         ; coi <- boxyUnify ty1 ty2
 344 --      ; coi <- unifyType ty1 ty2
 345         ; let co = fromCoI coi ty1
 346         ; co_fn <- instCallDicts loc preds
 347         ; return (co_fn <.> WpTyApp co) }
 348
 349 instCallDicts loc (pred : preds)
 350   = do  { uniq <- newUnique
 351         ; let name = mkPredName uniq loc pred
 352               dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc}
 353         ; extendLIE dict
 354         ; co_fn <- instCallDicts loc preds
 355         ; return (co_fn <.> WpApp (instToId dict)) }
 356
 357 -------------
 358 cloneDict :: Inst -> TcM Inst
 359 cloneDict dict@(Dict nm ty loc) = do { uniq <- newUnique
 360                                      ; return (dict {tci_name = setNameUnique nm uniq}) }
 361 cloneDict eq@(EqInst {})        = return eq
 362 cloneDict other = pprPanic "cloneDict" (ppr other)
 363
 364 -- For vanilla implicit parameters, there is only one in scope
 365 -- at any time, so we used to use the name of the implicit parameter itself
 366 -- But with splittable implicit parameters there may be many in
 367 -- scope, so we make up a new namea.
 368 newIPDict :: InstOrigin -> IPName Name -> Type
 369           -> TcM (IPName Id, Inst)
 370 newIPDict orig ip_name ty = do
 371     inst_loc <- getInstLoc orig
 372     uniq <- newUnique
 373     let
 374         pred = IParam ip_name ty
 375         name = mkPredName uniq inst_loc pred
 376         dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}
 377
 378     return (mapIPName (\n -> instToId dict) ip_name, dict)
 379 \end{code}
 380
 381
 382 \begin{code}
 383 mkPredName :: Unique -> InstLoc -> PredType -> Name
 384 mkPredName uniq loc pred_ty
 385   = mkInternalName uniq occ (instLocSpan loc)
 386   where
 387     occ = case pred_ty of
 388             ClassP cls _ -> mkDictOcc (getOccName cls)
 389             IParam ip  _ -> getOccName (ipNameName ip)
 390             EqPred ty  _ -> mkEqPredCoOcc baseOcc
 391               where
 392                 -- we use the outermost tycon of the lhs, if there is one, to
 393                 -- improve readability of Core code
 394                 baseOcc = case splitTyConApp_maybe ty of
 395                             Nothing      -> mkOccName tcName "$"
 396                             Just (tc, _) -> getOccName tc
 397 \end{code}
 398
 399 %************************************************************************
 400 %*                                                                      *
 401 \subsection{Building methods (calls of overloaded functions)}
 402 %*                                                                      *
 403 %************************************************************************
 404
 405
 406 \begin{code}
 407 newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
 408 newMethodFromName origin ty name = do
 409     id <- tcLookupId name
 410         -- Use tcLookupId not tcLookupGlobalId; the method is almost
 411         -- always a class op, but with -fno-implicit-prelude GHC is
 412         -- meant to find whatever thing is in scope, and that may
 413         -- be an ordinary function.
 414     loc <- getInstLoc origin
 415     inst <- tcInstClassOp loc id [ty]
 416     extendLIE inst
 417     return (instToId inst)
 418
 419 newMethodWithGivenTy orig id tys = do
 420     loc <- getInstLoc orig
 421     inst <- newMethod loc id tys
 422     extendLIE inst
 423     return (instToId inst)
 424
 425 --------------------------------------------
 426 -- tcInstClassOp, and newMethod do *not* drop the
 427 -- Inst into the LIE; they just returns the Inst
 428 -- This is important because they are used by TcSimplify
 429 -- to simplify Insts
 430
 431 -- NB: the kind of the type variable to be instantiated
 432 --     might be a sub-kind of the type to which it is applied,
 433 --     notably when the latter is a type variable of kind ??
 434 --     Hence the call to checkKind
 435 -- A worry: is this needed anywhere else?
 436 tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
 437 tcInstClassOp inst_loc sel_id tys = do
 438     let
 439         (tyvars, _rho) = tcSplitForAllTys (idType sel_id)
 440     zipWithM_ checkKind tyvars tys
 441     newMethod inst_loc sel_id tys
 442
 443 checkKind :: TyVar -> TcType -> TcM ()
 444 -- Ensure that the type has a sub-kind of the tyvar
 445 checkKind tv ty
 446   = do  { let ty1 = ty
 447                 -- ty1 <- zonkTcType ty
 448         ; if typeKind ty1 `isSubKind` Var.tyVarKind tv
 449           then return ()
 450           else
 451
 452     pprPanic "checkKind: adding kind constraint"
 453              (vcat [ppr tv <+> ppr (Var.tyVarKind tv),
 454                     ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
 455         }
 456 --    do        { tv1 <- tcInstTyVar tv
 457 --      ; unifyType ty1 (mkTyVarTy tv1) } }
 458
 459
 460 ---------------------------
 461 newMethod inst_loc id tys = do
 462     new_uniq <- newUnique
 463     let
 464         (theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
 465         meth_id     = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
 466         inst        = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
 467                               tci_theta = theta, tci_loc = inst_loc}
 468         loc         = instLocSpan inst_loc
 469
 470     return inst
 471 \end{code}
 472
 473 \begin{code}
 474 shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
 475 shortCutIntLit i ty
 476   | isIntTy ty && inIntRange i = Just (HsLit (HsInt i))
 477   | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i))
 478   | isIntegerTy ty             = Just (HsLit (HsInteger i ty))
 479   | otherwise                  = shortCutFracLit (fromInteger i) ty
 480         -- The 'otherwise' case is important
 481         -- Consider (3 :: Float).  Syntactically it looks like an IntLit,
 482         -- so we'll call shortCutIntLit, but of course it's a float
 483         -- This can make a big difference for programs with a lot of
 484         -- literals, compiled without -O
 485
 486 shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
 487 shortCutFracLit f ty
 488   | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim f))
 489   | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim f))
 490   | otherwise     = Nothing
 491   where
 492
 493 mkLit :: DataCon -> HsLit -> HsExpr Id
 494 mkLit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
 495
 496 shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
 497 shortCutStringLit s ty
 498   | isStringTy ty                       -- Short cut for String
 499   = Just (HsLit (HsString s))
 500   | otherwise = Nothing
 501
 502 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
 503 mkIntegerLit i = do
 504     integer_ty <- tcMetaTy integerTyConName
 505     span <- getSrcSpanM
 506     return (L span $ HsLit (HsInteger i integer_ty))
 507
 508 mkRatLit :: Rational -> TcM (LHsExpr TcId)
 509 mkRatLit r = do
 510     rat_ty <- tcMetaTy rationalTyConName
 511     span <- getSrcSpanM
 512     return (L span $ HsLit (HsRat r rat_ty))
 513
 514 mkStrLit :: FastString -> TcM (LHsExpr TcId)
 515 mkStrLit s = do
 516     --string_ty <- tcMetaTy stringTyConName
 517     span <- getSrcSpanM
 518     return (L span $ HsLit (HsString s))
 519
 520 isHsVar :: HsExpr Name -> Name -> Bool
 521 isHsVar (HsVar f) g = f==g
 522 isHsVar other     g = False
 523 \end{code}
 524
 525
 526 %************************************************************************
 527 %*                                                                      *
 528 \subsection{Zonking}
 529 %*                                                                      *
 530 %************************************************************************
 531
 532 Zonking makes sure that the instance types are fully zonked.
 533
 534 \begin{code}
 535 zonkInst :: Inst -> TcM Inst
 536 zonkInst dict@(Dict { tci_pred = pred}) = do
 537     new_pred <- zonkTcPredType pred
 538     return (dict {tci_pred = new_pred})
 539
 540 zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
 541     new_id <- zonkId id
 542         -- Essential to zonk the id in case it's a local variable
 543         -- Can't use zonkIdOcc because the id might itself be
 544         -- an InstId, in which case it won't be in scope
 545
 546     new_tys <- zonkTcTypes tys
 547     new_theta <- zonkTcThetaType theta
 548     return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
 549         -- No need to zonk the tci_id
 550
 551 zonkInst lit@(LitInst {tci_ty = ty}) = do
 552     new_ty <- zonkTcType ty
 553     return (lit {tci_ty = new_ty})
 554
 555 zonkInst implic@(ImplicInst {})
 556   = ASSERT( all isImmutableTyVar (tci_tyvars implic) )
 557     do  { givens'  <- zonkInsts (tci_given  implic)
 558         ; wanteds' <- zonkInsts (tci_wanted implic)
 559         ; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
 560
 561 zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
 562   = do { co' <- eitherEqInst eqinst
 563                   (\covar -> return (mkWantedCo covar))
 564                   (\co    -> liftM mkGivenCo $ zonkTcType co)
 565        ; ty1' <- zonkTcType ty1
 566        ; ty2' <- zonkTcType ty2
 567        ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' })
 568        }
 569
 570 zonkInsts insts = mapM zonkInst insts
 571 \end{code}
 572
 573
 574 %************************************************************************
 575 %*                                                                      *
 576 \subsection{Printing}
 577 %*                                                                      *
 578 %************************************************************************
 579
 580 ToDo: improve these pretty-printing things.  The ``origin'' is really only
 581 relevant in error messages.
 582
 583 \begin{code}
 584 instance Outputable Inst where
 585     ppr inst = pprInst inst
 586
 587 pprDictsTheta :: [Inst] -> SDoc
 588 -- Print in type-like fashion (Eq a, Show b)
 589 -- The Inst can be an implication constraint, but not a Method or LitInst
 590 pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
 591
 592 pprDictsInFull :: [Inst] -> SDoc
 593 -- Print in type-like fashion, but with source location
 594 pprDictsInFull dicts
 595   = vcat (map go dicts)
 596   where
 597     go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
 598
 599 pprInsts :: [Inst] -> SDoc
 600 -- Debugging: print the evidence :: type
 601 pprInsts insts = brackets (interpp'SP insts)
 602
 603 pprInst, pprInstInFull :: Inst -> SDoc
 604 -- Debugging: print the evidence :: type
 605 pprInst i@(EqInst {tci_left = ty1, tci_right = ty2, tci_co = co})
 606         = eitherEqInst i
 607                 (\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
 608                 (\co    -> text "Given"  <+> ppr co              <+> dcolon <+> ppr (EqPred ty1 ty2))
 609 pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
 610                 <+> braces (ppr (instType inst) <> implicWantedEqs)
 611   where
 612     name = instName inst
 613     implicWantedEqs
 614       | isImplicInst inst = text " &" <+>
 615                             ppr (filter isEqInst (tci_wanted inst))
 616       | otherwise         = empty
 617
 618 pprInstInFull inst@(EqInst {}) = pprInst inst
 619 pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
 620
 621 tidyInst :: TidyEnv -> Inst -> Inst
 622 tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
 623   eq { tci_left  = tidyType env lty
 624      , tci_right = tidyType env rty
 625      , tci_co    = either Left (Right . tidyType env) co
 626      }
 627 tidyInst env lit@(LitInst {tci_ty = ty})   = lit {tci_ty = tidyType env ty}
 628 tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
 629 tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
 630 tidyInst env implic@(ImplicInst {})
 631   = implic { tci_tyvars = tvs'
 632            , tci_given  = map (tidyInst env') (tci_given  implic)
 633            , tci_wanted = map (tidyInst env') (tci_wanted implic) }
 634   where
 635     (env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
 636
 637 tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
 638 -- This function doesn't assume that the tyvars are in scope
 639 -- so it works like tidyOpenType, returning a TidyEnv
 640 tidyMoreInsts env insts
 641   = (env', map (tidyInst env') insts)
 642   where
 643     env' = tidyFreeTyVars env (tyVarsOfInsts insts)
 644
 645 tidyInsts :: [Inst] -> (TidyEnv, [Inst])
 646 tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
 647
 648 showLIE :: SDoc -> TcM ()       -- Debugging
 649 showLIE str
 650   = do { lie_var <- getLIEVar ;
 651          lie <- readMutVar lie_var ;
 652          traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
 653 \end{code}
 654
 655
 656 %************************************************************************
 657 %*                                                                      *
 658         Extending the instance environment
 659 %*                                                                      *
 660 %************************************************************************
 661
 662 \begin{code}
 663 tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
 664   -- Add new locally-defined instances
 665 tcExtendLocalInstEnv dfuns thing_inside
 666  = do { traceDFuns dfuns
 667       ; env <- getGblEnv
 668       ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
 669       ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
 670                          tcg_inst_env = inst_env' }
 671       ; setGblEnv env' thing_inside }
 672
 673 addLocalInst :: InstEnv -> Instance -> TcM InstEnv
 674 -- Check that the proposed new instance is OK,
 675 -- and then add it to the home inst env
 676 addLocalInst home_ie ispec
 677   = do  {       -- Instantiate the dfun type so that we extend the instance
 678                 -- envt with completely fresh template variables
 679                 -- This is important because the template variables must
 680                 -- not overlap with anything in the things being looked up
 681                 -- (since we do unification).
 682                 -- We use tcInstSkolType because we don't want to allocate fresh
 683                 --  *meta* type variables.
 684           let dfun = instanceDFunId ispec
 685         ; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
 686         ; let   (cls, tys') = tcSplitDFunHead tau'
 687                 dfun'       = setIdType dfun (mkSigmaTy tvs' theta' tau')
 688                 ispec'      = setInstanceDFunId ispec dfun'
 689
 690                 -- Load imported instances, so that we report
 691                 -- duplicates correctly
 692         ; eps <- getEps
 693         ; let inst_envs = (eps_inst_env eps, home_ie)
 694
 695                 -- Check functional dependencies
 696         ; case checkFunDeps inst_envs ispec' of
 697                 Just specs -> funDepErr ispec' specs
 698                 Nothing    -> return ()
 699
 700                 -- Check for duplicate instance decls
 701         ; let { (matches, _) = lookupInstEnv inst_envs cls tys'
 702               ; dup_ispecs = [ dup_ispec
 703                              | (dup_ispec, _) <- matches
 704                              , let (_,_,_,dup_tys) = instanceHead dup_ispec
 705                              , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
 706                 -- Find memebers of the match list which ispec itself matches.
 707                 -- If the match is 2-way, it's a duplicate
 708         ; case dup_ispecs of
 709             dup_ispec : _ -> dupInstErr ispec' dup_ispec
 710             []            -> return ()
 711
 712                 -- OK, now extend the envt
 713         ; return (extendInstEnv home_ie ispec') }
 714
 715 getOverlapFlag :: TcM OverlapFlag
 716 getOverlapFlag
 717   = do  { dflags <- getDOpts
 718         ; let overlap_ok    = dopt Opt_OverlappingInstances dflags
 719               incoherent_ok = dopt Opt_IncoherentInstances  dflags
 720               overlap_flag | incoherent_ok = Incoherent
 721                            | overlap_ok    = OverlapOk
 722                            | otherwise     = NoOverlap
 723
 724         ; return overlap_flag }
 725
 726 traceDFuns ispecs
 727   = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
 728   where
 729     pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
 730         -- Print the dfun name itself too
 731
 732 funDepErr ispec ispecs
 733   = addDictLoc ispec $
 734     addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
 735                2 (pprInstances (ispec:ispecs)))
 736 dupInstErr ispec dup_ispec
 737   = addDictLoc ispec $
 738     addErr (hang (ptext (sLit "Duplicate instance declarations:"))
 739                2 (pprInstances [ispec, dup_ispec]))
 740
 741 addDictLoc ispec thing_inside
 742   = setSrcSpan (mkSrcSpan loc loc) thing_inside
 743   where
 744    loc = getSrcLoc ispec
 745 \end{code}
 746
 747
 748 %************************************************************************
 749 %*                                                                      *
 750 \subsection{Looking up Insts}
 751 %*                                                                      *
 752 %************************************************************************
 753
 754 \begin{code}
 755 data LookupInstResult
 756   = NoInstance
 757   | GenInst [Inst] (LHsExpr TcId)       -- The expression and its needed insts
 758
 759 lookupSimpleInst :: Inst -> TcM LookupInstResult
 760 -- This is "simple" in that it returns NoInstance for implication constraints
 761
 762 -- It's important that lookupInst does not put any new stuff into
 763 -- the LIE.  Instead, any Insts needed by the lookup are returned in
 764 -- the LookupInstResult, where they can be further processed by tcSimplify
 765
 766 lookupSimpleInst (EqInst {}) = return NoInstance
 767
 768 --------------------- Implications ------------------------
 769 lookupSimpleInst (ImplicInst {}) = return NoInstance
 770
 771 --------------------- Methods ------------------------
 772 lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
 773   = do  { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
 774         ; let co_fn = dict_app <.> mkWpTyApps tys
 775         ; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
 776   where
 777     span = instLocSpan loc
 778
 779 --------------------- Literals ------------------------
 780 -- Look for short cuts first: if the literal is *definitely* a
 781 -- int, integer, float or a double, generate the real thing here.
 782 -- This is essential (see nofib/spectral/nucleic).
 783 -- [Same shortcut as in newOverloadedLit, but we
 784 --  may have done some unification by now]
 785
 786 lookupSimpleInst (LitInst {tci_lit = HsIntegral i from_integer_name _, tci_ty = ty, tci_loc = loc})
 787   | Just expr <- shortCutIntLit i ty
 788   = return (GenInst [] (noLoc expr))
 789   | otherwise
 790   = ASSERT( from_integer_name `isHsVar` fromIntegerName ) do    -- A LitInst invariant
 791     from_integer <- tcLookupId fromIntegerName
 792     method_inst <- tcInstClassOp loc from_integer [ty]
 793     integer_lit <- mkIntegerLit i
 794     return (GenInst [method_inst]
 795                      (mkHsApp (L (instLocSpan loc)
 796                                  (HsVar (instToId method_inst))) integer_lit))
 797
 798 lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name _, tci_ty = ty, tci_loc = loc})
 799   | Just expr <- shortCutFracLit f ty
 800   = return (GenInst [] (noLoc expr))
 801
 802   | otherwise
 803   = ASSERT( from_rat_name `isHsVar` fromRationalName ) do       -- A LitInst invariant
 804     from_rational <- tcLookupId fromRationalName
 805     method_inst <- tcInstClassOp loc from_rational [ty]
 806     rat_lit <- mkRatLit f
 807     return (GenInst [method_inst] (mkHsApp (L (instLocSpan loc)
 808                                                (HsVar (instToId method_inst))) rat_lit))
 809
 810 lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name _, tci_ty = ty, tci_loc = loc})
 811   | Just expr <- shortCutStringLit s ty
 812   = return (GenInst [] (noLoc expr))
 813   | otherwise
 814   = ASSERT( from_string_name `isHsVar` fromStringName ) do      -- A LitInst invariant
 815     from_string <- tcLookupId fromStringName
 816     method_inst <- tcInstClassOp loc from_string [ty]
 817     string_lit <- mkStrLit s
 818     return (GenInst [method_inst]
 819                      (mkHsApp (L (instLocSpan loc)
 820                                  (HsVar (instToId method_inst))) string_lit))
 821
 822 --------------------- Dictionaries ------------------------
 823 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
 824   = do  { mb_result <- lookupPred pred
 825         ; case mb_result of {
 826             Nothing -> return NoInstance ;
 827             Just (dfun_id, mb_inst_tys) -> do
 828
 829     { use_stage <- getStage
 830     ; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
 831                       (topIdLvl dfun_id) use_stage
 832
 833         -- It's possible that not all the tyvars are in
 834         -- the substitution, tenv. For example:
 835         --      instance C X a => D X where ...
 836         -- (presumably there's a functional dependency in class C)
 837         -- Hence mb_inst_tys :: Either TyVar TcType
 838
 839     ; let inst_tv (Left tv)  = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
 840           inst_tv (Right ty) = return ty
 841     ; tys <- mapM inst_tv mb_inst_tys
 842     ; let
 843         (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
 844         src_loc    = instLocSpan loc
 845         dfun       = HsVar dfun_id
 846     ; if null theta then
 847         return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
 848       else do
 849     { (dict_app, dicts) <- getLIE $ instCallDicts loc theta -- !!!
 850     ; let co_fn = dict_app <.> mkWpTyApps tys
 851     ; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
 852     }}}}
 853
 854 ---------------
 855 lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
 856 -- Look up a class constraint in the instance environment
 857 lookupPred pred@(ClassP clas tys)
 858   = do  { eps     <- getEps
 859         ; tcg_env <- getGblEnv
 860         ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
 861         ; case lookupInstEnv inst_envs clas tys of {
 862             ([(ispec, inst_tys)], [])
 863                 -> do   { let dfun_id = is_dfun ispec
 864                         ; traceTc (text "lookupInst success" <+>
 865                                    vcat [text "dict" <+> ppr pred,
 866                                          text "witness" <+> ppr dfun_id
 867                                          <+> ppr (idType dfun_id) ])
 868                                 -- Record that this dfun is needed
 869                         ; record_dfun_usage dfun_id
 870                         ; return (Just (dfun_id, inst_tys)) } ;
 871
 872             (matches, unifs)
 873                 -> do   { traceTc (text "lookupInst fail" <+>
 874                                    vcat [text "dict" <+> ppr pred,
 875                                          text "matches" <+> ppr matches,
 876                                          text "unifs" <+> ppr unifs])
 877                 -- In the case of overlap (multiple matches) we report
 878                 -- NoInstance here.  That has the effect of making the
 879                 -- context-simplifier return the dict as an irreducible one.
 880                 -- Then it'll be given to addNoInstanceErrs, which will do another
 881                 -- lookupInstEnv to get the detailed info about what went wrong.
 882                         ; return Nothing }
 883         }}
 884
 885 lookupPred ip_pred = return Nothing     -- Implicit parameters
 886
 887 record_dfun_usage dfun_id
 888   = do  { hsc_env <- getTopEnv
 889         ; let  dfun_name = idName dfun_id
 890                dfun_mod  = nameModule dfun_name
 891         ; if isInternalName dfun_name ||    -- Internal name => defined in this module
 892              modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
 893           then return () -- internal, or in another package
 894            else do { tcg_env <- getGblEnv
 895                    ; updMutVar (tcg_inst_uses tcg_env)
 896                                (`addOneToNameSet` idName dfun_id) }}
 897
 898
 899 tcGetInstEnvs :: TcM (InstEnv, InstEnv)
 900 -- Gets both the external-package inst-env
 901 -- and the home-pkg inst env (includes module being compiled)
 902 tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
 903                      return (eps_inst_env eps, tcg_inst_env env) }
 904 \end{code}
 905
 906
 907
 908 %************************************************************************
 909 %*                                                                      *
 910                 Re-mappable syntax
 911 %*                                                                      *
 912 %************************************************************************
 913
 914 Suppose we are doing the -fno-implicit-prelude thing, and we encounter
 915 a do-expression.  We have to find (>>) in the current environment, which is
 916 done by the rename. Then we have to check that it has the same type as
 917 Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
 918 this:
 919
 920   (>>) :: HB m n mn => m a -> n b -> mn b
 921
 922 So the idea is to generate a local binding for (>>), thus:
 923
 924         let then72 :: forall a b. m a -> m b -> m b
 925             then72 = ...something involving the user's (>>)...
 926         in
 927         ...the do-expression...
 928
 929 Now the do-expression can proceed using then72, which has exactly
 930 the expected type.
 931
 932 In fact tcSyntaxName just generates the RHS for then72, because we only
 933 want an actual binding in the do-expression case. For literals, we can
 934 just use the expression inline.
 935
 936 \begin{code}
 937 tcSyntaxName :: InstOrigin
 938              -> TcType                  -- Type to instantiate it at
 939              -> (Name, HsExpr Name)     -- (Standard name, user name)
 940              -> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
 941 --      *** NOW USED ONLY FOR CmdTop (sigh) ***
 942 -- NB: tcSyntaxName calls tcExpr, and hence can do unification.
 943 -- So we do not call it from lookupInst, which is called from tcSimplify
 944
 945 tcSyntaxName orig ty (std_nm, HsVar user_nm)
 946   | std_nm == user_nm
 947   = do id <- newMethodFromName orig ty std_nm
 948        return (std_nm, HsVar id)
 949
 950 tcSyntaxName orig ty (std_nm, user_nm_expr) = do
 951     std_id <- tcLookupId std_nm
 952     let
 953         -- C.f. newMethodAtLoc
 954         ([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 955         sigma1          = substTyWith [tv] [ty] tau
 956         -- Actually, the "tau-type" might be a sigma-type in the
 957         -- case of locally-polymorphic methods.
 958
 959     addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
 960
 961         -- Check that the user-supplied thing has the
 962         -- same type as the standard one.
 963         -- Tiresome jiggling because tcCheckSigma takes a located expression
 964      span <- getSrcSpanM
 965      expr <- tcPolyExpr (L span user_nm_expr) sigma1
 966      return (std_nm, unLoc expr)
 967
 968 syntaxNameCtxt name orig ty tidy_env = do
 969     inst_loc <- getInstLoc orig
 970     let
 971         msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
 972                                 ptext (sLit "(needed by a syntactic construct)"),
 973                     nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
 974                     nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
 975
 976     return (tidy_env, msg)
 977 \end{code}
 978
 979 %************************************************************************
 980 %*                                                                      *
 981                 EqInsts
 982 %*                                                                      *
 983 %************************************************************************
 984
 985 \begin{code}
 986 mkGivenCo   :: Coercion -> Either TcTyVar Coercion
 987 mkGivenCo   =  Right
 988
 989 mkWantedCo  :: TcTyVar  -> Either TcTyVar Coercion
 990 mkWantedCo  =  Left
 991
 992 fromGivenCo :: Either TcTyVar Coercion -> Coercion
 993 fromGivenCo (Right co)   = co
 994 fromGivenCo _            = panic "fromGivenCo: not a wanted coercion"
 995
 996 fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar
 997 fromWantedCo _ (Left covar) = covar
 998 fromWantedCo msg _          = panic ("fromWantedCo: not a wanted coercion: " ++ msg)
 999
1000 eitherEqInst :: Inst                -- given or wanted EqInst
1001              -> (TcTyVar  -> a)     --  result if wanted
1002              -> (Coercion -> a)     --  result if given
1003              -> a
1004 eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
1005         = case either_co of
1006                 Left  covar -> withWanted covar
1007                 Right co    -> withGiven  co
1008
1009 mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst]
1010 mkEqInsts preds cos = zipWithM mkEqInst preds cos
1011
1012 mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst
1013 mkEqInst (EqPred ty1 ty2) co
1014         = do { uniq <- newUnique
1015              ; src_span <- getSrcSpanM
1016              ; err_ctxt <- getErrCtxt
1017              ; let loc  = InstLoc EqOrigin src_span err_ctxt
1018                    name = mkName uniq src_span
1019                    inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name}
1020              ; return inst
1021              }
1022         where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
1023
1024 mkWantedEqInst :: PredType -> TcM Inst
1025 mkWantedEqInst pred@(EqPred ty1 ty2)
1026   = do { cotv <- newMetaCoVar ty1 ty2
1027        ; mkEqInst pred (Left cotv)
1028        }
1029
1030 -- type inference:
1031 --      We want to promote the wanted EqInst to a given EqInst
1032 --      in the signature context.
1033 --      This means we have to give the coercion a name
1034 --      and fill it in as its own name.
1035 finalizeEqInst
1036         :: Inst                 -- wanted
1037         -> TcM Inst             -- given
1038 finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name})
1039         = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2)
1040              ; writeWantedCoercion wanted (TyVarTy var)
1041              ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
1042              ; return given
1043              }
1044
1045 writeWantedCoercion
1046         :: Inst         -- wanted EqInst
1047         -> Coercion     -- coercion to fill the hole with
1048         -> TcM ()
1049 writeWantedCoercion wanted co
1050         = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted
1051              ; writeMetaTyVar cotv co
1052              }
1053
1054 eqInstType :: Inst -> TcType
1055 eqInstType inst = eitherEqInst inst mkTyVarTy id
1056
1057 eqInstCoercion :: Inst -> Either TcTyVar Coercion
1058 eqInstCoercion = tci_co
1059
1060 eqInstTys :: Inst -> (TcType, TcType)
1061 eqInstTys inst = (tci_left inst, tci_right inst)
1062
1063 updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst
1064 updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst}
1065 \end{code}