diff options
| -rw-r--r-- | lsp/Main.hs | 59 |
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 |