{-# LANGUAGE GADTs #-}
module GHC.Debugger.Runtime.Term.Cache where

import GHC
import GHC.Types.Id
import GHC.Tc.Utils.TcType
import GHC.Runtime.Eval
import GHC.Types.Unique.Supply (uniqFromTag)
import GHC.Types.Var.Env

import GHC.Debugger.Runtime.Term.Key

import Data.Map (Map)
import qualified Data.Map as M

--------------------------------------------------------------------------------
-- * Term Cache
--------------------------------------------------------------------------------

-- | A term cache maps Names to Terms.
--
-- We use the term cache to avoid redundant computation forcing (unique) names
-- we've already forced before.
--
-- A kind of trie map from 'TermKey's. The Map entry for no-path-fragments is
-- the 'Term' of the original 'Id'.
type TermCache = TermKeyMap Term

-- | Lookup a 'TermKey' in a 'TermCache'.
-- Returns @Nothing@ for a cache miss and @Just@ otherwise.
lookupTermCache :: TermKey -> TermCache -> Maybe Term
lookupTermCache :: TermKey -> TermCache -> Maybe Term
lookupTermCache = TermKey -> TermCache -> Maybe Term
forall a. TermKey -> TermKeyMap a -> Maybe a
lookupTermKeyMap

-- | Inserts a 'Term' for the given 'TermKey' in the 'TermCache'.
--
-- Overwrites existing values.
insertTermCache :: TermKey -> Term -> TermCache -> TermCache
insertTermCache :: TermKey -> Term -> TermCache -> TermCache
insertTermCache = TermKey -> Term -> TermCache -> TermCache
forall a. TermKey -> a -> TermKeyMap a -> TermKeyMap a
insertTermKeyMap

--------------------------------------------------------------------------------
-- * TermKeyMap
--------------------------------------------------------------------------------

-- | Mapping from 'TermKey' to @a@. Backs 'TermCache', but is more general.
type TermKeyMap a = IdEnv (Map [PathFragment] a)

-- | Lookup a 'TermKey' in a 'TermKeyMap'.
lookupTermKeyMap :: TermKey -> TermKeyMap a -> Maybe a
lookupTermKeyMap :: forall a. TermKey -> TermKeyMap a -> Maybe a
lookupTermKeyMap TermKey
key TermKeyMap a
tc = do
  let (Id
i, [PathFragment]
path) = TermKey -> (Id, [PathFragment])
unconsTermKey TermKey
key
  path_map <- TermKeyMap a -> Id -> Maybe (Map [PathFragment] a)
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv TermKeyMap a
tc Id
i
  M.lookup path path_map

-- | Inserts a 'Term' for the given 'TermKey' in the 'TermKeyMap'.
--
-- Overwrites existing values.
insertTermKeyMap :: TermKey -> a -> TermKeyMap a -> TermKeyMap a
insertTermKeyMap :: forall a. TermKey -> a -> TermKeyMap a -> TermKeyMap a
insertTermKeyMap TermKey
key a
term TermKeyMap a
tc =
  let
    (Id
i, [PathFragment]
path) = TermKey -> (Id, [PathFragment])
unconsTermKey TermKey
key
    new_map :: Map [PathFragment] a
new_map = case TermKeyMap a -> Id -> Maybe (Map [PathFragment] a)
forall a. VarEnv a -> Id -> Maybe a
lookupVarEnv TermKeyMap a
tc Id
i of
      Maybe (Map [PathFragment] a)
Nothing           -> [PathFragment] -> a -> Map [PathFragment] a
forall k a. k -> a -> Map k a
M.singleton [PathFragment]
path a
term
      Just Map [PathFragment] a
existing_map -> [PathFragment] -> a -> Map [PathFragment] a -> Map [PathFragment] a
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [PathFragment]
path a
term Map [PathFragment] a
existing_map
  in TermKeyMap a -> Id -> Map [PathFragment] a -> TermKeyMap a
forall a. VarEnv a -> Id -> a -> VarEnv a
extendVarEnv TermKeyMap a
tc Id
i Map [PathFragment] a
new_map