X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=377c082b86692622229dcc52522188151938bc7e;hb=90dc9026b091be5cca5da4c6cbd3713ecc493361;hp=ffb010491db53de80a73d97e9c48b22101179588;hpb=a3a15a646977ab98f9150bb2b926d960796077e4;p=ghc-hetmet.git

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index ffb0104..377c082 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -17,7 +17,7 @@ module Inst (
 	newDictBndr, newDictBndrs, newDictBndrsO,
 	instCall, instStupidTheta,
 	cloneDict, 
-	shortCutFracLit, shortCutIntLit, newIPDict, 
+	shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict, 
 	newMethod, newMethodFromName, newMethodWithGivenTy, 
 	tcInstClassOp, 
 	tcSyntaxName, isHsVar,
@@ -44,6 +44,7 @@ module Inst (
 import {-# SOURCE #-}	TcExpr( tcPolyExpr )
 import {-# SOURCE #-}	TcUnify( unifyType )
 
+import FastString(FastString)
 import HsSyn
 import TcHsSyn
 import TcRnMonad
@@ -83,7 +84,7 @@ Selection
 ~~~~~~~~~
 \begin{code}
 instName :: Inst -> Name
-instName inst = idName (instToId inst)
+instName inst = Var.varName (instToVar inst)
 
 instToId :: Inst -> TcId
 instToId inst = ASSERT2( isId id, ppr inst ) id 
@@ -110,7 +111,8 @@ instType imp@(ImplicInst {})      = mkImplicTy (tci_tyvars imp) (tci_given imp)
 					       (tci_wanted imp)
 
 mkImplicTy tvs givens wanteds	-- The type of an implication constraint
-  = -- pprTrace "mkImplicTy" (ppr givens) $
+  = ASSERT( all isDict givens )
+    -- pprTrace "mkImplicTy" (ppr givens) $
     mkForAllTys tvs $ 
     mkPhiTy (map dictPred givens) $
     if isSingleton wanteds then
@@ -160,12 +162,14 @@ ipNamesOfInst other		    	     = []
 tyVarsOfInst :: Inst -> TcTyVarSet
 tyVarsOfInst (LitInst {tci_ty = ty})  = tyVarsOfType  ty
 tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
-tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` idFreeTyVars id
+tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
 				 -- The id might have free type variables; in the case of
 				 -- locally-overloaded class methods, for example
 tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
-  = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) `minusVarSet` mkVarSet tvs
-
+  = (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds) 
+    `minusVarSet` mkVarSet tvs
+    `unionVarSet` unionVarSets (map varTypeTyVars tvs)
+		-- Remember the free tyvars of a coercion
 
 tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
 tyVarsOfLIE   lie   = tyVarsOfInsts (lieToList lie)
@@ -328,8 +332,15 @@ mkPredName uniq loc pred_ty
   = mkInternalName uniq occ (srcSpanStart (instLocSpan loc))
   where
     occ = case pred_ty of
-	    ClassP cls tys -> mkDictOcc (getOccName cls)
-	    IParam ip ty   -> getOccName (ipNameName ip)
+	    ClassP cls _ -> mkDictOcc (getOccName cls)
+	    IParam ip  _ -> getOccName (ipNameName ip)
+	    EqPred ty  _ -> mkEqPredCoOcc baseOcc
+	      where
+		-- we use the outermost tycon of the lhs, if there is one, to
+		-- improve readability of Core code
+	        baseOcc = case splitTyConApp_maybe ty of
+			    Nothing      -> mkOccName tcName "$"
+                            Just (tc, _) -> getOccName tc
 \end{code}
 
 %************************************************************************
@@ -426,6 +437,12 @@ shortCutFracLit f ty
   where
     mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
 
+shortCutStringLit :: FastString -> TcType -> Maybe (HsExpr TcId)
+shortCutStringLit s ty
+  | isStringTy ty 			-- Short cut for String
+  = Just (HsLit (HsString s))
+  | otherwise = Nothing
+
 mkIntegerLit :: Integer -> TcM (LHsExpr TcId)
 mkIntegerLit i
   = tcMetaTy integerTyConName 	`thenM` \ integer_ty ->
@@ -438,6 +455,12 @@ mkRatLit r
     getSrcSpanM			`thenM` \ span -> 
     returnM (L span $ HsLit (HsRat r rat_ty))
 
+mkStrLit :: FastString -> TcM (LHsExpr TcId)
+mkStrLit s
+  = --tcMetaTy stringTyConName 	`thenM` \ string_ty ->
+    getSrcSpanM			`thenM` \ span -> 
+    returnM (L span $ HsLit (HsString s))
+
 isHsVar :: HsExpr Name -> Name -> Bool
 isHsVar (HsVar f) g = f==g
 isHsVar other 	  g = False
@@ -705,6 +728,18 @@ lookupSimpleInst (LitInst {tci_lit = HsFractional f from_rat_name, tci_ty = ty,
     returnM (GenInst [method_inst] (mkHsApp (L (instLocSpan loc) 
 					       (HsVar (instToId method_inst))) rat_lit))
 
+lookupSimpleInst (LitInst {tci_lit = HsIsString s from_string_name, tci_ty = ty, tci_loc = loc})
+  | Just expr <- shortCutStringLit s ty
+  = returnM (GenInst [] (noLoc expr))
+  | otherwise
+  = ASSERT( from_string_name `isHsVar` fromStringName )	-- A LitInst invariant
+    tcLookupId fromStringName			`thenM` \ from_string ->
+    tcInstClassOp loc from_string [ty]		`thenM` \ method_inst ->
+    mkStrLit s					`thenM` \ string_lit ->
+    returnM (GenInst [method_inst]
+		     (mkHsApp (L (instLocSpan loc)
+			   	 (HsVar (instToId method_inst))) string_lit))
+
 --------------------- Dictionaries ------------------------
 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
   = do 	{ mb_result <- lookupPred pred
@@ -743,7 +778,7 @@ lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
     	(theta, _) = tcSplitPhiTy dfun_rho
 	src_loc	   = instLocSpan loc
 	dfun	   = HsVar dfun_id
-	tys	   = map (substTyVar tenv') tyvars
+	tys	   = substTyVars tenv' tyvars
     ; if null theta then
     	returnM (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
       else do