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.

diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs
index 15fcf39..359035f 100644 (file)
--- a/compiler/deSugar/Check.lhs
+++ b/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 (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
 get_lit other_pat                       = Nothing
 
 mb_neg :: Num a => Maybe b -> a -> a

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index e90a556..f5df3ed 100644 (file)
--- a/compiler/deSugar/DsExpr.lhs
+++ b/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 (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
 
 dsExpr (NegApp expr neg_expr) 
   = do { core_expr <- dsLExpr expr

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 36b6b4c..b41873f 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/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
                    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 :: 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
        -- 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

diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs
index d7e8ba6..2cdab30 100644 (file)
--- a/compiler/deSugar/MatchLit.lhs
+++ b/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
 -- (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}
 \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 (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}
 
 %************************************************************************
 \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)
   | 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
   | 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
     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}
 
 
 \end{code}
 
 

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 71cfaaf..76e51df 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/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 :: 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
 
 -- An Integer is like an an (overloaded) '3' in a Haskell source program
 -- Similarly 3.5 for fractionals
 

diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs
index f4c9cf7..edf08e3 100644 (file)
--- a/compiler/hsSyn/HsLit.lhs
+++ b/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
 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.
   -- 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
 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
   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 _) (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}
 \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
 instance Outputable (HsOverLit id) where
   ppr (HsIntegral i _)   = integer i
   ppr (HsFractional f _) = rational f

+  ppr (HsIsString s _)   = pprHsString s

 \end{code}
 \end{code}

diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index d2c5d0e..9bd3448 100644 (file)
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -118,6 +118,7 @@ mkSimpleHsAlt pat expr
 
 mkHsIntegral   i       = HsIntegral   i  noSyntaxExpr
 mkHsFractional f       = HsFractional f  noSyntaxExpr
 
 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
 mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
 
 mkNPat lit neg     = NPat lit neg noSyntaxExpr placeHolderType

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3e9ca8f..206b494 100644 (file)
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -176,6 +176,7 @@ data DynFlag
    | Opt_ScopedTypeVariables
    | Opt_BangPatterns
    | Opt_IndexedTypes
    | Opt_ScopedTypeVariables
    | Opt_BangPatterns
    | Opt_IndexedTypes

+   | Opt_OverloadedStrings

 
    -- optimisation opts
    | Opt_Strictness
 
    -- optimisation opts
    | Opt_Strictness

@@ -1042,6 +1043,7 @@ fFlags = [
   ( "implicit-prelude",                Opt_ImplicitPrelude ),
   ( "scoped-type-variables",           Opt_ScopedTypeVariables ),
   ( "bang-patterns",                   Opt_BangPatterns ),
   ( "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 ),
   ( "indexed-types",                   Opt_IndexedTypes ),
   ( "monomorphism-restriction",                Opt_MonomorphismRestriction ),
   ( "mono-pat-binds",                  Opt_MonoPatBinds ),

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 55f8cf2..ffc1f44 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/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) }
        : 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) }
        | 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 }
 
 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 }
        | PRIMINTEGER           { L1 $ HsIntPrim    $ getPRIMINTEGER $1 }
        | PRIMCHAR              { L1 $ HsCharPrim   $ getPRIMCHAR $1 }
        | PRIMSTRING            { L1 $ HsStringPrim $ getPRIMSTRING $1 }

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 221e4c2..895c8a8 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -9,7 +9,7 @@ module RdrHsSyn (
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
        mkHsOpApp, mkClassDecl,
        extractHsRhoRdrTyVars, extractGenericPatTyVars,
  
        mkHsOpApp, mkClassDecl,

-       mkHsNegApp, mkHsIntegral, mkHsFractional,
+       mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsIsString,

        mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, 
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
        mkHsDo, mkHsSplice,
         mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec, 
        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp

diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index 1aa0ae6..35c828f 100644 (file)
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -109,6 +109,7 @@ basicKnownKeyNames
        runMainIOName,
        orderingTyConName,
        rationalTyConName,
        runMainIOName,
        orderingTyConName,
        rationalTyConName,

+       stringTyConName,

        ratioDataConName,
        ratioTyConName,
        integerTyConName, smallIntegerDataConName, largeIntegerDataConName,
        ratioDataConName,
        ratioTyConName,
        integerTyConName, smallIntegerDataConName, largeIntegerDataConName,

@@ -130,11 +131,15 @@ basicKnownKeyNames
        realFracClassName,              -- numeric
        realFloatClassName,             -- numeric
        dataClassName, 
        realFracClassName,              -- numeric
        realFloatClassName,             -- numeric
        dataClassName, 

+       isStringClassName,

 
        -- Numeric stuff
        negateName, minusName, 
        fromRationalName, fromIntegerName, 
        geName, eqName, 
 
        -- Numeric stuff
        negateName, minusName, 
        fromRationalName, fromIntegerName, 
        geName, eqName, 

+
+        -- String stuff
+        fromStringName,

        
        -- Enum stuff
        enumFromName, enumFromThenName, 
        
        -- 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("+")
 
 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")
 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
 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
 
 -- 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
 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
 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
 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
 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
 
 -- dotnet interop
 objectTyConName            = tcQual   dOTNET FSLIT("Object") objectTyConKey

@@ -731,6 +741,8 @@ monadFixClassKey    = mkPreludeClassUnique 28
 monadPlusClassKey      = mkPreludeClassUnique 30
 randomClassKey         = mkPreludeClassUnique 31
 randomGenClassKey      = mkPreludeClassUnique 32
 monadPlusClassKey      = mkPreludeClassUnique 30
 randomClassKey         = mkPreludeClassUnique 31
 randomGenClassKey      = mkPreludeClassUnique 32

+
+isStringClassKey       = mkPreludeClassUnique 33

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -833,13 +845,15 @@ rightCoercionTyConKey                   = mkPreludeTyConUnique 96
 instCoercionTyConKey                    = mkPreludeTyConUnique 97
 unsafeCoercionTyConKey                  = mkPreludeTyConUnique 98
 
 instCoercionTyConKey                    = mkPreludeTyConUnique 97
 unsafeCoercionTyConKey                  = mkPreludeTyConUnique 98
 

-

 unknownTyConKey                                = mkPreludeTyConUnique 99
 unknown1TyConKey                       = mkPreludeTyConUnique 130
 unknown2TyConKey                       = mkPreludeTyConUnique 131
 unknown3TyConKey                       = mkPreludeTyConUnique 132
 opaqueTyConKey                          = mkPreludeTyConUnique 133
 
 unknownTyConKey                                = mkPreludeTyConUnique 99
 unknown1TyConKey                       = mkPreludeTyConUnique 130
 unknown2TyConKey                       = mkPreludeTyConUnique 131
 unknown3TyConKey                       = mkPreludeTyConUnique 132
 opaqueTyConKey                          = mkPreludeTyConUnique 133
 

+stringTyConKey                         = mkPreludeTyConUnique 134
+
+

 ---------------- Template Haskell -------------------
 --     USES TyConUniques 100-129
 -----------------------------------------------------
 ---------------- Template Haskell -------------------
 --     USES TyConUniques 100-129
 -----------------------------------------------------

@@ -1017,6 +1031,8 @@ appAIdKey = mkPreludeMiscIdUnique 122
 choiceAIdKey   = mkPreludeMiscIdUnique 123 --  |||
 loopAIdKey     = mkPreludeMiscIdUnique 124
 
 choiceAIdKey   = mkPreludeMiscIdUnique 123 --  |||
 loopAIdKey     = mkPreludeMiscIdUnique 124
 

+fromStringClassOpKey         = mkPreludeMiscIdUnique 125
+

 ---------------- Template Haskell -------------------
 --     USES IdUniques 200-399
 -----------------------------------------------------
 ---------------- Template Haskell -------------------
 --     USES IdUniques 200-399
 -----------------------------------------------------

@@ -1076,7 +1092,9 @@ needsDataDeclCtxtClassKeys = -- see comments in TcDeriv
 standardClassKeys = derivableClassKeys ++ numericClassKeys
                  ++ [randomClassKey, randomGenClassKey,
                      functorClassKey, 
 standardClassKeys = derivableClassKeys ++ numericClassKeys
                  ++ [randomClassKey, randomGenClassKey,
                      functorClassKey, 

-                     monadClassKey, monadPlusClassKey]
+                     monadClassKey, monadPlusClassKey,
+                     isStringClassKey
+                    ]

 \end{code}
 
 @derivableClassKeys@ is also used in checking \tr{deriving} constructs
 \end{code}
 
 @derivableClassKeys@ is also used in checking \tr{deriving} constructs

diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 32806f0..d09c2ab 100644 (file)
--- a/compiler/rename/RnEnv.lhs
+++ b/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 
   * "do" notation
 
 We store the relevant Name in the HsSyn tree, in 

-  * HsIntegral/HsFractional    
+  * HsIntegral/HsFractional/HsIsString

   * NegApp
   * NPlusKPat
   * HsDo
   * NegApp
   * NPlusKPat
   * HsDo

diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 996c102..17c7f97 100644 (file)
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -109,6 +109,16 @@ rnExpr (HsIPVar v)
   = newIPNameRn v              `thenM` \ name ->
     returnM (HsIPVar name, emptyFVs)
 
   = 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)
 rnExpr (HsLit lit) 
   = rnLit lit          `thenM_`
     returnM (HsLit lit, emptyFVs)

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 8dbf887..34a19a3 100644 (file)
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -21,7 +21,7 @@ module RnTypes (
        dupFieldErr, patSigErr, checkTupSize
   ) where
 
        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 )
 
 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,
 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 )
 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"
     
   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) 
 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)
        -- 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}
 
 
 \end{code}
 
 

diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index a11efe0..377c082 100644 (file)
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -17,7 +17,7 @@ module Inst (
        newDictBndr, newDictBndrs, newDictBndrsO,
        instCall, instStupidTheta,
        cloneDict, 
        newDictBndr, newDictBndrs, newDictBndrsO,
        instCall, instStupidTheta,
        cloneDict, 

-       shortCutFracLit, shortCutIntLit, newIPDict, 
+       shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict, 

        newMethod, newMethodFromName, newMethodWithGivenTy, 
        tcInstClassOp, 
        tcSyntaxName, isHsVar,
        newMethod, newMethodFromName, newMethodWithGivenTy, 
        tcInstClassOp, 
        tcSyntaxName, isHsVar,

@@ -44,6 +44,7 @@ module Inst (
 import {-# SOURCE #-}  TcExpr( tcPolyExpr )
 import {-# SOURCE #-}  TcUnify( unifyType )
 
 import {-# SOURCE #-}  TcExpr( tcPolyExpr )
 import {-# SOURCE #-}  TcUnify( unifyType )
 

+import FastString(FastString)

 import HsSyn
 import TcHsSyn
 import TcRnMonad
 import HsSyn
 import TcHsSyn
 import TcRnMonad

@@ -436,6 +437,12 @@ shortCutFracLit f ty
   where
     mk_lit con lit = HsApp (nlHsVar (dataConWrapId con)) (nlHsLit lit)
 
   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 ->
 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))
 
     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
 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))
 
     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
 --------------------- Dictionaries ------------------------
 lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
   = do         { mb_result <- lookupPred pred

diff --git a/compiler/typecheck/TcDefaults.lhs b/compiler/typecheck/TcDefaults.lhs
index 0011215..f4d3b6d 100644 (file)
--- a/compiler/typecheck/TcDefaults.lhs
+++ b/compiler/typecheck/TcDefaults.lhs
@@ -46,6 +46,7 @@ tcDefaults [L locn (DefaultDecl mono_tys)]
   = setSrcSpan locn                    $
     addErrCtxt defaultDeclCtxt         $
     tcLookupClass numClassName         `thenM` \ num_class ->
   = 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
     mappM tc_default_ty mono_tys       `thenM` \ tau_tys ->
     
        -- Check that all the types are instances of Num

diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index f4e2587..615a7a0 100644 (file)
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/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') }
   = 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)
 
 -------------------------------------------------------------------------
 zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id)

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index e7fd6ca..4fe704a 100644 (file)
--- a/compiler/typecheck/TcPat.lhs
+++ b/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) }
 
   = 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
 newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
 newLitInst orig lit res_ty     -- Make a LitInst
   = do         { loc <- getInstLoc orig

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 7b9f1f1..29938ee 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -2258,8 +2258,13 @@ disambiguate extended_defaulting insts
                                do { integer_ty <- tcMetaTy integerTyConName
                                   ; checkWiredInTyCon doubleTyCon
                                   ; return [integer_ty, doubleTy] }
                                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])
        ; 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
   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
 
    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
 
        -- 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
 
 
 disambigGroup :: [Type]                        -- The default types