{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Check for recursive type constructors.

-}



module GHC.Core.TyCon.RecWalk (

        -- * Recursion breaking
        RecTcChecker, initRecTc, defaultRecTcMaxBound,
        setRecTcMaxBound, checkRecTc

    ) where

import GHC.Prelude

import GHC.Core.TyCon
import GHC.Core.TyCon.Env
import GHC.Utils.Outputable

{-
************************************************************************
*                                                                      *
           Walking over recursive TyCons
*                                                                      *
************************************************************************

Note [Expanding newtypes and products]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When expanding a type to expose a data-type constructor, we need to be
careful about newtypes, lest we fall into an infinite loop. Here are
the key examples:

  newtype Id  x = MkId x
  newtype Fix f = MkFix (f (Fix f))
  newtype T     = MkT (T -> T)

  Type           Expansion
 --------------------------
  T              T -> T
  Fix Maybe      Maybe (Fix Maybe)
  Id (Id Int)    Int
  Fix Id         NO NO NO

Notice that
 * We can expand T, even though it's recursive.
 * We can expand Id (Id Int), even though the Id shows up
   twice at the outer level, because Id is non-recursive

So, when expanding, we keep track of when we've seen a recursive
newtype at outermost level; and bail out if we see it again.

We sometimes want to do the same for product types, so that the
strictness analyser doesn't unbox infinitely deeply.

More precisely, we keep a *count* of how many times we've seen it.
This is to account for
   data instance T (a,b) = MkT (T a) (T b)
Then (#10482) if we have a type like
        T (Int,(Int,(Int,(Int,Int))))
we can still unbox deeply enough during strictness analysis.
We have to treat T as potentially recursive, but it's still
good to be able to unwrap multiple layers.

The function that manages all this is checkRecTc.
-}

data RecTcChecker = RC !Int (TyConEnv Int)
  -- The upper bound, and the number of times
  -- we have encountered each TyCon

instance Outputable RecTcChecker where
  ppr :: RecTcChecker -> SDoc
ppr (RC Int
n TyConEnv Int
env) = String -> SDoc
text String
"RC:" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n SDoc -> SDoc -> SDoc
<+> TyConEnv Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyConEnv Int
env

-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.
initRecTc :: RecTcChecker
initRecTc :: RecTcChecker
initRecTc = Int -> TyConEnv Int -> RecTcChecker
RC Int
defaultRecTcMaxBound TyConEnv Int
forall a. TyConEnv a
emptyTyConEnv

-- | The default upper bound (100) for the number of times a 'RecTcChecker' is
-- allowed to encounter each 'TyCon'.
defaultRecTcMaxBound :: Int
defaultRecTcMaxBound :: Int
defaultRecTcMaxBound = Int
100
-- Should we have a flag for this?

-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed
-- to encounter each 'TyCon'.
setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker
setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker
setRecTcMaxBound Int
new_bound (RC Int
_old_bound TyConEnv Int
rec_nts) = Int -> TyConEnv Int -> RecTcChecker
RC Int
new_bound TyConEnv Int
rec_nts

checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker
-- Nothing      => Recursion detected
-- Just rec_tcs => Keep going
checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker
checkRecTc (RC Int
bound TyConEnv Int
rec_nts) TyCon
tc
  = case TyConEnv Int -> TyCon -> Maybe Int
forall a. TyConEnv a -> TyCon -> Maybe a
lookupTyConEnv TyConEnv Int
rec_nts TyCon
tc of
      Just Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
bound -> Maybe RecTcChecker
forall a. Maybe a
Nothing
             | Bool
otherwise  -> RecTcChecker -> Maybe RecTcChecker
forall a. a -> Maybe a
Just (Int -> TyConEnv Int -> RecTcChecker
RC Int
bound (TyConEnv Int -> TyCon -> Int -> TyConEnv Int
forall a. TyConEnv a -> TyCon -> a -> TyConEnv a
extendTyConEnv TyConEnv Int
rec_nts TyCon
tc (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)))
      Maybe Int
Nothing             -> RecTcChecker -> Maybe RecTcChecker
forall a. a -> Maybe a
Just (Int -> TyConEnv Int -> RecTcChecker
RC Int
bound (TyConEnv Int -> TyCon -> Int -> TyConEnv Int
forall a. TyConEnv a -> TyCon -> a -> TyConEnv a
extendTyConEnv TyConEnv Int
rec_nts TyCon
tc Int
1))