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.
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
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
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
-- (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}
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}
%************************************************************************
| 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
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}
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
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.
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}
instance Outputable (HsOverLit id) where
ppr (HsIntegral i _) = integer i
ppr (HsFractional f _) = rational f
+ ppr (HsIsString s _) = pprHsString s
\end{code}
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
| Opt_ScopedTypeVariables
| Opt_BangPatterns
| Opt_IndexedTypes
+ | Opt_OverloadedStrings
-- optimisation opts
| Opt_Strictness
( "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 ),
: 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) }
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 }
extractHsRhoRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl,
- mkHsNegApp, mkHsIntegral, mkHsFractional,
+ mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsIsString,
mkHsDo, mkHsSplice,
mkTyData, mkPrefixCon, mkRecCon, mkInlineSpec,
mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
runMainIOName,
orderingTyConName,
rationalTyConName,
+ stringTyConName,
ratioDataConName,
ratioTyConName,
integerTyConName, smallIntegerDataConName, largeIntegerDataConName,
realFracClassName, -- numeric
realFloatClassName, -- numeric
dataClassName,
+ isStringClassName,
-- Numeric stuff
negateName, minusName,
fromRationalName, fromIntegerName,
geName, eqName,
+
+ -- String stuff
+ fromStringName,
-- Enum stuff
enumFromName, enumFromThenName,
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")
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
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
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
monadPlusClassKey = mkPreludeClassUnique 30
randomClassKey = mkPreludeClassUnique 31
randomGenClassKey = mkPreludeClassUnique 32
+
+isStringClassKey = mkPreludeClassUnique 33
\end{code}
%************************************************************************
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
-----------------------------------------------------
choiceAIdKey = mkPreludeMiscIdUnique 123 -- |||
loopAIdKey = mkPreludeMiscIdUnique 124
+fromStringClassOpKey = mkPreludeMiscIdUnique 125
+
---------------- Template Haskell -------------------
-- USES IdUniques 200-399
-----------------------------------------------------
standardClassKeys = derivableClassKeys ++ numericClassKeys
++ [randomClassKey, randomGenClassKey,
functorClassKey,
- monadClassKey, monadPlusClassKey]
+ monadClassKey, monadPlusClassKey,
+ isStringClassKey
+ ]
\end{code}
@derivableClassKeys@ is also used in checking \tr{deriving} constructs
* "do" notation
We store the relevant Name in the HsSyn tree, in
- * HsIntegral/HsFractional
+ * HsIntegral/HsFractional/HsIsString
* NegApp
* NPlusKPat
* HsDo
= 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)
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 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 )
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)
-- 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}
newDictBndr, newDictBndrs, newDictBndrsO,
instCall, instStupidTheta,
cloneDict,
- shortCutFracLit, shortCutIntLit, newIPDict,
+ shortCutFracLit, shortCutIntLit, shortCutStringLit, newIPDict,
newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp,
tcSyntaxName, isHsVar,
import {-# SOURCE #-} TcExpr( tcPolyExpr )
import {-# SOURCE #-} TcUnify( unifyType )
+import FastString(FastString)
import HsSyn
import TcHsSyn
import TcRnMonad
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 ->
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
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
= 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
= 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)
= 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
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
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