Add a builder for incremental computations.

Also add binder/occurrence highlighting.

7 files changed, 277 insertions, 67 deletions

diff --git a/src/lib/IncState.hs b/src/lib/IncState.hs
index 1f676546..b0b9e4ec 100644
--- a/src/lib/IncState.hs
+++ b/src/lib/IncState.hs
@@ -9,11 +9,142 @@
 module IncState (
   IncState (..), MapEltUpdate (..), MapUpdate (..),
   Overwrite (..), TailUpdate (..), Unchanging (..), Overwritable (..),
-  mapUpdateMapWithKey, MonoidState (..)) where
+  mapUpdateMapWithKey, MonoidState (..), AllOrNothing (..), fmapIncMap,
+  IncM, IncVar, liftIncM, runIncM, IncFun, fmapIncVar, incZip2, incUnzip3,
+  incUnzip2, incZip3, liftMonoidStateIncM) where
+
+import Control.Monad.State.Strict
+import Data.IORef
 
 import Data.Aeson (ToJSON (..))
 import qualified Data.Map.Strict as M
 import GHC.Generics
+import Data.Maybe (fromJust)
+
+-- === incremental computation builder ===
+
+-- We use IO here for IORefs but we could use ST or something else instead
+type IncFun a b = a -> IO (b, Delta a -> IO (Delta b))
+type IncM = StateT (IO ()) IO
+type IncVar a = (a, IORef (Maybe (Delta a)))
+
+liftIncM :: IncVar a -> IncFun a b -> IncM (IncVar b)
+liftIncM (x, dxRef) f = do
+  (y, df) <- liftIO $ f x
+  dyRef <- liftIO $ newIORef Nothing
+  addIncAction do
+    Just dx <- liftIO $ readIORef dxRef
+    dy <- df dx
+    liftIO $ writeIORef dyRef (Just dy)
+  return (y, dyRef)
+
+-- like LiftIncM but you don't have to bother with the initial values
+liftMonoidStateIncM :: IncVar (MonoidState a) -> IO (a -> IO b) -> IncM (IncVar (MonoidState b))
+liftMonoidStateIncM v createIncFun = liftIncM v \(MonoidState xInit) -> do
+  incFun <- createIncFun
+  yInit <- incFun xInit
+  return (MonoidState yInit, incFun)
+
+runIncM :: (IncVar a -> IncM (IncVar b)) -> IncFun a b
+runIncM f = \x -> do
+  dxRef <- newIORef Nothing
+  ((y, dyRef), action) <- runStateT (f (x, dxRef)) (return ())
+  return (y, \dx -> do
+     writeIORef dxRef (Just dx)
+     action
+     fromJust <$> readIORef dyRef)
+
+fmapIncVar :: IncVar a -> (a -> b) -> (Delta a -> Delta b) -> IncM (IncVar b)
+fmapIncVar v f df = liftIncM v \x -> return (f x, \dx -> return $ df dx)
+
+fmapIncMap
+  :: forall k a b. Ord k
+  => IncVar (M.Map k a) -> (k -> IncVar a -> IncM (IncVar b)) -> IncM (IncVar (M.Map k b))
+fmapIncMap v f = liftIncM v \m -> do
+  initDfsAndResults <- flip M.traverseWithKey m \k x -> runIncM (f k) x
+  let initResults = (fst <$> initDfsAndResults) :: M.Map k b
+  let initDfs     = (snd <$> initDfsAndResults) :: M.Map k (Delta a -> IO (Delta b))
+  dfsRef <- newIORef initDfs
+  return (initResults, deltaComputation dfsRef)
+  where
+    deltaComputation
+      :: IORef (M.Map k (Delta a -> IO (Delta b)))
+      -> MapUpdate k a -> IO (MapUpdate k b)
+    deltaComputation dfs dxs = MapUpdate <$> do
+      flip M.traverseWithKey (mapUpdates dxs) \k -> \case
+       Create x -> do
+         (y, df) <- runIncM (f k) x
+         modifyIORef dfs (M.insert k df)
+         return $ Create y
+       Replace x -> do
+         (y, df) <- runIncM (f k) x
+         modifyIORef dfs (M.insert k df)
+         return $ Replace y
+       Update dx -> do
+         df <- fromJust <$> M.lookup k <$> readIORef dfs
+         Update <$> df dx
+       Delete -> do
+         modifyIORef dfs (M.delete k)
+         return Delete
+
+incUnzip2 :: IncVar (a, b) -> IncM (IncVar a, IncVar b)
+incUnzip2 v = do
+  x <- fmapIncVar v (\(x, _) -> x) (\(dx, _ ) -> dx)
+  y <- fmapIncVar v (\(_, y) -> y) (\(_ , dy) -> dy)
+  return (x, y)
+
+incUnzip3 :: IncVar (a, b, c) -> IncM (IncVar a, IncVar b, IncVar c)
+incUnzip3 v = do
+  x <- fmapIncVar v (\(x, _, _) -> x) (\(dx, _ , _ ) -> dx)
+  y <- fmapIncVar v (\(_, y, _) -> y) (\(_ , dy, _ ) -> dy)
+  z <- fmapIncVar v (\(_, _, z) -> z) (\(_ , _ , dz) -> dz)
+  return (x, y, z)
+
+zipIncVar :: IncVar a -> IncVar b -> IncM (IncVar (a, b))
+zipIncVar (x, dxRef) (y, dyRef) = do
+  let xy = (x, y)
+  dxyRef <- liftIO $ newIORef Nothing
+  addIncAction do
+    Just dx <- liftIO $ readIORef dxRef
+    Just dy <- liftIO $ readIORef dyRef
+    liftIO $ writeIORef dxyRef (Just (dx, dy))
+  return (xy, dxyRef)
+
+zipWithIncVar :: IncVar a -> IncVar b -> (a -> b -> c) -> (Delta a -> Delta b -> Delta c) -> IncM (IncVar c)
+zipWithIncVar x y f df = do
+  xy <- zipIncVar x y
+  fmapIncVar xy (uncurry f) (uncurry df)
+
+incZip2 :: IncVar a -> IncVar b -> IncM (IncVar (a, b))
+incZip2 x y = zipWithIncVar x y (,) (,)
+
+incZip3 :: IncVar a -> IncVar b -> IncVar c -> IncM (IncVar (a, b, c))
+incZip3 x y z = do
+  xy <- zipWithIncVar x y (,) (,)
+  zipWithIncVar xy z (\(a,b) c -> (a, b, c)) (\(a,b) c -> (a, b, c))
+
+instance (IncState a, IncState b, IncState c) => IncState (a, b, c) where
+  type Delta (a, b, c) = (Delta a, Delta b, Delta c)
+  applyDiff (x, y, z) (dx, dy, dz) = (applyDiff x dx, applyDiff y dy, applyDiff z dz)
+
+instance (IncState a, IncState b) => IncState (a, b) where
+  type Delta (a, b) = (Delta a, Delta b)
+  applyDiff (x, y) (dx, dy) = (applyDiff x dx, applyDiff y dy)
+
+
+addIncAction :: IO () -> IncM ()
+addIncAction action = modify \curAction -> curAction >> action
+
+-- === AllOrNothing class ===
+
+class (forall a. IncState (f a)) => AllOrNothing f where
+  fmapAllOrNothing :: IncVar (f a) -> (a -> b) -> IncM (IncVar (f b))
+
+instance AllOrNothing Unchanging where
+  fmapAllOrNothing v f = fmapIncVar v (\(Unchanging x) -> Unchanging (f x)) (const ())
+
+instance AllOrNothing Overwritable where
+  fmapAllOrNothing v f = fmapIncVar v (\(Overwritable x) -> Overwritable (f x)) (fmap f)
 
 -- === Delta type family ===
 
diff --git a/src/lib/Live/Eval.hs b/src/lib/Live/Eval.hs
index 5605ca6b..3b1ba69d 100644
--- a/src/lib/Live/Eval.hs
+++ b/src/lib/Live/Eval.hs
@@ -7,8 +7,9 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Live.Eval (
-  watchAndEvalFile, EvalServer, CellsState, CellsUpdate,
-  NodeList (..), NodeListUpdate (..), subscribeIO, cellsStateAsUpdate) where
+  watchAndEvalFile, EvalServer, CellState (..), CellUpdate (..), CellsState, CellsUpdate,
+  NodeList (..), NodeListUpdate (..), subscribeIO,
+  CellStatus (..), nodeListAsUpdate, NodeId) where
 
 import Control.Concurrent
 import Control.Monad
@@ -28,7 +29,6 @@ import Types.Source
 import TopLevel
 import ConcreteSyntax
 import MonadUtil
-import RenderHtml
 
 -- === Top-level interface ===
 
@@ -47,9 +47,6 @@ sourceBlockEvalFun cfg resultChan env block = do
   let cfg' = cfg { cfgLogAction = send resultChan }
   evalSourceBlockIO cfg' env block
 
-cellsStateAsUpdate :: CellsState -> CellsUpdate
-cellsStateAsUpdate = nodeListAsUpdate
-
 -- === DAG diff state ===
 
 -- We intend to make this an arbitrary Dag at some point but for now we just
@@ -153,17 +150,6 @@ newtype EvaluatorM a =
   deriving (Functor, Applicative, Monad, MonadIO, Actor (EvaluatorMsg))
 deriving instance IncServer CellsState EvaluatorM
 
-instance Semigroup CellUpdate where
-  CellUpdate s o <> CellUpdate s' o' = CellUpdate (s<>s') (o<>o')
-
-instance Monoid CellUpdate where
-  mempty = CellUpdate mempty mempty
-
-instance IncState CellState where
-  type Delta CellState = CellUpdate
-  applyDiff (CellState source status result) (CellUpdate status' result') =
-    CellState source (fromOverwritable (applyDiff (Overwritable status) status')) (result <> result')
-
 instance DefuncState EvaluatorMUpdate EvaluatorM where
   update = \case
     UpdateDagEU dag     -> EvaluatorM $ update dag
@@ -215,7 +201,7 @@ data CellStatus =
   | Inert              -- doesn't require running at all
     deriving (Show, Generic)
 
-data CellState  = CellState SourceBlockWithId CellStatus Outputs
+data CellState  = CellState SourceBlock CellStatus Outputs
      deriving (Show, Generic)
 
 data CellUpdate = CellUpdate (Overwrite CellStatus) Outputs deriving (Show, Generic)
@@ -291,7 +277,7 @@ launchNextJob = do
     curEnv <- (!! cellIndex) <$> getl PrevEnvs
     let nodeId = nodeList !! cellIndex
     CellState source _ _ <- fromJust <$> getl (NodeInfo nodeId)
-    if isInert $ sourceBlockWithoutId source
+    if isInert source
       then do
         update $ AppendEnv curEnv
         launchNextJob
@@ -307,7 +293,7 @@ launchJob cellIndex nodeId env = do
     threadId <- myThreadId
     let jobId = (threadId, nodeId)
     let resultsMailbox = sliceMailbox (JobUpdate jobId . PartialJobUpdate) mailbox
-    finalEnv <- jobAction resultsMailbox env $ sourceBlockWithoutId source
+    finalEnv <- jobAction resultsMailbox env source
     send mailbox $ JobUpdate jobId $ JobComplete finalEnv
   let jobId = (threadId, nodeId)
   update $ UpdateCurJob (Just (jobId, cellIndex))
@@ -324,7 +310,7 @@ processDagUpdate (NodeListUpdate tailUpdate mapUpdate) = do
   envs <- getl PrevEnvs
   update $ UpdateEnvs $ take (nValid + 1) envs
   update $ UpdateDagEU $ NodeListUpdate tailUpdate $ mapUpdateMapWithKey mapUpdate
-    (\cellId (Unchanging source) -> initCellState cellId source)
+    (\_ (Unchanging source) -> initCellState source)
     (\_ () -> mempty)
   getl CurRunningJob >>= \case
     Nothing -> launchNextJob
@@ -351,16 +337,27 @@ isInert sb = case sbContents sb of
     EmptyLines    -> True
   UnParseable _ _ -> True
 
-initCellState :: NodeId -> SourceBlock -> CellState
-initCellState cellId source = do
+initCellState :: SourceBlock -> CellState
+initCellState source = do
   let status = if isInert source
         then Inert
         else Waiting
-  CellState (SourceBlockWithId cellId source) status mempty
+  CellState source status mempty
 
 -- === ToJSON ===
 
-instance ToJSON CellState where
 instance ToJSON CellStatus
-instance ToJSON CellUpdate
 instance (IncState s, ToJSON s, ToJSON (Delta s)) => ToJSON (NodeListUpdate s)
+
+-- === IncState and related instance ===
+
+instance Semigroup CellUpdate where
+  CellUpdate s o <> CellUpdate s' o' = CellUpdate (s<>s') (o<>o')
+
+instance Monoid CellUpdate where
+  mempty = CellUpdate mempty mempty
+
+instance IncState CellState where
+  type Delta CellState = CellUpdate
+  applyDiff (CellState source status result) (CellUpdate status' result') =
+    CellState source (fromOverwritable (applyDiff (Overwritable status) status')) (result <> result')
diff --git a/src/lib/Live/Web.hs b/src/lib/Live/Web.hs
index 7a6da1b6..dfac48bc 100644
--- a/src/lib/Live/Web.hs
+++ b/src/lib/Live/Web.hs
@@ -19,7 +19,7 @@ import Data.ByteString.Lazy (toStrict)
 import qualified Data.ByteString as BS
 
 -- import Paths_dex (getDataFileName)
-
+import RenderHtml
 import Live.Eval
 import TopLevel
 
@@ -52,8 +52,9 @@ resultStream :: EvalServer -> StreamingBody
 resultStream resultsServer write flush = do
   sendUpdate ("start"::String)
   (initResult, resultsChan) <- subscribeIO resultsServer
-  sendUpdate $ cellsStateAsUpdate initResult
-  forever $ readChan resultsChan >>= sendUpdate
+  (renderedInit, renderUpdateFun) <- renderResults initResult
+  sendUpdate renderedInit
+  forever $ readChan resultsChan >>= renderUpdateFun >>= sendUpdate
   where
     sendUpdate :: ToJSON a => a -> IO ()
     sendUpdate x = write (fromByteString $ encodePacket x) >> flush
diff --git a/src/lib/RenderHtml.hs b/src/lib/RenderHtml.hs
index a1730ff6..fe4d7703 100644
--- a/src/lib/RenderHtml.hs
+++ b/src/lib/RenderHtml.hs
@@ -8,11 +8,11 @@
 {-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 
 module RenderHtml (
-  progHtml, pprintHtml, ToMarkup, renderSourceBlock,
-  RenderedSourceBlock, RenderedOutputs, SourceBlockWithId (..)) where
+  progHtml, pprintHtml, ToMarkup, renderSourceBlock, renderResults,
+  RenderedSourceBlock, RenderedOutputs) where
 
 import Text.Blaze.Internal (MarkupM)
-import Text.Blaze.Html5 as H hiding (map, b)
+import Text.Blaze.Html5 as H hiding (map, a, b)
 import Text.Blaze.Html5.Attributes as At
 import Text.Blaze.Html.Renderer.String
 import Data.Aeson (ToJSON (..))
@@ -32,22 +32,88 @@ import Err
 import Paths_dex (getDataFileName)
 import PPrint
 import Types.Source
-import Util (unsnoc)
+import Util (unsnoc, foldMapM)
 import IncState
+import Live.Eval
 
--- === rendering source blocks and results ===
+type RenderingState  = NodeList       RenderedCellState
+type RenderingUpdate = NodeListUpdate RenderedCellState
 
-type BlockId = Int
-data SourceBlockWithId = SourceBlockWithId
-  { sourceBlockId        :: BlockId
-  , sourceBlockWithoutId :: SourceBlock }
-  deriving (Show, Generic)
+data RenderedCellState = RenderedCellState RenderedSourceBlock CellStatus RenderedOutputs
+     deriving Generic
+
+data RenderedCellUpdate = RenderedCellUpdate (Overwrite CellStatus) RenderedOutputs
+     deriving Generic
+
+instance Semigroup RenderedCellUpdate where
+  RenderedCellUpdate s o <> RenderedCellUpdate s' o' = RenderedCellUpdate (s<>s') (o<>o')
+
+instance Monoid RenderedCellUpdate where
+  mempty = RenderedCellUpdate mempty mempty
+
+instance ToJSON RenderedCellState
+instance ToJSON RenderedCellUpdate
+
+instance IncState RenderedCellState where
+  type Delta RenderedCellState = RenderedCellUpdate
+  applyDiff (RenderedCellState sb status result) (RenderedCellUpdate status' result') =
+    RenderedCellState sb (fromOverwritable (applyDiff (Overwritable status) status')) (result <> result')
 
-instance ToJSON SourceBlockWithId where
-  toJSON (SourceBlockWithId n b) = toJSON $ renderSourceBlock n b
+renderResults :: CellsState -> IO (RenderingUpdate, CellsUpdate -> IO RenderingUpdate)
+renderResults initState = do
+  (initRender, updates) <- runIncM renderCells initState
+  return (nodeListAsUpdate initRender, updates)
 
-instance ToJSON Outputs where
-  toJSON x = toJSON $ renderOutputs x
+type BlockId = Int
+
+renderCells :: IncVar CellsState -> IncM (IncVar RenderingState)
+renderCells cells = fmapNodeList cells renderCell
+
+renderCell :: BlockId -> IncVar CellState -> IncM (IncVar RenderedCellState)
+renderCell blockId cellState = do
+  (sourceBlock, status, outputs) <- unpackCellStateInc cellState
+  sourceBlock' <- fmapAllOrNothing sourceBlock $ renderSourceBlock blockId
+  outputs' <- renderOutputs outputs
+  packRenderedCellState sourceBlock' status outputs'
+
+renderOutputs :: IncVar (MonoidState Outputs) -> IncM (IncVar (MonoidState RenderedOutputs))
+renderOutputs outputsVar = liftMonoidStateIncM outputsVar do
+  return \(Outputs outs) -> foldMapM renderOutput outs
+
+fmapNodeList :: IncVar (NodeList a) -> (BlockId -> IncVar a -> IncM (IncVar b)) -> IncM (IncVar (NodeList b))
+fmapNodeList nl f = do
+  (l, m) <- unpackNodeList nl
+  m' <- fmapIncMap m f
+  packNodeList l m'
+
+unpackCellStateInc
+  :: IncVar CellState -> IncM ( IncVar (Unchanging SourceBlock)
+                              , IncVar (Overwritable CellStatus)
+                              , IncVar (MonoidState Outputs) )
+unpackCellStateInc cellState = do
+  incUnzip3 =<< fmapIncVar cellState
+    (\(CellState sb s outs) -> (Unchanging sb, Overwritable s, MonoidState outs))
+    (\(CellUpdate s outs) -> ((), s, outs))
+
+packRenderedCellState
+  :: IncVar (Unchanging RenderedSourceBlock)
+  -> IncVar (Overwritable CellStatus)
+  -> IncVar (MonoidState RenderedOutputs)
+  -> IncM (IncVar RenderedCellState)
+packRenderedCellState sourceBlock status outputs = do
+  renderedCellState <- incZip3 sourceBlock status outputs
+  fmapIncVar renderedCellState
+    (\(Unchanging sb, Overwritable s, MonoidState outs) -> RenderedCellState sb s outs)
+    (\((), s, outs) -> RenderedCellUpdate s outs)
+
+unpackNodeList :: IncVar (NodeList a) -> IncM (IncVar [NodeId], IncVar (M.Map NodeId a))
+unpackNodeList nl = do
+  incUnzip2 =<< fmapIncVar nl (\(NodeList l m) -> (l, m)) (\(NodeListUpdate l m) -> (l, m))
+
+packNodeList :: IncVar [NodeId] -> IncVar (M.Map NodeId a) -> IncM (IncVar (NodeList a))
+packNodeList lv mv = do
+  nl <- incZip2 lv mv
+  fmapIncVar nl (\(l, m) -> NodeList l m) (\(l, m) -> NodeListUpdate l m)
 
 -- === rendering results ===
 
@@ -107,20 +173,19 @@ instance IncState TreeNodeState where
   applyDiff (TreeNodeState s h t) (TreeNodeUpdate h' t') =
     TreeNodeState s (h<>h') (t<>fold t')
 
-renderOutputs :: Outputs -> RenderedOutputs
-renderOutputs (Outputs outs) = foldMap renderOutput outs
-
-renderOutput :: Output -> [RenderedOutput]
+renderOutput :: Output -> IO [RenderedOutput]
 renderOutput = \case
-  TextOut s      -> pure $ RenderedTextOut s
-  HtmlOut s      -> pure $ RenderedHtmlOut s
+  TextOut s      -> emit $ RenderedTextOut s
+  HtmlOut s      -> emit $ RenderedHtmlOut s
   SourceInfo s   -> case s of
-    SIGroupingInfo  info -> renderGroupingInfo  info
-    SINamingInfo    info -> renderNamingInfo    info
-    SITypingInfo    info -> renderTypingInfo      info
-  PassResult n s -> pure $ RenderedPassResult n s
-  MiscLog s      -> pure $ RenderedMiscLog s
-  Error e        -> pure $ RenderedError (getErrSrcId e) (pprint e)
+    SIGroupingInfo  info -> return $ renderGroupingInfo  info
+    SINamingInfo    info -> return $ renderNamingInfo    info
+    SITypingInfo    info -> return $ renderTypingInfo    info
+  PassResult n s -> emit $ RenderedPassResult n s
+  MiscLog s      -> emit $ RenderedMiscLog s
+  Error e        -> emit $ RenderedError (getErrSrcId e) (pprint e)
+  where emit :: RenderedOutput -> IO [RenderedOutput]
+        emit x = return [x]
 
 renderSourceBlock :: BlockId -> SourceBlock -> RenderedSourceBlock
 renderSourceBlock n b = RenderedSourceBlock
@@ -166,15 +231,20 @@ renderFocus srcId node = case gtnChildren node of
 
 renderNamingInfo :: NamingInfo -> RenderedOutputs
 renderNamingInfo (NamingInfo m) = [RenderedTreeNodeUpdate treeNodeUpdate]
-  where
-    treeNodeUpdate = M.toList m <&> \(sid, node) ->
-      (sid, Update $ renderNameInfo node)
-
-renderNameInfo :: NameInfo -> TreeNodeUpdate
-renderNameInfo = \case
-  LocalOcc _ -> TreeNodeUpdate [] ["Local name"]
-  LocalBinder _ -> TreeNodeUpdate mempty mempty
-  TopOcc s -> TreeNodeUpdate [] [s]
+  where treeNodeUpdate = fold $ M.toList m <&> \(sid, node) -> renderNameInfo sid node
+
+renderNameInfo :: SrcId -> NameInfo -> [(SrcId, MapEltUpdate TreeNodeState)]
+renderNameInfo sid = \case
+  LocalOcc binderSid -> do
+    let occUpdate = (sid, Update $ TreeNodeUpdate [(binderSid, HighlightBinder)] ["Local name"])
+    let binderUpdate = (binderSid, Update $ TreeNodeUpdate [(sid, HighlightOcc)] [])
+    [occUpdate, binderUpdate]
+  -- TODO: this path isn't exercised because we don't actually generate any
+  -- `LocalBinder` info in `SourceRename`
+  LocalBinder binderScope -> [(sid, Update $ TreeNodeUpdate (selfHighlight:scopeHighlights) mempty)]
+    where selfHighlight = (sid, HighlightBinder)
+          scopeHighlights = binderScope <&> \scopeSid -> (scopeSid, HighlightScope)
+  TopOcc s -> [(sid, Update $ TreeNodeUpdate [] [s])]
 
 renderTypingInfo :: TypingInfo -> RenderedOutputs
 renderTypingInfo (TypingInfo m) = [RenderedTreeNodeUpdate treeNodeUpdate]
diff --git a/src/lib/SourceRename.hs b/src/lib/SourceRename.hs
index 0ed26d89..2250b385 100644
--- a/src/lib/SourceRename.hs
+++ b/src/lib/SourceRename.hs
@@ -308,6 +308,7 @@ sourceRenameUBinder asUVar (WithSrcB sid ubinder) cont = case ubinder of
     when (not mayShadow && shadows) $ throw sid $ RepeatedVarErr $ pprint b
     withFreshM (getNameHint b) \name -> do
       Distinct <- getDistinct
+      emitNameInfo sid $ LocalBinder []
       extendSourceMap sid b (asUVar $ binderName name) $
         cont $ WithSrcB sid $ UBind b name
   UBind _ _ -> error "Shouldn't be source-renaming internal names"
diff --git a/static/index.ts b/static/index.ts
index dde033f5..9d712f37 100644
--- a/static/index.ts
+++ b/static/index.ts
@@ -18,7 +18,8 @@ type HTMLString = string
 type Div = Element
 type Status = "Waiting" | "Running" | "Complete" | "CompleteWithErrors" | "Inert"
 
-type HighlightType = "HighlightGroup" |  "HighlightLeaf" | "HighlightError"
+type HighlightType = "HighlightGroup" |  "HighlightLeaf" | "HighlightError" | "HighlightScope"
+                   | "HighlightBinder" | "HighlightOcc"
 type Highlight    = [SrcId, HighlightType]
 
 type HsMaybe<T> = {tag:"Just"; contents:T} | {tag: "Nothing"}
@@ -285,7 +286,7 @@ function applyTreeNodeUpdate(cell:Cell, srcId:SrcId, update:HsTreeNodeMapUpdate)
             const nodeUpdate : HsTreeNodeUpdate = update.contents
             const node : TreeNode = cell.treeMap.get(srcId) ?? oops()
             nodeUpdate.tnuText.forEach(      (t) => {node.text       = node.text.concat(t, "\n")})
-            nodeUpdate.tnuHighlights.forEach((h) => {node.highlights = node.highlights.concat(h)})}
+            node.highlights = node.highlights.concat(nodeUpdate.tnuHighlights)}
 }
 function computeRange(cell:Cell, l:SrcId, r:SrcId) : [Div, Div] | null {
     const lDiv = selectSpan(cell, l)
@@ -321,6 +322,12 @@ function computeHighlightClass(h:HighlightType) : string {
             return "highlight-leaf"
         case "HighlightError":
             return "highlight-error"
+        case "HighlightScope":
+            return "highlight-scope";
+        case "HighlightBinder":
+            return "highlight-binder";
+        case "HighlightOcc":
+            return "highlight-occ";
     }
 }
 function highlightTreeNode(isTemporary: boolean, node: TreeNode, highlightType:HighlightType) {
diff --git a/static/style.css b/static/style.css
index bceabfe6..988b8cad 100644
--- a/static/style.css
+++ b/static/style.css
@@ -80,6 +80,9 @@ body {
   text-decoration: red wavy underline;
   text-decoration-skip-ink: none;}
 .highlight-group { background-color: yellow; }
+.highlight-scope { background-color: lightyellow; }
+.highlight-binder { background-color: lightblue; }
+.highlight-occ    { background-color: yellow; }
 .highlight-leaf  { background-color: lightgray; }
 
 /* lexeme colors */