Make the type-defaulting in GHCi use () as the first default type

[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 182a7c5..7311ae0 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -28,11 +28,10 @@ import Inst
 import TcEnv
 import InstEnv
 import TcGadt
 import TcEnv
 import InstEnv
 import TcGadt

-import TcMType

 import TcType
 import TcType

+import TcMType

 import TcIface
 import Var
 import TcIface
 import Var

-import TyCon

 import Name
 import NameSet
 import Class
 import Name
 import NameSet
 import Class

@@ -657,7 +656,7 @@ tcSimplifyInfer
        :: SDoc
        -> TcTyVarSet           -- fv(T); type vars
        -> [Inst]               -- Wanted
        :: SDoc
        -> TcTyVarSet           -- fv(T); type vars
        -> [Inst]               -- Wanted

-       -> TcM ([TcTyVar],      -- Tyvars to quantify (zonked)
+       -> TcM ([TcTyVar],      -- Tyvars to quantify (zonked and quantified)

                [Inst],         -- Dict Ids that must be bound here (zonked)
                TcDictBinds)    -- Bindings
        -- Any free (escaping) Insts are tossed into the environment
                [Inst],         -- Dict Ids that must be bound here (zonked)
                TcDictBinds)    -- Bindings
        -- Any free (escaping) Insts are tossed into the environment

@@ -848,11 +847,13 @@ bindIrredsR loc qtvs co_vars reft givens irreds
   | otherwise
   = do { let givens' = filter isDict givens
                -- The givens can include methods
   | otherwise
   = do { let givens' = filter isDict givens
                -- The givens can include methods

+               -- See Note [Pruning the givens in an implication constraint]

 
 

-          -- If there are no 'givens', then it's safe to 
+          -- If there are no 'givens' *and* the refinement is empty
+          -- (the refinement is like more givens), then it's safe to 

           -- partition the 'wanteds' by their qtvs, thereby trimming irreds
           -- See Note [Freeness and implications]
           -- partition the 'wanteds' by their qtvs, thereby trimming irreds
           -- See Note [Freeness and implications]

-       ; irreds' <- if null givens'
+       ; irreds' <- if null givens' && isEmptyRefinement reft

                     then do
                        { let qtv_set = mkVarSet qtvs
                              (frees, real_irreds) = partition (isFreeWrtTyVars qtv_set) irreds
                     then do
                        { let qtv_set = mkVarSet qtvs
                              (frees, real_irreds) = partition (isFreeWrtTyVars qtv_set) irreds

@@ -862,7 +863,8 @@ bindIrredsR loc qtvs co_vars reft givens irreds
        
        ; let all_tvs = qtvs ++ co_vars -- Abstract over all these
        ; (implics, bind) <- makeImplicationBind loc all_tvs reft givens' irreds'
        
        ; let all_tvs = qtvs ++ co_vars -- Abstract over all these
        ; (implics, bind) <- makeImplicationBind loc all_tvs reft givens' irreds'

-                               -- This call does the real work
+                       -- This call does the real work
+                       -- If irreds' is empty, it does something sensible

        ; extendLIEs implics
        ; return bind } 
 
        ; extendLIEs implics
        ; return bind } 
 

@@ -875,6 +877,8 @@ makeImplicationBind :: InstLoc -> [TcTyVar] -> Refinement
 -- The binding looks like
 --     (ir1, .., irn) = f qtvs givens
 -- where f is (evidence for) the new implication constraint
 -- The binding looks like
 --     (ir1, .., irn) = f qtvs givens
 -- where f is (evidence for) the new implication constraint

+--     f :: forall qtvs. {reft} givens => (ir1, .., irn)
+-- qtvs includes coercion variables

 --
 -- This binding must line up the 'rhs' in reduceImplication
 makeImplicationBind loc all_tvs reft
 --
 -- This binding must line up the 'rhs' in reduceImplication
 makeImplicationBind loc all_tvs reft

@@ -1171,7 +1175,7 @@ tcSimplifyRestricted      -- Used for restricted binding groups
        -> [Name]               -- Things bound in this group
        -> TcTyVarSet           -- Free in the type of the RHSs
        -> [Inst]               -- Free in the RHSs
        -> [Name]               -- Things bound in this group
        -> TcTyVarSet           -- Free in the type of the RHSs
        -> [Inst]               -- Free in the RHSs

-       -> TcM ([TyVar],        -- Tyvars to quantify (zonked)
+       -> TcM ([TyVar],        -- Tyvars to quantify (zonked and quantified)

                TcDictBinds)    -- Bindings
        -- tcSimpifyRestricted returns no constraints to
        -- quantify over; by definition there are none.
                TcDictBinds)    -- Bindings
        -- tcSimpifyRestricted returns no constraints to
        -- quantify over; by definition there are none.

@@ -1876,6 +1880,20 @@ We can satisfy the (C Int) from the superclass of D, so we don't want
 to float the (C Int) out, even though it mentions no type variable in
 the constraints!
 
 to float the (C Int) out, even though it mentions no type variable in
 the constraints!
 

+Note [Pruning the givens in an implication constraint]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we are about to form the implication constraint
+       forall tvs.  Eq a => Ord b
+The (Eq a) cannot contribute to the (Ord b), because it has no access to
+the type variable 'b'.  So we could filter out the (Eq a) from the givens.
+
+Doing so would be a bit tidier, but all the implication constraints get
+simplified away by the optimiser, so it's no great win.   So I don't take
+advantage of that at the moment.
+
+If you do, BE CAREFUL of wobbly type variables.
+
+

 %************************************************************************
 %*                                                                     *
                Avails and AvailHow: the pool of evidence
 %************************************************************************
 %*                                                                     *
                Avails and AvailHow: the pool of evidence

@@ -2176,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
        -- 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
        ; (irreds2, binds2) <- topCheckLoop doc irreds1
 
                -- Deal with implicit parameter

@@ -2226,26 +2243,23 @@ Since we're not using the result of @foo@, the result if (presumably)
 @void@.
 
 \begin{code}
 @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
        -- 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 () }
   | otherwise
   = do         {       -- Figure out what default types to use
   | null defaultable_groups
   = do { traceTc (text "disambigutate" <+> vcat [ppr unaries, ppr bad_tvs, ppr defaultable_groups])
        ;     return () }
   | otherwise
   = do         {       -- Figure out what default types to use

-         mb_defaults <- getDefaultTys
-       ; default_tys <- case mb_defaults of
-                          Just tys -> return tys
-                          Nothing  ->  -- No use-supplied default;
-                                       -- use [Integer, Double]
-                               do { integer_ty <- tcMetaTy integerTyConName
-                                  ; checkWiredInTyCon doubleTyCon
-                                  ; return [integer_ty, doubleTy] }
+       ; default_tys <- getDefaultTys extended_defaulting ovl_strings
+

        ; traceTc (text "disambigutate" <+> vcat [ppr unaries, ppr bad_tvs, ppr defaultable_groups])
        ; mapM_ (disambigGroup default_tys) defaultable_groups  }
   where
        ; 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
    unaries :: [(Inst,Class, TcTyVar)]  -- (C tv) constraints
    bad_tvs :: TcTyVarSet         -- Tyvars mentioned by *other* constraints
    (unaries, bad_tvs) = getDefaultableDicts insts

@@ -2257,21 +2271,26 @@ disambiguate extended_defaulting insts
 
    defaultable_group :: [(Inst,Class,TcTyVar)] -> Bool
    defaultable_group ds@((_,_,tv):_)
 
    defaultable_group :: [(Inst,Class,TcTyVar)] -> Bool
    defaultable_group ds@((_,_,tv):_)

-       =  not (isImmutableTyVar tv)    -- Note [Avoiding spurious errors]
+       =  isTyConableTyVar tv  -- Note [Avoiding spurious errors]

        && not (tv `elemVarSet` bad_tvs)
        && defaultable_classes [c | (_,c,_) <- ds]
    defaultable_group [] = panic "defaultable_group"
 
    defaultable_classes clss 
        | extended_defaulting = any isInteractiveClass clss
        && not (tv `elemVarSet` bad_tvs)
        && defaultable_classes [c | (_,c,_) <- ds]
    defaultable_group [] = panic "defaultable_group"
 
    defaultable_classes clss 
        | extended_defaulting = any isInteractiveClass clss

-       | otherwise = all isStandardClass clss && any isNumericClass 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 
 
        -- 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])
+       = 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)
 
 disambigGroup :: [Type]                        -- The default types
              -> [(Inst,Class,TcTyVar)] -- All standard classes of form (C a)

@@ -2296,8 +2315,43 @@ disambigGroup default_tys dicts
                -- After this we can't fail
           ; warnDefault dicts default_ty
           ; unifyType default_ty (mkTyVarTy tyvar) }
                -- After this we can't fail
           ; warnDefault dicts default_ty
           ; unifyType default_ty (mkTyVarTy tyvar) }

+
+
+getDefaultTys :: Bool -> Bool -> TcM [Type]
+getDefaultTys extended_deflts ovl_strings
+  = do { mb_defaults <- getDeclaredDefaultTys
+       ; case mb_defaults of
+          Just tys -> return tys       -- User-supplied defaults
+          Nothing  -> do
+
+       -- No use-supplied default
+       -- Use [Integer, Double], plus modifications
+       { integer_ty <- tcMetaTy integerTyConName
+       ; checkWiredInTyCon doubleTyCon
+       ; string_ty <- tcMetaTy stringTyConName
+       ; return (opt_deflt extended_deflts unitTy
+                       -- Note [Default unitTy]
+                       ++
+                 [integer_ty,doubleTy]
+                       ++
+                 opt_deflt ovl_strings string_ty) }}
+  where
+    opt_deflt True  ty = [ty]
+    opt_deflt False ty = []

 \end{code}
 
 \end{code}
 

+Note [Default unitTy]
+~~~~~~~~~~~~~~~~~~~~~
+In interative mode (or with -fextended-default-rules) we add () as the first type we
+try when defaulting.  This has very little real impact, except in the following case.
+Consider: 
+       Text.Printf.printf "hello"
+This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't
+want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to
+default the 'a' to (), rather than to Integer (which is what would otherwise happen;
+and then GHCi doesn't attempt to print the ().  So in interactive mode, we add
+() to the list of defaulting types.  See Trac #1200.
+

 Note [Avoiding spurious errors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When doing the unification for defaulting, we check for skolem
 Note [Avoiding spurious errors]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 When doing the unification for defaulting, we check for skolem

@@ -2330,78 +2384,34 @@ instance declarations.
 
 \begin{code}
 tcSimplifyDeriv :: InstOrigin
 
 \begin{code}
 tcSimplifyDeriv :: InstOrigin

-                -> TyCon

                -> [TyVar]      
                -> ThetaType            -- Wanted
                -> TcM ThetaType        -- Needed
                -> [TyVar]      
                -> ThetaType            -- Wanted
                -> TcM ThetaType        -- Needed

+-- Given  instance (wanted) => C inst_ty 
+-- Simplify 'wanted' as much as possible
+-- The inst_ty is needed only for the termination check

 
 

-tcSimplifyDeriv orig tc tyvars theta
-  = tcInstTyVars tyvars                        `thenM` \ (tvs, _, tenv) ->
+tcSimplifyDeriv orig tyvars theta
+  = do { (tvs, _, tenv) <- tcInstTyVars tyvars

        -- The main loop may do unification, and that may crash if 
        -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
        -- ToDo: what if two of them do get unified?
        -- The main loop may do unification, and that may crash if 
        -- it doesn't see a TcTyVar, so we have to instantiate. Sigh
        -- ToDo: what if two of them do get unified?

-    newDictBndrsO orig (substTheta tenv theta) `thenM` \ wanteds ->
-    topCheckLoop doc wanteds                   `thenM` \ (irreds, _) ->
-
-    doptM Opt_GlasgowExts                      `thenM` \ gla_exts ->
-    doptM Opt_AllowUndecidableInstances                `thenM` \ undecidable_ok ->
-    let
-       inst_ty = mkTyConApp tc (mkTyVarTys tvs)
-       (ok_insts, bad_insts) = partition is_ok_inst irreds
-       is_ok_inst inst
-          = isDict inst        -- Exclude implication consraints
-          && (isTyVarClassPred pred || (gla_exts && ok_gla_pred pred))
-          where
-            pred = dictPred inst
-
-       ok_gla_pred pred = null (checkInstTermination [inst_ty] [pred])
-               -- See Note [Deriving context]
-          
-       tv_set = mkVarSet tvs
-       simpl_theta = map dictPred ok_insts
-       weird_preds = [pred | pred <- simpl_theta
-                           , not (tyVarsOfPred pred `subVarSet` tv_set)]  
-
-         -- Check for a bizarre corner case, when the derived instance decl should
-         -- have form  instance C a b => D (T a) where ...
-         -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts
-         -- of problems; in particular, it's hard to compare solutions for
-         -- equality when finding the fixpoint.  So I just rule it out for now.
-       
-       rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
-               -- This reverse-mapping is a Royal Pain, 
-               -- but the result should mention TyVars not TcTyVars
-    in
-       -- In effect, the bad and wierd insts cover all of the cases that
-       -- would make checkValidInstance fail; if it were called right after tcSimplifyDeriv
-       --   * wierd_preds ensures unambiguous instances (checkAmbiguity in checkValidInstance)
-       --   * ok_gla_pred ensures termination (checkInstTermination in checkValidInstance)
-    addNoInstanceErrs bad_insts                                `thenM_`
-    mapM_ (addErrTc . badDerivedPred) weird_preds      `thenM_`
-    returnM (substTheta rev_env simpl_theta)
+       ; wanteds <- newDictBndrsO orig (substTheta tenv theta)
+       ; (irreds, _) <- topCheckLoop doc wanteds
+
+       ; let rev_env = zipTopTvSubst tvs (mkTyVarTys tyvars)
+             simpl_theta = substTheta rev_env (map dictPred irreds)
+               -- This reverse-mapping is a pain, but the result
+               -- should mention the original TyVars not TcTyVars
+
+       -- NB: the caller will further check the tv_dicts for
+       --     legal instance-declaration form
+
+       ; return simpl_theta }

   where
     doc = ptext SLIT("deriving classes for a data type")
 \end{code}
 
   where
     doc = ptext SLIT("deriving classes for a data type")
 \end{code}
 

-Note [Deriving context]
-~~~~~~~~~~~~~~~~~~~~~~~
-With -fglasgow-exts, we allow things like (C Int a) in the simplified
-context for a derived instance declaration, because at a use of this
-instance, we might know that a=Bool, and have an instance for (C Int
-Bool)
-
-We nevertheless insist that each predicate meets the termination
-conditions. If not, the deriving mechanism generates larger and larger
-constraints.  Example:
-  data Succ a = S a
-  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show
-
-Note the lack of a Show instance for Succ.  First we'll generate
-  instance (Show (Succ a), Show a) => Show (Seq a)
-and then
-  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)
-and so on.  Instead we want to complain of no instance for (Show (Succ a)).
-  

 
 
 @tcSimplifyDefault@ just checks class-type constraints, essentially;
 
 
 @tcSimplifyDefault@ just checks class-type constraints, essentially;

@@ -2652,12 +2662,6 @@ warnDefault ups default_ty
                                quotes (ppr default_ty),
                      pprDictsInFull tidy_dicts]
 
                                quotes (ppr default_ty),
                      pprDictsInFull tidy_dicts]
 

--- Used for the ...Thetas variants; all top level
-badDerivedPred pred
-  = vcat [ptext SLIT("Can't derive instances where the instance context mentions"),
-         ptext SLIT("type variables that are not data type parameters"),
-         nest 2 (ptext SLIT("Offending constraint:") <+> ppr pred)]
-

 reduceDepthErr n stack
   = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
          ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),
 reduceDepthErr n stack
   = vcat [ptext SLIT("Context reduction stack overflow; size =") <+> int n,
          ptext SLIT("Use -fcontext-stack=N to increase stack size to N"),