Reorganise the work list, so that flattening goals are treated in the right order
authorSimon Peyton Jones <simonpj@microsoft.com>
Tue, 9 Dec 2014 17:38:12 +0000 (17:38 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 10 Dec 2014 16:01:15 +0000 (16:01 +0000)
Trac #9872 showed the importance of processing goals in depth-first, so that
we do not build up a huge pool of suspended function calls, waiting for their
children to fire.  There is a detailed explanation in
     Note [The flattening work list]
in TcFlatten

The effect for Trac #9872 (slow1.hs) is dramatic.  We go from too long
to wait down to 28Gbyte allocation.  GHC 7.8.3 did 116Gbyte allocation!

14 files changed:
compiler/typecheck/TcCanonical.hs
compiler/typecheck/TcFlatten.hs
compiler/typecheck/TcInteract.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcSMonad.hs
testsuite/tests/indexed-types/should_fail/NoMatchErr.stderr
testsuite/tests/indexed-types/should_fail/T2544.stderr
testsuite/tests/indexed-types/should_fail/T2627b.stderr
testsuite/tests/indexed-types/should_fail/T4093a.hs
testsuite/tests/indexed-types/should_fail/T4093a.stderr
testsuite/tests/indexed-types/should_fail/T7010.stderr
testsuite/tests/indexed-types/should_fail/T9036.stderr
testsuite/tests/typecheck/should_fail/FrozenErrorTests.stderr
testsuite/tests/typecheck/should_fail/T5853.stderr

index 97ab0e8..669dc06 100644 (file)
@@ -197,8 +197,7 @@ canClassNC ev cls tys
     `andWhenContinue` emitSuperclasses
 
 canClass ev cls tys
-  = do { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
-       ; (xis, cos) <- flattenMany fmode tys
+  = do { (xis, cos) <- flattenMany FM_FlattenAll ev tys
        ; let co = mkTcTyConAppCo Nominal (classTyCon cls) cos
              xi = mkClassPred cls xis
              mk_ct new_ev = CDictCan { cc_ev = new_ev
@@ -332,10 +331,9 @@ canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
 -- Precondition: ty not a tuple and no other evidence form
 canIrred old_ev
   = do { let old_ty = ctEvPred old_ev
-             fmode  = FE { fe_ev = old_ev, fe_mode = FM_FlattenAll }
-                      -- Flatten (F [a]), say, so that it can reduce to Eq a
        ; traceTcS "can_pred" (text "IrredPred = " <+> ppr old_ty)
-       ; (xi,co) <- flatten fmode old_ty -- co :: xi ~ old_ty
+       ; (xi,co) <- flatten FM_FlattenAll old_ev old_ty -- co :: xi ~ old_ty
+                      -- Flatten (F [a]), say, so that it can reduce to Eq a
        ; mb <- rewriteEvidence old_ev xi co
        ; case mb of {
              Stop ev s           -> return (Stop ev s) ;
@@ -351,9 +349,8 @@ canIrred old_ev
 
 canHole :: CtEvidence -> OccName -> HoleSort -> TcS (StopOrContinue Ct)
 canHole ev occ hole_sort
-  = do { let ty    = ctEvPred ev
-             fmode = FE { fe_ev = ev, fe_mode = FM_SubstOnly }
-       ; (xi,co) <- flatten fmode ty -- co :: xi ~ ty
+  = do { let ty = ctEvPred ev
+       ; (xi,co) <- flatten FM_SubstOnly ev ty -- co :: xi ~ ty
        ; mb <- rewriteEvidence ev xi co
        ; case mb of
            ContinueWith new_ev -> do { emitInsoluble (CHoleCan { cc_ev = new_ev
@@ -472,8 +469,7 @@ can_eq_fam_nc :: CtEvidence -> SwapFlag
 --   or the swapped version thereof
 -- Flatten both sides and go round again
 can_eq_fam_nc ev swapped fn tys rhs ps_rhs
-  = do { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
-       ; (xi_lhs, co_lhs) <- flattenFamApp fmode fn tys
+  = do { (xi_lhs, co_lhs) <- flattenFamApp FM_FlattenAll ev fn tys
        ; mb_ct <- rewriteEqEvidence ev swapped xi_lhs rhs co_lhs (mkTcNomReflCo rhs)
        ; case mb_ct of
            Stop ev s           -> return (Stop ev s)
@@ -488,9 +484,8 @@ can_eq_wanted_app :: CtEvidence -> TcType -> TcType
 -- One or the other is an App; neither is a type variable
 -- See Note [Canonicalising type applications]
 can_eq_wanted_app ev ty1 ty2
-  = do { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
-       ; (xi1, co1) <- flatten fmode ty1
-       ; (xi2, co2) <- flatten fmode ty2
+  = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1
+       ; (xi2, co2) <- flatten FM_FlattenAll ev ty2
         ; mb_ct <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2
         ; case mb_ct of {
             Stop ev s           -> return (Stop ev s) ;
@@ -568,9 +563,8 @@ canDecomposableTyConAppOK ev tc1 tys1 tys2
 canEqFailure :: CtEvidence -> TcType -> TcType -> TcS (StopOrContinue Ct)
 -- See Note [Make sure that insolubles are fully rewritten]
 canEqFailure ev ty1 ty2
-  = do { let fmode = FE { fe_ev = ev, fe_mode = FM_SubstOnly }
-       ; (s1, co1) <- flatten fmode ty1
-       ; (s2, co2) <- flatten fmode ty2
+  = do { (s1, co1) <- flatten FM_SubstOnly ev ty1
+       ; (s2, co2) <- flatten FM_SubstOnly ev ty2
        ; mb_ct <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2
        ; case mb_ct of
            ContinueWith new_ev -> do { emitInsoluble (mkNonCanonical new_ev)
@@ -643,8 +637,7 @@ canCFunEqCan :: CtEvidence
 -- and the RHS is a fsk, which we must *not* substitute.
 -- So just substitute in the LHS
 canCFunEqCan ev fn tys fsk
-  = do { let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
-       ; (tys', cos) <- flattenMany fmode tys
+  = do { (tys', cos) <- flattenMany FM_FlattenAll ev tys
                         -- cos :: tys' ~ tys
        ; let lhs_co  = mkTcTyConAppCo Nominal fn cos
                         -- :: F tys' ~ F tys
@@ -683,8 +676,7 @@ canEqTyVar ev swapped tv1 ty2 ps_ty2              -- ev :: tv ~ s2
                              -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }
                                  -- Flatten the RHS less vigorously, to avoid gratuitous flattening
                                  -- True <=> xi2 should not itself be a type-function application
-                             let fmode = FE { fe_ev = ev, fe_mode = FM_FlattenAll }
-                           ; (xi2, co2) <- flatten fmode ps_ty2 -- co2 :: xi2 ~ ps_ty2
+                           ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2 -- co2 :: xi2 ~ ps_ty2
                                            -- Use ps_ty2 to preserve type synonyms if poss
                            ; dflags <- getDynFlags
                            ; canEqTyVar2 dflags ev swapped tv1' xi2 co2 } }
index 01d5a10..6ab8b22 100644 (file)
@@ -2,7 +2,8 @@
 
 module TcFlatten(
    FlattenEnv(..), FlattenMode(..),
-   flatten, flattenMany, flattenFamApp, flattenTyVarOuter,
+   flatten, flattenMany, flatten_many,
+   flattenFamApp, flattenTyVarOuter,
    unflatten,
    eqCanRewrite, canRewriteOrSame
  ) where
@@ -565,7 +566,8 @@ unexpanded synonym.
 
 data FlattenEnv
   = FE { fe_mode :: FlattenMode
-       , fe_ev   :: CtEvidence }
+       , fe_ev   :: CtEvidence
+       }
 
 data FlattenMode  -- Postcondition for all three: inert wrt the type substitution
   = FM_FlattenAll          -- Postcondition: function-free
@@ -607,45 +609,66 @@ Note: T5321Fun got faster when I disabled FM_Avoid
       T5837 did too, but it's pathalogical anyway
 -}
 
+------------------
+flatten :: FlattenMode -> CtEvidence -> TcType -> TcS (Xi, TcCoercion)
+flatten mode ev ty
+  = runFlatten (flatten_one fmode ty)
+  where
+    fmode = FE { fe_mode = mode, fe_ev = ev }
+
+flattenMany :: FlattenMode -> CtEvidence -> [TcType] -> TcS ([Xi], [TcCoercion])
 -- Flatten a bunch of types all at once.
-flattenMany :: FlattenEnv -> [Type] -> TcS ([Xi], [TcCoercion])
+flattenMany mode ev tys
+  = runFlatten (flatten_many fmode tys)
+  where
+    fmode = FE { fe_mode = mode, fe_ev = ev }
+
+flattenFamApp :: FlattenMode -> CtEvidence -> TyCon -> [TcType] -> TcS (Xi, TcCoercion)
+flattenFamApp mode ev tc tys
+  = runFlatten (flatten_fam_app fmode tc tys)
+  where
+    fmode = FE { fe_mode = mode, fe_ev = ev }
+
+------------------
+flatten_many :: FlattenEnv -> [Type] -> TcS ([Xi], [TcCoercion])
 -- Coercions :: Xi ~ Type
 -- Returns True iff (no flattening happened)
 -- NB: The EvVar inside the 'fe_ev :: CtEvidence' is unused,
 --     we merely want (a) Given/Solved/Derived/Wanted info
 --                    (b) the GivenLoc/WantedLoc for when we create new evidence
-flattenMany fmode tys
+flatten_many fmode tys
   = -- pprTrace "flattenMany" empty $
     go tys
   where go []       = return ([],[])
-        go (ty:tys) = do { (xi,co)    <- flatten fmode ty
+        go (ty:tys) = do { (xi,co)    <- flatten_one fmode ty
                          ; (xis,cos)  <- go tys
                          ; return (xi:xis,co:cos) }
 
-flatten :: FlattenEnv -> TcType -> TcS (Xi, TcCoercion)
+------------------
+flatten_one :: FlattenEnv -> TcType -> TcS (Xi, TcCoercion)
 -- Flatten a type to get rid of type function applications, returning
 -- the new type-function-free type, and a collection of new equality
 -- constraints.  See Note [Flattening] for more detail.
 --
 -- Postcondition: Coercion :: Xi ~ TcType
 
-flatten _ xi@(LitTy {}) = return (xi, mkTcNomReflCo xi)
+flatten_one _ xi@(LitTy {}) = return (xi, mkTcNomReflCo xi)
 
-flatten fmode (TyVarTy tv)
+flatten_one fmode (TyVarTy tv)
   = flattenTyVar fmode tv
 
-flatten fmode (AppTy ty1 ty2)
-  = do { (xi1,co1) <- flatten fmode ty1
-       ; (xi2,co2) <- flatten fmode ty2
+flatten_one fmode (AppTy ty1 ty2)
+  = do { (xi1,co1) <- flatten_one fmode ty1
+       ; (xi2,co2) <- flatten_one fmode ty2
        ; traceTcS "flatten/appty" (ppr ty1 $$ ppr ty2 $$ ppr xi1 $$ ppr co1 $$ ppr xi2 $$ ppr co2)
        ; return (mkAppTy xi1 xi2, mkTcAppCo co1 co2) }
 
-flatten fmode (FunTy ty1 ty2)
-  = do { (xi1,co1) <- flatten fmode ty1
-       ; (xi2,co2) <- flatten fmode ty2
+flatten_one fmode (FunTy ty1 ty2)
+  = do { (xi1,co1) <- flatten_one fmode ty1
+       ; (xi2,co2) <- flatten_one fmode ty2
        ; return (mkFunTy xi1 xi2, mkTcFunCo Nominal co1 co2) }
 
-flatten fmode (TyConApp tc tys)
+flatten_one fmode (TyConApp tc tys)
 
   -- Expand type synonyms that mention type families
   -- on the RHS; see Note [Flattening synonyms]
@@ -653,7 +676,7 @@ flatten fmode (TyConApp tc tys)
   , let expanded_ty = mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys'
   = case fe_mode fmode of
       FM_FlattenAll | anyNameEnv isTypeFamilyTyCon (tyConsOfType rhs)
-                   -> flatten fmode expanded_ty
+                   -> flatten_one fmode expanded_ty
                     | otherwise
                    -> flattenTyConApp fmode tc tys
       _ -> flattenTyConApp fmode tc tys
@@ -662,7 +685,7 @@ flatten fmode (TyConApp tc tys)
   -- flatten it away as well, and generate a new given equality constraint
   -- between the application and a newly generated flattening skolem variable.
   | isTypeFamilyTyCon tc
-  = flattenFamApp fmode tc tys
+  = flatten_fam_app fmode tc tys
 
   -- For * a normal data type application
   --     * data family application
@@ -675,18 +698,18 @@ flatten fmode (TyConApp tc tys)
 --                   _ -> fmode
   = flattenTyConApp fmode tc tys
 
-flatten fmode ty@(ForAllTy {})
+flatten_one fmode ty@(ForAllTy {})
 -- We allow for-alls when, but only when, no type function
 -- applications inside the forall involve the bound type variables.
   = do { let (tvs, rho) = splitForAllTys ty
-       ; (rho', co) <- flatten (fmode { fe_mode = FM_SubstOnly }) rho
+       ; (rho', co) <- flatten_one (fmode { fe_mode = FM_SubstOnly }) rho
                          -- Substitute only under a forall
                          -- See Note [Flattening under a forall]
        ; return (mkForAllTys tvs rho', foldr mkTcForAllCo co tvs) }
 
 flattenTyConApp :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion)
 flattenTyConApp fmode tc tys
-  = do { (xis, cos) <- flattenMany fmode tys
+  = do { (xis, cos) <- flatten_many fmode tys
        ; return (mkTyConApp tc xis, mkTcTyConAppCo Nominal tc cos) }
 
 {-
@@ -732,43 +755,43 @@ and we have not begun to think about how to make that work!
 ************************************************************************
 -}
 
-flattenFamApp, flattenExactFamApp, flattenExactFamApp_fully
+flatten_fam_app, flatten_exact_fam_app, flatten_exact_fam_app_fully
   :: FlattenEnv -> TyCon -> [TcType] -> TcS (Xi, TcCoercion)
-  --   flattenFamApp            can be over-saturated
-  --   flattenExactFamApp       is exactly saturated
-  --   flattenExactFamApp_fully lifts out the application to top level
+  --   flatten_fam_app            can be over-saturated
+  --   flatten_exact_fam_app       is exactly saturated
+  --   flatten_exact_fam_app_fully lifts out the application to top level
   -- Postcondition: Coercion :: Xi ~ F tys
-flattenFamApp fmode tc tys  -- Can be over-saturated
+flatten_fam_app fmode tc tys  -- Can be over-saturated
     = ASSERT( tyConArity tc <= length tys )  -- Type functions are saturated
                  -- The type function might be *over* saturated
                  -- in which case the remaining arguments should
                  -- be dealt with by AppTys
       do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys
-         ; (xi1, co1) <- flattenExactFamApp fmode tc tys1
+         ; (xi1, co1) <- flatten_exact_fam_app fmode tc tys1
                -- co1 :: xi1 ~ F tys1
-         ; (xis_rest, cos_rest) <- flattenMany fmode tys_rest
+         ; (xis_rest, cos_rest) <- flatten_many fmode tys_rest
                -- cos_res :: xis_rest ~ tys_rest
          ; return ( mkAppTys xi1 xis_rest   -- NB mkAppTys: rhs_xi might not be a type variable
                                             --    cf Trac #5655
                   , mkTcAppCos co1 cos_rest -- (rhs_xi :: F xis) ; (F cos :: F xis ~ F tys)
                   ) }
 
-flattenExactFamApp fmode tc tys
+flatten_exact_fam_app fmode tc tys
   = case fe_mode fmode of
-       FM_FlattenAll -> flattenExactFamApp_fully fmode tc tys
+       FM_FlattenAll -> flatten_exact_fam_app_fully fmode tc tys
 
-       FM_SubstOnly -> do { (xis, cos) <- flattenMany fmode tys
+       FM_SubstOnly -> do { (xis, cos) <- flatten_many fmode tys
                           ; return ( mkTyConApp tc xis
                                    , mkTcTyConAppCo Nominal tc cos ) }
 
-       FM_Avoid tv flat_top -> do { (xis, cos) <- flattenMany fmode tys
+       FM_Avoid tv flat_top -> do { (xis, cos) <- flatten_many fmode tys
                                   ; if flat_top || tv `elemVarSet` tyVarsOfTypes xis
-                                    then flattenExactFamApp_fully fmode tc tys
+                                    then flatten_exact_fam_app_fully fmode tc tys
                                     else return ( mkTyConApp tc xis
                                                 , mkTcTyConAppCo Nominal tc cos ) }
 
-flattenExactFamApp_fully fmode tc tys
-  = do { (xis, cos) <- flattenMany (fmode { fe_mode = FM_FlattenAll })tys
+flatten_exact_fam_app_fully fmode tc tys
+  = do { (xis, cos) <- flatten_many (fmode { fe_mode = FM_FlattenAll })tys
        ; let ret_co = mkTcTyConAppCo Nominal tc cos
               -- ret_co :: F xis ~ F tys
              ctxt_ev = fe_ev fmode
@@ -796,7 +819,7 @@ flattenExactFamApp_fully fmode tc tys
                                         , cc_fun    = tc
                                         , cc_tyargs = xis
                                         , cc_fsk    = fsk }
-                   ; updWorkListTcS (extendWorkListFunEq ct)
+                   ; emitFlatWork ct
 
                    ; traceTcS "flatten/flat-cache miss" $ (ppr fam_ty $$ ppr fsk $$ ppr ev)
                    ; return (mkTyVarTy fsk, mkTcSymCo (ctEvCoercion ev) `mkTcTransCo` ret_co) } }
@@ -827,7 +850,7 @@ flattenTyVar fmode tv
                        ty' = mkTyVarTy tv'
 
            Right (ty1, co1)  -- Recurse
-                    -> do { (ty2, co2) <- flatten fmode ty1
+                    -> do { (ty2, co2) <- flatten_one fmode ty1
                           ; traceTcS "flattenTyVar3" (ppr tv $$ ppr ty2)
                           ; return (ty2, co2 `mkTcTransCo` co1) }
        }
@@ -873,7 +896,7 @@ flattenTyVarFinal ctxt_ev tv
   = -- Done, but make sure the kind is zonked
     do { let kind       = tyVarKind tv
              kind_fmode = FE { fe_ev = ctxt_ev, fe_mode = FM_SubstOnly }
-       ; (new_knd, _kind_co) <- flatten kind_fmode kind
+       ; (new_knd, _kind_co) <- flatten_one kind_fmode kind
        ; return (Left (setVarType tv new_knd)) }
 
 {-
index edb3303..47401ed 100644 (file)
@@ -29,6 +29,7 @@ import RdrName ( GlobalRdrEnv, lookupGRE_Name, mkRdrQual, is_as,
                  is_decl, Provenance(Imported), gre_prov )
 import FunDeps
 import FamInst
+import Inst( tyVarsOfCt )
 
 import TcEvidence
 import Outputable
@@ -976,7 +977,7 @@ kick_out new_ev new_tv (IC { inert_eqs = tv_eqs
                        , inert_insols = insols_in }
 
     kicked_out = WL { wl_eqs    = tv_eqs_out
-                    , wl_funeqs = foldrBag insertDeque emptyDeque feqs_out
+                    , wl_funeqs = feqs_out
                     , wl_rest   = bagToList (dicts_out `andCts` irs_out
                                              `andCts` insols_out)
                     , wl_implics = emptyBag }
@@ -1660,7 +1661,9 @@ shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion
                   -> TyCon -> [TcType] -> TcS (StopOrContinue Ct)
 shortCutReduction old_ev fsk ax_co fam_tc tc_args
   | isGiven old_ev
-  = do { (xis, cos) <- flattenMany (FE { fe_ev = old_ev, fe_mode = FM_FlattenAll }) tc_args
+  = runFlatten $
+    do { let fmode = FE { fe_mode = FM_FlattenAll, fe_ev = old_ev }
+       ; (xis, cos) <- flatten_many fmode tc_args
                -- ax_co :: F args ~ G tc_args
                -- cos   :: xis ~ tc_args
                -- old_ev :: F args ~ fsk
@@ -1673,12 +1676,14 @@ shortCutReduction old_ev fsk ax_co fam_tc tc_args
                                         `mkTcTransCo` ctEvCoercion old_ev) )
 
        ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk }
-       ; updWorkListTcS (extendWorkListFunEq new_ct)
+       ; emitFlatWork new_ct
        ; stopWith old_ev "Fun/Top (given, shortcut)" }
 
   | otherwise
   = ASSERT( not (isDerived old_ev) )   -- Caller ensures this
-    do { (xis, cos) <- flattenMany (FE { fe_ev = old_ev, fe_mode = FM_FlattenAll }) tc_args
+    runFlatten $
+    do { let fmode = FE { fe_mode = FM_FlattenAll, fe_ev = old_ev }
+       ; (xis, cos) <- flatten_many fmode tc_args
                -- ax_co :: F args ~ G tc_args
                -- cos   :: xis ~ tc_args
                -- G cos ; sym ax_co ; old_ev :: G xis ~ fsk
@@ -1691,7 +1696,7 @@ shortCutReduction old_ev fsk ax_co fam_tc tc_args
                                       `mkTcTransCo` ctEvCoercion new_ev))
 
        ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc, cc_tyargs = xis, cc_fsk = fsk }
-       ; updWorkListTcS (extendWorkListFunEq new_ct)
+       ; emitFlatWork new_ct
        ; stopWith old_ev "Fun/Top (wanted, shortcut)" }
   where
     loc = ctEvLoc old_ev
index dbc8b41..31f753c 100644 (file)
@@ -455,7 +455,15 @@ writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()
 writeTcRef = writeMutVar
 
 updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()
-updTcRef = updMutVar
+-- Returns ()
+updTcRef ref fn = liftIO $ do { old <- readIORef ref
+                              ; writeIORef ref (fn old) }
+
+updTcRefX :: TcRef a -> (a -> a) -> TcRnIf gbl lcl a
+-- Returns previous value
+updTcRefX ref fn = liftIO $ do { old <- readIORef ref
+                              ; writeIORef ref (fn old)
+                              ; return old }
 
 {-
 ************************************************************************
index 0b4d75c..204a471 100644 (file)
@@ -3,41 +3,26 @@
 -- Type definitions for the constraint solver
 module TcSMonad (
 
-       -- Canonical constraints, definition is now in TcRnTypes
-
+    -- The work list
     WorkList(..), isEmptyWorkList, emptyWorkList,
-    extendWorkListFunEq,
     extendWorkListNonEq, extendWorkListCt,
     extendWorkListCts, appendWorkList, selectWorkItem,
     workListSize,
-
     updWorkListTcS, updWorkListTcS_return,
+    runFlatten, emitFlatWork,
 
-    updInertTcS, updInertCans, updInertDicts, updInertIrreds, updInertFunEqs,
-
-    Ct(..), Xi, tyVarsOfCt, tyVarsOfCts,
-    emitInsoluble, emitWorkNC,
-
-    isWanted, isDerived,
-    isGivenCt, isWantedCt, isDerivedCt,
+    -- The TcS monad
+    TcS, runTcS, runTcSWithEvBinds,
+    failTcS, tryTcS, nestTcS, nestImplicTcS, recoverTcS,
 
-    mkGivenLoc,
+    runTcPluginTcS, addUsedRdrNamesTcS, deferTcSForAllEq,
 
-    TcS, runTcS, runTcSWithEvBinds, failTcS, panicTcS, traceTcS, -- Basic functionality
+    -- Tracing etc
+    panicTcS, traceTcS,
     traceFireTcS, bumpStepCountTcS, csTraceTcS,
-    tryTcS, nestTcS, nestImplicTcS, recoverTcS,
     wrapErrTcS, wrapWarnTcS,
-    runTcPluginTcS,
-
-    -- Getting and setting the flattening cache
-    addSolvedDict,
 
-    -- Marking stuff as used
-    addUsedRdrNamesTcS,
-
-    deferTcSForAllEq,
-
-    setEvBind,
+    -- Evidence creation and transformation
     XEvTerm(..),
     Freshness(..), freshGoals, isFresh,
 
@@ -49,40 +34,47 @@ module TcSMonad (
     maybeSym,
 
     newTcEvBinds, newWantedEvVar, newWantedEvVarNC,
+    setWantedTyBind, reportUnifications,
+    setEvBind,
     newEvVar, newGivenEvVar,
     emitNewDerived, emitNewDerivedEq,
     instDFunConstraints,
 
-       -- Creation of evidence variables
-    setWantedTyBind, reportUnifications,
-
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getTcLevel,
     getTcEvBindsMap,
 
-    lookupFlatCache, newFlattenSkolem,            -- Flatten skolems
-
-        -- Deque
-    Deque(..), insertDeque, emptyDeque,
-
         -- Inerts
     InertSet(..), InertCans(..),
+    updInertTcS, updInertCans, updInertDicts, updInertIrreds,
     getNoGivenEqs, setInertCans, getInertEqs, getInertCans,
     emptyInert, getTcSInerts, setTcSInerts,
     getUnsolvedInerts, checkAllSolved,
     splitInertCans, removeInertCts,
     prepareInertsForImplications,
     addInertCan, insertInertItemTcS, insertFunEq,
+    emitInsoluble, emitWorkNC,
     EqualCtList,
-    lookupSolvedDict, extendFlatCache,
 
+    -- Inert CDictCans
     lookupInertDict, findDictsByClass, addDict, addDictsByClass, delDict, partitionDicts,
 
-    findFunEq, findTyEqs,
+    -- Inert CTyEqCans
+    findTyEqs,
+
+    -- Inert solved dictionaries
+    addSolvedDict, lookupSolvedDict,
+
+    -- The flattening cache
+    lookupFlatCache, extendFlatCache, newFlattenSkolem,            -- Flatten skolems
+
+    -- Inert CFunEqCans
+    updInertFunEqs, findFunEq, sizeFunEqMap,
     findFunEqsByTyCon, findFunEqs, partitionFunEqs,
-    sizeFunEqMap,
 
     instDFunType,                              -- Instantiation
+
+    -- MetaTyVars
     newFlexiTcSTy, instFlexiTcS, instFlexiTcSHelperTcS,
     cloneMetaTyVar, demoteUnfilledFmv,
 
@@ -90,8 +82,11 @@ module TcSMonad (
     isFilledMetaTyVar_maybe, isFilledMetaTyVar,
     zonkTyVarsAndFV, zonkTcType, zonkTcTyVar, zonkFlats,
 
-    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
+    -- References
+    newTcRef, readTcRef, updTcRef,
 
+    -- Misc
+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,
     matchFam,
     checkWellStagedDFun,
     pprEq                                    -- Smaller utils, re-exported from TcM
@@ -176,43 +171,62 @@ equalities (wl_eqs) from the rest of the canonical constraints,
 so that it's easier to deal with them first, but the separation
 is not strictly necessary. Notice that non-canonical constraints
 are also parts of the worklist.
--}
-
-data Deque a = DQ [a] [a]   -- Insert in RH field, remove from LH field
-                            -- First to remove is at head of LH field
-
-instance Outputable a => Outputable (Deque a) where
-  ppr q = ppr (dequeList q)
-
-dequeList :: Deque a -> [a]
-dequeList (DQ as bs) = as ++ reverse bs  -- First one to come out at the start
 
-emptyDeque :: Deque a
-emptyDeque = DQ [] []
+Note [The flattening work list]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The "flattening work list", held in the tcs_flat_work field of TcSEnv,
+is a list of CFunEqCans generated during flattening.  The key idea
+is this.  Consider flattening (Eq (F (G Int) (H Bool)):
+  * The flattener recursively calls itself on sub-terms before building
+    the main term, so it will encounter the terms in order
+              G Int
+              H Bool
+              F (G Int) (H Bool)
+    flattening to sub-goals
+              w1: G Int ~ fuv0
+              w2: H Bool ~ fuv1
+              w3: F fuv0 fuv1 ~ fuv2
+
+  * Processing w3 first is BAD, because we can't reduce i t,so it'll
+    get put into the inert set, and later kicked out when w1, w2 are
+    solved.  In Trac #9872 this led to inert sets containing hundreds
+    of suspended calls.
+
+  * So we want to process w1, w2 first.
+
+  * So you might think that we should just use a FIFO deque for the work-list,
+    so that putting adding goals in order w1,w2,w3 would mean we processed
+    w1 first.
+
+  * BUT suppose we have 'type instance G Int = H Char'.  Then processing
+    w1 leads to a new goal
+                w4: H Char ~ fuv0
+    We do NOT want to put that on the far end of a deque!  Instead we want
+    to put it at the *front* of the work-list so that we continue to work
+    on it.
+
+So the work-list structure is this:
+
+  * The wl_funeqs is a LIFO stack; we push new goals (such as w4) on
+    top (extendWorkListFunEq), and take new work from the top
+    (selectWorkItem).
+
+  * When flattening, emitFlatWork pushes new flattening goals (like
+    w1,w2,w3) onto the flattening work list, tcs_flat_work, another
+    push-down stack.
+
+  * When we finish flattening, we *reverse* the tcs_flat_work stack
+    onto the wl_funeqs stack (which brings w1 to the top).
+
+The function runFlatten initialised the tcs_flat_work stack, and reverses
+it onto wl_fun_eqs at the end.
 
-isEmptyDeque :: Deque a -> Bool
-isEmptyDeque (DQ as bs) = null as && null bs
-
-dequeSize :: Deque a -> Int
-dequeSize (DQ as bs) = length as + length bs
-
-insertDeque :: a -> Deque a -> Deque a
-insertDeque b (DQ as bs) = DQ as (b:bs)
-
-appendDeque :: Deque a -> Deque a -> Deque a
-appendDeque (DQ as1 bs1) (DQ as2 bs2) = DQ (as1 ++ reverse bs1 ++ as2) bs2
-
-extractDeque :: Deque a -> Maybe (Deque a, a)
-extractDeque (DQ [] [])     = Nothing
-extractDeque (DQ (a:as) bs) = Just (DQ as bs, a)
-extractDeque (DQ [] bs)     = case reverse bs of
-                                (a:as) -> Just (DQ as [], a)
-                                [] -> panic "extractDeque"
+-}
 
 -- See Note [WorkList priorities]
 data WorkList
   = WL { wl_eqs     :: [Ct]
-       , wl_funeqs  :: Deque Ct
+       , wl_funeqs  :: [Ct]  -- LIFO stack of goals
        , wl_rest    :: [Ct]
        , wl_implics :: Bag Implication  -- See Note [Residual implications]
     }
@@ -221,15 +235,15 @@ appendWorkList :: WorkList -> WorkList -> WorkList
 appendWorkList
     (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1, wl_implics = implics1 })
     (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2, wl_implics = implics2 })
-   = WL { wl_eqs     = eqs1     ++            eqs2
-        , wl_funeqs  = funeqs1  `appendDeque` funeqs2
-        , wl_rest    = rest1    ++            rest2
+   = WL { wl_eqs     = eqs1     ++ eqs2
+        , wl_funeqs  = funeqs1  ++ funeqs2
+        , wl_rest    = rest1    ++ rest2
         , wl_implics = implics1 `unionBags`   implics2 }
 
 
 workListSize :: WorkList -> Int
 workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })
-  = length eqs + dequeSize funeqs + length rest
+  = length eqs + length funeqs + length rest
 
 extendWorkListEq :: Ct -> WorkList -> WorkList
 extendWorkListEq ct wl
@@ -237,7 +251,7 @@ extendWorkListEq ct wl
 
 extendWorkListFunEq :: Ct -> WorkList -> WorkList
 extendWorkListFunEq ct wl
-  = wl { wl_funeqs = insertDeque ct (wl_funeqs wl) }
+  = wl { wl_funeqs = ct : wl_funeqs wl }
 
 extendWorkListNonEq :: Ct -> WorkList -> WorkList
 -- Extension by non equality
@@ -268,20 +282,19 @@ extendWorkListCts cts wl = foldr extendWorkListCt wl cts
 isEmptyWorkList :: WorkList -> Bool
 isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs
                     , wl_rest = rest, wl_implics = implics })
-  = null eqs && null rest && isEmptyDeque funeqs && isEmptyBag implics
+  = null eqs && null rest && null funeqs && isEmptyBag implics
 
 emptyWorkList :: WorkList
 emptyWorkList = WL { wl_eqs  = [], wl_rest = []
-                   , wl_funeqs = emptyDeque, wl_implics = emptyBag }
+                   , wl_funeqs = [], wl_implics = emptyBag }
 
 selectWorkItem :: WorkList -> (Maybe Ct, WorkList)
 selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs, wl_rest = rest })
   = case (eqs,feqs,rest) of
-      (ct:cts,_,_)     -> (Just ct, wl { wl_eqs    = cts })
-      (_,fun_eqs,_)    | Just (fun_eqs', ct) <- extractDeque fun_eqs
-                       -> (Just ct, wl { wl_funeqs = fun_eqs' })
-      (_,_,(ct:cts))   -> (Just ct, wl { wl_rest   = cts })
-      (_,_,_)          -> (Nothing,wl)
+      (ct:cts,_,_) -> (Just ct, wl { wl_eqs    = cts })
+      (_,ct:fes,_) -> (Just ct, wl { wl_funeqs = fes })
+      (_,_,ct:cts) -> (Just ct, wl { wl_rest   = cts })
+      (_,_,_)      -> (Nothing,wl)
 
 -- Pretty printing
 instance Outputable WorkList where
@@ -290,14 +303,43 @@ instance Outputable WorkList where
    = text "WL" <+> (braces $
      vcat [ ppUnless (null eqs) $
             ptext (sLit "Eqs =") <+> vcat (map ppr eqs)
-          , ppUnless (isEmptyDeque feqs) $
-            ptext (sLit "Funeqs =") <+> vcat (map ppr (dequeList feqs))
+          , ppUnless (null feqs) $
+            ptext (sLit "Funeqs =") <+> vcat (map ppr feqs)
           , ppUnless (null rest) $
             ptext (sLit "Non-eqs =") <+> vcat (map ppr rest)
           , ppUnless (isEmptyBag implics) $
             ptext (sLit "Implics =") <+> vcat (map ppr (bagToList implics))
           ])
 
+emitFlatWork :: Ct -> TcS ()
+-- See Note [The flattening work list]
+emitFlatWork ct
+  = TcS $ \env ->
+    do { let flat_ref = tcs_flat_work env
+       ; TcM.updTcRef flat_ref (ct :) }
+
+runFlatten :: TcS a -> TcS a
+-- Run thing_inside (which does flattening), and put all
+-- the work it generates onto the main work list
+-- See Note [The flattening work list]
+runFlatten (TcS thing_inside)
+  = TcS $ \env ->
+    do { let flat_ref = tcs_flat_work env
+       ; old_flats <- TcM.updTcRefX flat_ref (\_ -> [])
+       ; res <- thing_inside env
+       ; new_flats <- TcM.updTcRefX flat_ref (\_ -> old_flats)
+       ; TcM.updTcRef (tcs_worklist env) (add_flats new_flats)
+       ; return res }
+  where
+    add_flats new_flats wl
+      = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) }
+
+    add_funeqs []     wl = wl
+    add_funeqs (f:fs) wl = add_funeqs fs (f:wl)
+      -- add_funeqs fs ws = reverse fs ++ ws
+      -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4]
+      --        = [f3,f2,f1,w1,w2,w3,w4]
+
 {-
 ************************************************************************
 *                                                                      *
@@ -965,14 +1007,14 @@ insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val
 --  = insertFunEq m tc tys ct
 -- insertFunEqCt _ ct = pprPanic "insertFunEqCt" (ppr ct)
 
-partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> (Bag Ct, FunEqMap Ct)
+partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)
 -- Optimise for the case where the predicate is false
 -- partitionFunEqs is called only from kick-out, and kick-out usually
 -- kicks out very few equalities, so we want to optimise for that case
-partitionFunEqs f m = (yeses, foldrBag del m yeses)
+partitionFunEqs f m = (yeses, foldr del m yeses)
   where
-    yeses = foldTcAppMap k m emptyBag
-    k ct yeses | f ct      = yeses `snocBag` ct
+    yeses = foldTcAppMap k m []
+    k ct yeses | f ct      = ct : yeses
                | otherwise = yeses
     del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m
         = delFunEq m tc tys
@@ -1012,8 +1054,13 @@ data TcSEnv
 
       tcs_count    :: IORef Int, -- Global step count
 
-      tcs_inerts   :: IORef InertSet, -- Current inert set
-      tcs_worklist :: IORef WorkList  -- Current worklist
+      tcs_inerts    :: IORef InertSet, -- Current inert set
+
+      -- The main work-list and the flattening worklist
+      -- See Note [Work list priorities] and
+      --     Note [The flattening work list]
+      tcs_worklist  :: IORef WorkList, -- Current worklist
+      tcs_flat_work :: IORef [Ct]      -- Flattening worklist
     }
 
 ---------------
@@ -1113,12 +1160,14 @@ runTcSWithEvBinds ev_binds_var tcs
        ; step_count <- TcM.newTcRef 0
        ; inert_var <- TcM.newTcRef is
        ; wl_var <- TcM.newTcRef emptyWorkList
+       ; fw_var <- TcM.newTcRef (panic "Flat work list")
 
-       ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
-                          , tcs_unified  = unified_var
-                          , tcs_count    = step_count
-                          , tcs_inerts   = inert_var
-                          , tcs_worklist = wl_var }
+       ; let env = TcSEnv { tcs_ev_binds  = ev_binds_var
+                          , tcs_unified   = unified_var
+                          , tcs_count     = step_count
+                          , tcs_inerts    = inert_var
+                          , tcs_worklist  = wl_var
+                          , tcs_flat_work = fw_var }
 
              -- Run the computation
        ; res <- unTcS tcs env
@@ -1166,11 +1215,13 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
                                    -- See Note [Do not inherit the flat cache]
        ; new_inert_var <- TcM.newTcRef nest_inert
        ; new_wl_var    <- TcM.newTcRef emptyWorkList
+       ; new_fw_var    <- TcM.newTcRef (panic "Flat work list")
        ; let nest_env = TcSEnv { tcs_ev_binds    = ref
                                , tcs_unified     = unified_var
                                , tcs_count       = count
                                , tcs_inerts      = new_inert_var
-                               , tcs_worklist    = new_wl_var }
+                               , tcs_worklist    = new_wl_var
+                               , tcs_flat_work   = new_fw_var }
        ; res <- TcM.setTcLevel inner_tclvl $
                 thing_inside nest_env
 
@@ -1300,6 +1351,15 @@ emitInsoluble ct
         already_there = not (isWantedCt ct) && anyBag (tcEqType this_pred . ctPred) old_insols
              -- See Note [Do not add duplicate derived insolubles]
 
+newTcRef :: a -> TcS (TcRef a)
+newTcRef x = wrapTcS (TcM.newTcRef x)
+
+readTcRef :: TcRef a -> TcS a
+readTcRef ref = wrapTcS (TcM.readTcRef ref)
+
+updTcRef :: TcRef a -> (a->a) -> TcS ()
+updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)
+
 getTcEvBinds :: TcS EvBindsVar
 getTcEvBinds = TcS (return . tcs_ev_binds)
 
index 5a0443b..6a566f4 100644 (file)
@@ -1,11 +1,11 @@
-
-NoMatchErr.hs:19:7:
-    Couldn't match type ‘Memo d0’ with ‘Memo d’
-    NB: ‘Memo’ is a type function, and may not be injective
-    The type variable ‘d0’ is ambiguous
-    Expected type: Memo d a -> Memo d a
-      Actual type: Memo d0 a -> Memo d0 a
-    In the ambiguity check for the type signature for ‘f’:
-      f :: forall d a. Fun d => Memo d a -> Memo d a
-    To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
-    In the type signature for ‘f’: f :: (Fun d) => Memo d a -> Memo d a
+\r
+NoMatchErr.hs:19:7:\r
+    Couldn't match type ‘Memo d’ with ‘Memo d0’\r
+    NB: ‘Memo’ is a type function, and may not be injective\r
+    The type variable ‘d0’ is ambiguous\r
+    Expected type: Memo d a -> Memo d a\r
+      Actual type: Memo d0 a -> Memo d0 a\r
+    In the ambiguity check for the type signature for ‘f’:\r
+      f :: forall d a. Fun d => Memo d a -> Memo d a\r
+    To defer the ambiguity check to use sites, enable AllowAmbiguousTypes\r
+    In the type signature for ‘f’: f :: (Fun d) => Memo d a -> Memo d a\r
index 256fa30..6c52308 100644 (file)
@@ -1,22 +1,11 @@
-
-T2544.hs:15:18:
-    Couldn't match type ‘IxMap i0’ with ‘IxMap l’
-    NB: ‘IxMap’ is a type function, and may not be injective
-    The type variable ‘i0’ is ambiguous
-    Expected type: IxMap l [Int]
-      Actual type: IxMap i0 [Int]
-    Relevant bindings include
-      empty :: IxMap (l :|: r) [Int] (bound at T2544.hs:15:4)
-    In the first argument of ‘BiApp’, namely ‘empty’
-    In the expression: BiApp empty empty
-
-T2544.hs:15:24:
-    Couldn't match type ‘IxMap i1’ with ‘IxMap r’
-    NB: ‘IxMap’ is a type function, and may not be injective
-    The type variable ‘i1’ is ambiguous
-    Expected type: IxMap r [Int]
-      Actual type: IxMap i1 [Int]
-    Relevant bindings include
-      empty :: IxMap (l :|: r) [Int] (bound at T2544.hs:15:4)
-    In the second argument of ‘BiApp’, namely ‘empty’
-    In the expression: BiApp empty empty
+\r
+T2544.hs:15:12:\r
+    Couldn't match type ‘IxMap l’ with ‘IxMap i0’\r
+    NB: ‘IxMap’ is a type function, and may not be injective\r
+    The type variable ‘i0’ is ambiguous\r
+    Expected type: IxMap (l :|: r) [Int]\r
+      Actual type: BiApp (IxMap i0) (IxMap i1) [Int]\r
+    Relevant bindings include\r
+      empty :: IxMap (l :|: r) [Int] (bound at T2544.hs:15:4)\r
+    In the expression: BiApp empty empty\r
+    In an equation for ‘empty’: empty = BiApp empty empty\r
index 2cb51a9..d6daef1 100644 (file)
@@ -1,8 +1,8 @@
-
-T2627b.hs:20:24:
-    Occurs check: cannot construct the infinite type:
-      a0 ~ Dual (Dual a0)
-    The type variable ‘a0’ is ambiguous
-    In the expression: conn undefined undefined
-    In an equation for ‘conn’:
-        conn (Rd k) (Wr a r) = conn undefined undefined
+\r
+T2627b.hs:20:24:\r
+    Occurs check: cannot construct the infinite type:\r
+      b0 ~ Dual (Dual b0)\r
+    The type variable ‘b0’ is ambiguous\r
+    In the expression: conn undefined undefined\r
+    In an equation for ‘conn’:\r
+        conn (Rd k) (Wr a r) = conn undefined undefined\r
index 746f996..8bc26d6 100644 (file)
@@ -11,28 +11,34 @@ hang = Just ()
 {- Ambiguity check\r
 \r
  [G] Foo e ~ Maybe e\r
- [W] Foo e ~ Foo ee\r
- [W] Foo ee ~ Maybe ee)\r
+ [W] Foo e ~ Foo e0\r
+ [W] Foo e0 ~ Maybe e0\r
 ---\r
  [G] Foo e ~ fsk\r
  [G] fsk ~ Maybe e\r
 \r
  [W] Foo e ~ fmv1\r
- [W] Foo ee ~ fmv2\r
+ [W] Foo e0 ~ fmv2\r
  [W] fmv1 ~ fmv2\r
- [W] fmv2 ~ Maybe ee\r
+ [W] fmv2 ~ Maybe e0\r
 \r
 --->   fmv1 := fsk\r
- [W] Foo ee ~ fmv2\r
+ [G] Foo e ~ fsk\r
+ [G] fsk ~ Maybe e\r
+\r
+ [W] Foo e0 ~ fmv2\r
  [W] fsk ~ fmv2\r
- [W] fmv2 ~ Maybe ee\r
+ [W] fmv2 ~ Maybe e0\r
 \r
 --->\r
- [W] Foo ee ~ fmv2\r
+ [G] Foo e ~ fsk\r
+ [G] fsk ~ Maybe e\r
+\r
+ [W] Foo e0 ~ fmv2\r
  [W] fmv2 ~ Maybe e\r
- [W] fmv2 ~ Maybe ee\r
+ [W] fmv2 ~ Maybe e0\r
 \r
-Now the question is whether we get a derived equality e ~ ee.  Currently\r
+Now the question is whether we get a derived equality e ~ e0.  Currently\r
 we don't, but we easily could.  But then we'd need to be careful not to\r
 report insoluble Int ~ Bool if we had\r
    F a ~ Int, F a ~ Bool\r
index 9918821..a2d4415 100644 (file)
@@ -1,12 +1,14 @@
-
-T4093a.hs:7:9:
-    Could not deduce (Foo e0 ~ Maybe e0)
-    from the context (Foo e ~ Maybe e)
-      bound by the type signature for hang :: (Foo e ~ Maybe e) => Foo e
-      at T4093a.hs:7:9-34
-    The type variable ‘e0’ is ambiguous
-    In the ambiguity check for the type signature for ‘hang’:
-      hang :: forall e. (Foo e ~ Maybe e) => Foo e
-    To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
-    In the type signature for ‘hang’:
-      hang :: (Foo e ~ Maybe e) => Foo e
+\r
+T4093a.hs:7:9:\r
+    Could not deduce (Foo e0 ~ Maybe e)\r
+    from the context (Foo e ~ Maybe e)\r
+      bound by the type signature for hang :: (Foo e ~ Maybe e) => Foo e\r
+      at T4093a.hs:7:9-34\r
+    The type variable ‘e0’ is ambiguous\r
+    Expected type: Foo e\r
+      Actual type: Foo e0\r
+    In the ambiguity check for the type signature for ‘hang’:\r
+      hang :: forall e. (Foo e ~ Maybe e) => Foo e\r
+    To defer the ambiguity check to use sites, enable AllowAmbiguousTypes\r
+    In the type signature for ‘hang’:\r
+      hang :: (Foo e ~ Maybe e) => Foo e\r
index 9441b38..4ff0597 100644 (file)
@@ -1,7 +1,7 @@
-
-T7010.hs:53:27:
-    Couldn't match type ‘IO Float’ with ‘Serial (IO Float)’
-    Expected type: (Float, ValueTuple Vector)
-      Actual type: (Float, ValueTuple Float)
-    In the first argument of ‘withArgs’, namely ‘plug’
-    In the expression: withArgs plug
+\r
+T7010.hs:53:27:\r
+    Couldn't match type ‘Serial (IO Float)’ with ‘IO Float’\r
+    Expected type: (Float, ValueTuple Vector)\r
+      Actual type: (Float, ValueTuple Float)\r
+    In the first argument of ‘withArgs’, namely ‘plug’\r
+    In the expression: withArgs plug\r
index 499e6b4..9a9486e 100644 (file)
@@ -1,13 +1,13 @@
-
-T9036.hs:17:17:
-    Couldn't match type ‘GetMonad t0’ with ‘GetMonad t’
-    NB: ‘GetMonad’ is a type function, and may not be injective
-    The type variable ‘t0’ is ambiguous
-    Expected type: Maybe (GetMonad t after) -> Curried t [t]
-      Actual type: Maybe (GetMonad t0 after) -> Curried t0 [t0]
-    In the ambiguity check for the type signature for ‘simpleLogger’:
-      simpleLogger :: forall t after.
-                      Maybe (GetMonad t after) -> Curried t [t]
-    To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
-    In the type signature for ‘simpleLogger’:
-      simpleLogger :: Maybe (GetMonad t after) -> t `Curried` [t]
+\r
+T9036.hs:17:17:\r
+    Couldn't match type ‘Curried t [t]’ with ‘Curried t0 [t0]’\r
+    NB: ‘Curried’ is a type function, and may not be injective\r
+    The type variable ‘t0’ is ambiguous\r
+    Expected type: Maybe (GetMonad t after) -> Curried t [t]\r
+      Actual type: Maybe (GetMonad t0 after) -> Curried t0 [t0]\r
+    In the ambiguity check for the type signature for ‘simpleLogger’:\r
+      simpleLogger :: forall t after.\r
+                      Maybe (GetMonad t after) -> Curried t [t]\r
+    To defer the ambiguity check to use sites, enable AllowAmbiguousTypes\r
+    In the type signature for ‘simpleLogger’:\r
+      simpleLogger :: Maybe (GetMonad t after) -> t `Curried` [t]\r
index 1261408..bebaf0d 100644 (file)
@@ -1,53 +1,53 @@
-
-FrozenErrorTests.hs:12:12:
-    Couldn't match type ‘Int’ with ‘Bool’
-    Inaccessible code in
-      a pattern with constructor
-        MkT3 :: forall a. (a ~ Bool) => T a,
-      in a case alternative
-    In the pattern: MkT3
-    In a case alternative: MkT3 -> ()
-    In the expression: case x of { MkT3 -> () }
-
-FrozenErrorTests.hs:26:9:
-    Occurs check: cannot construct the infinite type: a ~ [a]
-    Expected type: [a]
-      Actual type: F a Bool
-    Relevant bindings include
-      test1 :: a (bound at FrozenErrorTests.hs:26:1)
-    In the expression: goo1 False undefined
-    In an equation for ‘test1’: test1 = goo1 False undefined
-
-FrozenErrorTests.hs:29:15:
-    Couldn't match type ‘[Int]’ with ‘Int’
-    Expected type: [[Int]]
-      Actual type: F [Int] Bool
-    In the first argument of ‘goo2’, namely ‘(goo1 False undefined)’
-    In the expression: goo2 (goo1 False undefined)
-    In an equation for ‘test2’: test2 = goo2 (goo1 False undefined)
-
-FrozenErrorTests.hs:30:9:
-    Couldn't match type ‘[Int]’ with ‘Int’
-    Expected type: [[Int]]
-      Actual type: F [Int] Bool
-    In the expression: goo1 False (goo2 undefined)
-    In an equation for ‘test3’: test3 = goo1 False (goo2 undefined)
-
-FrozenErrorTests.hs:45:15:
-    Couldn't match type ‘T2 c c’ with ‘M (T2 (T2 c c) c)’
-    Expected type: T2 (M (T2 (T2 c c) c)) (T2 (T2 c c) c)
-      Actual type: F (T2 (T2 c c) c) Bool
-    Relevant bindings include
-      test4 :: T2 (T2 c c) c (bound at FrozenErrorTests.hs:45:1)
-    In the first argument of ‘goo4’, namely ‘(goo3 False undefined)’
-    In the expression: goo4 (goo3 False undefined)
-    In an equation for ‘test4’: test4 = goo4 (goo3 False undefined)
-
-FrozenErrorTests.hs:46:9:
-    Couldn't match type ‘T2 c c’ with ‘M (T2 (T2 c c) c)’
-    Expected type: T2 (M (T2 (T2 c c) c)) (T2 (T2 c c) c)
-      Actual type: F (T2 (T2 c c) c) Bool
-    Relevant bindings include
-      test5 :: T2 (T2 c c) c (bound at FrozenErrorTests.hs:46:1)
-    In the expression: goo3 False (goo4 undefined)
-    In an equation for ‘test5’: test5 = goo3 False (goo4 undefined)
+\r
+FrozenErrorTests.hs:12:12:\r
+    Couldn't match type ‘Int’ with ‘Bool’\r
+    Inaccessible code in\r
+      a pattern with constructor\r
+        MkT3 :: forall a. (a ~ Bool) => T a,\r
+      in a case alternative\r
+    In the pattern: MkT3\r
+    In a case alternative: MkT3 -> ()\r
+    In the expression: case x of { MkT3 -> () }\r
+\r
+FrozenErrorTests.hs:26:9:\r
+    Occurs check: cannot construct the infinite type: a ~ [a]\r
+    Expected type: [a]\r
+      Actual type: F a Bool\r
+    Relevant bindings include\r
+      test1 :: a (bound at FrozenErrorTests.hs:26:1)\r
+    In the expression: goo1 False undefined\r
+    In an equation for ‘test1’: test1 = goo1 False undefined\r
+\r
+FrozenErrorTests.hs:29:15:\r
+    Couldn't match type ‘Int’ with ‘[Int]’\r
+    Expected type: [[Int]]\r
+      Actual type: F [Int] Bool\r
+    In the first argument of ‘goo2’, namely ‘(goo1 False undefined)’\r
+    In the expression: goo2 (goo1 False undefined)\r
+    In an equation for ‘test2’: test2 = goo2 (goo1 False undefined)\r
+\r
+FrozenErrorTests.hs:30:9:\r
+    Couldn't match type ‘[Int]’ with ‘Int’\r
+    Expected type: [[Int]]\r
+      Actual type: F [Int] Bool\r
+    In the expression: goo1 False (goo2 undefined)\r
+    In an equation for ‘test3’: test3 = goo1 False (goo2 undefined)\r
+\r
+FrozenErrorTests.hs:45:15:\r
+    Couldn't match type ‘T2 c c’ with ‘M (T2 (T2 c c) c)’\r
+    Expected type: T2 (M (T2 (T2 c c) c)) (T2 (T2 c c) c)\r
+      Actual type: F (T2 (T2 c c) c) Bool\r
+    Relevant bindings include\r
+      test4 :: T2 (T2 c c) c (bound at FrozenErrorTests.hs:45:1)\r
+    In the first argument of ‘goo4’, namely ‘(goo3 False undefined)’\r
+    In the expression: goo4 (goo3 False undefined)\r
+    In an equation for ‘test4’: test4 = goo4 (goo3 False undefined)\r
+\r
+FrozenErrorTests.hs:46:9:\r
+    Couldn't match type ‘T2 c c’ with ‘M (T2 (T2 c c) c)’\r
+    Expected type: T2 (M (T2 (T2 c c) c)) (T2 (T2 c c) c)\r
+      Actual type: F (T2 (T2 c c) c) Bool\r
+    Relevant bindings include\r
+      test5 :: T2 (T2 c c) c (bound at FrozenErrorTests.hs:46:1)\r
+    In the expression: goo3 False (goo4 undefined)\r
+    In an equation for ‘test5’: test5 = goo3 False (goo4 undefined)\r
index 63868d0..21145ca 100644 (file)
@@ -1,17 +1,20 @@
-
-T5853.hs:15:52:
-    Could not deduce (Subst (Subst fa b) a ~ Subst fa a)
-    from the context (F fa,
-                      Elem (Subst fa b) ~ b,
-                      Subst (Subst fa b) (Elem fa) ~ fa,
-                      F (Subst fa a),
-                      Elem (Subst fa a) ~ a,
-                      Subst (Subst fa a) (Elem fa) ~ fa)
-      bound by the RULE "map/map" at T5853.hs:15:2-57
-    NB: ‘Subst’ is a type function, and may not be injective
-    Relevant bindings include
-      f :: Elem fa -> b (bound at T5853.hs:15:19)
-      g :: a -> Elem fa (bound at T5853.hs:15:21)
-      xs :: Subst fa a (bound at T5853.hs:15:23)
-    In the expression: (f . g) <$> xs
-    When checking the transformation rule "map/map"
+\r
+T5853.hs:15:52:\r
+    Could not deduce (fb ~ Subst (Subst fb a) (Elem fb))\r
+    from the context (F (Subst (Subst fb a) b),\r
+                      Elem (Subst (Subst fb a) b) ~ b,\r
+                      Subst (Subst (Subst fb a) b) (Elem fb) ~ fb,\r
+                      Subst fb b ~ Subst (Subst fb a) b,\r
+                      F (Subst fb a),\r
+                      Elem (Subst fb a) ~ a,\r
+                      Elem (Subst (Subst fb a) b) ~ b,\r
+                      Subst (Subst (Subst fb a) b) a ~ Subst fb a)\r
+      bound by the RULE "map/map" at T5853.hs:15:2-57\r
+      ‘fb’ is a rigid type variable bound by\r
+           the RULE "map/map" at T5853.hs:15:2\r
+    Relevant bindings include\r
+      f :: b -> Elem fb (bound at T5853.hs:15:19)\r
+      g :: a -> b (bound at T5853.hs:15:21)\r
+      xs :: Subst fb a (bound at T5853.hs:15:23)\r
+    In the expression: (f . g) <$> xs\r
+    When checking the transformation rule "map/map"\r