Make hover-info updates even more incremental

dex.cabal

@@ -93,7 +93,6 @@ library
                      , Transpose
                      , Types.Core
                      , Types.Imp
-                     , Types.Misc
                      , Types.Primitives
                      , Types.OpNames
                      , Types.Source

src/dex.hs

@@ -36,7 +36,6 @@ import Live.Web (runWeb)
 import Core
 import Types.Core
 import Types.Imp
-import Types.Misc
 import Types.Source
 
 data ErrorHandling = HaltOnErr | ContinueOnErr

src/lib/ConcreteSyntax.hs

@@ -31,7 +31,6 @@ import Lexing
 import Types.Core
 import Types.Source
 import Types.Primitives
-import SourceIdTraversal
 import qualified Types.OpNames as P
 import Util
 
@@ -60,7 +59,7 @@ parseUModule name s = do
 {-# SCC parseUModule #-}
 
 preludeImportBlock :: SourceBlock
-preludeImportBlock = SourceBlock 0 0 LogNothing "" mempty Nothing (Misc $ ImportModule Prelude)
+preludeImportBlock = SourceBlock 0 0 LogNothing "" mempty (Misc $ ImportModule Prelude)
 
 sourceBlocks :: Parser [SourceBlock]
 sourceBlocks = manyTill (sourceBlock <* outputLines) eof
@@ -99,8 +98,7 @@ sourceBlock = do
     b <- sourceBlock'
     return (level, b)
   let lexInfo' = lexInfo { lexemeInfo = lexemeInfo lexInfo <&> \(t, (l, r)) -> (t, (l-offset, r-offset))}
-  let groupTree = getGroupTree b
-  return $ SourceBlock (unPos (sourceLine pos)) offset level src lexInfo' (Just groupTree) b
+  return $ SourceBlock (unPos (sourceLine pos)) offset level src lexInfo' b
 
 recover :: ParseError Text Void -> Parser (LogLevel, SourceBlock')
 recover e = do

src/lib/ImpToLLVM.hs

@@ -55,7 +55,6 @@ import PPrint
 import RawName qualified as R
 import Types.Core
 import Types.Imp
-import Types.Misc
 import Types.Primitives
 import Types.Source
 import Util (IsBool (..), bindM2, enumerate)

src/lib/IncState.hs

@@ -11,6 +11,7 @@ module IncState (
   Overwrite (..), TailUpdate (..), Unchanging (..), Overwritable (..),
   mapUpdateMapWithKey) where
 
+import Data.Aeson (ToJSON, ToJSONKey)
 import qualified Data.Map.Strict as M
 import GHC.Generics
 
@@ -104,7 +105,8 @@ instance IncState [a] (TailUpdate a) where
   applyDiff xs (TailUpdate numDrop ys) = take (length xs - numDrop) xs <> ys
 
 -- Trivial diff that works for any type - just replace the old value with a completely new one.
-data Overwrite a = NoChange | OverwriteWith a  deriving (Show, Generic)
+data Overwrite a = NoChange | OverwriteWith a
+  deriving (Show, Eq, Generic, Functor, Foldable, Traversable)
 newtype Overwritable a = Overwritable { fromOverwritable :: a } deriving (Show, Eq, Ord)
 
 instance Semigroup (Overwrite a) where
@@ -126,3 +128,8 @@ newtype Unchanging a = Unchanging { fromUnchanging :: a } deriving (Show, Eq, Or
 
 instance IncState (Unchanging a) () where
   applyDiff s () = s
+
+instance            ToJSON a  => ToJSON (Overwrite a)
+instance (ToJSON s, ToJSON d, ToJSONKey k) => ToJSON (MapUpdate k s d)
+instance ToJSON a => ToJSON (TailUpdate a)
+instance (ToJSON s, ToJSON d) => ToJSON (MapEltUpdate s d)

src/lib/LLVM/CUDA.hs

@@ -40,7 +40,7 @@ import qualified Data.Set as S
 
 import LLVM.Compile
 import Types.Imp
-import Types.Misc
+import Types.Source
 
 
 data LLVMKernel = LLVMKernel L.Module

src/lib/LLVM/Compile.hs

@@ -33,7 +33,6 @@ import Control.Monad
 import Logging
 import PPrint ()
 import Paths_dex  (getDataFileName)
-import Types.Misc
 -- The only reason this module depends on Types.Source is that we pass in the logger,
 -- in order to optionally print out the IRs. LLVM mutates its IRs in-place, so
 -- we can't just expose a functional API for each stage without taking a

src/lib/Live/Eval.hs

@@ -5,50 +5,44 @@
 -- https://developers.google.com/open-source/licenses/bsd
 
 {-# LANGUAGE UndecidableInstances #-}
-{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Live.Eval (
-  watchAndEvalFile, ResultsServer, ResultsUpdate, subscribeIO, nodeListAsUpdate, addSourceBlockIds) where
+  watchAndEvalFile, EvalServer, EvalUpdate, CellsUpdate, fmapCellsUpdate,
+  NodeList (..), NodeListUpdate (..), subscribeIO, nodeListAsUpdate) where
 
 import Control.Concurrent
 import Control.Monad
 import Control.Monad.State.Strict
 import Control.Monad.Writer.Strict
 import qualified Data.Map.Strict as M
-import Data.Aeson (ToJSON, ToJSONKey, toJSON, Value)
+import Data.Aeson (ToJSON)
 import Data.Functor ((<&>))
-import Data.Foldable (toList)
 import Data.Maybe (fromJust)
 import Data.Text (Text)
 import Prelude hiding (span)
 import GHC.Generics
 
 import Actor
 import IncState
-import Types.Misc
 import Types.Source
 import TopLevel
 import ConcreteSyntax
-import RenderHtml (ToMarkup, pprintHtml)
 import MonadUtil
-import Util (unsnoc)
 
 -- === Top-level interface ===
 
+type EvalServer = StateServer EvalState EvalUpdate
+type EvalState  = CellsState  SourceBlock Result
+type EvalUpdate = CellsUpdate SourceBlock Result
+
 -- `watchAndEvalFile` returns the channel by which a client may
 -- subscribe by sending a write-only view of its input channel.
-watchAndEvalFile :: FilePath -> EvalConfig -> TopStateEx -> IO ResultsServer
+watchAndEvalFile :: FilePath -> EvalConfig -> TopStateEx -> IO EvalServer
 watchAndEvalFile fname opts env = do
   watcher <- launchFileWatcher fname
   parser <- launchCellParser watcher \source -> uModuleSourceBlocks $ parseUModule Main source
   launchDagEvaluator parser env (evalSourceBlockIO' opts)
 
-addSourceBlockIds :: CellsUpdate SourceBlock o -> CellsUpdate SourceBlockWithId o
-addSourceBlockIds (NodeListUpdate listUpdate mapUpdate) = NodeListUpdate listUpdate mapUpdate'
-   where mapUpdate' = mapUpdateMapWithKey mapUpdate
-                        (\k (CellState b s o) -> CellState (SourceBlockWithId k b) s o)
-                        (\_ d -> d)
-
 -- shim to pretend that evalSourceBlockIO streams its results. TODO: make it actually do that.
 evalSourceBlockIO'
   :: EvalConfig -> Mailbox Result -> TopStateEx -> SourceBlock -> IO TopStateEx
@@ -57,8 +51,11 @@ evalSourceBlockIO' cfg resultChan env block = do
   send resultChan result
   return env'
 
-type ResultsServer = Evaluator        SourceBlock Result
-type ResultsUpdate = CellsUpdate SourceBlock Result
+fmapCellsUpdate :: CellsUpdate i o -> (NodeId -> i -> i') -> (NodeId -> o -> o') -> CellsUpdate i' o'
+fmapCellsUpdate (NodeListUpdate t m) fi fo = NodeListUpdate t m' where
+  m' = mapUpdateMapWithKey m
+         (\k (CellState i s o) -> CellState (fi k i) s (fo k o))
+         (\k (CellUpdate  s o) -> CellUpdate         s (fo k o))
 
 -- === DAG diff state ===
 
@@ -335,84 +332,7 @@ processDagUpdate (NodeListUpdate tailUpdate mapUpdate) = do
 
 -- === instances ===
 
-instance (ToJSON i, ToJSON o) => ToJSON (NodeListUpdate (CellState i o) o) where
-instance (ToJSON s, ToJSON d, ToJSONKey k) => ToJSON (MapUpdate k s d)
-instance ToJSON a => ToJSON (TailUpdate a)
-instance (ToJSON s, ToJSON d) => ToJSON (MapEltUpdate s d)
-instance ToJSON SrcId
-deriving instance ToJSONKey SrcId
-instance ToJSON LexemeType
+instance                         ToJSON CellStatus
 instance (ToJSON i, ToJSON o) => ToJSON (CellState i o)
-instance (ToJSON i, ToJSON o) => ToJSON (CellsUpdate i o)
 instance            ToJSON o  => ToJSON (CellUpdate o)
-instance            ToJSON a  => ToJSON (Overwrite a)
-instance ToJSON CellStatus
-
-data SourceBlockJSONData = SourceBlockJSONData
-  { jdLine        :: Int
-  , jdBlockId     :: Int
-  , jdLexemeList  :: [SrcId]
-  , jdFocusMap     :: FocusMap
-  , jdHighlightMap :: HighlightMap
-  , jdHoverInfoMap :: HoverInfoMap
-  , jdHTML        :: String }  deriving (Generic)
-
-instance ToJSON SourceBlockJSONData
-
-instance ToJSON SourceBlockWithId where
-  toJSON b@(SourceBlockWithId blockId b') = toJSON $ SourceBlockJSONData
-    { jdLine       = sbLine b'
-    , jdBlockId    = blockId
-    , jdLexemeList = unsnoc $ lexemeList $ sbLexemeInfo b'
-    , jdFocusMap     = computeFocus      b'
-    , jdHighlightMap = computeHighlights b'
-    , jdHoverInfoMap = computeHoverInfo b'
-    , jdHTML       = pprintHtml b
-    }
-instance ToJSON Result      where toJSON = toJSONViaHtml
-
-toJSONViaHtml :: ToMarkup a => a -> Value
-toJSONViaHtml x = toJSON $ pprintHtml x
-
--- === textual information on hover ===
-
-type HoverInfo = String
-newtype HoverInfoMap = HoverInfoMap (M.Map LexemeId HoverInfo)   deriving (ToJSON, Semigroup, Monoid)
-
-computeHoverInfo :: SourceBlock -> HoverInfoMap
-computeHoverInfo sb = HoverInfoMap $
-  M.fromList $ toList (lexemeList (sbLexemeInfo sb)) <&> \srcId -> (srcId, show srcId)
-
--- === highlighting on hover ===
--- TODO: put this somewhere else, like RenderHtml or something
-
-newtype FocusMap = FocusMap (M.Map LexemeId SrcId)   deriving (ToJSON, Semigroup, Monoid)
-newtype HighlightMap = HighlightMap (M.Map SrcId Highlights)  deriving (ToJSON, Semigroup, Monoid)
-type Highlights = [(HighlightType, LexemeSpan)]
-data HighlightType = HighlightGroup | HighlightLeaf  deriving Generic
-
-instance ToJSON HighlightType
-
-computeFocus :: SourceBlock -> FocusMap
-computeFocus sb = execWriter $ mapM go $ sbGroupTree sb where
-  go :: GroupTree -> Writer FocusMap ()
-  go t = forM_ (gtChildren t) \child-> do
-    go child
-    tell $ FocusMap $ M.singleton (gtSrcId child) (gtSrcId t)
-
-computeHighlights :: SourceBlock -> HighlightMap
-computeHighlights sb = execWriter $ mapM go $ sbGroupTree sb where
-  go :: GroupTree -> Writer HighlightMap ()
-  go t = do
-    spans <- forM (gtChildren t) \child -> do
-      go child
-      return (getHighlightType (gtSrcId child), gtSpan child)
-    tell $ HighlightMap $ M.singleton (gtSrcId t) spans
-
-  getHighlightType :: SrcId -> HighlightType
-  getHighlightType sid = case M.lookup sid (lexemeInfo $ sbLexemeInfo sb) of
-    Nothing -> HighlightGroup  -- not a lexeme
-    Just (lexemeTy, _) -> case lexemeTy of
-      Symbol  -> HighlightLeaf
-      Keyword -> HighlightLeaf
-      _ -> HighlightGroup
+instance (ToJSON s, ToJSON d) => ToJSON (NodeListUpdate s d)

src/lib/Live/Web.hs

@@ -21,15 +21,17 @@ import qualified Data.ByteString as BS
 -- import Paths_dex (getDataFileName)
 
 import Live.Eval
+import RenderHtml
 import TopLevel
+import Types.Source
 
 runWeb :: FilePath -> EvalConfig -> TopStateEx -> IO ()
 runWeb fname opts env = do
   resultsChan <- watchAndEvalFile fname opts env
   putStrLn "Streaming output to http://localhost:8000/"
   run 8000 $ serveResults resultsChan
 
-serveResults :: ResultsServer -> Application
+serveResults :: EvalServer -> Application
 serveResults resultsSubscribe request respond = do
   print (pathInfo request)
   case pathInfo request of
@@ -48,18 +50,23 @@ serveResults resultsSubscribe request respond = do
       -- fname <- getDataFileName dataFname
       respond $ responseFile status200 [("Content-Type", ctype)] fname Nothing
 
-resultStream :: ResultsServer -> StreamingBody
+resultStream :: EvalServer -> StreamingBody
 resultStream resultsServer write flush = do
-  write (fromByteString $ encodeResults ("start"::String)) >> flush
+  sendUpdate ("start"::String)
   (initResult, resultsChan) <- subscribeIO resultsServer
-  sendUpdate $ nodeListAsUpdate initResult
-  forever $ readChan resultsChan >>= sendUpdate
+  sendUpdate $ renderEvalUpdate $ nodeListAsUpdate initResult
+  forever do
+    nextUpdate <- readChan resultsChan
+    sendUpdate $ renderEvalUpdate nextUpdate
   where
-    sendUpdate :: ResultsUpdate -> IO ()
-    sendUpdate update = do
-      let s = encodeResults $ addSourceBlockIds update
-      write (fromByteString s) >> flush
+    sendUpdate :: ToJSON a => a -> IO ()
+    sendUpdate x = write (fromByteString $ encodePacket x) >> flush
 
-    encodeResults :: ToJSON a => a -> BS.ByteString
-    encodeResults = toStrict . wrap . encode
-      where wrap s = "data:" <> s <> "\n\n"
+encodePacket :: ToJSON a => a -> BS.ByteString
+encodePacket = toStrict . wrap . encode
+  where wrap s = "data:" <> s <> "\n\n"
+
+renderEvalUpdate :: CellsUpdate SourceBlock Result -> CellsUpdate RenderedSourceBlock RenderedResult
+renderEvalUpdate cellsUpdate = fmapCellsUpdate cellsUpdate
+  (\k b -> renderSourceBlock k b)
+  (\_ r -> renderResult r)

src/lib/PPrint.hs

@@ -39,7 +39,6 @@ import Occurrence (Count (Bounded), UsageInfo (..))
 import Occurrence qualified as Occ
 import Types.Core
 import Types.Imp
-import Types.Misc
 import Types.Primitives
 import Types.Source
 import QueryTypePure
@@ -484,6 +483,7 @@ prettyDuration d = p (showFFloat (Just 3) (d * mult) "") <+> unit
 
 instance Pretty Output where
   pretty (TextOut s) = pretty s
+  pretty (SourceInfo _) = "hello"
   pretty (HtmlOut _) = "<html output>"
   -- pretty (ExportedFun _ _) = ""
   pretty (BenchResult name compileTime runTime stats) =