Add support for overloaded string literals.

The class is named IsString with the single method fromString.
Overloaded strings work the same way as overloaded numeric literals.
In expressions a string literals gets a fromString applied to it.
In a pattern there will be an equality comparison with the fromString:ed literal.

Use -foverloaded-strings to enable this extension.
 

compiler/deSugar/Check.lhs

@@ -424,6 +424,7 @@ get_lit :: Pat id -> Maybe HsLit
 get_lit (LitPat lit)			 = Just lit
 get_lit (NPat (HsIntegral i   _) mb _ _) = Just (HsIntPrim   (mb_neg mb i))
 get_lit (NPat (HsFractional f _) mb _ _) = Just (HsFloatPrim (mb_neg mb f))
+get_lit (NPat (HsIsString s   _)  _ _ _) = Just (HsStringPrim s)
 get_lit other_pat			 = Nothing
 
 mb_neg :: Num a => Maybe b -> a -> a

compiler/deSugar/DsExpr.lhs

@@ -207,7 +207,7 @@ dsExpr (HsVar var)     	      = returnDs (Var var)
 dsExpr (HsIPVar ip)    	      = returnDs (Var (ipNameName ip))
 dsExpr (HsLit lit)     	      = dsLit lit
 dsExpr (HsOverLit lit) 	      = dsOverLit lit
-dsExpr (HsWrap co_fn e)     = dsCoercion co_fn (dsExpr e)
+dsExpr (HsWrap co_fn e)       = dsCoercion co_fn (dsExpr e)
 
 dsExpr (NegApp expr neg_expr) 
   = do	{ core_expr <- dsLExpr expr

compiler/deSugar/DsMeta.hs

@@ -1269,10 +1269,13 @@ mk_integer  i = do integer_ty <- lookupType integerTyConName
                    return $ HsInteger i integer_ty
 mk_rational r = do rat_ty <- lookupType rationalTyConName
                    return $ HsRat r rat_ty
+mk_string s   = do string_ty <- lookupType stringTyConName
+                   return $ HsString s
 
 repOverloadedLiteral :: HsOverLit Name -> DsM (Core TH.Lit)
 repOverloadedLiteral (HsIntegral i _)   = do { lit <- mk_integer  i; repLiteral lit }
 repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral lit }
+repOverloadedLiteral (HsIsString s _)   = do { lit <- mk_string   s; repLiteral lit }
 	-- The type Rational will be in the environment, becuase 
 	-- the smart constructor 'TH.Syntax.rationalL' uses it in its type,
 	-- and rationalL is sucked in when any TH stuff is used

compiler/deSugar/MatchLit.lhs

@@ -87,6 +87,7 @@ dsOverLit :: HsOverLit Id -> DsM CoreExpr
 -- (an expression for) the literal value itself
 dsOverLit (HsIntegral   _ lit) = dsExpr lit
 dsOverLit (HsFractional _ lit) = dsExpr lit
+dsOverLit (HsIsString   _ lit) = dsExpr lit
 \end{code}
 
 \begin{code}
@@ -109,6 +110,8 @@ hsOverLitKey (HsIntegral i _) False   = MachInt i
 hsOverLitKey (HsIntegral i _) True    = MachInt (-i)
 hsOverLitKey (HsFractional r _) False = MachFloat r
 hsOverLitKey (HsFractional r _) True  = MachFloat (-r)
+hsOverLitKey (HsIsString s _)  False  = MachStr s
+-- negated string should never happen
 \end{code}
 
 %************************************************************************
@@ -140,6 +143,7 @@ tidyNPat over_lit mb_neg eq lit_ty
   | isIntTy    lit_ty = mk_con_pat intDataCon    (HsIntPrim int_val)
   | isFloatTy  lit_ty = mk_con_pat floatDataCon  (HsFloatPrim  rat_val)
   | isDoubleTy lit_ty = mk_con_pat doubleDataCon (HsDoublePrim rat_val)
+--  | isStringTy lit_ty = mk_con_pat stringDataCon (HsStringPrim str_val)
   | otherwise	      = NPat over_lit mb_neg eq lit_ty
   where
     mk_con_pat :: DataCon -> HsLit -> Pat Id
@@ -158,6 +162,11 @@ tidyNPat over_lit mb_neg eq lit_ty
     rat_val = case neg_lit of
 		HsIntegral   i _ -> fromInteger i
 		HsFractional f _ -> f
+	
+    str_val :: FastString
+    str_val = case neg_lit of
+		HsIsString   s _ -> s
+		_                -> error "tidyNPat"
 \end{code}
 
 

compiler/hsSyn/Convert.lhs

@@ -418,6 +418,7 @@ cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 cvtOverLit (IntegerL i)  = do { force i; return $ mkHsIntegral i }
 cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r }
+cvtOverLit (StringL s)   = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' }
 -- An Integer is like an an (overloaded) '3' in a Haskell source program
 -- Similarly 3.5 for fractionals
 

compiler/hsSyn/HsLit.lhs

@@ -56,6 +56,7 @@ instance Eq HsLit where
 data HsOverLit id 	-- An overloaded literal
   = HsIntegral	 Integer  (SyntaxExpr id)	-- Integer-looking literals;
   | HsFractional Rational (SyntaxExpr id)	-- Frac-looking literals
+  | HsIsString   FastString (SyntaxExpr id)	-- String-looking literals
   -- Before type checking, the SyntaxExpr is 'fromInteger' or 'fromRational'
   -- After type checking, it is (fromInteger 3) or lit_78; that is,
   -- the expression that should replace the literal.
@@ -68,13 +69,19 @@ data HsOverLit id 	-- An overloaded literal
 instance Eq (HsOverLit id) where
   (HsIntegral i1 _)   == (HsIntegral i2 _)   = i1 == i2
   (HsFractional f1 _) == (HsFractional f2 _) = f1 == f2
+  (HsIsString s1 _)   == (HsIsString s2 _)   = s1 == s2
   l1		      == l2		     = False
 
 instance Ord (HsOverLit id) where
   compare (HsIntegral i1 _)   (HsIntegral i2 _)   = i1 `compare` i2
   compare (HsIntegral _ _)    (HsFractional _ _)  = LT
+  compare (HsIntegral _ _)    (HsIsString _ _)    = LT
   compare (HsFractional f1 _) (HsFractional f2 _) = f1 `compare` f2
   compare (HsFractional f1 _) (HsIntegral _ _)    = GT
+  compare (HsFractional f1 _) (HsIsString _ _)    = LT
+  compare (HsIsString s1 _)   (HsIsString s2 _)   = s1 `compare` s2
+  compare (HsIsString s1 _)   (HsIntegral _ _)    = GT
+  compare (HsIsString s1 _)   (HsFractional _ _)  = GT
 \end{code}
 
 \begin{code}
@@ -94,4 +101,5 @@ instance Outputable HsLit where
 instance Outputable (HsOverLit id) where
   ppr (HsIntegral i _)   = integer i
   ppr (HsFractional f _) = rational f
+  ppr (HsIsString s _)   = pprHsString s
 \end{code}

compiler/hsSyn/HsUtils.lhs

@@ -118,6 +118,7 @@ mkSimpleHsAlt pat expr
 
 mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
 mkHsFractional f       = HsFractional f  noSyntaxExpr
+mkHsIsString   s       = HsIsString   s  noSyntaxExpr
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 
 mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType

compiler/main/DynFlags.hs

@@ -176,6 +176,7 @@ data DynFlag
    | Opt_ScopedTypeVariables
    | Opt_BangPatterns
    | Opt_IndexedTypes
+   | Opt_OverloadedStrings
 
    -- optimisation opts
    | Opt_Strictness
@@ -1042,6 +1043,7 @@ fFlags = [
   ( "implicit-prelude",  		Opt_ImplicitPrelude ),
   ( "scoped-type-variables",  		Opt_ScopedTypeVariables ),
   ( "bang-patterns",	  		Opt_BangPatterns ),
+  ( "overloaded-strings",		Opt_OverloadedStrings ),
   ( "indexed-types",	  		Opt_IndexedTypes ),
   ( "monomorphism-restriction",		Opt_MonomorphismRestriction ),
   ( "mono-pat-binds",			Opt_MonoPatBinds ),

compiler/parser/Parser.y.pp

@@ -1325,6 +1325,9 @@ aexp2	:: { LHsExpr RdrName }
 	: ipvar				{ L1 (HsIPVar $! unLoc $1) }
 	| qcname			{ L1 (HsVar   $! unLoc $1) }
 	| literal			{ L1 (HsLit   $! unLoc $1) }
+-- This will enable overloaded strings permanently.  Normally the renamer turns HsString
+-- into HsOverLit when -foverloaded-strings is on.
+--	| STRING			{ L1 (HsOverLit $! mkHsIsString (getSTRING $1)) }
 	| INTEGER			{ L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) }
 	| RATIONAL			{ L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) }
 	| '(' exp ')'			{ LL (HsPar $2) }
@@ -1776,7 +1779,7 @@ consym :: { Located RdrName }
 
 literal :: { Located HsLit }
 	: CHAR 			{ L1 $ HsChar       $ getCHAR $1 }
-	| STRING		{ L1 $ HsString     $ getSTRING $1 }
+	| STRING 		{ L1 $ HsString     $ getSTRING $1 }
 	| PRIMINTEGER		{ L1 $ HsIntPrim    $ getPRIMINTEGER $1 }
 	| PRIMCHAR		{ L1 $ HsCharPrim   $ getPRIMCHAR $1 }
 	| PRIMSTRING		{ L1 $ HsStringPrim $ getPRIMSTRING $1 }

compiler/parser/RdrHsSyn.lhs

@@ -9,7 +9,7 @@ module RdrHsSyn (
 	extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
 	mkHsOpApp, mkClassDecl,
-	mkHsNegApp, mkHsIntegral, mkHsFractional,
+	mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsIsString,
 	mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,	
 	mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp

compiler/prelude/PrelNames.lhs

@@ -109,6 +109,7 @@ basicKnownKeyNames
 	runMainIOName,
 	orderingTyConName,
 	rationalTyConName,
+	stringTyConName,
 	ratioDataConName,
 	ratioTyConName,
 	integerTyConName, smallIntegerDataConName, largeIntegerDataConName,
@@ -130,11 +131,15 @@ basicKnownKeyNames
 	realFracClassName,		-- numeric
 	realFloatClassName,		-- numeric
 	dataClassName, 
+	isStringClassName,
 
 	-- Numeric stuff
 	negateName, minusName, 
 	fromRationalName, fromIntegerName, 
 	geName, eqName, 
+
+        -- String stuff
+        fromStringName,
 	
 	-- Enum stuff
 	enumFromName, enumFromThenName,	
@@ -372,6 +377,8 @@ minus_RDR		= nameRdrName minusName
 times_RDR		= varQual_RDR  gHC_NUM FSLIT("*")
 plus_RDR                = varQual_RDR gHC_NUM FSLIT("+")
 
+fromString_RDR		= nameRdrName fromStringName
+
 compose_RDR		= varQual_RDR gHC_BASE FSLIT(".")
 
 not_RDR 		= varQual_RDR gHC_BASE FSLIT("not")
@@ -463,6 +470,7 @@ unpackCStringAppendName = varQual gHC_BASE FSLIT("unpackAppendCString#") unpackC
 unpackCStringFoldrName  = varQual gHC_BASE FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey
 unpackCStringUtf8Name   = varQual gHC_BASE FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey
 eqStringName	 	= varQual gHC_BASE FSLIT("eqString")  eqStringIdKey
+stringTyConName         = tcQual  gHC_BASE FSLIT("String") stringTyConKey
 
 -- The 'inline' function
 inlineIdName	 	= varQual gHC_BASE FSLIT("inline") inlineIdKey
@@ -482,13 +490,14 @@ returnMName	   = methName gHC_BASE FSLIT("return") returnMClassOpKey
 failMName	   = methName gHC_BASE FSLIT("fail")   failMClassOpKey
 
 -- Random PrelBase functions
+fromStringName    = methName gHC_BASE FSLIT("fromString") fromStringClassOpKey
 otherwiseIdName   = varQual gHC_BASE FSLIT("otherwise")  otherwiseIdKey
 foldrName	  = varQual gHC_BASE FSLIT("foldr")      foldrIdKey
 buildName	  = varQual gHC_BASE FSLIT("build")      buildIdKey
 augmentName	  = varQual gHC_BASE FSLIT("augment")    augmentIdKey
 appendName	  = varQual gHC_BASE FSLIT("++")         appendIdKey
-andName		  = varQual gHC_BASE FSLIT("&&")	  andIdKey
-orName		  = varQual gHC_BASE FSLIT("||")	  orIdKey
+andName		  = varQual gHC_BASE FSLIT("&&")	 andIdKey
+orName		  = varQual gHC_BASE FSLIT("||")	 orIdKey
 assertName        = varQual gHC_BASE FSLIT("assert")     assertIdKey
 breakpointName    = varQual gHC_BASE FSLIT("breakpoint") breakpointIdKey
 breakpointCondName= varQual gHC_BASE FSLIT("breakpointCond") breakpointCondIdKey
@@ -654,6 +663,7 @@ loopAName	   = varQual aRROW FSLIT("loop")  loopAIdKey
 monadPlusClassName  = clsQual mONAD FSLIT("MonadPlus")  monadPlusClassKey
 randomClassName     = clsQual rANDOM FSLIT("Random")    randomClassKey
 randomGenClassName  = clsQual rANDOM FSLIT("RandomGen") randomGenClassKey
+isStringClassName   = clsQual gHC_BASE FSLIT("IsString") isStringClassKey
 
 -- dotnet interop
 objectTyConName	    = tcQual   dOTNET FSLIT("Object") objectTyConKey
@@ -731,6 +741,8 @@ monadFixClassKey	= mkPreludeClassUnique 28
 monadPlusClassKey	= mkPreludeClassUnique 30
 randomClassKey		= mkPreludeClassUnique 31
 randomGenClassKey	= mkPreludeClassUnique 32
+
+isStringClassKey	= mkPreludeClassUnique 33
 \end{code}
 
 %************************************************************************
@@ -833,13 +845,15 @@ rightCoercionTyConKey                   = mkPreludeTyConUnique 96
 instCoercionTyConKey                    = mkPreludeTyConUnique 97
 unsafeCoercionTyConKey                  = mkPreludeTyConUnique 98
 
-
 unknownTyConKey				= mkPreludeTyConUnique 99
 unknown1TyConKey			= mkPreludeTyConUnique 130
 unknown2TyConKey			= mkPreludeTyConUnique 131
 unknown3TyConKey			= mkPreludeTyConUnique 132
 opaqueTyConKey                          = mkPreludeTyConUnique 133
 
+stringTyConKey				= mkPreludeTyConUnique 134
+
+
 ---------------- Template Haskell -------------------
 --	USES TyConUniques 100-129
 -----------------------------------------------------
@@ -1017,6 +1031,8 @@ appAIdKey	= mkPreludeMiscIdUnique 122
 choiceAIdKey	= mkPreludeMiscIdUnique 123 --  |||
 loopAIdKey	= mkPreludeMiscIdUnique 124
 
+fromStringClassOpKey	      = mkPreludeMiscIdUnique 125
+
 ---------------- Template Haskell -------------------
 --	USES IdUniques 200-399
 -----------------------------------------------------
@@ -1076,7 +1092,9 @@ needsDataDeclCtxtClassKeys = -- see comments in TcDeriv
 standardClassKeys = derivableClassKeys ++ numericClassKeys
 		  ++ [randomClassKey, randomGenClassKey,
 		      functorClassKey, 
-		      monadClassKey, monadPlusClassKey]
+		      monadClassKey, monadPlusClassKey,
+		      isStringClassKey
+		     ]
 \end{code}
 
 @derivableClassKeys@ is also used in checking \tr{deriving} constructs

compiler/rename/RnEnv.lhs

@@ -546,7 +546,7 @@ At the moment this just happens for
   * "do" notation
 
 We store the relevant Name in the HsSyn tree, in 
-  * HsIntegral/HsFractional	
+  * HsIntegral/HsFractional/HsIsString
   * NegApp
   * NPlusKPat
   * HsDo

compiler/rename/RnExpr.lhs

@@ -109,6 +109,16 @@ rnExpr (HsIPVar v)
   = newIPNameRn v		`thenM` \ name ->
     returnM (HsIPVar name, emptyFVs)
 
+rnExpr (HsLit lit@(HsString s))
+  = do {
+         opt_OverloadedStrings <- doptM Opt_OverloadedStrings
+       ; if opt_OverloadedStrings then
+            rnExpr (HsOverLit (mkHsIsString s))
+	 else -- Same as below
+	    rnLit lit		`thenM_`
+            returnM (HsLit lit, emptyFVs)
+       }
+
 rnExpr (HsLit lit) 
   = rnLit lit		`thenM_`
     returnM (HsLit lit, emptyFVs)

compiler/rename/RnTypes.lhs

@@ -21,7 +21,7 @@ module RnTypes (
 	dupFieldErr, patSigErr, checkTupSize
   ) where
 
-import DynFlags		( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts, Opt_ScopedTypeVariables ) )
+import DynFlags		( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts, Opt_ScopedTypeVariables, Opt_OverloadedStrings ) )
 
 import HsSyn
 import RdrHsSyn		( extractHsRhoRdrTyVars )
@@ -40,7 +40,7 @@ import RdrName		( RdrName, elemLocalRdrEnv )
 import PrelNames	( eqClassName, integralClassName, geName, eqName,
 		  	  negateName, minusName, lengthPName, indexPName,
 			  plusIntegerName, fromIntegerName, timesIntegerName,
-			  ratioDataConName, fromRationalName )
+			  ratioDataConName, fromRationalName, fromStringName )
 import TypeRep		( funTyCon )
 import Constants	( mAX_TUPLE_SIZE )
 import Name		( Name )
@@ -586,6 +586,10 @@ rnPat (SigPatIn pat ty)
   where
     doc = text "In a pattern type-signature"
     
+rnPat (LitPat lit@(HsString s))
+  = do { ovlStr <- doptM Opt_OverloadedStrings
+       ; if ovlStr then rnPat (mkNPat (mkHsIsString s) Nothing)
+         else do { rnLit lit; return (LitPat lit, emptyFVs) } }  -- Same as below
 rnPat (LitPat lit) 
   = rnLit lit 	`thenM_` 
     returnM (LitPat lit, emptyFVs) 
@@ -741,6 +745,10 @@ rnOverLit (HsFractional i _)
 	-- and denominator (see DsUtils.mkIntegerLit)
     in
     returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
+
+rnOverLit (HsIsString s _)
+  = lookupSyntaxName fromStringName	`thenM` \ (from_string_name, fvs) ->
+	returnM (HsIsString s from_string_name, fvs)
 \end{code}
 
 

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
@@ -436,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 ->
@@ -448,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
@@ -715,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

compiler/typecheck/TcDefaults.lhs

@@ -46,6 +46,7 @@ tcDefaults [L locn (DefaultDecl mono_tys)]
   = setSrcSpan locn 			$
     addErrCtxt defaultDeclCtxt		$
     tcLookupClass numClassName		`thenM` \ num_class ->
+    tcLookupClass isStringClassName		`thenM` \ num_class ->
     mappM tc_default_ty mono_tys	`thenM` \ tau_tys ->
     
     	-- Check that all the types are instances of Num

compiler/typecheck/TcHsSyn.lhs

@@ -564,6 +564,8 @@ zonkOverLit env (HsIntegral i e)
   = do	{ e' <- zonkExpr env e; return (HsIntegral i e') }
 zonkOverLit env (HsFractional r e)
   = do	{ e' <- zonkExpr env e; return (HsFractional r e') }
+zonkOverLit env (HsIsString s e)
+  = do	{ e' <- zonkExpr env e; return (HsIsString s e') }
 
 -------------------------------------------------------------------------
 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)

compiler/typecheck/TcPat.lhs

@@ -813,6 +813,19 @@ tcOverloadedLit orig lit@(HsFractional r fr) res_ty
   = do 	{ expr <- newLitInst orig lit res_ty
 	; return (HsFractional r expr) }
 
+tcOverloadedLit orig lit@(HsIsString s fr) res_ty
+  | not (fr `isHsVar` fromStringName)	-- c.f. HsIntegral case
+  = do	{ str_ty <- tcMetaTy stringTyConName
+	; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty)
+	; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s)))) }
+
+  | Just expr <- shortCutStringLit s res_ty 
+  = return (HsIsString s expr)
+
+  | otherwise
+  = do 	{ expr <- newLitInst orig lit res_ty
+	; return (HsIsString s expr) }
+
 newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
 newLitInst orig lit res_ty	-- Make a LitInst
   = do 	{ loc <- getInstLoc orig

compiler/typecheck/TcSimplify.lhs

@@ -2258,8 +2258,13 @@ disambiguate extended_defaulting insts
 				do { integer_ty <- tcMetaTy integerTyConName
 				   ; checkWiredInTyCon doubleTyCon
 				   ; return [integer_ty, doubleTy] }
+        ; string_ty <- tcMetaTy stringTyConName
+	; ovlStr <- doptM Opt_OverloadedStrings
+	-- XXX This should not be added unconditionally, but the default declaration stuff
+	-- is too wired to Num for me to understand.  /LA
+        ; let default_str_tys = default_tys ++ if ovlStr then [string_ty] else []
 	; traceTc (text "disambigutate" <+> vcat [ppr unaries, ppr bad_tvs, ppr defaultable_groups])
-	; mapM_ (disambigGroup default_tys) defaultable_groups  }
+	; mapM_ (disambigGroup default_str_tys) defaultable_groups  }
   where
    unaries :: [(Inst,Class, TcTyVar)]  -- (C tv) constraints
    bad_tvs :: TcTyVarSet	  -- Tyvars mentioned by *other* constraints
@@ -2279,13 +2284,13 @@ disambiguate extended_defaulting insts
 
    defaultable_classes clss 
 	| extended_defaulting = any isInteractiveClass clss
-	| otherwise = all isStandardClass clss && any isNumericClass clss
+	| otherwise = all isStandardClass clss && (any isNumericClass clss || any ((== isStringClassKey) . classKey) clss)
 
  	-- In interactive mode, or with -fextended-default-rules,
 	-- we default Show a to Show () to avoid graututious errors on "show []"
    isInteractiveClass cls 
 	= isNumericClass cls
-	|| (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey])
+	|| (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey, isStringClassKey])
 
 
 disambigGroup :: [Type]			-- The default types