From 041c35e5d9f3aefab6908b4c776a3fd8242720ab Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Wed, 21 Feb 2007 10:36:45 +0000 Subject: [PATCH] Fix defaulting for overloaded strings This patch fixes the typechecking of the default declaration itself, when overloaded strings are involved. It also documents the behaviour in the user manual. nofib/spectral/power should work again now! --- compiler/typecheck/TcDefaults.lhs | 48 ++++++++++++++++++++++++------------- compiler/typecheck/TcSimplify.lhs | 26 ++++++++++++-------- docs/users_guide/glasgow_exts.xml | 26 +++++++++++++++++++- 3 files changed, 73 insertions(+), 27 deletions(-) diff --git a/compiler/typecheck/TcDefaults.lhs b/compiler/typecheck/TcDefaults.lhs index f4d3b6d..6bd8b4a 100644 --- a/compiler/typecheck/TcDefaults.lhs +++ b/compiler/typecheck/TcDefaults.lhs @@ -11,13 +11,16 @@ module TcDefaults ( tcDefaults ) where import HsSyn import Name +import Class import TcRnMonad import TcEnv import TcHsType import TcSimplify import TcType import PrelNames +import DynFlags import SrcLoc +import Maybe import Outputable \end{code} @@ -45,29 +48,38 @@ tcDefaults [L locn (DefaultDecl [])] 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 - -- We only care about whether it worked or not - tcSimplifyDefault [mkClassPred num_class [ty] | ty <- tau_tys] `thenM_` + do { ovl_str <- doptM Opt_OverloadedStrings + ; num_class <- tcLookupClass numClassName + ; is_str_class <- tcLookupClass isStringClassName + ; let deflt_clss | ovl_str = [num_class, is_str_class] + | otherwise = [num_class] + + ; tau_tys <- mappM (tc_default_ty deflt_clss) mono_tys - returnM (Just tau_tys) + ; return (Just tau_tys) } -tcDefaults decls@(L locn (DefaultDecl _) : _) = - setSrcSpan locn $ +tcDefaults decls@(L locn (DefaultDecl _) : _) + = setSrcSpan locn $ failWithTc (dupDefaultDeclErr decls) -tc_default_ty hs_ty - = tcHsSigType DefaultDeclCtxt hs_ty `thenM` \ ty -> - checkTc (isTauTy ty) (polyDefErr hs_ty) `thenM_` - returnM ty +tc_default_ty deflt_clss hs_ty + = do { ty <- tcHsSigType DefaultDeclCtxt hs_ty + ; checkTc (isTauTy ty) (polyDefErr hs_ty) -defaultDeclCtxt = ptext SLIT("when checking that each type in a default declaration") - $$ ptext SLIT("is an instance of class Num") + -- Check that the type is an instance of at least one of the deflt_clss + ; oks <- mapM (check_instance ty) deflt_clss + ; checkTc (or oks) (badDefaultTy ty deflt_clss) + ; return ty } +check_instance :: Type -> Class -> TcM Bool + -- Check that ty is an instance of cls + -- We only care about whether it worked or not; return a boolean +check_instance ty cls + = do { (_, mb_res) <- tryTc (tcSimplifyDefault [mkClassPred cls [ty]]) + ; return (isJust mb_res) } + +defaultDeclCtxt = ptext SLIT("When checking the types in a default declaration") dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things) = hang (ptext SLIT("Multiple default declarations")) @@ -77,5 +89,9 @@ dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things) polyDefErr ty = hang (ptext SLIT("Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty) + +badDefaultTy ty deflt_clss + = hang (ptext SLIT("The default type") <+> quotes (ppr ty) <+> ptext SLIT("is not an instance of")) + 2 (foldr1 (\a b -> a <+> ptext SLIT("or") <+> b) (map (quotes. ppr) deflt_clss)) \end{code} diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs index a59a51d..47c92af 100644 --- a/compiler/typecheck/TcSimplify.lhs +++ b/compiler/typecheck/TcSimplify.lhs @@ -2194,9 +2194,8 @@ tc_simplify_top doc interactive wanteds -- OK, so there are some errors { -- Use the defaulting rules to do extra unification -- NB: irreds are already zonked - ; extended_default <- if interactive then return True - else doptM Opt_ExtendedDefaultRules - ; disambiguate extended_default irreds1 -- Does unification + ; dflags <- getDOpts + ; disambiguate interactive dflags irreds1 -- Does unification ; (irreds2, binds2) <- topCheckLoop doc irreds1 -- Deal with implicit parameter @@ -2244,10 +2243,10 @@ Since we're not using the result of @foo@, the result if (presumably) @void@. \begin{code} -disambiguate :: Bool -> [Inst] -> TcM () +disambiguate :: Bool -> DynFlags -> [Inst] -> TcM () -- Just does unification to fix the default types -- The Insts are assumed to be pre-zonked -disambiguate extended_defaulting insts +disambiguate interactive dflags insts | null defaultable_groups = do { traceTc (text "disambigutate" <+> vcat [ppr unaries, ppr bad_tvs, ppr defaultable_groups]) ; return () } @@ -2261,14 +2260,16 @@ disambiguate extended_defaulting insts do { integer_ty <- tcMetaTy integerTyConName ; checkWiredInTyCon doubleTyCon ; string_ty <- tcMetaTy stringTyConName - ; ovl_str <- doptM Opt_OverloadedStrings - ; if ovl_str -- Add String if -foverloaded-strings + ; if ovl_strings -- Add String if -foverloaded-strings then return [integer_ty,doubleTy,string_ty] else return [integer_ty,doubleTy] } ; traceTc (text "disambigutate" <+> vcat [ppr unaries, ppr bad_tvs, ppr defaultable_groups]) ; mapM_ (disambigGroup default_tys) defaultable_groups } where + extended_defaulting = interactive || dopt Opt_ExtendedDefaultRules dflags + ovl_strings = dopt Opt_OverloadedStrings dflags + unaries :: [(Inst,Class, TcTyVar)] -- (C tv) constraints bad_tvs :: TcTyVarSet -- Tyvars mentioned by *other* constraints (unaries, bad_tvs) = getDefaultableDicts insts @@ -2287,14 +2288,19 @@ disambiguate extended_defaulting insts defaultable_classes clss | extended_defaulting = any isInteractiveClass clss - | otherwise = all isStandardClass clss && (any isNumericClass clss || any ((== isStringClassKey) . classKey) clss) + | otherwise = all is_std_class clss && (any is_num_class 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, isStringClassKey]) + = is_num_class cls || (classKey cls `elem` [showClassKey, eqClassKey, ordClassKey]) + + is_num_class cls = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) + -- is_num_class adds IsString to the standard numeric classes, + -- when -foverloaded-strings is enabled + is_std_class cls = isStandardClass cls || (ovl_strings && (cls `hasKey` isStringClassKey)) + -- Similarly is_std_class disambigGroup :: [Type] -- The default types -> [(Inst,Class,TcTyVar)] -- All standard classes of form (C a) diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index dfedb08..a8c91df 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -4086,15 +4086,39 @@ The class IsString is defined as: class IsString a where fromString :: String -> a -And the only predefined instance is the obvious one to make strings work as usual: +The only predefined instance is the obvious one to make strings work as usual: instance IsString [Char] where fromString cs = cs +The class IsString is not in scope by default. If you want to mention +it explicitly (for exmaple, to give an instance declaration for it), you can import it +from module GHC.Exts. + + +Haskell's defaulting mechanism is extended to cover string literals, when is specified. +Specifically: + + +Each type in a default declaration must be an +instance of Num or of IsString. + + + +The standard defaulting rule (Haskell Report, Section 4.3.4) +is extended thus: defaulting applies when all the unresolved constraints involve standard classes +or IsString; and at least one is a numeric class +or IsString. + + A small example: +module Main where + +import GHC.Exts( IsString(..) ) + newtype MyString = MyString String deriving (Eq, Show) instance IsString MyString where fromString = MyString -- 1.7.10.4