From: simonpj@microsoft.com Date: Wed, 21 Feb 2007 10:36:45 +0000 (+0000) Subject: Fix defaulting for overloaded strings X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=041c35e5d9f3aefab6908b4c776a3fd8242720ab;p=ghc-hetmet.git 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! --- 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