From 90dc9026b091be5cca5da4c6cbd3713ecc493361 Mon Sep 17 00:00:00 2001 From: "lennart@augustsson.net" Date: Thu, 21 Dec 2006 21:01:47 +0000 Subject: [PATCH] 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 | 1 + compiler/deSugar/DsExpr.lhs | 2 +- compiler/deSugar/DsMeta.hs | 3 +++ compiler/deSugar/MatchLit.lhs | 9 +++++++++ compiler/hsSyn/Convert.lhs | 1 + compiler/hsSyn/HsLit.lhs | 8 ++++++++ compiler/hsSyn/HsUtils.lhs | 1 + compiler/main/DynFlags.hs | 2 ++ compiler/parser/Parser.y.pp | 5 ++++- compiler/parser/RdrHsSyn.lhs | 2 +- compiler/prelude/PrelNames.lhs | 26 ++++++++++++++++++++++---- compiler/rename/RnEnv.lhs | 2 +- compiler/rename/RnExpr.lhs | 10 ++++++++++ compiler/rename/RnTypes.lhs | 12 ++++++++++-- compiler/typecheck/Inst.lhs | 27 ++++++++++++++++++++++++++- compiler/typecheck/TcDefaults.lhs | 1 + compiler/typecheck/TcHsSyn.lhs | 2 ++ compiler/typecheck/TcPat.lhs | 13 +++++++++++++ compiler/typecheck/TcSimplify.lhs | 11 ++++++++--- 19 files changed, 124 insertions(+), 14 deletions(-) diff --git a/compiler/deSugar/Check.lhs b/compiler/deSugar/Check.lhs index 15fcf39..359035f 100644 --- 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 (NPat (HsIsString s _) _ _ _) = Just (HsStringPrim s) 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 --- 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 (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 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 36b6b4c..b41873f 100644 --- 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 +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 diff --git a/compiler/deSugar/MatchLit.lhs b/compiler/deSugar/MatchLit.lhs index d7e8ba6..2cdab30 100644 --- 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 +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} diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 71cfaaf..76e51df 100644 --- 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 (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 diff --git a/compiler/hsSyn/HsLit.lhs b/compiler/hsSyn/HsLit.lhs index f4c9cf7..edf08e3 100644 --- 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 + | 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} diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index d2c5d0e..9bd3448 100644 --- 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 +mkHsIsString s = HsIsString s noSyntaxExpr 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 --- a/compiler/main/DynFlags.hs +++ b/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 ), diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 55f8cf2..ffc1f44 100644 --- 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) } +-- 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 } diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 221e4c2..895c8a8 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/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 diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 1aa0ae6..35c828f 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/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 diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 32806f0..d09c2ab 100644 --- 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 - * HsIntegral/HsFractional + * HsIntegral/HsFractional/HsIsString * NegApp * NPlusKPat * HsDo diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 996c102..17c7f97 100644 --- 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) +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) diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 8dbf887..34a19a3 100644 --- a/compiler/rename/RnTypes.lhs +++ b/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} diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index a11efe0..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 @@ -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 diff --git a/compiler/typecheck/TcDefaults.lhs b/compiler/typecheck/TcDefaults.lhs index 0011215..f4d3b6d 100644 --- 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 -> + tcLookupClass isStringClassName `thenM` \ num_class -> 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 --- 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') } +zonkOverLit env (HsIsString s e) + = do { e' <- zonkExpr env e; return (HsIsString s e') } ------------------------------------------------------------------------- zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs index e7fd6ca..4fe704a 100644 --- 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) } +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 diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index 7b9f1f1..29938ee 100644 --- 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] } + ; 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 -- 1.7.10.4