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.
 
parent 69346489
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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
......
......@@ -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}
......@@ -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
......
......@@ -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 ),
......
......@@ -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 }
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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}
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment