Tweaks to parse highlighting. It's works pretty nicely now!

src/lib/Live/Eval.hs

@@ -13,11 +13,14 @@ module Live.Eval (
 import Control.Concurrent
 import Control.Monad
 import Control.Monad.State.Strict
+import Control.Monad.Reader
 import qualified Data.Map.Strict as M
 import Data.Aeson (ToJSON, ToJSONKey, toJSON, Value)
 import Data.Functor ((<&>))
-import Data.Maybe (fromJust)
+import Data.Foldable (fold)
+import Data.Maybe (fromJust, fromMaybe)
 import Data.Text (Text)
+import Prelude hiding (span)
 import GHC.Generics
 
 import Actor
@@ -317,14 +320,79 @@ data SourceBlockJSONData = SourceBlockJSONData
   , jdBlockId     :: Int
   , jdLexemeList  :: [SrcId]
   , jdASTInfo     :: ASTInfo
+  , jdASTLims     :: M.Map SrcId (SrcId, SrcId)   -- precomputed leftmost and rightmost spans associated with each node
   , jdHTML        :: String }  deriving (Generic)
 
 instance ToJSON SourceBlockJSONData
 
 instance ToJSON SourceBlockWithId where
   toJSON b@(SourceBlockWithId blockId b') = toJSON $ SourceBlockJSONData
-   (sbLine b') blockId (unsnoc $ lexemeList $ sbLexemeInfo b') (sbASTInfo b') (pprintHtml b)
+    { jdLine       = sbLine b'
+    , jdBlockId    = blockId
+    , jdLexemeList = unsnoc $ lexemeList $ sbLexemeInfo b'
+    , jdASTInfo    = sbASTInfo b'
+    , jdASTLims    = computeASTLims (sbASTInfo b') (sbLexemeInfo b')
+    , jdHTML       = pprintHtml b
+    }
 instance ToJSON Result      where toJSON = toJSONViaHtml
 
+
 toJSONViaHtml :: ToMarkup a => a -> Value
 toJSONViaHtml x = toJSON $ pprintHtml x
+
+-- === computing the linear lexeme limits on each SrcId ===
+
+data OrdSrcId = OrdSrcId Int SrcId
+newtype OrdSrcIdSpan = OrdSrcIdSpan (Maybe (OrdSrcId, OrdSrcId))
+
+type SpanMap = M.Map SrcId OrdSrcIdSpan
+type ComputeSpanM = ReaderT (ASTInfo, LexemeInfo) (State SpanMap)
+
+instance Eq OrdSrcId where
+  OrdSrcId x _ == OrdSrcId y _ = x == y
+
+instance Ord OrdSrcId where
+  compare (OrdSrcId x _) (OrdSrcId y _) = compare x y
+
+instance Monoid OrdSrcIdSpan where
+  mempty = OrdSrcIdSpan Nothing
+
+instance Semigroup OrdSrcIdSpan where
+  OrdSrcIdSpan Nothing <> s = s
+  s <> OrdSrcIdSpan Nothing = s
+  OrdSrcIdSpan (Just (l, r)) <> OrdSrcIdSpan (Just (l', r')) =
+    OrdSrcIdSpan $ Just (min l l', max r r')
+
+computeASTLims :: ASTInfo -> LexemeInfo -> M.Map SrcId (SrcId, SrcId)
+computeASTLims astInfo lexemeInfo =
+  M.mapMaybe stripOrd $ flip execState mempty $ flip runReaderT (astInfo, lexemeInfo) $
+    visitSrcId rootSrcId
+  where stripOrd :: OrdSrcIdSpan -> Maybe (SrcId, SrcId)
+        stripOrd (OrdSrcIdSpan s) = case s of
+          Just (OrdSrcId _ l, OrdSrcId _ r) -> Just (l, r)
+          Nothing -> Nothing
+
+insertSpan :: SrcId -> OrdSrcIdSpan -> ComputeSpanM ()
+insertSpan sid span = modify \m -> M.insert sid span m
+
+getSelfSpans :: SrcId -> ComputeSpanM [OrdSrcIdSpan]
+getSelfSpans sid = do
+  lexemes <- asks $ lexemeInfo . snd
+  case M.lookup sid lexemes of
+    Nothing -> return []
+    Just (_, (low, _)) -> do
+      let sidOrd = OrdSrcId low sid
+      return [OrdSrcIdSpan $ Just $ (sidOrd, sidOrd)]
+
+getChildren :: SrcId -> ComputeSpanM [SrcId]
+getChildren sid = do
+  astInfo <- asks fst
+  return $ fromMaybe [] $ M.lookup sid $ astChildren astInfo
+
+visitSrcId :: SrcId -> ComputeSpanM OrdSrcIdSpan
+visitSrcId sid = do
+  childSpans <- mapM visitSrcId =<< getChildren sid
+  selfSpans <- getSelfSpans sid
+  let finalSpan = fold $ selfSpans ++ childSpans
+  insertSpan sid finalSpan
+  return finalSpan

src/lib/SourceIdTraversal.hs

@@ -49,7 +49,7 @@ instance IsTree Group where
     CPrim _   xs -> mapM_ visit xs
     CParens   xs -> mapM_ visit xs
     CBrackets xs -> mapM_ visit xs
-    CBin       b l r -> visit b >> visit l >> visit r
+    CBin       b l r -> visit l >> visit b >> visit r
     CJuxtapose _ l r -> visit l >> visit r
     CPrefix      l r -> visit l >> visit r
     CGivens (x,y) -> visit x >> visit y

src/lib/Types/Source.hs

@@ -56,6 +56,9 @@ newtype SourceOrInternalName (c::C) (n::S) = SourceOrInternalName (SourceNameOr
 -- XXX: 0 is reserved for the root
 newtype SrcId = SrcId Int  deriving (Show, Eq, Ord, Generic)
 
+rootSrcId :: SrcId
+rootSrcId = SrcId 0
+
 -- This is just for syntax highlighting. It won't be needed if we have
 -- a separate lexing pass where we have a complete lossless data type for
 -- lexemes.

static/index.js

@@ -70,16 +70,16 @@ function render(renderMode) {
 }
 
 function selectSpan(cellCtx, srcId) {
-    let [cell, blockId, _] = cellCtx
+    let [cell, blockId,  ,  ] = cellCtx
     return cell.querySelector("#span_".concat(blockId.toString(), "_", srcId.toString()));}
 
 function attachHovertip(cellCtx, srcId) {
     let span = selectSpan(cellCtx, srcId);
-    span.addEventListener("mouseover", (event) => enterSpan(event, cellCtx, srcId));
-    span.addEventListener("mouseout" , (event) => leaveSpan(event, cellCtx, srcId));}
+    span.addEventListener("mouseover", (event) => toggleSpan(event, cellCtx, srcId));
+    span.addEventListener("mouseout" , (event) => toggleSpan(event, cellCtx, srcId));}
 
 function getParent(cellCtx, srcId) {
-    let [ ,  , astInfo] = cellCtx;
+    let [ ,  , astInfo, ] = cellCtx;
     let parent = astInfo["astParent"][srcId.toString()]
     if (parent == undefined) {
         console.error(srcId, astInfo);
@@ -89,48 +89,51 @@ function getParent(cellCtx, srcId) {
     }}
 
 function getChildren(cellCtx, srcId) {
-    let [ ,  , astInfo] = cellCtx;
+    let [ ,  , astInfo, ] = cellCtx;
     let children = astInfo["astChildren"][srcId.toString()]
     if (children == undefined) {
         return [];
     } else {
         return children;
     }}
 
-function traverseSpans(cellCtx, srcId, f) {
-    let span = selectSpan(cellCtx, srcId)
-    if (span !== null) f(span);
-    getChildren(cellCtx, srcId).map(function (childId) {
-        traverseSpans(cellCtx, childId, f);
-    })}
+function isLeafGroup(span) {
+    return span !== null && (span.classList.contains("keyword") || span.classList.contains("symbol"))
+}
 
-function enterSpan(event, cellCtx, srcId) {
-    event.stopPropagation();
-    let parentId = getParent(cellCtx, srcId);
-    traverseSpans(cellCtx, parentId, function (span) {
-        span.style.backgroundColor = "lightblue";
-        span.style.outlineColor = "lightblue";
-        span.style.outlineStyle = "solid";
-    });
-    let siblingIds = getChildren(cellCtx, parentId);
-    siblingIds.map(function (siblingId) {
-        traverseSpans(cellCtx, siblingId, function (span) {
-            span.style.backgroundColor = "yellow";
-    })})}
+function toggleSrcIdHighlighting(cellCtx, srcId) {
+    let maybeLeaf = selectSpan(cellCtx, srcId)
+    // XXX: this is a bit of a hack. We should probably collect information
+    // about node types on the Haskell side
+    if (isLeafGroup(maybeLeaf)) {
+        maybeLeaf.classList.toggle("highlighted-leaf");
+    } else {
+        getSrcIdSpans(cellCtx, srcId).map(function (span) {
+          span.classList.toggle("highlighted");
+    })}}
+
+// All HTML spans associated with the srcId (these should be contiguous)
+function getSrcIdSpans(cellCtx, srcId) {
+    let [ , , , nodeSpans] = cellCtx;
+    let [leftSrcId, rightSrcId] = nodeSpans[srcId];
+    return spansBetween(selectSpan(cellCtx, leftSrcId), selectSpan(cellCtx, rightSrcId));}
+
+function spansBetween(l, r) {
+    let spans = []
+    while (l !== null && !(Object.is(l, r))) {
+        spans.push(l);
+        l = l.nextSibling;
+    }
+    spans.push(r)
+    return spans;}
 
-function leaveSpan(event, cellCtx, srcId) {
+function toggleSpan(event, cellCtx, srcId) {
     event.stopPropagation();
     let parentId = getParent(cellCtx, srcId);
-    traverseSpans(cellCtx, parentId, function (span) {
-        span.style.backgroundColor = null;
-        span.style.outlineColor = null;
-        span.style.outlineStyle = null;
-    });
     let siblingIds = getChildren(cellCtx, parentId);
     siblingIds.map(function (siblingId) {
-        traverseSpans(cellCtx, siblingId, function (span) {
-            span.style.backgroundColor = null;
-    })})}
+        toggleSrcIdHighlighting(cellCtx, siblingId)
+    })}
 
 function setCellContents(cell, contents) {
     let source  = contents[0];
@@ -200,7 +203,8 @@ function processUpdate(msg) {
             var blockId    = source["jdBlockId"];
             var astInfo    = source["jdASTInfo"];
             var lexemeList = source["jdLexemeList"];
-            cellCtx = [cell, blockId, astInfo];
+            var astLims    = source["jdASTLims"];
+            cellCtx = [cell, blockId, astInfo, astLims];
             lexemeList.map(function (lexemeId) {attachHovertip(cellCtx, lexemeId)})
         }
     });

static/style.css

@@ -100,6 +100,14 @@ code {
   color: #E07000;
 }
 
+.highlighted {
+  background-color: yellow;
+}
+
+.highlighted-leaf {
+  background-color: lightblue;
+}
+
 .type-name {
   color: #A80000;
 }