[commit: ghc] master: Make SubGoalDepth a type of its own (e42ddfe)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/e42ddfe17c92d4c4e446b9b88a4ab440370a0749/ghc

>---------------------------------------------------------------

commit e42ddfe17c92d4c4e446b9b88a4ab440370a0749
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Nov 20 09:24:27 2013 +0000

    Make SubGoalDepth a type of its own
    
    In preparation of counting type function applications and constraint
    resolving separately.


>---------------------------------------------------------------

e42ddfe17c92d4c4e446b9b88a4ab440370a0749
 compiler/typecheck/TcErrors.lhs   |    2 +-
 compiler/typecheck/TcInteract.lhs |    4 ++--
 compiler/typecheck/TcRnMonad.lhs  |    4 +++-
 compiler/typecheck/TcRnTypes.lhs  |   29 ++++++++++++++++++++++-------
 compiler/typecheck/TcSMonad.lhs   |    2 +-
 5 files changed, 29 insertions(+), 12 deletions(-)

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 3bf76b0..e348401 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -1407,7 +1407,7 @@ solverDepthErrorTcS ct
   where
     loc   = cc_loc ct
     depth = ctLocDepth loc
-    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int depth
+    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> ppr depth
                , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
 \end{code}
 
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 3e434ab..f0e90dd 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -138,7 +138,7 @@ data SelectWorkItem
                               -- the max subgoal depth and we must stop
        | NextWorkItem Ct      -- More work left, here's the next item to look at
 
-selectNextWorkItem :: SubGoalDepth -- Max depth allowed
+selectNextWorkItem :: Int -- Max depth allowed
                    -> TcS SelectWorkItem
 selectNextWorkItem max_depth
   = updWorkListTcS_return pick_next
@@ -149,7 +149,7 @@ selectNextWorkItem max_depth
           (Nothing,_)
               -> (NoWorkRemaining,wl)           -- No more work
           (Just ct, new_wl)
-              | ctLocDepth (cc_loc ct) > max_depth  -- Depth exceeded
+              | subGoalDepthExceeded max_depth (ctLocDepth (cc_loc ct)) -- Depth exceeded
               -> (MaxDepthExceeded ct,new_wl)
           (Just ct, new_wl)
               -> (NextWorkItem ct, new_wl)      -- New workitem and worklist
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index e35464c..cf8298f 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -880,7 +880,9 @@ popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })
 getCtLoc :: CtOrigin -> TcM CtLoc
 getCtLoc origin
   = do { env <- getLclEnv 
-       ; return (CtLoc { ctl_origin = origin, ctl_env =  env, ctl_depth = 0 }) }
+       ; return (CtLoc { ctl_origin = origin
+                       , ctl_env = env
+                       , ctl_depth = initialSubGoalDepth }) }
 
 setCtLoc :: CtLoc -> TcM a -> TcM a
 -- Set the SrcSpan and error context from the CtLoc
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index d71c300..7699b22 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -48,14 +48,15 @@ module TcRnTypes(
         isCDictCan_Maybe, isCFunEqCan_maybe,
         isCIrredEvCan, isCNonCanonical, isWantedCt, isDerivedCt,
         isGivenCt, isHoleCt,
-        ctEvidence,
-        SubGoalDepth, mkNonCanonical, mkNonCanonicalCt,
+        ctEvidence, mkNonCanonical, mkNonCanonicalCt,
         ctPred, ctEvPred, ctEvTerm, ctEvId,
 
         WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,
         andWC, unionsWC, addFlats, addImplics, mkFlatWC, addInsols,
 
         Implication(..),
+        SubGoalDepth, initialSubGoalDepth, bumpSubGoalDepth,
+        subGoalDepthExceeded,
         CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin,
         ctLocDepth, bumpCtLocDepth,
         setCtLocOrigin, setCtLocEnv,
@@ -1493,14 +1494,28 @@ data CtLoc = CtLoc { ctl_origin :: CtOrigin
   --    context:          tcl_ctxt  :: [ErrCtxt]
   --    binder stack:     tcl_bndrs :: [TcIdBinders]
 
-type SubGoalDepth = Int -- An ever increasing number used to restrict
-                        -- simplifier iterations. Bounded by -fcontext-stack.
-                        -- See Note [WorkList]
+newtype SubGoalDepth = SubGoalDepth Int
+ -- An ever increasing number used to restrict
+ -- simplifier iterations. Bounded by -fcontext-stack.
+ -- See Note [WorkList]
+
+instance Outputable SubGoalDepth where
+ ppr (SubGoalDepth n) = int n
+
+initialSubGoalDepth :: SubGoalDepth
+initialSubGoalDepth = SubGoalDepth 0
+
+bumpSubGoalDepth :: SubGoalDepth -> SubGoalDepth
+bumpSubGoalDepth (SubGoalDepth n) = SubGoalDepth (n+1)
+
+subGoalDepthExceeded :: Int -> SubGoalDepth -> Bool
+subGoalDepthExceeded max_depth (SubGoalDepth d) = d > max_depth
+
 
 mkGivenLoc :: SkolemInfo -> TcLclEnv -> CtLoc
 mkGivenLoc skol_info env = CtLoc { ctl_origin = GivenOrigin skol_info
                                  , ctl_env = env
-                                 , ctl_depth = 0 }
+                                 , ctl_depth = initialSubGoalDepth }
 
 ctLocEnv :: CtLoc -> TcLclEnv
 ctLocEnv = ctl_env
@@ -1515,7 +1530,7 @@ ctLocSpan :: CtLoc -> SrcSpan
 ctLocSpan (CtLoc { ctl_env = lcl}) = tcl_loc lcl
 
 bumpCtLocDepth :: CtLoc -> CtLoc
-bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = d+1 }
+bumpCtLocDepth loc@(CtLoc { ctl_depth = d }) = loc { ctl_depth = bumpSubGoalDepth d }
 
 setCtLocOrigin :: CtLoc -> CtOrigin -> CtLoc
 setCtLocOrigin ctl orig = ctl { ctl_origin = orig }
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index d4e737d..d2b9ea3 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -1034,7 +1034,7 @@ traceFireTcS ct doc
     do { dflags <- getDynFlags
        ; when (dopt Opt_D_dump_cs_trace dflags && traceLevel dflags >= 1) $
     do { n <- TcM.readTcRef (tcs_count env)
-       ; let msg = int n <> brackets (int (ctLocDepth (cc_loc ct)))
+       ; let msg = int n <> brackets (ppr (ctLocDepth (cc_loc ct)))
                    <+> ppr (ctEvidence ct) <> colon <+> doc
        ; TcM.debugDumpTcRn msg } }