Highlight error source locations

src/lib/Actor.hs

@@ -10,12 +10,12 @@ module Actor (
   ActorM, Actor (..), launchActor, send, selfMailbox, messageLoop,
   sliceMailbox, SubscribeMsg (..), IncServer, IncServerT, FileWatcher,
   StateServer, flushDiffs, handleSubscribeMsg, subscribe, subscribeIO, sendSync,
-  runIncServerT, launchFileWatcher, Mailbox
+  runIncServerT, launchFileWatcher, Mailbox, launchIncFunctionEvaluator
   ) where
 
 import Control.Concurrent
 import Control.Monad
-import Control.Monad.State.Strict hiding (get)
+import Control.Monad.State.Strict
 import Control.Monad.Reader
 import qualified Data.ByteString as BS
 import Data.IORef
@@ -162,6 +162,36 @@ runIncServerT s cont = do
   ref <- newRef $ IncServerState [] mempty s
   runReaderT (runIncServerT' cont) ref
 
+-- === Incremental function server ===
+
+-- If you just need something that computes a function incrementally and doesn't
+-- need to maintain any other state then this will do.
+
+data IncFunctionEvaluatorMsg da b db =
+   Subscribe_IFEM (SubscribeMsg b db)
+ | Update_IFEM da
+   deriving (Show)
+
+launchIncFunctionEvaluator
+  :: (IncState b db, Show da, MonadIO m)
+  => StateServer a da
+  -> (a -> (b,s))
+  -> (b -> s -> da -> (db, s))
+  -> m (StateServer b db)
+launchIncFunctionEvaluator server fInit fUpdate =
+  sliceMailbox Subscribe_IFEM <$> launchActor do
+    x0 <- subscribe Update_IFEM server
+    let (y0, s0) = fInit x0
+    flip evalStateT s0 $ runIncServerT y0 $ messageLoop \case
+      Subscribe_IFEM msg -> handleSubscribeMsg msg
+      Update_IFEM dx -> do
+        y <- getl It
+        s <- lift get
+        let (dy, s') = fUpdate y s dx
+        lift $ put s'
+        update dy
+        flushDiffs
+
 -- === Refs ===
 -- Just a wrapper around IORef lifted to `MonadIO`
 

src/lib/Err.hs

@@ -52,11 +52,11 @@ data Err =
    SearchFailure String      -- used as the identity for `Alternative` instances and for MonadFail.
  | InternalErr String
  | ParseErr  ParseErr
- | SyntaxErr SyntaxErr
- | NameErr   NameErr
- | TypeErr   TypeErr
+ | SyntaxErr SrcId SyntaxErr
+ | NameErr   SrcId NameErr
+ | TypeErr   SrcId TypeErr
  | RuntimeErr
- | MiscErr   MiscErr
+ | MiscErr MiscErr
    deriving (Show, Eq)
 
 type MsgStr  = String
@@ -161,14 +161,11 @@ data InfVarDesc =
 -- === ToErr class ===
 
 class ToErr a where
-  toErr :: a -> Err
+  toErr :: SrcId -> a -> Err
 
-instance ToErr Err where toErr = id
-instance ToErr ParseErr  where toErr = ParseErr
 instance ToErr SyntaxErr where toErr = SyntaxErr
 instance ToErr NameErr   where toErr = NameErr
 instance ToErr TypeErr   where toErr = TypeErr
-instance ToErr MiscErr   where toErr = MiscErr
 
 -- === Error messages ===
 
@@ -180,12 +177,12 @@ instance PrintableErr Err where
     SearchFailure s -> "Internal search failure: " ++ s
     InternalErr s -> "Internal compiler error: " ++ s ++ "\n" ++
       "Please report this at github.com/google-research/dex-lang/issues\n"
-    ParseErr   e -> "Parse error: "  ++ printErr e
-    SyntaxErr  e -> "Syntax error: " ++ printErr e
-    NameErr    e -> "Name error: "   ++ printErr e
-    TypeErr    e -> "Type error: "   ++ printErr e
-    MiscErr    e -> "Error: "        ++ printErr e
-    RuntimeErr   -> "Runtime error"
+    ParseErr    e -> "Parse error: "  ++ printErr e
+    SyntaxErr _ e -> "Syntax error: " ++ printErr e
+    NameErr   _ e -> "Name error: "   ++ printErr e
+    TypeErr   _ e -> "Type error: "   ++ printErr e
+    MiscErr     e -> "Error: "        ++ printErr e
+    RuntimeErr    -> "Runtime error"
 
 instance PrintableErr ParseErr where
   printErr = \case
@@ -257,7 +254,7 @@ instance PrintableErr TypeErr where
     PatternArityErr n1 n2 -> "unexpected number of pattern binders. Expected "   ++ show n1 ++ " but got " ++ show n2
     SumTypeCantFail               -> "sum type constructor in can't-fail pattern"
     PatTypeErr patTy rhsTy        -> "pattern is for a " ++ patTy ++ "but we're matching against a " ++ rhsTy
-    EliminationErr expected ty    -> "expected a " ++ expected ++ ". Got a: " ++ ty
+    EliminationErr expected ty    -> "expected a " ++ expected ++ ". Got: " ++ ty
     IllFormedCasePattern          -> "case patterns must start with a data constructor or variant pattern"
     NotAMethod method className   -> "unexpected method: " ++ method ++ " is not a method of " ++ className
     DuplicateMethod method        -> "duplicate method: " ++ method
@@ -468,7 +465,7 @@ instance Fallible HardFailM where
 -- === convenience layer ===
 
 throw :: (ToErr e, Fallible m) => SrcId -> e -> m a
-throw _ e = throwErr $ toErr e
+throw sid e = throwErr $ toErr sid e
 {-# INLINE throw #-}
 
 getCurrentCallStack :: () -> Maybe [String]

src/lib/Export.hs

@@ -48,11 +48,11 @@ prepareFunctionForExport :: (Mut n, Topper m)
 prepareFunctionForExport cc f = do
   naryPi <- case getType f of
     TyCon (Pi piTy) -> return piTy
-    _ -> throw rootSrcId $ MiscMiscErr "Only first-order functions can be exported"
+    _ -> throwErr $ MiscErr $ MiscMiscErr "Only first-order functions can be exported"
   sig <- liftExportSigM $ corePiToExportSig cc naryPi
   closedSig <- case hoistToTop sig of
     HoistFailure _ ->
-      throw rootSrcId $ MiscMiscErr $ "Types of exported functions have to be closed terms. Got: " ++ pprint naryPi
+      throwErr $ MiscErr $ MiscMiscErr $ "Types of exported functions have to be closed terms. Got: " ++ pprint naryPi
     HoistSuccess s -> return s
   f' <- liftBuilder $ buildCoreLam naryPi \xs -> naryApp (sink f) (toAtom <$> xs)
   fSimp <- simplifyTopFunction $ coreLamToTopLam f'
@@ -68,7 +68,7 @@ prepareSLamForExport cc f@(TopLam _ naryPi _) = do
   sig <- liftExportSigM $ simpPiToExportSig cc naryPi
   closedSig <- case hoistToTop sig of
     HoistFailure _ ->
-      throw rootSrcId $ MiscMiscErr $ "Types of exported functions have to be closed terms. Got: " ++ pprint naryPi
+      throwErr $ MiscErr $ MiscMiscErr $ "Types of exported functions have to be closed terms. Got: " ++ pprint naryPi
     HoistSuccess s -> return s
   fImp <- compileTopLevelFun cc f
   nativeFun <- toCFunction "userFunc" fImp >>= emitObjFile >>= loadObject
@@ -105,15 +105,15 @@ corePiToExportSig :: CallingConvention
 corePiToExportSig cc (CorePiType _ expls tbs (EffTy effs resultTy)) = do
     case effs of
       Pure -> return ()
-      _    -> throw rootSrcId $ MiscMiscErr "Only pure functions can be exported"
+      _    -> throwErr $ MiscErr $ MiscMiscErr "Only pure functions can be exported"
     goArgs cc Empty [] (zipAttrs expls tbs) resultTy
 
 simpPiToExportSig :: CallingConvention
   -> PiType SimpIR i -> ExportSigM SimpIR i o (ExportedSignature o)
 simpPiToExportSig cc (PiType bs (EffTy effs resultTy)) = do
   case effs of
     Pure -> return ()
-    _    -> throw rootSrcId $ MiscMiscErr "Only pure functions can be exported"
+    _    -> throwErr $ MiscErr $ MiscMiscErr "Only pure functions can be exported"
   bs' <- return $ fmapNest (\b -> WithAttrB Explicit b) bs
   goArgs cc Empty [] bs' resultTy
 
@@ -164,7 +164,7 @@ toExportType ty = case ty of
     Nothing  -> unsupported
     Just ety -> return ety
   _ -> unsupported
-  where unsupported = throw rootSrcId $ MiscMiscErr $ "Unsupported type of argument in exported function: " ++ pprint ty
+  where unsupported = throwErr $ MiscErr $ MiscMiscErr $ "Unsupported type of argument in exported function: " ++ pprint ty
 {-# INLINE toExportType #-}
 
 parseTabTy :: IRRep r => Type r i -> ExportSigM r i o (Maybe (ExportType o))

src/lib/IncState.hs

@@ -9,7 +9,7 @@
 module IncState (
   IncState (..), MapEltUpdate (..), MapUpdate (..),
   Overwrite (..), TailUpdate (..), Unchanging (..), Overwritable (..),
-  mapUpdateMapWithKey) where
+  mapUpdateMapWithKey, MonoidState (..)) where
 
 import Data.Aeson (ToJSON, ToJSONKey)
 import qualified Data.Map.Strict as M
@@ -122,6 +122,12 @@ instance IncState (Overwritable a) (Overwrite a) where
     NoChange         -> s
     OverwriteWith s' -> Overwritable s'
 
+-- Case when the diff and the state are the same
+newtype MonoidState a = MonoidState a
+
+instance Monoid a => IncState (MonoidState a) a where
+  applyDiff (MonoidState d) d' = MonoidState $ d <> d'
+
 
 -- Trivial diff that works for any type - just replace the old value with a completely new one.
 newtype Unchanging a = Unchanging { fromUnchanging :: a } deriving (Show, Eq, Ord)

src/lib/Inference.hs

@@ -2087,7 +2087,7 @@ trySynthTerm sid ty reqMethodAccess = do
   hasInferenceVars ty >>= \case
     True -> throw sid $ CantSynthInfVars $ pprint ty
     False -> withVoidSubst do
-      synthTy <- liftExcept $ typeAsSynthType ty
+      synthTy <- liftExcept $ typeAsSynthType sid ty
       synthTerm sid synthTy reqMethodAccess
         <|> (throw sid $ CantSynthDict $ pprint ty)
 {-# SCC trySynthTerm #-}
@@ -2126,15 +2126,15 @@ extendGivens newGivens cont = do
 {-# INLINE extendGivens #-}
 
 getSynthType :: SynthAtom n -> SynthType n
-getSynthType x = ignoreExcept $ typeAsSynthType (getType x)
+getSynthType x = ignoreExcept $ typeAsSynthType rootSrcId (getType x)
 {-# INLINE getSynthType #-}
 
-typeAsSynthType :: CType n -> Except (SynthType n)
-typeAsSynthType = \case
+typeAsSynthType :: SrcId -> CType n -> Except (SynthType n)
+typeAsSynthType sid = \case
   TyCon (DictTy dictTy) -> return $ SynthDictType dictTy
   TyCon (Pi (CorePiType ImplicitApp expls bs (EffTy Pure (TyCon (DictTy d))))) ->
     return $ SynthPiType (expls, Abs bs d)
-  ty -> Failure $ toErr $ NotASynthType $ pprint ty
+  ty -> Failure $ toErr sid $ NotASynthType $ pprint ty
 {-# SCC typeAsSynthType #-}
 
 getSuperclassClosure :: EnvReader m => Givens n -> [SynthAtom n] -> m n (Givens n)
@@ -2259,7 +2259,7 @@ emptyMixedArgs = ([], [])
 
 typeErrAsSearchFailure :: InfererM i n a -> InfererM i n a
 typeErrAsSearchFailure cont = cont `catchErr` \case
-  TypeErr _ -> empty
+  TypeErr _ _ -> empty
   e -> throwErr e
 
 synthDictForData :: forall i n. SrcId -> DictType n -> InfererM i n (SynthAtom n)

src/lib/Lexing.hs

@@ -44,7 +44,7 @@ type Parser = StateT ParseCtx (Parsec Void Text)
 
 parseit :: Text -> Parser a -> Except a
 parseit s p = case parse (fst <$> runStateT p initParseCtx) "" s of
-  Left e  -> throw rootSrcId $ MiscParseErr $ errorBundlePretty e
+  Left e  -> throwErr $ ParseErr $ MiscParseErr $ errorBundlePretty e
   Right x -> return x
 
 mustParseit :: Text -> Parser a -> a

src/lib/Live/Eval.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 
 module Live.Eval (
-  watchAndEvalFile, EvalServer, EvalUpdate, CellsUpdate, fmapCellsUpdate,
+  watchAndEvalFile, EvalServer, EvalUpdate, CellsState, CellsUpdate, fmapCellsUpdate,
   NodeList (..), NodeListUpdate (..), subscribeIO, nodeListAsUpdate) where
 
 import Control.Concurrent

src/lib/Live/Web.hs

@@ -22,16 +22,18 @@ import qualified Data.ByteString as BS
 
 import Live.Eval
 import RenderHtml
+import IncState
+import Actor
 import TopLevel
 import Types.Source
 
 runWeb :: FilePath -> EvalConfig -> TopStateEx -> IO ()
 runWeb fname opts env = do
-  resultsChan <- watchAndEvalFile fname opts env
+  resultsChan <- watchAndEvalFile fname opts env >>= renderResults
   putStrLn "Streaming output to http://localhost:8000/"
   run 8000 $ serveResults resultsChan
 
-serveResults :: EvalServer -> Application
+serveResults :: RenderedResultsServer -> Application
 serveResults resultsSubscribe request respond = do
   print (pathInfo request)
   case pathInfo request of
@@ -50,14 +52,15 @@ serveResults resultsSubscribe request respond = do
       -- fname <- getDataFileName dataFname
       respond $ responseFile status200 [("Content-Type", ctype)] fname Nothing
 
-resultStream :: EvalServer -> StreamingBody
+type RenderedResultsServer = StateServer (MonoidState RenderedResults) RenderedResults
+type RenderedResults = CellsUpdate RenderedSourceBlock RenderedOutputs
+
+resultStream :: RenderedResultsServer -> StreamingBody
 resultStream resultsServer write flush = do
   sendUpdate ("start"::String)
-  (initResult, resultsChan) <- subscribeIO resultsServer
-  sendUpdate $ renderEvalUpdate $ nodeListAsUpdate initResult
-  forever do
-    nextUpdate <- readChan resultsChan
-    sendUpdate $ renderEvalUpdate nextUpdate
+  (MonoidState initResult, resultsChan) <- subscribeIO resultsServer
+  sendUpdate initResult
+  forever $ readChan resultsChan >>= sendUpdate
   where
     sendUpdate :: ToJSON a => a -> IO ()
     sendUpdate x = write (fromByteString $ encodePacket x) >> flush
@@ -66,6 +69,11 @@ encodePacket :: ToJSON a => a -> BS.ByteString
 encodePacket = toStrict . wrap . encode
   where wrap s = "data:" <> s <> "\n\n"
 
+renderResults :: EvalServer -> IO RenderedResultsServer
+renderResults evalServer = launchIncFunctionEvaluator evalServer
+   (\x -> (MonoidState $ renderEvalUpdate $ nodeListAsUpdate x, ()))
+   (\_ () dx -> (renderEvalUpdate dx, ()))
+
 renderEvalUpdate :: CellsUpdate SourceBlock Outputs -> CellsUpdate RenderedSourceBlock RenderedOutputs
 renderEvalUpdate cellsUpdate = fmapCellsUpdate cellsUpdate
   (\k b -> renderSourceBlock k b)