Commit 90dc9026 authored by lennart@augustsson.net's avatar lennart@augustsson.net
Browse files

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