Add -ftype-function-stack to set type function stack depth

6 files changed, 40 insertions, 14 deletions

diff --git a/compiler/main/Constants.lhs b/compiler/main/Constants.lhs
index 497bae500e..a891336e53 100644
--- a/compiler/main/Constants.lhs
+++ b/compiler/main/Constants.lhs
@@ -18,8 +18,11 @@ mAX_TUPLE_SIZE = 62 -- Should really match the number
                     -- of decls in Data.Tuple
 
 mAX_CONTEXT_REDUCTION_DEPTH :: Int
-mAX_CONTEXT_REDUCTION_DEPTH = 200
-  -- Increase to 200; see Trac #5395
+mAX_CONTEXT_REDUCTION_DEPTH = 20
+
+mAX_TYPE_FUNCTION_REDUCTION_DEPTH :: Int
+mAX_TYPE_FUNCTION_REDUCTION_DEPTH = 200
+  -- Needs to be much higher than mAX_CONTEXT_REDUCTION_DEPTH; see Trac #5395
 
 wORD64_SIZE :: Int
 wORD64_SIZE = 8
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 53e5297432..7c07a361b9 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -623,6 +623,7 @@ data DynFlags = DynFlags {
   mainModIs             :: Module,
   mainFunIs             :: Maybe String,
   ctxtStkDepth          :: Int,         -- ^ Typechecker context stack depth
+  tyFunStkDepth         :: Int,         -- ^ Typechecker type function stack depth
 
   thisPackage           :: PackageId,   -- ^ name of package currently being compiled
 
@@ -1326,6 +1327,7 @@ defaultDynFlags mySettings =
         mainModIs               = mAIN,
         mainFunIs               = Nothing,
         ctxtStkDepth            = mAX_CONTEXT_REDUCTION_DEPTH,
+        tyFunStkDepth           = mAX_TYPE_FUNCTION_REDUCTION_DEPTH,
 
         thisPackage             = mainPackageId,
 
@@ -2397,6 +2399,7 @@ dynamic_flags = [
   , Flag "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing }))
   , Flag "frule-check"                 (sepArg (\s d -> d{ ruleCheck = Just s }))
   , Flag "fcontext-stack"              (intSuffix (\n d -> d{ ctxtStkDepth = n }))
+  , Flag "ftype-function-depth"        (intSuffix (\n d -> d{ tyFunStkDepth = n }))
   , Flag "fstrictness-before"          (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d }))
   , Flag "ffloat-lam-args"             (intSuffix (\n d -> d{ floatLamArgs = Just n }))
   , Flag "ffloat-all-lams"             (noArg (\d -> d{ floatLamArgs = Nothing }))
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 627bc3ebb3..63e22f63fd 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -1403,12 +1403,17 @@ solverDepthErrorTcS cnt ct
        ; env0 <- tcInitTidyEnv
        ; let tidy_env  = tidyFreeTyVars env0 (tyVarsOfType pred)
              tidy_pred = tidyType tidy_env pred
-       ; failWithTcM (tidy_env, hang msg 2 (ppr tidy_pred)) }
+       ; failWithTcM (tidy_env, hang (msg cnt) 2 (ppr tidy_pred)) }
   where
     loc   = cc_loc ct
     depth = ctLocDepth loc
-    msg = vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int (subGoalCounterValue cnt depth)
-               , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
+    value = subGoalCounterValue cnt depth
+    msg CountConstraints =
+        vcat [ ptext (sLit "Context reduction stack overflow; size =") <+> int value
+             , ptext (sLit "Use -fcontext-stack=N to increase stack size to N") ]
+    msg CountTyFunApps =
+        vcat [ ptext (sLit "Type function application stack overflow; size =") <+> int value
+             , ptext (sLit "Use -ftype-function-depth=N to increase stack size to N") ]
 \end{code}
 
 %************************************************************************
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 82ffebf8d6..8b9e758d29 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -116,7 +116,7 @@ solveInteract cts
   = {-# SCC "solveInteract" #-}
     withWorkList cts $
     do { dyn_flags <- getDynFlags
-       ; solve_loop (ctxtStkDepth dyn_flags) }
+       ; solve_loop (maxSubGoalDepth dyn_flags) }
   where
     solve_loop max_depth
       = {-# SCC "solve_loop" #-}
@@ -140,7 +140,7 @@ data SelectWorkItem
                               -- must stop
        | NextWorkItem Ct      -- More work left, here's the next item to look at
 
-selectNextWorkItem :: Int -- Max depth allowed
+selectNextWorkItem :: SubGoalDepth -- Max depth allowed
                    -> TcS SelectWorkItem
 selectNextWorkItem max_depth
   = updWorkListTcS_return pick_next
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 0e5ea89be2..b58d5ef6f8 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -56,8 +56,8 @@ module TcRnTypes(
 
         Implication(..),
         SubGoalCounter(..),
-        SubGoalDepth, initialSubGoalDepth, bumpSubGoalDepth,
-        subGoalCounterValue, subGoalDepthExceeded,
+        SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,
+        bumpSubGoalDepth, subGoalCounterValue, subGoalDepthExceeded,
         CtLoc(..), ctLocSpan, ctLocEnv, ctLocOrigin,
         ctLocDepth, bumpCtLocDepth,
         setCtLocOrigin, setCtLocEnv,
@@ -1513,6 +1513,13 @@ Each counter starts at zero and increases.
     [W] d{8} : Int ~ a
   and remembered as having depth 8.
 
+  Again, without UndecidableInstances, this counter is bounded, but without it
+  can resolve things ad infinitum. Hence there is a maximum level. But we use a
+  different maximum, as we expect possibly many more type function reductions
+  in sensible programs than type class constraints.
+
+  The flag -ftype-function-depth=n fixes the maximium level.
+
 \begin{code}
 data SubGoalCounter = CountConstraints | CountTyFunApps
 
@@ -1530,6 +1537,8 @@ instance Outputable SubGoalDepth where
 initialSubGoalDepth :: SubGoalDepth
 initialSubGoalDepth = SubGoalDepth 0 0
 
+maxSubGoalDepth :: DynFlags -> SubGoalDepth
+maxSubGoalDepth dflags = SubGoalDepth (ctxtStkDepth dflags) (tyFunStkDepth dflags)
 
 bumpSubGoalDepth :: SubGoalCounter -> SubGoalDepth -> SubGoalDepth
 bumpSubGoalDepth CountConstraints (SubGoalDepth c f) = SubGoalDepth (c+1) f
@@ -1539,11 +1548,11 @@ subGoalCounterValue :: SubGoalCounter -> SubGoalDepth -> Int
 subGoalCounterValue CountConstraints (SubGoalDepth c _) = c
 subGoalCounterValue CountTyFunApps   (SubGoalDepth _ f) = f
 
-subGoalDepthExceeded :: Int -> SubGoalDepth -> Maybe SubGoalCounter
-subGoalDepthExceeded max_depth (SubGoalDepth c f)
-        | c > max_depth = Just CountConstraints
-        | f > max_depth = Just CountTyFunApps
-        | otherwise     = Nothing
+subGoalDepthExceeded :: SubGoalDepth -> SubGoalDepth -> Maybe SubGoalCounter
+subGoalDepthExceeded (SubGoalDepth mc mf) (SubGoalDepth c f)
+        | c > mc    = Just CountConstraints
+        | f > mf    = Just CountTyFunApps
+        | otherwise = Nothing
 \end{code}
 
 
diff --git a/docs/users_guide/flags.xml b/docs/users_guide/flags.xml
index d5f4b8bd2e..72ef91ed82 100644
--- a/docs/users_guide/flags.xml
+++ b/docs/users_guide/flags.xml
@@ -723,6 +723,12 @@
             <entry></entry>
           </row>
           <row>
+            <entry><option>-ftype-function-depth=N</option><replaceable>n</replaceable></entry>
+            <entry>set the <link linkend="type-families">limit for type function reductions</link>. Default is 200.</entry>
+            <entry>dynamic</entry>
+            <entry></entry>
+          </row>
+          <row>
             <entry><option>-XAllowAmbiguousTypes</option></entry>
             <entry>Allow the user to write <link linkend="ambiguity">ambiguous types</link>,
                    and the type inference engine to infer them.