lsp: Also typecheck

1 files changed, 35 insertions, 24 deletions

diff --git a/lsp/Main.hs b/lsp/Main.hs
index 1784aec..d1da888 100644
--- a/lsp/Main.hs
+++ b/lsp/Main.hs
@@ -17,37 +17,48 @@ import Language.LSP.Server
 
 import qualified HSVIS.Diagnostic as HV
 import qualified HSVIS.Parser as HV
+import qualified HSVIS.Typecheck as HV
 
 
-parseFile :: NormalizedUri -> T.Text -> [Diagnostic]
+mkDiag :: HV.Diagnostic -> Diagnostic
+mkDiag msg = Diagnostic
+  { _range =
+      let -- TODO: col needs to be UTF-16 based, which this is not
+          mkPos (HV.Pos line col) = Position (fromIntegral line) (fromIntegral col)
+          HV.Range from to = HV.dRange msg
+      in Range (mkPos from) (mkPos to)
+  , _severity = Just DiagnosticSeverity_Error
+  , _code = Nothing
+  , _codeDescription = Nothing
+  , _source = Just "hs-vis"
+  , _message = T.pack $ intercalate "\n" $
+      HV.dMsg msg : ["In " ++ entry | entry <- reverse (HV.dStk msg)]
+  , _tags = Nothing
+  , _relatedInformation = Nothing
+  , _data_ = Nothing
+  }
+
+parseFile :: NormalizedUri -> T.Text -> ([Diagnostic], Maybe HV.PProgram)
 parseFile (NormalizedUri _ fpath) source =
-  let (errs, _) = HV.parse (T.unpack fpath) (T.unpack source)
-  in map mkDiag errs
-  where
-    mkDiag :: HV.Diagnostic -> Diagnostic
-    mkDiag msg = Diagnostic
-      { _range =
-          let -- TODO: col needs to be UTF-16 based, which this is not
-              mkPos (HV.Pos line col) = Position (fromIntegral line) (fromIntegral col)
-              HV.Range from to = HV.dRange msg
-          in Range (mkPos from) (mkPos to)
-      , _severity = Just DiagnosticSeverity_Error
-      , _code = Nothing
-      , _codeDescription = Nothing
-      , _source = Just "hs-vis"
-      , _message = T.pack $ intercalate "\n" $
-          HV.dMsg msg : ["In " ++ entry | entry <- reverse (HV.dStk msg)]
-      , _tags = Nothing
-      , _relatedInformation = Nothing
-      , _data_ = Nothing
-      }
+  let (errs, mpprog) = HV.parse (T.unpack fpath) (T.unpack source)
+  in (map mkDiag errs, mpprog)
+
+typecheckFile :: NormalizedUri -> T.Text -> HV.PProgram -> ([Diagnostic], HV.TProgram)
+typecheckFile (NormalizedUri _ fpath) source pprog =
+  let (errs, tprog) = HV.typecheck (T.unpack fpath) (T.unpack source) pprog
+  in (map mkDiag errs, tprog)
 
 publishDiagsForUri :: Uri -> LspM () ()
 publishDiagsForUri fileUri = do
-  getVirtualFile (toNormalizedUri fileUri) >>= \case
+  let filename = toNormalizedUri fileUri
+  getVirtualFile filename >>= \case
     Just vfile -> do
-      let diags = parseFile (toNormalizedUri fileUri)
-                            (Rope.toText (vfile ^. L.file_text))
+      let source = Rope.toText (vfile ^. L.file_text)
+      let (diags1, mpprog) = parseFile filename source
+      let (diags2, _mtprog) = case mpprog of Just pprog -> Just <$> typecheckFile filename source pprog
+                                             Nothing -> ([], Nothing)
+      let diags = diags1 ++ diags2
+
       -- liftIO $ appendFile "/home/tom/hsvislsplog.txt" ("  -> publishing diags: " ++ show diags ++ "\n")
       sendNotification SMethod_TextDocumentPublishDiagnostics PublishDiagnosticsParams
         { _uri = fileUri