tricu

An interpreted language for exploring Tree Calculus
Log | Files | Refs | README | LICENSE

TreeObservation.hs (1405B)

      1 -- Full-result observation is deliberately separate from normal evaluation.
      2 module TreeObservation (forceTreeShared) where
      3 
      4 import Control.Exception (evaluate)
      5 import qualified Data.IntMap.Strict as IntMap
      6 import Runtime (T(..))
      7 import System.Mem.StableName (StableName, makeStableName, hashStableName)
      8 
      9 data Visit = Enter T | Leave (StableName T)
     10 
     11 -- | Force a finite tree, avoiding repeated traversal of physically shared nodes.
     12 -- Names are taken after WHNF; hash collisions are resolved by name equality.
     13 -- Only completed subtrees are cached, so cycles are not mistaken for finite
     14 -- normal forms. Infinite inputs still require an external resource budget.
     15 -- The memo is local, and the explicit work stack avoids host recursion by depth.
     16 forceTreeShared :: T -> IO ()
     17 forceTreeShared root = go IntMap.empty [Enter root]
     18   where
     19     go _ [] = pure ()
     20     go seen (Leave name : rest) =
     21       go (IntMap.insertWith (++) (hashStableName name) [name] seen) rest
     22     go seen (Enter input : rest) = do
     23       tree <- evaluate input
     24       name <- makeStableName tree
     25       if name `elem` IntMap.findWithDefault [] (hashStableName name) seen
     26         then go seen rest
     27         else let done = Leave name : rest
     28              in case tree of
     29                Leaf -> go seen done
     30                Stem child -> go seen (Enter child : done)
     31                Fork left right -> go seen (Enter left : Enter right : done)