Fix dying on broken code and handle errors in Main.hs

src/test/contracts/negative/fail1.ligo

@@ -0,0 +1,6 @@
+function hello (const x : int) : return is
+  block {
+      const boom : int =
+        if boom > x
+        else x;
+  } with boom

src/test/contracts/negative/fail2.ligo

@@ -0,0 +1,4 @@
+function hello (const x : int) : return
+  block {
+      const boom : int = x
+  } with boom

tools/lsp/squirrel/app/Main.hs

@@ -1,15 +1,16 @@
 
 import           Control.Concurrent
 import           Control.Concurrent.STM
-import           Control.Exception as E
+import           Control.Exception                     as E
 import           Control.Lens
 import           Control.Monad
 
 import           Data.Default
 -- import           Data.Foldable
 import qualified Data.Text                             as Text
-import           Data.Text                               (Text)
+import           Data.Text                                     (Text)
-import           Data.String.Interpolate (i)
+import           Data.String                                   (fromString)
+import           Data.String.Interpolate                       (i)
 
 import qualified Language.Haskell.LSP.Control          as CTRL
 import qualified Language.Haskell.LSP.Core             as Core
@@ -27,8 +28,8 @@ import           Parser
 import           ParseTree
 import           Range
 import           Product
-import           AST hiding (def)
+import           AST                                           hiding (def)
-import qualified AST.Find as Find
+import qualified AST.Find                              as Find
 import           Error
 
 main :: IO ()
@@ -157,34 +158,43 @@ eventLoop funs chan = do
           (Just 0)
 
       ReqDefinition req -> do
-        let uri = req^.J.params.J.textDocument.J.uri
+        stopDyingAlready funs req do
-        let pos = posToRange $ req^.J.params.J.position
+          let uri = req^.J.params.J.textDocument.J.uri
-        tree <- loadByURI uri
+          let pos = posToRange $ req^.J.params.J.position
-        case Find.definitionOf pos tree of
+          tree <- loadByURI uri
-          Just defPos -> do
+          case Find.definitionOf pos tree of
-            respondWith req RspDefinition $ J.MultiLoc [J.Location uri $ rangeToLoc defPos]
+            Just defPos -> do
-          Nothing -> do
+              respondWith funs req RspDefinition $ J.MultiLoc [J.Location uri $ rangeToLoc defPos]
-            respondWith req RspDefinition $ J.MultiLoc []
+            Nothing -> do
+              respondWith funs req RspDefinition $ J.MultiLoc []
 
       ReqFindReferences req -> do
-        let uri = req^.J.params.J.textDocument.J.uri
+        stopDyingAlready funs req do
-        let pos = posToRange $ req^.J.params.J.position
+          let uri = req^.J.params.J.textDocument.J.uri
-        tree <- loadFromVFS funs uri
+          let pos = posToRange $ req^.J.params.J.position
-        case Find.referencesOf pos tree of
+          tree <- loadFromVFS funs uri
-          Just refs -> do
+          case Find.referencesOf pos tree of
-            let locations = J.Location uri . rangeToLoc <$> refs
+            Just refs -> do
-            respondWith req RspFindReferences $ J.List locations
+              let locations = J.Location uri . rangeToLoc <$> refs
-          Nothing -> do
+              respondWith funs req RspFindReferences $ J.List locations
-            respondWith req RspFindReferences $ J.List []
+            Nothing -> do
+              respondWith funs req RspFindReferences $ J.List []
 
       _ -> U.logs "unknown msg"
-  where
+
-    respondWith
+respondWith
-      :: J.RequestMessage J.ClientMethod req rsp
+  :: Core.LspFuncs ()
-      -> (J.ResponseMessage rsp -> FromServerMessage)
+  -> J.RequestMessage J.ClientMethod req rsp
-      -> rsp
+  -> (J.ResponseMessage rsp -> FromServerMessage)
-      -> IO ()
+  -> rsp
-    respondWith req wrap rsp = Core.sendFunc funs $ wrap $ Core.makeResponseMessage req rsp
+  -> IO ()
+respondWith funs req wrap rsp = Core.sendFunc funs $ wrap $ Core.makeResponseMessage req rsp
+
+stopDyingAlready :: Core.LspFuncs () -> J.RequestMessage m a b -> IO () -> IO ()
+stopDyingAlready funs req = flip catch \(e :: SomeException) -> do
+  Core.sendErrorResponseS (Core.sendFunc funs) (req^.J.id.to J.responseId) J.InternalError
+    $ fromString
+    $ "this happened: " ++ show e
 
 posToRange :: J.Position -> Range
 posToRange (J.Position l c) = Range (l + 1, c + 1, 0) (l + 1, c + 1, 0) ""

tools/lsp/squirrel/src/AST/Parser.hs

@@ -915,12 +915,12 @@ example :: FilePath
 -- example = "../../../src/test/contracts/bytes_arithmetic.ligo"
 -- example = "../../../src/test/contracts/bytes_unpack.ligo"
 -- example = "../../../src/test/contracts/chain_id.ligo"
-example = "../../../src/test/contracts/coase.ligo"
+-- example = "../../../src/test/contracts/coase.ligo"
 -- example = "../../../src/test/contracts/failwith.ligo"
 -- example = "../../../src/test/contracts/loop.ligo"
 -- example = "../../../src/test/contracts/redeclaration.ligo"
 -- example = "../../../src/test/contracts/includer.ligo"
 -- example = "../../../src/test/contracts/namespaces.ligo"
 -- example = "../../../src/test/contracts/blocks.ligo"
--- example = "../../../src/test/contracts/application.ligo"
+example = "../../../src/test/contracts/negative/fail1.ligo"
 -- example = "../../../src/test/contracts/application.ligo"

tools/lsp/squirrel/src/Parser.hs

@@ -94,7 +94,7 @@ import Debug.Trace
 --
 type Parser =
    WriterT [Error ASTInfo]
-  (StateT (Product PList)
+  (StateT  (Product PList)
    IO)
 
 type PList = [ParseForest, [Text], FilePath, Set.Set FilePath]
@@ -103,7 +103,8 @@ type PList = [ParseForest, [Text], FilePath, Set.Set FilePath]
 type ASTInfo = Product [Range, [Text]]
 
 runParser
-  :: Parser a
+  :: Stubbed a ASTInfo
+  => Parser a
   -> Source
   -> IO (a, [Error ASTInfo])
 runParser parser fin = do
@@ -117,9 +118,12 @@ runParser parser fin = do
     (Cons dir
     (Cons Set.empty
      Nil)))
+    `catch` \(e :: Error ASTInfo) -> do
+      return $ (stub e, [])
 
 runParser'
-  :: Parser a
+  :: Stubbed a ASTInfo
+  => Parser a
   -> Source
   -> IO a
 runParser' parser fin = fst <$> runParser parser fin
@@ -326,7 +330,7 @@ some p = some'
 
 -- | Run parser on given file and pretty-print stuff.
 --
-debugParser :: Show a => Parser a -> Source -> IO ()
+debugParser :: (Show a, Stubbed a ASTInfo) => Parser a -> Source -> IO ()
 debugParser parser fin = do
   (res, errs) <- runParser parser fin
   putStrLn "Result:"