Inst.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[Inst]{The @Inst@ type: dictionaries or method instances}

\begin{code}
module Inst ( 
	Inst, 

	pprInstances, pprDictsTheta, pprDictsInFull,	-- User error messages
	showLIE, pprInst, pprInsts, pprInstInFull,	-- Debugging messages

	tidyInsts, tidyMoreInsts,

	newDicts, newDictsAtLoc, cloneDict, 
	shortCutFracLit, shortCutIntLit, newIPDict, 
	newMethod, newMethodFromName, newMethodWithGivenTy, 
	tcInstClassOp, tcInstStupidTheta,
	tcSyntaxName, isHsVar,

	tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, 
	ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
	instLoc, getDictClassTys, dictPred,

	mkInstCoFn, 
	lookupInst, LookupInstResult(..), lookupPred, 
	tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,

	isDict, isClassDict, isMethod, 
	isLinearInst, linearInstType, isIPDict, isInheritableInst,
	isTyVarDict, isMethodFor, 

	zonkInst, zonkInsts,
	instToId, instToVar, instName,

	InstOrigin(..), InstLoc(..), pprInstLoc
    ) where

#include "HsVersions.h"

import {-# SOURCE #-}	TcExpr( tcPolyExpr )

import HsSyn	( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, mkHsApp,
		  ExprCoFn(..), (<.>), nlHsLit, nlHsVar )
import TcHsSyn	( zonkId )
import TcRnMonad
import TcEnv	( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy )
import InstEnv	( DFunId, InstEnv, Instance(..), OverlapFlag(..),
		  lookupInstEnv, extendInstEnv, pprInstances, 
		  instanceHead, instanceDFunId, setInstanceDFunId )
import FunDeps	( checkFunDeps )
import TcMType	( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, 
		  tcInstTyVar, tcInstSkolType
		)
import TcType	( Type, TcType, TcThetaType, TcTyVarSet, TcPredType,
		  BoxyRhoType,
		  PredType(..), SkolemInfo(..), typeKind, mkSigmaTy,
		  tcSplitForAllTys, applyTys, 
		  tcSplitPhiTy, tcSplitDFunHead,
		  isIntTy,isFloatTy, isIntegerTy, isDoubleTy,
		  mkPredTy, mkTyVarTys,
		  tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred,
		  isClassPred, isTyVarClassPred, isLinearPred, 
		  getClassPredTys, mkPredName,
		  isInheritablePred, isIPPred, 
		  tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, 
		  pprPred, pprParendType, pprTheta 
		)
import Type	( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
		  notElemTvSubst, extendTvSubstList )
import Unify	( tcMatchTys )
import Module	( modulePackageId )
import {- Kind parts of -} Type	( isSubKind )
import Coercion ( isEqPred )
import HscTypes	( ExternalPackageState(..), HscEnv(..) )
import CoreFVs	( idFreeTyVars )
import DataCon	( DataCon, dataConStupidTheta, dataConName, 
                  dataConWrapId, dataConUnivTyVars )
import Id	( Id, idName, idType, mkUserLocal, mkLocalId, isId )
import Name	( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule,
		  isInternalName, setNameUnique )
import NameSet	( addOneToNameSet )
import Literal	( inIntRange )
import Var	( Var, TyVar, tyVarKind, setIdType, mkTyVar )
import VarEnv	( TidyEnv, emptyTidyEnv )
import VarSet	( elemVarSet, emptyVarSet, unionVarSet, mkVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames	( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc	( mkSrcSpan, noLoc, unLoc, Located(..) )
import DynFlags	( DynFlag(..), DynFlags(..), dopt )
import Maybes	( isJust )
import Outputable
\end{code}


Selection
~~~~~~~~~
\begin{code}
mkInstCoFn :: [TcType] -> [Inst] -> ExprCoFn
mkInstCoFn tys dicts = CoApps (map instToId dicts) <.> CoTyApps tys

instName :: Inst -> Name
instName inst = idName (instToId inst)

instToId :: Inst -> TcId
instToId inst = ASSERT2( isId id, ppr inst ) id 
	      where
		id = instToVar inst

instToVar :: Inst -> Var
instToVar (LitInst nm _ ty _) = mkLocalId nm ty
instToVar (Method id _ _ _ _) = id
instToVar (Dict nm pred _)    
  | isEqPred pred = mkTyVar nm (mkPredTy pred)
  | otherwise	  = mkLocalId nm (mkPredTy pred)

instLoc (Dict _ _       loc) = loc
instLoc (Method _ _ _ _ loc) = loc
instLoc (LitInst _ _ _  loc) = loc

dictPred (Dict _ pred _ ) = pred
dictPred inst		  = pprPanic "dictPred" (ppr inst)

getDictClassTys (Dict _ pred _) = getClassPredTys pred

-- fdPredsOfInst is used to get predicates that contain functional 
-- dependencies *or* might do so.  The "might do" part is because
-- a constraint (C a b) might have a superclass with FDs
-- 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

fdPredsOfInsts :: [Inst] -> [PredType]
fdPredsOfInsts insts = concatMap fdPredsOfInst insts

isInheritableInst (Dict _ pred _) 	 = isInheritablePred pred
isInheritableInst (Method _ _ _ theta _) = all isInheritablePred theta
isInheritableInst other			 = True


ipNamesOfInsts :: [Inst] -> [Name]
ipNamesOfInst  :: Inst   -> [Name]
-- Get the implicit parameters mentioned by these Insts
-- 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		      = []

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


tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
\end{code}

Predicates
~~~~~~~~~~
\begin{code}
isDict :: Inst -> Bool
isDict (Dict _ _ _) = True
isDict other	    = False

isClassDict :: Inst -> Bool
isClassDict (Dict _ pred _) = isClassPred pred
isClassDict other	    = False

isTyVarDict :: Inst -> Bool
isTyVarDict (Dict _ pred _) = isTyVarClassPred pred
isTyVarDict other	    = False

isIPDict :: Inst -> Bool
isIPDict (Dict _ 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

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}



%************************************************************************
%*									*
\subsection{Building dictionaries}
%*									*
%************************************************************************

\begin{code}
newDicts :: InstOrigin
	 -> TcThetaType
	 -> TcM [Inst]
newDicts orig theta
  = getInstLoc orig		`thenM` \ loc ->
    newDictsAtLoc loc theta

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)

newDictsAtLoc :: InstLoc -> TcThetaType -> TcM [Inst]
newDictsAtLoc inst_loc theta = mapM (newDictAtLoc inst_loc) theta

{-
newDictOcc :: InstLoc -> TcPredType -> TcM Inst
newDictOcc inst_loc (EqPred ty1 ty2)
  = do	{ unifyType ty1 ty2	-- We insist that they unify right away
	; return ty1 }		-- And return the relexive coercion
-}
newDictAtLoc inst_loc pred
  = do 	{ uniq <- newUnique 
	; let name = mkPredName uniq (instLocSrcLoc inst_loc) pred 
	; return (Dict name pred inst_loc) }

-- 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
-- But with splittable implicit parameters there may be many in 
-- scope, so we make up a new namea.
newIPDict :: InstOrigin -> IPName Name -> Type 
	  -> TcM (IPName Id, Inst)
newIPDict orig ip_name ty
  = getInstLoc orig			`thenM` \ inst_loc ->
    newUnique				`thenM` \ uniq ->
    let
	pred = IParam ip_name ty
        name = mkPredName uniq (instLocSrcLoc inst_loc) pred 
	dict = Dict name pred inst_loc
    in
    returnM (mapIPName (\n -> instToId dict) ip_name, dict)
\end{code}



%************************************************************************
%*									*
\subsection{Building methods (calls of overloaded functions)}
%*									*
%************************************************************************


\begin{code}
tcInstStupidTheta :: DataCon -> [TcType] -> TcM ()
-- Instantiate the "stupid theta" of the data con, and throw 
-- the constraints into the constraint set
tcInstStupidTheta data_con inst_tys
  | null stupid_theta
  = return ()
  | otherwise
  = do	{ stupid_dicts <- newDicts (OccurrenceOf (dataConName data_con))
				   (substTheta tenv stupid_theta)
	; extendLIEs stupid_dicts }
  where
    stupid_theta = dataConStupidTheta data_con
    tenv = zipTopTvSubst (dataConUnivTyVars data_con) inst_tys

newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
newMethodFromName origin ty name
  = tcLookupId name		`thenM` \ id ->
	-- Use tcLookupId not tcLookupGlobalId; the method is almost
	-- always a class op, but with -fno-implicit-prelude GHC is
	-- meant to find whatever thing is in scope, and that may
	-- be an ordinary function. 
    getInstLoc origin		`thenM` \ loc ->
    tcInstClassOp loc id [ty]	`thenM` \ inst ->
    extendLIE inst		`thenM_`
    returnM (instToId inst)

newMethodWithGivenTy orig id tys
  = getInstLoc orig		`thenM` \ loc ->
    newMethod loc id tys	`thenM` \ inst ->
    extendLIE inst		`thenM_`
    returnM (instToId inst)

--------------------------------------------
-- tcInstClassOp, and newMethod do *not* drop the 
-- Inst into the LIE; they just returns the Inst
-- This is important because they are used by TcSimplify
-- to simplify Insts

-- NB: the kind of the type variable to be instantiated
--     might be a sub-kind of the type to which it is applied,
--     notably when the latter is a type variable of kind ??
--     Hence the call to checkKind
-- A worry: is this needed anywhere else?
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys
  = let
	(tyvars, _rho) = tcSplitForAllTys (idType sel_id)
    in
    zipWithM_ checkKind tyvars tys	`thenM_` 
    newMethod inst_loc sel_id tys

checkKind :: TyVar -> TcType -> TcM ()
-- Ensure that the type has a sub-kind of the tyvar
checkKind tv ty
  = do	{ let ty1 = ty 
		-- ty1 <- zonkTcType ty
	; if typeKind ty1 `isSubKind` tyVarKind tv
	  then return ()
	  else 

    pprPanic "checkKind: adding kind constraint" 
	     (vcat [ppr tv <+> ppr (tyVarKind tv), 
	            ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
	}
--    do	{ tv1 <- tcInstTyVar tv
--	; unifyType ty1 (mkTyVarTy tv1) } }


---------------------------
newMethod inst_loc id tys
  = newUnique		`thenM` \ new_uniq ->
    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
	loc         = instLocSrcLoc inst_loc
    in
    returnM inst
\end{code}

\begin{code}
shortCutIntLit :: Integer -> TcType -> Maybe (HsExpr TcId)
shortCutIntLit i ty
  | isIntTy ty && inIntRange i 		-- Short cut for Int
  = Just (HsLit (HsInt i))
  | isIntegerTy ty 			-- Short cut for Integer
  = Just (HsLit (HsInteger i ty))
  | otherwise = Nothing

shortCutFracLit :: Rational -> TcType -> Maybe (HsExpr TcId)
shortCutFracLit f ty
  | isFloatTy ty 
  = Just (mk_lit floatDataCon (HsFloatPrim f))
  | isDoubleTy ty
  = Just (mk_lit doubleDataCon (HsDoublePrim f))
  | otherwise = Nothing
  where
    mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)

mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
mkIntegerLit i
  = tcMetaTy integerTyConName 	`thenM` \ integer_ty ->
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsInteger i integer_ty))

mkRatLit :: Rational -> TcM (LHsExpr TcId)
mkRatLit r
  = tcMetaTy rationalTyConName 	`thenM` \ rat_ty ->
    getSrcSpanM			`thenM` \ span -> 
    returnM (L span $ HsLit (HsRat r rat_ty))

isHsVar :: HsExpr Name -> Name -> Bool
isHsVar (HsVar f) g = f==g
isHsVar other 	  g = False
\end{code}


%************************************************************************
%*									*
\subsection{Zonking}
%*									*
%************************************************************************

Zonking makes sure that the instance types are fully zonked.

\begin{code}
zonkInst :: Inst -> TcM Inst
zonkInst (Dict name pred loc)
  = zonkTcPredType pred			`thenM` \ new_pred ->
    returnM (Dict name new_pred loc)

zonkInst (Method m id tys theta loc) 
  = 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
	-- an InstId, in which case it won't be in scope

    zonkTcTypes tys		`thenM` \ new_tys ->
    zonkTcThetaType theta	`thenM` \ new_theta ->
    returnM (Method m new_id new_tys new_theta loc)

zonkInst (LitInst nm lit ty loc)
  = zonkTcType ty			`thenM` \ new_ty ->
    returnM (LitInst nm lit new_ty loc)

zonkInsts insts = mappM zonkInst insts
\end{code}


%************************************************************************
%*									*
\subsection{Printing}
%*									*
%************************************************************************

ToDo: improve these pretty-printing things.  The ``origin'' is really only
relevant in error messages.

\begin{code}
instance Outputable Inst where
    ppr inst = pprInst inst

pprDictsTheta :: [Inst] -> SDoc
-- Print in type-like fashion (Eq a, Show b)
pprDictsTheta dicts = pprTheta (map dictPred dicts)

pprDictsInFull :: [Inst] -> SDoc
-- Print in type-like fashion, but with source location
pprDictsInFull dicts 
  = vcat (map go dicts)
  where
    go dict = sep [quotes (ppr (dictPred dict)), nest 2 (pprInstLoc (instLoc dict))]

pprInsts :: [Inst] -> SDoc
-- Debugging: print the evidence :: type
pprInsts insts  = brackets (interpp'SP insts)

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 m@(Method inst_id id tys theta loc)
  = ppr inst_id <+> dcolon <+> 
	braces (sep [ppr id <+> ptext SLIT("at"),
		     brackets (sep (map pprParendType tys))])

pprInstInFull inst
  = 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

tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
-- This function doesn't assume that the tyvars are in scope
-- so it works like tidyOpenType, returning a TidyEnv
tidyMoreInsts env insts
  = (env', map (tidyInst env') insts)
  where
    env' = tidyFreeTyVars env (tyVarsOfInsts insts)

tidyInsts :: [Inst] -> (TidyEnv, [Inst])
tidyInsts insts = tidyMoreInsts emptyTidyEnv insts

showLIE :: SDoc -> TcM ()	-- Debugging
showLIE str
  = do { lie_var <- getLIEVar ;
	 lie <- readMutVar lie_var ;
	 traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
\end{code}


%************************************************************************
%*									*
	Extending the instance environment
%*									*
%************************************************************************

\begin{code}
tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
  -- Add new locally-defined instances
tcExtendLocalInstEnv dfuns thing_inside
 = do { traceDFuns dfuns
      ; env <- getGblEnv
      ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
      ; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
			 tcg_inst_env = inst_env' }
      ; setGblEnv env' thing_inside }

addLocalInst :: InstEnv -> Instance -> TcM InstEnv
-- Check that the proposed new instance is OK, 
-- and then add it to the home inst env
addLocalInst home_ie ispec
  = do	{ 	-- Instantiate the dfun type so that we extend the instance
		-- envt with completely fresh template variables
		-- This is important because the template variables must
		-- not overlap with anything in the things being looked up
		-- (since we do unification).  
		-- We use tcInstSkolType because we don't want to allocate fresh
		--  *meta* type variables.  
	  let dfun = instanceDFunId ispec
	; (tvs', theta', tau') <- tcInstSkolType (InstSkol dfun) (idType dfun)
	; let	(cls, tys') = tcSplitDFunHead tau'
		dfun' 	    = setIdType dfun (mkSigmaTy tvs' theta' tau')	    
	  	ispec'      = setInstanceDFunId ispec dfun'

		-- Load imported instances, so that we report
		-- duplicates correctly
	; eps <- getEps
	; let inst_envs = (eps_inst_env eps, home_ie)

		-- Check functional dependencies
	; case checkFunDeps inst_envs ispec' of
		Just specs -> funDepErr ispec' specs
		Nothing    -> return ()

		-- Check for duplicate instance decls
	; let { (matches, _) = lookupInstEnv inst_envs cls tys'
	      ;	dup_ispecs = [ dup_ispec 
			     | (_, dup_ispec) <- matches
			     , let (_,_,_,dup_tys) = instanceHead dup_ispec
			     , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
		-- Find memebers of the match list which ispec itself matches.
		-- If the match is 2-way, it's a duplicate
	; case dup_ispecs of
	    dup_ispec : _ -> dupInstErr ispec' dup_ispec
	    []            -> return ()

		-- OK, now extend the envt
	; return (extendInstEnv home_ie ispec') }

getOverlapFlag :: TcM OverlapFlag
getOverlapFlag 
  = do 	{ dflags <- getDOpts
	; let overlap_ok    = dopt Opt_AllowOverlappingInstances dflags
	      incoherent_ok = dopt Opt_AllowIncoherentInstances  dflags
	      overlap_flag | incoherent_ok = Incoherent
			   | overlap_ok    = OverlapOk
			   | otherwise     = NoOverlap
			   
	; return overlap_flag }

traceDFuns ispecs
  = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
  where
    pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
	-- Print the dfun name itself too

funDepErr ispec ispecs
  = addDictLoc ispec $
    addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:"))
	       2 (pprInstances (ispec:ispecs)))
dupInstErr ispec dup_ispec
  = addDictLoc ispec $
    addErr (hang (ptext SLIT("Duplicate instance declarations:"))
	       2 (pprInstances [ispec, dup_ispec]))

addDictLoc ispec thing_inside
  = setSrcSpan (mkSrcSpan loc loc) thing_inside
  where
   loc = getSrcLoc ispec
\end{code}
    

%************************************************************************
%*									*
\subsection{Looking up Insts}
%*									*
%************************************************************************

\begin{code}
data LookupInstResult
  = NoInstance
  | SimpleInst (LHsExpr TcId)		-- Just a variable, type application, or literal
  | GenInst    [Inst] (LHsExpr TcId)	-- The expression and its needed insts

lookupInst :: Inst -> TcM LookupInstResult
-- It's important that lookupInst does not put any new stuff into
-- the LIE.  Instead, any Insts needed by the lookup are returned in
-- the LookupInstResult, where they can be further processed by tcSimplify


-- Methods

lookupInst inst@(Method _ id tys theta loc)
  = do	{ dicts <- newDictsAtLoc loc theta
	; let co_fn = mkInstCoFn tys dicts
	; return (GenInst dicts (L span $ HsCoerce co_fn (HsVar id))) }
  where
    span = instLocSrcSpan loc

-- Literals

-- Look for short cuts first: if the literal is *definitely* a 
-- int, integer, float or a double, generate the real thing here.
-- This is essential (see nofib/spectral/nucleic).
-- [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)
  | Just expr <- shortCutIntLit i ty
  = returnM (GenInst [] (noLoc expr))	-- GenInst, not SimpleInst, because 
					-- expr may be a constructor application
  | otherwise
  = ASSERT( from_integer_name `isHsVar` fromIntegerName )	-- A LitInst invariant
    tcLookupId fromIntegerName			`thenM` \ from_integer ->
    tcInstClassOp loc from_integer [ty]		`thenM` \ method_inst ->
    mkIntegerLit i				`thenM` \ integer_lit ->
    returnM (GenInst [method_inst]
		     (mkHsApp (L (instLocSrcSpan loc)
			   	 (HsVar (instToId method_inst))) integer_lit))

lookupInst inst@(LitInst _nm (HsFractional f from_rat_name) ty loc)
  | Just expr <- shortCutFracLit f ty
  = returnM (GenInst [] (noLoc expr))

  | otherwise
  = ASSERT( from_rat_name `isHsVar` fromRationalName )	-- A LitInst invariant
    tcLookupId fromRationalName			`thenM` \ from_rational ->
    tcInstClassOp loc from_rational [ty]	`thenM` \ method_inst ->
    mkRatLit f					`thenM` \ rat_lit ->
    returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc) 
					       (HsVar (instToId method_inst))) rat_lit))

-- Dictionaries
lookupInst (Dict _ pred loc)
  = do 	{ mb_result <- lookupPred pred
	; case mb_result of {
	    Nothing -> return NoInstance ;
	    Just (tenv, dfun_id) -> do

    -- tenv is a substitution that instantiates the dfun_id 
    -- to match the requested result type.   
    -- 
    -- We ASSUME that the dfun is quantified over the very same tyvars 
    -- that are bound by the tenv.
    -- 
    -- However, the dfun
    -- might have some tyvars that *only* appear in arguments
    --	dfun :: forall a b. C a b, Ord b => D [a]
    -- We instantiate b to a flexi type variable -- it'll presumably
    -- become fixed later via functional dependencies
    { use_stage <- getStage
    ; checkWellStaged (ptext SLIT("instance for") <+> quotes (ppr pred))
    		      (topIdLvl dfun_id) use_stage

 	-- It's possible that not all the tyvars are in
	-- the substitution, tenv. For example:
	--	instance C X a => D X where ...
	-- (presumably there's a functional dependency in class C)
	-- Hence the open_tvs to instantiate any un-substituted tyvars.	
    ; let (tyvars, rho) = tcSplitForAllTys (idType dfun_id)
	  open_tvs      = filter (`notElemTvSubst` tenv) tyvars
    ; open_tvs' <- mappM tcInstTyVar open_tvs
    ; let
 	tenv' = extendTvSubstList tenv open_tvs (mkTyVarTys open_tvs')
		-- Since the open_tvs' are freshly made, they cannot possibly be captured by
		-- any nested for-alls in rho.  So the in-scope set is unchanged
    	dfun_rho   = substTy tenv' rho
    	(theta, _) = tcSplitPhiTy dfun_rho
	src_loc	   = instLocSrcSpan loc
	dfun	   = HsVar dfun_id
	tys	   = map (substTyVar tenv') tyvars
    ; if null theta then
    	returnM (SimpleInst (L src_loc $ HsCoerce (CoTyApps tys) dfun))
      else do
    { dicts <- newDictsAtLoc loc theta
    ; let co_fn = mkInstCoFn tys dicts
    ; returnM (GenInst dicts (L src_loc $ HsCoerce co_fn dfun))
    }}}}

---------------
lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId))
-- Look up a class constraint in the instance environment
lookupPred pred@(ClassP clas tys)
  = do	{ eps     <- getEps
	; tcg_env <- getGblEnv
	; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
	; case lookupInstEnv inst_envs clas tys of {
	    ([(tenv, ispec)], []) 
		-> do	{ let dfun_id = is_dfun ispec
			; traceTc (text "lookupInst success" <+> 
				   vcat [text "dict" <+> ppr pred, 
				         text "witness" <+> ppr dfun_id
					 <+> ppr (idType dfun_id) ])
				-- Record that this dfun is needed
			; record_dfun_usage dfun_id
			; return (Just (tenv, dfun_id)) } ;

     	    (matches, unifs)
		-> do	{ traceTc (text "lookupInst fail" <+> 
				   vcat [text "dict" <+> ppr pred,
				   	 text "matches" <+> ppr matches,
				   	 text "unifs" <+> ppr unifs])
		-- In the case of overlap (multiple matches) we report
		-- NoInstance here.  That has the effect of making the 
		-- context-simplifier return the dict as an irreducible one.
		-- Then it'll be given to addNoInstanceErrs, which will do another
		-- lookupInstEnv to get the detailed info about what went wrong.
			; return Nothing }
	}}

lookupPred ip_pred = return Nothing

record_dfun_usage dfun_id 
  = do	{ hsc_env <- getTopEnv
	; let  dfun_name = idName dfun_id
	       dfun_mod  = nameModule dfun_name
	; if isInternalName dfun_name ||    -- Internal name => defined in this module
	     modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
	  then return () -- internal, or in another package
	   else do { tcg_env <- getGblEnv
	  	   ; updMutVar (tcg_inst_uses tcg_env)
			       (`addOneToNameSet` idName dfun_id) }}


tcGetInstEnvs :: TcM (InstEnv, InstEnv)
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
		     return (eps_inst_env eps, tcg_inst_env env) }
\end{code}



%************************************************************************
%*									*
		Re-mappable syntax
%*									*
%************************************************************************

Suppose we are doing the -fno-implicit-prelude thing, and we encounter
a do-expression.  We have to find (>>) in the current environment, which is
done by the rename. Then we have to check that it has the same type as
Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had
this:

  (>>) :: HB m n mn => m a -> n b -> mn b

So the idea is to generate a local binding for (>>), thus:

	let then72 :: forall a b. m a -> m b -> m b
	    then72 = ...something involving the user's (>>)...
	in
	...the do-expression...

Now the do-expression can proceed using then72, which has exactly
the expected type.

In fact tcSyntaxName just generates the RHS for then72, because we only
want an actual binding in the do-expression case. For literals, we can 
just use the expression inline.

\begin{code}
tcSyntaxName :: InstOrigin
	     -> TcType			-- Type to instantiate it at
	     -> (Name, HsExpr Name)	-- (Standard name, user name)
	     -> TcM (Name, HsExpr TcId)	-- (Standard name, suitable expression)
--	*** NOW USED ONLY FOR CmdTop (sigh) ***
-- NB: tcSyntaxName calls tcExpr, and hence can do unification.
-- So we do not call it from lookupInst, which is called from tcSimplify

tcSyntaxName orig ty (std_nm, HsVar user_nm)
  | std_nm == user_nm
  = newMethodFromName orig ty std_nm	`thenM` \ id ->
    returnM (std_nm, HsVar id)

tcSyntaxName orig ty (std_nm, user_nm_expr)
  = tcLookupId std_nm		`thenM` \ std_id ->
    let	
	-- C.f. newMethodAtLoc
	([tv], _, tau)  = tcSplitSigmaTy (idType std_id)
 	sigma1		= substTyWith [tv] [ty] tau
	-- Actually, the "tau-type" might be a sigma-type in the
	-- case of locally-polymorphic methods.
    in
    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1)	$

	-- Check that the user-supplied thing has the
	-- same type as the standard one.  
	-- Tiresome jiggling because tcCheckSigma takes a located expression
    getSrcSpanM					`thenM` \ span -> 
    tcPolyExpr (L span user_nm_expr) sigma1	`thenM` \ expr ->
    returnM (std_nm, unLoc expr)

syntaxNameCtxt name orig ty tidy_env
  = getInstLoc orig		`thenM` \ inst_loc ->
    let
	msg = vcat [ptext SLIT("When checking that") <+> quotes (ppr name) <+> 
				ptext SLIT("(needed by a syntactic construct)"),
		    nest 2 (ptext SLIT("has the required type:") <+> ppr (tidyType tidy_env ty)),
		    nest 2 (pprInstLoc inst_loc)]
    in
    returnM (tidy_env, msg)
\end{code}