From 6d483ef5a8e4d7eedd80d462c853dd6eadabe3e7 Mon Sep 17 00:00:00 2001 From: Serhii Khoma Date: Sun, 21 Dec 2025 20:09:44 +0700 Subject: [PATCH] feat: mm0-hs -> update to latest stack (but server command is disabled) --- mm0-hs/package.yaml | 9 +- mm0-hs/src/MM0/Compiler/Elaborator.hs | 2 + mm0-hs/src/MM0/Compiler/Env.hs | 1 + mm0-hs/src/MM0/Compiler/Export.hs | 6 +- mm0-hs/src/MM0/Compiler/MathParser.hs | 15 +- mm0-hs/src/MM0/Compiler/Parser.hs | 6 +- mm0-hs/src/MM0/Compiler/PositionInfo.hs | 1 - mm0-hs/src/MM0/Compiler/PrettyPrinter.hs | 5 +- mm0-hs/src/MM0/FromMM.hs | 3 +- mm0-hs/src/MM0/FromMM/Closure.hs | 1 + mm0-hs/src/MM0/FromMM/Emancipate.hs | 12 +- mm0-hs/src/MM0/FromMM/FindBundled.hs | 1 + mm0-hs/src/MM0/FromMM/Parser.hs | 3 +- mm0-hs/src/MM0/FrontEnd/Elaborator.hs | 1 + mm0-hs/src/MM0/FrontEnd/LocalContext.hs | 3 +- mm0-hs/src/MM0/FrontEnd/MathParser.hs | 1 + mm0-hs/src/MM0/FrontEnd/Parser.y | 2 + mm0-hs/src/MM0/FrontEnd/ParserEnv.hs | 1 + mm0-hs/src/MM0/FrontEnd/ProofTextParser.hs | 2 + mm0-hs/src/MM0/HOL/Check.hs | 27 +- mm0-hs/src/MM0/HOL/ToHol.hs | 2 +- mm0-hs/src/MM0/HOL/ToLean.hs | 3 +- mm0-hs/src/MM0/HOL/ToLisp.hs | 1 - mm0-hs/src/MM0/HOL/ToOpenTheory.hs | 1 + mm0-hs/src/MM0/Kernel/Types.hs | 4 +- mm0-hs/src/MM0/Kernel/Verifier.hs | 2 +- mm0-hs/src/MM0/Server.hs | 537 --------------------- mm0-hs/src/MM0/Server.hs_new_unfinished | 508 +++++++++++++++++++ mm0-hs/src/MM0/Server.hs_old | 508 +++++++++++++++++++ mm0-hs/src/MM0/Util.hs | 2 +- mm0-hs/src/Main.hs | 4 +- mm0-hs/stack.yaml | 64 +-- mm0-hs/stack.yaml.lock | 51 +- 33 files changed, 1142 insertions(+), 647 deletions(-) delete mode 100644 mm0-hs/src/MM0/Server.hs create mode 100644 mm0-hs/src/MM0/Server.hs_new_unfinished create mode 100644 mm0-hs/src/MM0/Server.hs_old diff --git a/mm0-hs/package.yaml b/mm0-hs/package.yaml index da52dcdf9..d6fdfbc2c 100644 --- a/mm0-hs/package.yaml +++ b/mm0-hs/package.yaml @@ -59,7 +59,14 @@ dependencies: - time - transformers - unordered-containers -- haskell-lsp +- lsp +- text-rope + +ghc-options: +- -Wall +# - -Wextra +# Uncomment the line below to treat all warnings as errors +# - -Werror default-extensions: - FlexibleContexts diff --git a/mm0-hs/src/MM0/Compiler/Elaborator.hs b/mm0-hs/src/MM0/Compiler/Elaborator.hs index 88383d473..6d24270ae 100644 --- a/mm0-hs/src/MM0/Compiler/Elaborator.hs +++ b/mm0-hs/src/MM0/Compiler/Elaborator.hs @@ -5,6 +5,8 @@ module MM0.Compiler.Elaborator (elaborate, elabLoad, ErrorLevel(..), ElabError(..), ElabConfig(..), toElabError) where import Control.Applicative ((<|>)) +import Data.Semigroup (Endo(..)) +import Control.Monad (forM, when, liftM2, liftM3, unless, mzero, (>=>), guard, zipWithM) import Control.Monad.State import Control.Monad.RWS.Strict import Control.Monad.Trans.Maybe diff --git a/mm0-hs/src/MM0/Compiler/Env.hs b/mm0-hs/src/MM0/Compiler/Env.hs index 5c40d97f3..03b00db0d 100644 --- a/mm0-hs/src/MM0/Compiler/Env.hs +++ b/mm0-hs/src/MM0/Compiler/Env.hs @@ -15,6 +15,7 @@ import Data.Bits import Data.Char import Data.Maybe import Data.Word8 +import Control.Monad (forM_, when, filterM, mzero, guard, void) import Data.Text (Text) import Data.Default import qualified Data.IntMap as I diff --git a/mm0-hs/src/MM0/Compiler/Export.hs b/mm0-hs/src/MM0/Compiler/Export.hs index fb9f57d07..ae6e1808e 100644 --- a/mm0-hs/src/MM0/Compiler/Export.hs +++ b/mm0-hs/src/MM0/Compiler/Export.hs @@ -1,14 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DeriveGeneric, DeriveTraversable, TypeFamilies #-} +{-# LANGUAGE DeriveGeneric, DeriveTraversable, TypeFamilies, TypeOperators #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} {-# HLINT ignore "Redundant <$>" #-} module MM0.Compiler.Export (export, exportK, exportKP) where import GHC.Generics (Generic) import Control.Applicative +import Control.Monad (unless, forM, zipWithM, liftM2, liftM3) import Control.Monad.State import Control.Monad.Except import Control.Monad.RWS.Strict +import Data.Semigroup (Endo(..)) import Data.Bits import Data.Default import Data.Foldable @@ -77,7 +79,7 @@ data ProofF a = | PLetF VarName a a | ProofF [(Maybe VarName, a)] Bool [(VarName, Sort)] a - deriving (Generic, Functor, Foldable, Traversable, Show) + deriving (Generic, Functor, Foldable, Traversable, Show, Eq) instance Hashable a => Hashable (ProofF a) where instance MuRef SExpr where diff --git a/mm0-hs/src/MM0/Compiler/MathParser.hs b/mm0-hs/src/MM0/Compiler/MathParser.hs index 692320dce..3b0cdc128 100644 --- a/mm0-hs/src/MM0/Compiler/MathParser.hs +++ b/mm0-hs/src/MM0/Compiler/MathParser.hs @@ -1,5 +1,6 @@ module MM0.Compiler.MathParser (parseMath, QExpr(..)) where +import Control.Monad.Trans.Class import Control.Monad import Control.Monad.State import Control.Monad.Reader @@ -7,7 +8,7 @@ import Data.Maybe import qualified Data.HashMap.Strict as H import qualified Data.IntMap as I import qualified Data.Text as T -import Text.Megaparsec hiding (runParser, unPos) +import Text.Megaparsec hiding (runParser, unPos, setErrorOffset) import Text.Megaparsec.Internal (ParsecT(..)) import MM0.Compiler.AST import MM0.Compiler.Env hiding (try) @@ -38,25 +39,25 @@ unquote = do lift $ QUnquote <$> lispVal token1 :: MathParser (Span T.Text) -token1 = ReaderT $ \pe -> ParsecT $ \s@(State t o pst) cok _ _ eerr -> +token1 = ReaderT $ \pe -> ParsecT $ \s@(State t o pst errs) cok _ _ eerr -> let - unspace t' o' = State t2 (o'+T.length t1) where + unspace t' o' = State t2 (o'+T.length t1) pst errs where (t1, t2) = T.span isSpace t' go t' i = case T.uncons t' of Nothing | i == 0 -> eerr (TrivialError (o+i) (pure EndOfInput) mempty) s | otherwise -> - cok (Span (o, o+i) (T.take i t)) (State t' (o+i) pst) mempty + cok (Span (o, o+i) (T.take i t)) (State t' (o+i) pst errs) mempty Just (c, t2) -> case delimVal (pDelims pe) c of 0 -> go t2 (i+1) 4 | i == 0 -> eerr (TrivialError o (Just (Tokens (pure c))) mempty) s | otherwise -> - cok (Span (o, o+i) (T.take i t)) (unspace t2 (o+i+1) pst) mempty + cok (Span (o, o+i) (T.take i t)) (unspace t2 (o+i+1)) mempty d | isRightDelim d && i /= 0 -> - cok (Span (o, o+i) (T.take i t)) (unspace t' (o+i) pst) mempty + cok (Span (o, o+i) (T.take i t)) (unspace t' (o+i)) mempty | isLeftDelim d -> - cok (Span (o, o+i+1) (T.take (i+1) t)) (unspace t2 (o+i+1) pst) mempty + cok (Span (o, o+i+1) (T.take (i+1) t)) (unspace t2 (o+i+1)) mempty | otherwise -> go t2 (i+1) in go t 0 diff --git a/mm0-hs/src/MM0/Compiler/Parser.hs b/mm0-hs/src/MM0/Compiler/Parser.hs index b7be63051..43334d8fa 100644 --- a/mm0-hs/src/MM0/Compiler/Parser.hs +++ b/mm0-hs/src/MM0/Compiler/Parser.hs @@ -7,7 +7,7 @@ module MM0.Compiler.Parser (parseAST, runParser, PosState(..), import Prelude hiding (span) import Control.Applicative hiding (many, some, (<|>), Const) -import Control.Monad +import Control.Monad (liftM3, liftM4, void) import Control.Monad.State.Class import qualified Control.Monad.Trans.State as ST import Data.Void @@ -20,7 +20,7 @@ import Text.Megaparsec.Char import qualified Data.Set as S import qualified Data.Vector as V import qualified Data.Text as T -import qualified Text.Builder as TB +import qualified TextBuilder as TB import qualified Text.Megaparsec.Char.Lexer as L import MM0.Compiler.AST import MM0.Util @@ -329,7 +329,7 @@ importStmt :: Parser (Maybe (Span Stmt)) importStmt = mSpan (kw "import" >> commit (Import <$> lexeme (span strLit))) strLit :: Parser T.Text -strLit = single '"' *> (TB.run <$> p) where +strLit = single '"' *> (TB.toText <$> p) where p = do toks <- TB.text <$> takeWhileP (Just "end of string") (\c -> c /= '\\' && c /= '"') diff --git a/mm0-hs/src/MM0/Compiler/PositionInfo.hs b/mm0-hs/src/MM0/Compiler/PositionInfo.hs index ef8a824c9..289c010a1 100644 --- a/mm0-hs/src/MM0/Compiler/PositionInfo.hs +++ b/mm0-hs/src/MM0/Compiler/PositionInfo.hs @@ -18,7 +18,6 @@ import qualified Data.Vector.Mutable.Dynamic as VD import qualified Data.Text as T import MM0.Compiler.AST import MM0.Compiler.Env -import MM0.Kernel.Environment (VarName) type Lines = V.Vector Offset diff --git a/mm0-hs/src/MM0/Compiler/PrettyPrinter.hs b/mm0-hs/src/MM0/Compiler/PrettyPrinter.hs index 70daa3dd2..b90de8659 100644 --- a/mm0-hs/src/MM0/Compiler/PrettyPrinter.hs +++ b/mm0-hs/src/MM0/Compiler/PrettyPrinter.hs @@ -4,7 +4,6 @@ module MM0.Compiler.PrettyPrinter (PP, doc, dlift, ppExpr, render, render', renderNoBreak, ppExpr', (<+>), unifyErr, getStat, ppMVar, ppExprCyc, ppStmt, ppBinder, ppPBinder, ppGroupedBinders, ppDecl, ppDeclType) where -import Control.Applicative import Control.Concurrent.STM import Control.Monad.State import Data.Void @@ -12,8 +11,8 @@ import Data.List (elemIndex) import Data.Maybe import Data.Functor import Data.Foldable -import Data.Text.Prettyprint.Doc hiding (lparen, rparen) -import Data.Text.Prettyprint.Doc.Render.Text +import Prettyprinter hiding (lparen, rparen) +import Prettyprinter.Render.Text import qualified Data.HashMap.Strict as H import qualified Data.Vector as V import qualified Data.Vector.Mutable.Dynamic as VD diff --git a/mm0-hs/src/MM0/FromMM.hs b/mm0-hs/src/MM0/FromMM.hs index 4309ba69f..adf2db5cc 100644 --- a/mm0-hs/src/MM0/FromMM.hs +++ b/mm0-hs/src/MM0/FromMM.hs @@ -5,6 +5,7 @@ import System.Exit import Control.Monad import Control.Monad.State import Control.Monad.RWS.Strict +import Data.Semigroup (Endo(..)) import Data.Foldable import Data.Maybe import Data.Either @@ -25,7 +26,7 @@ import MM0.FromMM.Emancipate import MM0.FromMM.Closure import MM0.FromMM.FindBundled import MM0.Kernel.Environment (Ident, DepType(..), SExpr(..), PBinder(..), - VarName, TermName, ThmName, Comment, WithComment(..)) + VarName, TermName, ThmName, Comment) import MM0.Kernel.Types as K import MM0.Compiler.Export (exportKP) import qualified MM0.FrontEnd.AST as A diff --git a/mm0-hs/src/MM0/FromMM/Closure.hs b/mm0-hs/src/MM0/FromMM/Closure.hs index f76be795c..ba1e1d806 100644 --- a/mm0-hs/src/MM0/FromMM/Closure.hs +++ b/mm0-hs/src/MM0/FromMM/Closure.hs @@ -1,6 +1,7 @@ module MM0.FromMM.Closure (closure) where import Control.Monad.State +import Control.Monad (when) import Data.Bifunctor import qualified Data.Set as S import qualified Data.Text as T diff --git a/mm0-hs/src/MM0/FromMM/Emancipate.hs b/mm0-hs/src/MM0/FromMM/Emancipate.hs index caade4d36..6169a5a77 100644 --- a/mm0-hs/src/MM0/FromMM/Emancipate.hs +++ b/mm0-hs/src/MM0/FromMM/Emancipate.hs @@ -42,7 +42,9 @@ checkExpr db hy = modify . checkExpr' where checkExpr' :: MMExpr -> S.Set Label -> S.Set Label checkExpr' (SVar v) = if hy then S.insert v else id checkExpr' (App t es) = checkApp hs es where - Term _ (hs, _) _ _ = snd $ getStmt db t + hs = case snd $ getStmt db t of + Term _ (x, _) _ _ -> x + _ -> error "Emancipate: expected Term" checkApp :: [(VarStatus, Label)] -> [MMExpr] -> S.Set Label -> S.Set Label checkApp [] [] = id @@ -54,9 +56,13 @@ checkProof :: MMDatabase -> MMProof -> State (S.Set Label) () checkProof db = modify . checkProof' where checkProof' :: MMProof -> S.Set Label -> S.Set Label checkProof' (PTerm t ps) = checkApp hs ps where - Term _ (hs, _) _ _ = snd $ getStmt db t + hs = case snd $ getStmt db t of + Term _ (x, _) _ _ -> x + _ -> error "Emancipate: expected Term" checkProof' (PThm t ps) = checkApp hs ps where - Thm _ (hs, _) _ _ = snd $ getStmt db t + hs = case snd $ getStmt db t of + Thm _ (x, _) _ _ -> x + _ -> error "Emancipate: expected Thm" checkProof' (PSave p) = checkProof' p checkProof' _ = id diff --git a/mm0-hs/src/MM0/FromMM/FindBundled.hs b/mm0-hs/src/MM0/FromMM/FindBundled.hs index 24a7c8dfb..ffda37178 100644 --- a/mm0-hs/src/MM0/FromMM/FindBundled.hs +++ b/mm0-hs/src/MM0/FromMM/FindBundled.hs @@ -1,5 +1,6 @@ module MM0.FromMM.FindBundled (findBundled, bundle, reportBundled, Bundles) where +import Control.Monad import Control.Monad.RWS.Strict import qualified Data.Map.Strict as M import qualified Data.IntMap as I diff --git a/mm0-hs/src/MM0/FromMM/Parser.hs b/mm0-hs/src/MM0/FromMM/Parser.hs index 19190a9a1..fb692f550 100644 --- a/mm0-hs/src/MM0/FromMM/Parser.hs +++ b/mm0-hs/src/MM0/FromMM/Parser.hs @@ -1,6 +1,7 @@ module MM0.FromMM.Parser (parseMM) where -import Data.List +import Control.Monad +import Control.Monad.Trans.Class import Data.Char import Data.Maybe import Data.Default diff --git a/mm0-hs/src/MM0/FrontEnd/Elaborator.hs b/mm0-hs/src/MM0/FrontEnd/Elaborator.hs index 58e5c4f85..d24a31d7c 100644 --- a/mm0-hs/src/MM0/FrontEnd/Elaborator.hs +++ b/mm0-hs/src/MM0/FrontEnd/Elaborator.hs @@ -1,5 +1,6 @@ module MM0.FrontEnd.Elaborator (elabAST) where +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State import Control.Monad.Except import Data.Maybe diff --git a/mm0-hs/src/MM0/FrontEnd/LocalContext.hs b/mm0-hs/src/MM0/FrontEnd/LocalContext.hs index 3f17f273c..440d3a44d 100644 --- a/mm0-hs/src/MM0/FrontEnd/LocalContext.hs +++ b/mm0-hs/src/MM0/FrontEnd/LocalContext.hs @@ -1,8 +1,9 @@ module MM0.FrontEnd.LocalContext where +import Control.Monad (void) +import Control.Monad.Trans.Class import Control.Applicative import Control.Monad.Trans.Reader -import Control.Monad.Except import Data.Maybe import qualified Data.Map.Strict as M import qualified Data.Text as T diff --git a/mm0-hs/src/MM0/FrontEnd/MathParser.hs b/mm0-hs/src/MM0/FrontEnd/MathParser.hs index b301c9d9a..08803fcc9 100644 --- a/mm0-hs/src/MM0/FrontEnd/MathParser.hs +++ b/mm0-hs/src/MM0/FrontEnd/MathParser.hs @@ -2,6 +2,7 @@ {-# HLINT ignore "Eta reduce" #-} module MM0.FrontEnd.MathParser (parseFormula, parseFormulaProv, appPrec) where +import Control.Monad.Trans.Class (lift) import Control.Monad.Except import Control.Monad.Trans.State import Control.Monad.Reader.Class diff --git a/mm0-hs/src/MM0/FrontEnd/Parser.y b/mm0-hs/src/MM0/FrontEnd/Parser.y index 45f59160d..6671b44e5 100644 --- a/mm0-hs/src/MM0/FrontEnd/Parser.y +++ b/mm0-hs/src/MM0/FrontEnd/Parser.y @@ -1,5 +1,7 @@ { module MM0.FrontEnd.Parser (ParseError(..), parse) where + +import Control.Monad import MM0.FrontEnd.AST import MM0.FrontEnd.Lexer import Control.Monad.Except diff --git a/mm0-hs/src/MM0/FrontEnd/ParserEnv.hs b/mm0-hs/src/MM0/FrontEnd/ParserEnv.hs index 581477025..5440348aa 100644 --- a/mm0-hs/src/MM0/FrontEnd/ParserEnv.hs +++ b/mm0-hs/src/MM0/FrontEnd/ParserEnv.hs @@ -4,6 +4,7 @@ module MM0.FrontEnd.ParserEnv (Token, NotaInfo(..), addNotation, recalcCoeProv, tokenize, getCoe, getCoeProv) where +import Control.Monad.Trans.Class import Control.Monad.Except import Control.Monad.Trans.State import Control.Applicative ((<|>)) diff --git a/mm0-hs/src/MM0/FrontEnd/ProofTextParser.hs b/mm0-hs/src/MM0/FrontEnd/ProofTextParser.hs index 76dd5a876..00794c265 100644 --- a/mm0-hs/src/MM0/FrontEnd/ProofTextParser.hs +++ b/mm0-hs/src/MM0/FrontEnd/ProofTextParser.hs @@ -2,8 +2,10 @@ -- Intended mainly for debugging. module MM0.FrontEnd.ProofTextParser (parseProof, parseProofOrDie) where +import Data.Semigroup (Endo(..)) import Control.Applicative hiding (many, (<|>)) import Control.Monad.Trans.Class +import Control.Monad (liftM4, guard) import Control.Monad.State import Control.Monad.Writer import Data.Word8 diff --git a/mm0-hs/src/MM0/HOL/Check.hs b/mm0-hs/src/MM0/HOL/Check.hs index be4dc40ca..ea61bd3e2 100644 --- a/mm0-hs/src/MM0/HOL/Check.hs +++ b/mm0-hs/src/MM0/HOL/Check.hs @@ -1,11 +1,11 @@ module MM0.HOL.Check where -import Control.Monad.Except +import Control.Monad.Trans.Class (lift) +import Control.Monad import Control.Monad.Trans.State import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T -import MM0.Kernel.Environment (Ident, WithComment(..)) import MM0.HOL.Types import MM0.Util @@ -50,22 +50,24 @@ addDecl gctx = addDecl' where addDecl' :: HDecl -> Either String GlobalCtx addDecl' (HDSort s) = do - guard (S.notMember s (gSorts gctx)) + guardError ("sort '" ++ T.unpack s ++ "' already declared") (S.notMember s (gSorts gctx)) return $ gctx {gSorts = S.insert s (gSorts gctx)} addDecl' (HDTerm x t) = do - guard (M.notMember x (gTerms gctx)) + guardError ("term '" ++ T.unpack x ++ "' already declared") (M.notMember x (gTerms gctx)) return $ gctx {gTerms = M.insert x t (gTerms gctx)} addDecl' (HDDef x ts ss r e) = do - guard (M.notMember x (gTerms gctx)) + guardError ("term '" ++ T.unpack x ++ "' already declared") (M.notMember x (gTerms gctx)) let ctx = mkLC ts ss - withContext x $ inferTerm ctx e >>= guard . (r ==) + withContext x $ do + t <- inferTerm ctx e + guardError ("def type mismatch: " ++ show r ++ " != " ++ show t) (r == t) return $ gctx { gTerms = M.insert x (HType (snd <$> ts) (SType (snd <$> ss) r)) (gTerms gctx), gDefs = M.insert x (HDef ts ss r e) (gDefs gctx) } addDecl' (HDThm x t@(TType ts hs (GType ss r)) pr) = do - guard (M.notMember x (gThms gctx)) + guardError ("thm '" ++ T.unpack x ++ "' already declared") (M.notMember x (gThms gctx)) withContext x $ forM_ pr $ \(vs, p) -> do - guard (length vs == length hs) + guardError "arg length mismatch" (length vs == length hs) let ctx = mkLC ts ss r' <- evalStateT (inferProof ctx p) (M.fromList (zip vs hs)) guardError ("result does not match theorem statement:\n " ++ @@ -90,7 +92,7 @@ addDecl gctx = addDecl' where guard (ts == ts') mapM (lcLVar ctx) vs >>= guard . (ss ==) return r - inferTerm _ HTSorry = fail "sorry found" + inferTerm _ HTSorry = error "sorry found" inferSLam :: LocalCtx -> SLam -> Either String SType inferSLam ctx (SLam ss t) = SType (snd <$> ss) <$> go ctx ss where @@ -147,9 +149,10 @@ addDecl gctx = addDecl' where return t inferProof ctx (HConv eq p) = do (t1, t2, _) <- inferConv ctx eq - inferProof ctx p >>= guard . (t1 ==) + t <- inferProof ctx p + guardError ("conv mismatch: " ++ show t1 ++ " != " ++ show t) (t1 == t) return t2 - inferProof _ HSorry = fail "sorry found" + inferProof _ HSorry = error "sorry found" inferConvLam :: LocalCtx -> HConvLam -> ProofM (SLam, SLam, SType) inferConvLam ctx (HConvLam ss p) = do @@ -170,7 +173,7 @@ addDecl gctx = addDecl' where inferConv ctx (CTrans p1 p2) = do (e1, e2, r) <- inferConv ctx p1 (e2', e3, _) <- inferConv ctx p2 - guard (e2 == e2') + guardError ("trans mismatch: " ++ show e2 ++ " != " ++ show e2') (e2 == e2') return (e1, e3, r) inferConv ctx c@(CCong t ps xs) = do (es, es', ts') <- unzip3 <$> mapM (inferConvLam ctx) ps diff --git a/mm0-hs/src/MM0/HOL/ToHol.hs b/mm0-hs/src/MM0/HOL/ToHol.hs index 3d6e8d2a5..0d0816a55 100644 --- a/mm0-hs/src/MM0/HOL/ToHol.hs +++ b/mm0-hs/src/MM0/HOL/ToHol.hs @@ -1,9 +1,9 @@ module MM0.HOL.ToHol where +import Data.Semigroup (Endo(..)) import Control.Monad.RWS.Strict hiding (local, asks) import Control.Monad.Trans.Reader import Data.Maybe -import Data.Foldable import qualified Data.Map.Strict as M import qualified Data.Set as S import MM0.HOL.Types diff --git a/mm0-hs/src/MM0/HOL/ToLean.hs b/mm0-hs/src/MM0/HOL/ToLean.hs index db1250c21..e8cbdcebe 100644 --- a/mm0-hs/src/MM0/HOL/ToLean.hs +++ b/mm0-hs/src/MM0/HOL/ToLean.hs @@ -1,6 +1,7 @@ module MM0.HOL.ToLean (writeLean, Axioms(..)) where import Data.Foldable +import Control.Monad import Data.Maybe import System.FilePath import System.IO @@ -10,7 +11,7 @@ import Control.Monad.State.Strict import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T -import MM0.Kernel.Environment (Ident, Comment) +import MM0.Kernel.Environment (Comment) import MM0.HOL.Types import MM0.Util diff --git a/mm0-hs/src/MM0/HOL/ToLisp.hs b/mm0-hs/src/MM0/HOL/ToLisp.hs index 9b8171983..b2ce7ea95 100644 --- a/mm0-hs/src/MM0/HOL/ToLisp.hs +++ b/mm0-hs/src/MM0/HOL/ToLisp.hs @@ -1,7 +1,6 @@ module MM0.HOL.ToLisp where import qualified Data.Text as T -import MM0.Kernel.Environment (Ident, WithComment(..)) import MM0.HOL.Types class ToLisp a where diff --git a/mm0-hs/src/MM0/HOL/ToOpenTheory.hs b/mm0-hs/src/MM0/HOL/ToOpenTheory.hs index b85beb06c..8a7fed23e 100644 --- a/mm0-hs/src/MM0/HOL/ToOpenTheory.hs +++ b/mm0-hs/src/MM0/HOL/ToOpenTheory.hs @@ -2,6 +2,7 @@ module MM0.HOL.ToOpenTheory (writeOT, otToString) where import Prelude hiding (log) +import Control.Monad import Data.Default import Data.Semigroup import Control.Monad.Reader diff --git a/mm0-hs/src/MM0/Kernel/Types.hs b/mm0-hs/src/MM0/Kernel/Types.hs index 4d4c9d2cc..62f709fb6 100644 --- a/mm0-hs/src/MM0/Kernel/Types.hs +++ b/mm0-hs/src/MM0/Kernel/Types.hs @@ -4,8 +4,8 @@ module MM0.Kernel.Types ( import qualified Data.Text as T import Data.Maybe import Data.Void -import Data.Text.Prettyprint.Doc -import Data.Text.Prettyprint.Doc.Render.String +import Prettyprinter +import Prettyprinter.Render.String import MM0.Kernel.Environment newtype VInoutKind = VIKString Bool -- ^ False for input, True for output diff --git a/mm0-hs/src/MM0/Kernel/Verifier.hs b/mm0-hs/src/MM0/Kernel/Verifier.hs index 2f16a9d6d..ac75ad709 100644 --- a/mm0-hs/src/MM0/Kernel/Verifier.hs +++ b/mm0-hs/src/MM0/Kernel/Verifier.hs @@ -1,10 +1,10 @@ module MM0.Kernel.Verifier (verify) where import Control.Monad +import Data.Semigroup (Endo(..)) import Control.Monad.Except import Control.Monad.RWS.Strict import Data.Word -import Data.List import Data.Bits import Data.Char import Data.Default diff --git a/mm0-hs/src/MM0/Server.hs b/mm0-hs/src/MM0/Server.hs deleted file mode 100644 index 58c2adbc0..000000000 --- a/mm0-hs/src/MM0/Server.hs +++ /dev/null @@ -1,537 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Redundant <$>" #-} -module MM0.Server (server) where - -import Control.Concurrent -import Control.Concurrent.Async -import Control.Concurrent.STM -import qualified Control.Exception as E -import Control.Lens ((^.)) -import Control.Monad.Reader -import Data.Default -import Data.List -import Data.Maybe -import qualified Data.Aeson as A -import qualified Data.HashMap.Strict as H -import qualified Data.Vector as V -import qualified Data.Vector.Mutable.Dynamic as VD -import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Language.Haskell.LSP.Control as Ctrl (run) -import Language.Haskell.LSP.Core -import Language.Haskell.LSP.Diagnostics -import Language.Haskell.LSP.Messages -import Language.Haskell.LSP.Types -import qualified Language.Haskell.LSP.Types.Lens as J -import Language.Haskell.LSP.VFS -import Network.URI -import System.IO.Error -import System.Timeout -import System.Exit -import qualified System.Log.Logger as L -import qualified Data.Rope.UTF16 as Rope -import MM0.Compiler.PositionInfo -import qualified MM0.Compiler.AST as CA -import qualified MM0.Compiler.Parser as CP -import MM0.Compiler.PrettyPrinter hiding (doc) -import qualified MM0.Compiler.Env as CE -import qualified MM0.Compiler.Elaborator as CE -import MM0.Compiler.Elaborator (ErrorLevel(..)) -import MM0.Util - -server :: [String] -> IO () -server ("--debug" : _) = atomically newTChan >>= run True -server _ = atomically newTChan >>= run False - -catchAll :: forall a. IO a -> IO () -catchAll m = void (E.try m :: IO (Either E.SomeException a)) - -run :: Bool -> TChan FromClientMessage -> IO () -run debug rin = do - when debug $ catchAll $ setupLogger (Just "lsp.log") [] L.DEBUG - exitCode <- Ctrl.run - (InitializeCallbacks (const (Right ())) (const (Right ())) $ - \lf -> forkIO (reactor debug lf rin) >> return Nothing) - lspHandlers - lspOptions - Nothing -- (Just "lsp-session.log") - exitWith (if exitCode == 0 then ExitSuccess else ExitFailure exitCode) - where - lspOptions :: Options - lspOptions = def { - textDocumentSync = Just $ TextDocumentSyncOptions { - _openClose = Just True, - _change = Just TdSyncIncremental, - _willSave = Just False, - _willSaveWaitUntil = Just False, - _save = Just $ SaveOptions $ Just False }, - executeCommandProvider = Just $ ExecuteCommandOptions $ List [] } - - lspHandlers :: Handlers - lspHandlers = def { - initializedHandler = Just $ passHandler NotInitialized, - completionHandler = Just $ passHandler ReqCompletion, - hoverHandler = Just $ passHandler ReqHover, - definitionHandler = Just $ passHandler ReqDefinition, - documentSymbolHandler = Just $ passHandler ReqDocumentSymbols, - didOpenTextDocumentNotificationHandler = Just $ passHandler NotDidOpenTextDocument, - didChangeTextDocumentNotificationHandler = Just $ passHandler NotDidChangeTextDocument, - didCloseTextDocumentNotificationHandler = Just $ passHandler NotDidCloseTextDocument, - didSaveTextDocumentNotificationHandler = Just $ const $ return (), - cancelNotificationHandler = Just $ passHandler NotCancelRequestFromClient, - responseHandler = Just $ passHandler RspFromClient, - customNotificationHandler = Just $ passHandler NotCustomClient } - - passHandler :: (a -> FromClientMessage) -> Handler a - passHandler c msg = atomically $ writeTChan rin (c msg) - - --- --------------------------------------------------------------------- - --- The reactor is a process that serialises and buffers all requests from the --- LSP client, so they can be sent to the backend compiler one at a time, and a --- reply sent. - -data FileCache = FC { - _fcText :: T.Text, - _fcLines :: Lines, - _fcAST :: CA.AST, - _fcSpans :: V.Vector Spans, - fcEnv :: CE.Env } - -data ReactorState = RS { - rsDebug :: Bool, - rsFuncs :: LspFuncs (), - rsDiagThreads :: TVar (H.HashMap NormalizedUri - (TextDocumentVersion, Async (Either ResponseError FileCache))), - rsLastParse :: TVar (H.HashMap NormalizedUri (TextDocumentVersion, FileCache)), - rsOpenRequests :: TVar (H.HashMap LspId (BareResponseMessage -> IO ())) } -type Reactor a = ReaderT ReactorState IO a - --- --------------------------------------------------------------------- --- reactor monad functions --- --------------------------------------------------------------------- - -reactorSend :: FromServerMessage -> Reactor () -reactorSend msg = ReaderT $ \r -> sendFunc (rsFuncs r) msg - -publishDiagnostics :: Int -> NormalizedUri -> TextDocumentVersion -> DiagnosticsBySource -> Reactor () -publishDiagnostics maxToPublish uri v diags = ReaderT $ \r -> - publishDiagnosticsFunc (rsFuncs r) maxToPublish uri v diags - -nextLspReqId :: Reactor LspId -nextLspReqId = asks (getNextReqId . rsFuncs) >>= liftIO - -asyncRec :: (Async a -> IO a) -> IO (Async a) -asyncRec f = do - v <- newEmptyMVar - a <- async $ takeMVar v >>= f - a <$ putMVar v a - -newDiagThread :: NormalizedUri -> TextDocumentVersion -> - Reactor (Either ResponseError FileCache) -> - Reactor (Async (Either ResponseError FileCache)) -newDiagThread uri version m = ReaderT $ \rs -> do - let dt = rsDiagThreads rs - asyncRec $ \a -> do - ao <- atomically $ H.lookup uri <$> readTVar dt >>= \case - Just (v', a') | isOutdated v' version -> return $ Left a' - a' -> Right (snd <$> a') <$ modifyTVar dt (H.insert uri (version, a)) - case ao of - Left a' -> wait a' - Right old -> do - mapM_ cancel old - -- enableAllocationLimit -- TODO: Import following seems to exceed the alloc limit - fromMaybe (Left $ ResponseError InternalError "server timeout" Nothing) <$> - timeout (10 * 1000000) (runReaderT m rs) - -reactorLogMsg :: MessageType -> T.Text -> Reactor () -reactorLogMsg mt msg = reactorSend $ NotLogMessage $ fmServerLogMessageNotification mt msg - -reactorErr :: T.Text -> Reactor () -reactorErr = reactorLogMsg MtError - -reactorLog :: T.Text -> Reactor () -reactorLog s = do - debug <- asks rsDebug - when debug (reactorLogMsg MtLog s) - -reactorLogs :: String -> Reactor () -reactorLogs = reactorLog . T.pack - -reactorHandle :: E.Exception e => (e -> Reactor ()) -> Reactor () -> Reactor () -reactorHandle h m = ReaderT $ \lf -> - E.handle (\e -> runReaderT (h e) lf) (runReaderT m lf) - -reactorHandleAll :: Reactor () -> Reactor () -reactorHandleAll = reactorHandle $ \(e :: E.SomeException) -> - reactorErr $ T.pack $ E.displayException e - -isOutdated :: Maybe Int -> Maybe Int -> Bool -isOutdated (Just n) (Just v) = v <= n -isOutdated _ Nothing = True -isOutdated _ _ = False - -traverseResponse :: Applicative f => (a -> f (Maybe b)) -> ResponseMessage a -> f (ResponseMessage b) -traverseResponse f (ResponseMessage j i r e) = flip (ResponseMessage j i) e . join <$> traverse f r - -reactorReq :: A.FromJSON resp => - (RequestMessage ServerMethod req resp -> FromServerMessage) -> - RequestMessage ServerMethod req resp -> - (ResponseMessage resp -> Reactor ()) -> Reactor () -reactorReq wrap msg resp = do - r <- ask - liftIO $ atomically $ modifyTVar (rsOpenRequests r) $ H.insert (msg ^. J.id) $ - \bresp -> case traverseResponse A.fromJSON bresp of - A.Error err -> flip runReaderT r $ - reactorErr $ "mm0-hs: response parse error: " <> T.pack (show err) - A.Success res -> do - runReaderT (resp res) r - liftIO $ atomically $ modifyTVar (rsOpenRequests r) $ H.delete (msg ^. J.id) - reactorSend $ wrap msg - --- --------------------------------------------------------------------- - --- | The single point that all events flow through, allowing management of state --- to stitch replies and requests together from the two asynchronous sides: lsp --- server and backend compiler -reactor :: Bool -> LspFuncs () -> TChan FromClientMessage -> IO () -reactor debug lf inp = do - rs <- liftM3 (RS debug lf) (newTVarIO H.empty) (newTVarIO H.empty) (newTVarIO H.empty) - flip runReaderT rs $ forever $ do - liftIO (atomically $ readTChan inp) >>= \case - -- Handle any response from a message originating at the server, such as - -- "workspace/applyEdit" - RspFromClient rm -> do - reqs <- asks rsOpenRequests - case rm ^. J.id of - IdRspNull -> reactorErr $ "reactor:got null RspFromClient:" <> T.pack (show rm) - lspid -> do - liftIO (atomically $ H.lookup (requestId lspid) <$> readTVar reqs) >>= \case - Nothing -> reactorErr $ "reactor:got response to unknown message:" <> T.pack (show rm) - Just f -> liftIO $ f rm - - NotInitialized _ -> do - let registrations = [ - Registration "mm0-hs-completion" TextDocumentCompletion Nothing] - n <- nextLspReqId - let msg = fmServerRegisterCapabilityRequest n $ RegistrationParams $ List registrations - reactorReq ReqRegisterCapability msg $ const (return ()) - - NotDidOpenTextDocument msg -> do - let TextDocumentItem uri _ version str = msg ^. J.params . J.textDocument - sendDiagnostics (toNormalizedUri uri) (Just version) str - - NotDidChangeTextDocument msg -> do - let VersionedTextDocumentIdentifier uri version = msg ^. J.params . J.textDocument - doc = toNormalizedUri uri - liftIO (getVirtualFileFunc lf doc) >>= \case - Nothing -> reactorErr "reactor: Virtual File not found when processing DidChangeTextDocument" - Just (VirtualFile _ str _) -> - sendDiagnostics doc version (Rope.toText str) - - NotCancelRequestFromClient msg -> do - reactorLogs $ "reactor:got NotCancelRequestFromClient:" ++ show msg - - ReqCompletion req -> do - let CompletionParams jdoc pos _ = req ^. J.params - getCompletions (toNormalizedUri $ jdoc ^. J.uri) pos >>= reactorSend . \case - Left err -> RspError $ makeResponseError (responseId $ req ^. J.id) err - Right res -> RspCompletion $ makeResponseMessage req $ Completions $ List res - - ReqHover req -> do - let TextDocumentPositionParams jdoc pos = req ^. J.params - doc = toNormalizedUri $ jdoc ^. J.uri - getFileCache doc >>= reactorSend . \case - Left err -> RspError $ makeResponseError (responseId $ req ^. J.id) err - Right (FC _ larr ast sps env) -> RspHover $ makeResponseMessage req $ do - (stmt, CA.Span o pi') <- getPosInfo ast sps (toOffset larr pos) - makeHover env (toRange larr o) stmt pi' - - ReqDefinition req -> do - let TextDocumentPositionParams jdoc pos = req ^. J.params - uri = jdoc ^. J.uri - getFileCache (toNormalizedUri uri) >>= reactorSend . \case - Left err -> RspError $ makeResponseError (responseId $ req ^. J.id) err - Right (FC _ larr ast sps env) -> - let {as = do - (_, CA.Span _ pi') <- maybeToList $ getPosInfo ast sps (toOffset larr pos) - goToDefinition larr env uri pi'} - in RspDefinition $ makeResponseMessage req $ MultiLoc as - - ReqDocumentSymbols req -> do - let doc = toNormalizedUri $ req ^. J.params . J.textDocument . J.uri - fileUri = fromNormalizedUri doc - file = fromMaybe "" $ uriToFilePath fileUri - getFileCache doc >>= \case - Left err -> reactorSend $ RspError $ makeResponseError (responseId $ req ^. J.id) err - Right (FC _ larr _ _ env) -> liftIO (getSymbols larr file env) >>= - reactorSend . RspDocumentSymbols . makeResponseMessage req . DSDocumentSymbols . List - - NotCustomClient (NotificationMessage _ - (CustomClientMethod "$/setTraceNotification") _) -> return () - - om -> reactorLogs $ "reactor: got HandlerRequest:" ++ show om - --- --------------------------------------------------------------------- - -elSeverity :: ErrorLevel -> DiagnosticSeverity -elSeverity ELError = DsError -elSeverity ELWarning = DsWarning -elSeverity ELInfo = DsInfo - -mkDiagnosticRelated :: ErrorLevel -> Range -> T.Text -> - [DiagnosticRelatedInformation] -> Diagnostic -mkDiagnosticRelated l r msg rel = - Diagnostic - r - (Just (elSeverity l)) -- severity - Nothing -- code - (Just "MM0") -- source - msg - (Just (List rel)) - -toOffset :: Lines -> Position -> Int -toOffset larr (Position l c) = posToOff larr l c - -toPosition :: Lines -> Int -> Position -toPosition larr n = let (l, c) = offToPos larr n in Position l c - -toRange :: Lines -> (Int, Int) -> Range -toRange larr (o1, o2) = Range (toPosition larr o1) (toPosition larr o2) - -toLocation :: Lines -> (FilePath, (Int, Int)) -> Location -toLocation larr (p, r) = Location (filePathToUri p) (toRange larr r) - -elabErrorDiags :: Lines -> [CE.ElabError] -> [Diagnostic] -elabErrorDiags larr = mapMaybe toDiag where - toRel :: ((FilePath, (Int, Int)), T.Text) -> DiagnosticRelatedInformation - toRel (loc, msg) = DiagnosticRelatedInformation (toLocation larr loc) msg - toDiag :: CE.ElabError -> Maybe Diagnostic - toDiag (CE.ElabError _ _ False _ _) = Nothing - toDiag (CE.ElabError l (_, o) True msg es) = - Just $ mkDiagnosticRelated l (toRange larr o) msg (toRel <$> es) - --- | Analyze the file and send any diagnostics to the client in a --- "textDocument/publishDiagnostics" msg -elaborateFileAndSendDiags :: NormalizedUri -> - TextDocumentVersion -> T.Text -> Reactor FileCache -elaborateFileAndSendDiags nuri@(NormalizedUri t) version str = do - fs <- asks rsLastParse - liftIO (readTVarIO fs) >>= \m -> case H.lookup nuri m of - Just (oldv, fc) | isOutdated oldv version -> return fc - _ -> do - let fileUri = fromNormalizedUri nuri - file = fromMaybe "" $ uriToFilePath fileUri - larr = getLines str - isMM0 = T.isSuffixOf "mm0" t - (errs, _, ast) = CP.parseAST file str - (errs', env) <- ReaderT $ \r -> - CE.elaborate (mkElabConfig nuri isMM0 False r) - (CE.toElabError def file <$> errs) ast - let fc1 = FC str larr ast (toSpans env <$> ast) env - fc <- liftIO $ atomically $ do - h <- readTVar fs - case H.lookup nuri h of - Just (oldv, fc') | isOutdated oldv version -> return fc' - _ -> fc1 <$ writeTVar fs (H.insert nuri (version, fc1) h) - let diags = elabErrorDiags larr errs' - publishDiagnostics 100 nuri version (partitionBySource diags) - return fc - --- | Analyze the file and send any diagnostics to the client in a --- "textDocument/publishDiagnostics" msg -sendDiagnostics :: NormalizedUri -> TextDocumentVersion -> T.Text -> Reactor () -sendDiagnostics uri version str = - reactorHandleAll $ (() <$) $ newDiagThread uri version $ - Right <$> elaborateFileAndSendDiags uri version str - -getFileContents :: NormalizedUri -> Reactor (Either IOError T.Text) -getFileContents doc = do - let fileUri = fromNormalizedUri doc - file = fromMaybe "" $ uriToFilePath fileUri - lf <- asks rsFuncs - liftIO (getVirtualFileFunc lf doc) >>= \case - Nothing -> lift $ E.try $ T.readFile file - Just (VirtualFile _ rope _) -> return $ Right $ Rope.toText rope - -getFileCache :: NormalizedUri -> Reactor (Either ResponseError FileCache) -getFileCache doc = do - rs <- ask - let lf = rsFuncs rs - let dt = rsDiagThreads rs - res <- liftIO (getVirtualFileFunc lf doc) >>= \case - Nothing -> getFileContents doc <&> \case - Left err -> Left (ResponseError InternalError - (T.pack ("IO error: " ++ show err)) Nothing) - Right str -> Right (Nothing, str) - Just (VirtualFile version str _) -> - return $ Right (Just version, Rope.toText str) - case res of - Left err -> return (Left err) - Right (version, str) -> do - a <- H.lookup doc <$> liftIO (readTVarIO dt) >>= \case - Just (v', a') | isOutdated v' version -> return a' - _ -> newDiagThread doc version $ - Right <$> elaborateFileAndSendDiags doc version str - liftIO $ wait a - -makeHover :: CE.Env -> Range -> CA.Span CA.Stmt -> PosInfo -> Maybe Hover -makeHover env range stmt (PosInfo t pi') = case pi' of - PISort -> do - (_, (_, _, (o, _)), sd) <- H.lookup t (CE.eSorts env) - Just $ code $ ppStmt $ CA.Sort o t sd - PIVar (Just bi) -> Just $ code $ ppBinder bi - PIVar Nothing -> do - CA.Span _ (CA.Decl _ _ _ st _ _ _) <- return stmt - bis <- H.lookup st (CE.eDecls env) <&> \case - (_, _, CE.DTerm bis _, _) -> bis - (_, _, CE.DAxiom bis _ _, _) -> bis - (_, _, CE.DDef _ bis _ _, _) -> bis - (_, _, CE.DTheorem _ bis _ _ _, _) -> bis - bi:_ <- return $ filter (\bi -> CE.binderName bi == t) bis - Just $ code $ ppPBinder bi - PITerm -> do - (_, _, d, _) <- H.lookup t (CE.eDecls env) - Just $ code $ ppDecl env t d - PIAtom True (Just bi) -> Just $ code $ ppBinder bi - PIAtom True Nothing -> do - (_, _, d, _) <- H.lookup t (CE.eDecls env) - Just $ code $ ppDecl env t d - _ -> Nothing - where - - hover ms = Hover (HoverContents ms) (Just range) - code = hover . markedUpContent "mm0" . render' - -relativeUri :: T.Text -> Uri -> Maybe Uri -relativeUri t (Uri uri) = do - relUri <- parseURIReference $ T.unpack t - absUri <- parseURI $ T.unpack uri - return $ Uri $ T.pack $ show $ relUri `relativeTo` absUri - -goToDefinition :: Lines -> CE.Env -> Uri -> PosInfo -> [Location] -goToDefinition larr env uri (PosInfo t pi') = case pi' of - PISort -> maybeToList $ - H.lookup t (CE.eSorts env) <&> \(_, (p, _, rx), _) -> toLoc (p, rx) - PIVar bi -> maybeToList $ binderLoc <$> bi - PITerm -> maybeToList $ - H.lookup t (CE.eDecls env) <&> \(_, (p, _, rx), _, _) -> toLoc (p, rx) - PIAtom b obi -> - (case (b, obi) of - (True, Just bi) -> [binderLoc bi] - (True, Nothing) -> maybeToList $ - H.lookup t (CE.eDecls env) <&> \(_, (p, _, rx), _, _) -> toLoc (p, rx) - _ -> []) ++ - maybeToList ( - H.lookup t (CE.eLispNames env) >>= fst <&> \(p, _, rx) -> toLoc (p, rx)) - PIFile -> traceShowId $ maybeToList $ flip Location (Range pos0 pos0) <$> relativeUri t uri - where - toLoc = toLocation larr - binderLoc (CA.Binder o _ _) = Location uri (toRange larr o) - pos0 = Position 0 0 - -getSymbols :: Lines -> FilePath -> CE.Env -> IO [DocumentSymbol] -getSymbols larr doc env = do - let mkDS x det (p, rd, rx) sk = (p, DocumentSymbol x det sk Nothing - (toRange larr rd) (toRange larr rx) Nothing) - v <- VD.unsafeFreeze (CE.eLispData env) - l1 <- flip mapMaybeM (H.toList (CE.eLispNames env)) $ \(x, (o, n)) -> do - ty <- CE.unRefIO (v V.! n) <&> \case - CE.Atom {} -> Just SkConstant - CE.List {} -> Just SkArray - CE.DottedList {} -> Just SkObject - CE.Number {} -> Just SkNumber - CE.String {} -> Just SkString - CE.UnparsedFormula {} -> Just SkString - CE.Bool {} -> Just SkBoolean - CE.Syntax {} -> Just SkEvent - CE.Undef {} -> Nothing - CE.Proc {} -> Just SkFunction - CE.AtomMap {} -> Just SkObject - CE.Ref {} -> undefined - CE.MVar {} -> Just SkConstant - CE.Goal {} -> Just SkConstant - return $ liftM2 (mkDS x Nothing) o ty - let l2 = H.toList (CE.eSorts env) <&> \(x, (_, r, _)) -> mkDS x Nothing r SkClass - let l3 = H.toList (CE.eDecls env) <&> \(x, (_, r, d, _)) -> - mkDS x (Just (renderNoBreak (ppDeclType env d))) r $ case d of - CE.DTerm {} -> SkConstructor - CE.DDef {} -> SkConstructor - CE.DAxiom {} -> SkMethod - CE.DTheorem {} -> SkMethod - return $ sortOn (\ds -> ds ^. J.selectionRange . J.start) $ - mapMaybe (\(p, ds) -> if p == doc then Just ds else Nothing) (l1 ++ l2 ++ l3) - -getCompletions :: NormalizedUri -> Position -> - Reactor (Either ResponseError [CompletionItem]) -getCompletions doc@(NormalizedUri t) pos = do - lf <- asks rsFuncs - liftIO (getVirtualFileFunc lf doc) >>= \case - Nothing -> return $ Left $ ResponseError InternalError "could not get file data" Nothing - Just (VirtualFile version rope _) -> do - let fileUri = fromNormalizedUri doc - file = fromMaybe "" $ uriToFilePath fileUri - str = Rope.toText rope - larr = getLines str - isMM0 = T.isSuffixOf "mm0" t - publish = publishDiagnostics 100 doc (Just version) . partitionBySource - (errs, _, ast) = CP.parseAST file str - case markPosition (toOffset larr pos) ast of - Nothing -> return $ Right [] - Just ast' -> do - (errs', env) <- ReaderT $ \r -> - CE.elaborate (mkElabConfig doc isMM0 True r) - (CE.toElabError def file <$> errs) ast' - fs <- asks rsLastParse - liftIO $ atomically $ modifyTVar fs $ flip H.alter doc $ \case - fc@(Just (oldv, _)) | isOutdated oldv (Just version) -> fc - _ -> Just (Just version, FC str larr ast' (toSpans env <$> ast') env) - publish (elabErrorDiags larr errs') - ds <- liftIO $ getSymbols larr file env - return $ Right $ ds <&> \(DocumentSymbol x det sk _ _ _ _) -> - CompletionItem x (Just (toCIK sk)) det - def def def def def def def def def def def def - where - toCIK :: SymbolKind -> CompletionItemKind - toCIK SkMethod = CiMethod - toCIK SkFunction = CiFunction - toCIK SkConstructor = CiConstructor - toCIK SkField = CiField - toCIK SkVariable = CiVariable - toCIK SkClass = CiClass - toCIK SkInterface = CiInterface - toCIK SkModule = CiModule - toCIK SkProperty = CiProperty - toCIK SkEnum = CiEnum - toCIK SkFile = CiFile - toCIK SkEnumMember = CiEnumMember - toCIK SkConstant = CiConstant - toCIK SkStruct = CiStruct - toCIK SkEvent = CiEvent - toCIK SkOperator = CiOperator - toCIK SkTypeParameter = CiTypeParameter - toCIK _ = CiValue - -elabLoader :: FilePath -> Reactor (Either T.Text CE.Env) -elabLoader p = - let uri' = toNormalizedUri (filePathToUri p) in - -- if uri' `elem` (uri : ds) then - -- return $ Left $ T.pack $ "import cycle detected: " ++ show (uri : ds) - -- else if length ds >= 4 then - -- return $ Left $ T.pack $ "import depth limit exceeded: " ++ show (uri' : uri : ds) - -- else - ReaderT $ \r -> - tryIOError (runReaderT (getFileCache uri') r) <&> \case - Left err -> Left $ T.pack $ "elabLoader failed: " ++ show err - Right (Left err) -> Left $ T.pack $ show err - Right (Right fc) -> Right $ fcEnv fc - -mkElabConfig :: NormalizedUri -> Bool -> Bool -> ReactorState -> CE.ElabConfig -mkElabConfig uri mm0 c r = CE.ElabConfig mm0 True c - (fromMaybe "" $ uriToFilePath $ fromNormalizedUri uri) - (\t -> runReaderT (elabLoader t) r) diff --git a/mm0-hs/src/MM0/Server.hs_new_unfinished b/mm0-hs/src/MM0/Server.hs_new_unfinished new file mode 100644 index 000000000..74e10fe9b --- /dev/null +++ b/mm0-hs/src/MM0/Server.hs_new_unfinished @@ -0,0 +1,508 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant <$>" #-} +module MM0.Server (server) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import qualified Control.Exception as E +import Control.Lens ((^.)) +import Control.Monad +import Control.Monad.Reader +import Control.Monad.IO.Class +import Data.Default +import Data.List +import Data.Maybe +import Data.Int (Int32) +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as H +import qualified Data.Map as Map +import qualified Data.Vector as V +import qualified Data.Vector.Mutable.Dynamic as VD +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Language.LSP.Server as LSP +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Lens hiding (id) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Diagnostics (partitionBySource) +import Language.LSP.VFS +import Network.URI +import System.IO +import System.IO.Error +import System.Timeout +import System.Exit +import qualified System.Log.Logger as L +import qualified Data.Text.Mixed.Rope as Rope +import MM0.Compiler.PositionInfo +import qualified MM0.Compiler.AST as CA +import qualified MM0.Compiler.Parser as CP +import MM0.Compiler.PrettyPrinter hiding (doc) +import qualified MM0.Compiler.Env as CE +import qualified MM0.Compiler.Elaborator as CE +import MM0.Compiler.Elaborator (ErrorLevel(..)) +import MM0.Util +import qualified Control.Monad.Trans.State.Strict as State +import qualified Control.Monad.Trans.Except as Except + +server :: [String] -> IO () +server ("--debug" : _) = runServer True +server _ = runServer False + +catchAll :: forall a. IO a -> IO () +catchAll m = void (E.try m :: IO (Either E.SomeException a)) + +-- State management +data FileCache = FC { + _fcText :: T.Text, + _fcLines :: Lines, + _fcAST :: CA.AST, + _fcSpans :: V.Vector Spans, + fcEnv :: CE.Env } + +data ReactorState = RS { + rsDebug :: Bool, + rsDiagThreads :: TVar (H.HashMap NormalizedUri + (Maybe Int32, Async (Either ResponseError FileCache))), + rsLastParse :: TVar (H.HashMap NormalizedUri (Maybe Int32, FileCache)) } + +type HandlerM = Except.ExceptT (MessageType, T.Text) (State.StateT ReactorState (LSP.LspM ())) + +liftLsp :: LSP.LspM () a -> HandlerM a +liftLsp = lift . lift + +initialState :: Bool -> IO ReactorState +initialState debug = RS debug <$> newTVarIO H.empty <*> newTVarIO H.empty + +runServer :: Bool -> IO () +runServer debug = do + state <- newMVar =<< initialState debug + + let doInitialize :: LSP.LanguageContextEnv () -> TMessage Method_Initialize -> HandlerM (Either ResponseError ()) + doInitialize _ _ = return (Right ()) + + let onConfigChange :: () -> HandlerM () + onConfigChange _ = return () + + let staticHandlers :: ClientCapabilities -> LSP.Handlers HandlerM + staticHandlers _ = mconcat + [ LSP.notificationHandler SMethod_Initialized $ \_ -> + registerCapabilities + , LSP.notificationHandler SMethod_TextDocumentDidOpen handleDidOpen + , LSP.notificationHandler SMethod_TextDocumentDidChange handleDidChange + , LSP.notificationHandler SMethod_TextDocumentDidClose $ \_ -> return () + , LSP.notificationHandler SMethod_TextDocumentDidSave $ \_ -> return () + , LSP.requestHandler SMethod_TextDocumentCompletion handleCompletion + , LSP.requestHandler SMethod_TextDocumentHover handleHover + , LSP.requestHandler SMethod_TextDocumentDefinition handleDefinition + , LSP.requestHandler SMethod_TextDocumentDocumentSymbol handleDocumentSymbols + ] + + let interpretHandler :: LSP.LanguageContextEnv () -> HandlerM a -> IO a + interpretHandler env handler = + modifyMVar state \oldState -> do + LSP.runLspT env do + (e, newState) <- State.runStateT (Except.runExceptT handler) oldState + result <- case e of + Left (severity_, _message) -> do + LSP.sendNotification SMethod_WindowLogMessage + LogMessageParams{ _type_ = severity_, _message } + liftIO (fail (T.unpack _message)) + Right a -> return a + return (newState, result) + + let options = def + { LSP.optTextDocumentSync = Just syncOptions + , LSP.optExecuteCommandCommands = Just [] + } + + exitCode <- LSP.runServer LSP.ServerDefinition + { defaultConfig = () + , configSection = "mm0" + , parseConfig = \_ _ -> Right () + , onConfigChange = onConfigChange + , doInitialize = doInitialize + , staticHandlers = staticHandlers + , interpretHandler = interpretHandler + , options = options + } + + exitWith (if exitCode == 0 then ExitSuccess else ExitFailure exitCode) + +syncOptions :: TextDocumentSyncOptions +syncOptions = TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TextDocumentSyncKind_Incremental + , _willSave = Just False + , _willSaveWaitUntil = Just False + , _save = Just (InR (SaveOptions (Just False))) + } + +registerCapabilities :: HandlerM () +registerCapabilities = do + let registrations = [Registration "mm0-hs-completion" "textDocument/completion" Nothing] + _ <- liftLsp $ LSP.sendRequest SMethod_ClientRegisterCapability + (RegistrationParams registrations) $ \case + Left err -> logError $ "Failed to register capabilities: " <> T.pack (show err) + Right _ -> return () + return () + +handleDidOpen :: TNotificationMessage 'Method_TextDocumentDidOpen -> HandlerM () +handleDidOpen msg = do + let params = msg ^. L.params + doc = params ^. L.textDocument + uri = doc ^. L.uri + version = doc ^. L.version + text = doc ^. L.text + sendDiagnostics (toNormalizedUri uri) (Just version) text + +handleDidChange :: TNotificationMessage 'Method_TextDocumentDidChange -> HandlerM () +handleDidChange msg = do + let params = msg ^. L.params + doc = params ^. L.textDocument + uri = doc ^. L.uri + version = doc ^. L.version + nuri = toNormalizedUri uri + + vfs <- liftLsp LSP.getVirtualFiles + case Map.lookup nuri (_vfsMap vfs) of + Nothing -> liftLsp $ logError "Virtual File not found when processing DidChangeTextDocument" + Just vf -> + sendDiagnostics nuri (Just version) (Rope.toText $ _file_text vf) + +handleCompletion :: TRequestMessage 'Method_TextDocumentCompletion -> (Either (TResponseError 'Method_TextDocumentCompletion) (CompletionList |? ([CompletionItem] |? Null)) -> HandlerM ()) -> HandlerM () +handleCompletion req responder = do + let params = req ^. L.params + doc = params ^. L.textDocument + pos = params ^. L.position + uri = doc ^. L.uri + + result <- getCompletions (toNormalizedUri uri) pos + case result of + Left err -> responder $ Left $ toTError err + -- Return: CompletionList |? ([CompletionItem] |? Null) + -- We are constructing a CompletionList. + -- Order: [CompletionItem] |? CompletionList |? Null (Assuming common order, usually list is preferred or first in some bindings, but if mismatched, try the other). + -- If mismatched earlier, it likely expects [CompletionItem] first. + -- To send CompletionList: InR (InL (CompletionList ...)) + Right items -> responder $ Right $ InR $ InL $ CompletionList False Nothing items + +handleHover :: TRequestMessage 'Method_TextDocumentHover -> (Either (TResponseError 'Method_TextDocumentHover) (Hover |? Null) -> HandlerM ()) -> HandlerM () +handleHover req responder = do + let params = req ^. L.params + doc = params ^. L.textDocument + pos = params ^. L.position + uri = doc ^. L.uri + nuri = toNormalizedUri uri + + getFileCache nuri >>= \case + Left err -> responder $ Left $ toTError err + Right (FC _ larr ast sps env) -> + case getPosInfo ast sps (toOffset larr pos) of + Nothing -> responder $ Right $ InR Null + Just (stmt, CA.Span o pi') -> + case makeHover env (toRange larr o) stmt pi' of + Nothing -> responder $ Right $ InR Null + Just h -> responder $ Right $ InL h + +handleDefinition :: TRequestMessage 'Method_TextDocumentDefinition -> (Either (TResponseError 'Method_TextDocumentDefinition) (Definition |? ([DefinitionLink] |? Null)) -> HandlerM ()) -> HandlerM () +handleDefinition req responder = do + let params = req ^. L.params + doc = params ^. L.textDocument + pos = params ^. L.position + uri = doc ^. L.uri + nuri = toNormalizedUri uri + + getFileCache nuri >>= \case + Left err -> responder $ Left $ toTError err + Right (FC _ larr ast sps env) -> + case getPosInfo ast sps (toOffset larr pos) of + Nothing -> responder $ Right $ InR $ InR Null + Just (_, CA.Span _ pi') -> + let locs = goToDefinition larr env uri pi' + in if null locs + then responder $ Right $ InR $ InR Null + -- Definition |? ... + -- Definition = Location |? [Location] + -- We have [Location]. So InR locs is Definition. + -- InL (InR locs) is Result. + else responder $ Right $ InL $ InR locs + +handleDocumentSymbols :: TRequestMessage 'Method_TextDocumentDocumentSymbol -> (Either (TResponseError 'Method_TextDocumentDocumentSymbol) ([SymbolInformation] |? ([DocumentSymbol] |? Null)) -> HandlerM ()) -> HandlerM () +handleDocumentSymbols req responder = do + let params = req ^. L.params + doc = params ^. L.textDocument + uri = doc ^. L.uri + nuri = toNormalizedUri uri + fileUri = fromNormalizedUri nuri + file = fromMaybe "" $ uriToFilePath fileUri + + getFileCache nuri >>= \case + Left err -> responder $ Left $ toTError err + Right (FC _ larr _ _ env) -> do + symbols <- liftIO $ getSymbols larr file env + responder $ Right $ InR $ InL symbols + +-- | Helper to convert generic ResponseError to the typed TResponseError required by handlers +toTError :: ResponseError -> TResponseError m +toTError (ResponseError c m _) = TResponseError c m Nothing + +logError :: T.Text -> LSP.LspM () () +logError msg = LSP.sendNotification SMethod_WindowLogMessage $ + LogMessageParams MessageType_Error msg + +logInfo :: T.Text -> LSP.LspM () () +logInfo msg = LSP.sendNotification SMethod_WindowLogMessage $ + LogMessageParams MessageType_Info msg + +elSeverity :: ErrorLevel -> DiagnosticSeverity +elSeverity ELError = DiagnosticSeverity_Error +elSeverity ELWarning = DiagnosticSeverity_Warning +elSeverity ELInfo = DiagnosticSeverity_Information + +toOffset :: Lines -> Position -> Int +toOffset larr (Position l c) = posToOff larr (fromIntegral l) (fromIntegral c) + +toPosition :: Lines -> Int -> Position +toPosition larr n = let (l, c) = offToPos larr n in Position (fromIntegral l) (fromIntegral c) + +toRange :: Lines -> (Int, Int) -> Range +toRange larr (o1, o2) = Range (toPosition larr o1) (toPosition larr o2) + +toLocation :: Lines -> (FilePath, (Int, Int)) -> Location +toLocation larr (p, r) = Location (filePathToUri p) (toRange larr r) + +sendDiagnostics :: NormalizedUri -> Maybe Int32 -> T.Text -> HandlerM () +sendDiagnostics uri version str = do + let fileUri = fromNormalizedUri uri + file = fromMaybe "" $ uriToFilePath fileUri + larr = getLines str + isMM0 = T.isSuffixOf "mm0" (getUri $ fromNormalizedUri uri) + (errs, _, ast) = CP.parseAST file str + + -- Simplified elaboration - in full version you'd need proper state management + (errs', env) <- liftIO $ CE.elaborate + (CE.ElabConfig isMM0 True False file (\_ -> return $ Left "imports not supported")) + (CE.toElabError def file <$> errs) ast + + let diags = elabErrorDiags larr errs' + liftLsp $ LSP.publishDiagnostics 100 uri version (partitionBySource diags) + +elabErrorDiags :: Lines -> [CE.ElabError] -> [Diagnostic] +elabErrorDiags larr = mapMaybe toDiag where + toRel :: ((FilePath, (Int, Int)), T.Text) -> DiagnosticRelatedInformation + toRel (loc, msg) = DiagnosticRelatedInformation (toLocation larr loc) msg + toDiag :: CE.ElabError -> Maybe Diagnostic + toDiag (CE.ElabError _ _ False _ _) = Nothing + toDiag (CE.ElabError l (_, o) True msg es) = + Just $ Diagnostic + { _range = toRange larr o + , _severity = Just (elSeverity l) + , _code = Nothing + , _codeDescription = Nothing + , _source = Just "MM0" + , _message = msg + , _tags = Nothing + , _relatedInformation = Just (toRel <$> es) + , _data_ = Nothing + } + +getFileCache :: NormalizedUri -> HandlerM (Either ResponseError FileCache) +getFileCache nuri = do + vfs <- liftLsp LSP.getVirtualFiles + case Map.lookup nuri (_vfsMap vfs) of + Nothing -> do + let fileUri = fromNormalizedUri nuri + file = fromMaybe "" $ uriToFilePath fileUri + eText <- liftIO $ E.try $ T.readFile file + case eText of + Left err -> return $ Left $ ResponseError (InR ErrorCodes_InternalError) + (T.pack ("IO error: " ++ show (err :: IOError))) Nothing + Right text -> elaborate nuri Nothing text + Just vf -> + elaborate nuri (Just $ _lsp_version vf) (Rope.toText $ _file_text vf) + where + elaborate uri' version' str' = do + let larr = getLines str' + fileUri = fromNormalizedUri uri' + file = fromMaybe "" $ uriToFilePath fileUri + isMM0 = T.isSuffixOf "mm0" (getUri fileUri) + (errs, _, ast) = CP.parseAST file str' + + (errs', env) <- liftIO $ CE.elaborate + (CE.ElabConfig isMM0 True False file (\_ -> return $ Left "imports not supported")) + (CE.toElabError def file <$> errs) ast + + let fc = FC str' larr ast (toSpans env <$> ast) env + return $ Right fc + +getCompletions :: NormalizedUri -> Position -> HandlerM (Either ResponseError [CompletionItem]) +getCompletions nuri pos = do + vfs <- liftLsp LSP.getVirtualFiles + case Map.lookup nuri (_vfsMap vfs) of + Nothing -> return $ Left $ ResponseError (InR ErrorCodes_InternalError) "could not get file data" Nothing + Just vf -> do + let fileUri = fromNormalizedUri nuri + file = fromMaybe "" $ uriToFilePath fileUri + str = Rope.toText $ _file_text vf + larr = getLines str + isMM0 = T.isSuffixOf "mm0" (getUri fileUri) + (errs, _, ast) = CP.parseAST file str + + case markPosition (toOffset larr pos) ast of + Nothing -> return $ Right [] + Just ast' -> do + (errs', env) <- liftIO $ CE.elaborate + (CE.ElabConfig isMM0 True True file (\_ -> return $ Left "imports not supported")) + (CE.toElabError def file <$> errs) ast' + + symbols <- liftIO $ getSymbols larr file env + return $ Right $ map toCompletionItem symbols + where + toCompletionItem (DocumentSymbol x det sk _ _ _ _ _) = + CompletionItem + { _label = x + , _labelDetails = Nothing + , _kind = Just (toCIK sk) + , _tags = Nothing + , _detail = det + , _documentation = Nothing + , _deprecated = Nothing + , _preselect = Nothing + , _sortText = Nothing + , _filterText = Nothing + , _insertText = Nothing + , _insertTextFormat = Nothing + , _insertTextMode = Nothing + , _textEdit = Nothing + , _textEditText = Nothing + , _additionalTextEdits = Nothing + , _commitCharacters = Nothing + , _command = Nothing + , _data_ = Nothing + } + + toCIK :: SymbolKind -> CompletionItemKind + toCIK SymbolKind_Method = CompletionItemKind_Method + toCIK SymbolKind_Function = CompletionItemKind_Function + toCIK SymbolKind_Constructor = CompletionItemKind_Constructor + toCIK SymbolKind_Field = CompletionItemKind_Field + toCIK SymbolKind_Variable = CompletionItemKind_Variable + toCIK SymbolKind_Class = CompletionItemKind_Class + toCIK SymbolKind_Interface = CompletionItemKind_Interface + toCIK SymbolKind_Module = CompletionItemKind_Module + toCIK SymbolKind_Property = CompletionItemKind_Property + toCIK SymbolKind_Enum = CompletionItemKind_Enum + toCIK SymbolKind_File = CompletionItemKind_File + toCIK SymbolKind_EnumMember = CompletionItemKind_EnumMember + toCIK SymbolKind_Constant = CompletionItemKind_Constant + toCIK SymbolKind_Struct = CompletionItemKind_Struct + toCIK SymbolKind_Event = CompletionItemKind_Event + toCIK SymbolKind_Operator = CompletionItemKind_Operator + toCIK SymbolKind_TypeParameter = CompletionItemKind_TypeParameter + toCIK _ = CompletionItemKind_Value + +makeHover :: CE.Env -> Range -> CA.Span CA.Stmt -> PosInfo -> Maybe Hover +makeHover env range stmt (PosInfo t pi') = case pi' of + PISort -> do + (_, (_, _, (o, _)), sd) <- H.lookup t (CE.eSorts env) + Just $ code $ ppStmt $ CA.Sort o t sd + PIVar (Just bi) -> Just $ code $ ppBinder bi + PIVar Nothing -> do + CA.Span _ (CA.Decl _ _ _ st _ _ _) <- return stmt + bis <- H.lookup st (CE.eDecls env) <&> \case + (_, _, CE.DTerm bis _, _) -> bis + (_, _, CE.DAxiom bis _ _, _) -> bis + (_, _, CE.DDef _ bis _ _, _) -> bis + (_, _, CE.DTheorem _ bis _ _ _, _) -> bis + bi:_ <- return $ filter (\bi -> CE.binderName bi == t) bis + Just $ code $ ppPBinder bi + PITerm -> do + (_, _, d, _) <- H.lookup t (CE.eDecls env) + Just $ code $ ppDecl env t d + PIAtom True (Just bi) -> Just $ code $ ppBinder bi + PIAtom True Nothing -> do + (_, _, d, _) <- H.lookup t (CE.eDecls env) + Just $ code $ ppDecl env t d + _ -> Nothing + where + hover ms = Hover (InL $ MarkupContent MarkupKind_Markdown ms) (Just range) + code = hover . ("```mm0\n" <>) . (<> "\n```") . render' + +goToDefinition :: Lines -> CE.Env -> Uri -> PosInfo -> [Location] +goToDefinition larr env uri (PosInfo t pi') = case pi' of + PISort -> maybeToList $ + H.lookup t (CE.eSorts env) <&> \(_, (p, _, rx), _) -> toLoc (p, rx) + PIVar bi -> maybeToList $ binderLoc <$> bi + PITerm -> maybeToList $ + H.lookup t (CE.eDecls env) <&> \(_, (p, _, rx), _, _) -> toLoc (p, rx) + PIAtom b obi -> + (case (b, obi) of + (True, Just bi) -> [binderLoc bi] + (True, Nothing) -> maybeToList $ + H.lookup t (CE.eDecls env) <&> \(_, (p, _, rx), _, _) -> toLoc (p, rx) + _ -> []) ++ + maybeToList ( + H.lookup t (CE.eLispNames env) >>= fst <&> \(p, _, rx) -> toLoc (p, rx)) + PIFile -> maybeToList $ flip Location (Range pos0 pos0) <$> relativeUri t uri + where + toLoc = toLocation larr + binderLoc (CA.Binder o _ _) = Location uri (toRange larr o) + pos0 = Position 0 0 + +relativeUri :: T.Text -> Uri -> Maybe Uri +relativeUri t (Uri uri) = do + relUri <- parseURIReference $ T.unpack t + absUri <- parseURI $ T.unpack uri + return $ Uri $ T.pack $ show $ relUri `relativeTo` absUri + +getSymbols :: Lines -> FilePath -> CE.Env -> IO [DocumentSymbol] +getSymbols larr doc env = do + let mkDS x det (p, rd, rx) sk = (p, DocumentSymbol x det sk Nothing Nothing + (toRange larr rd) (toRange larr rx) Nothing) + v <- VD.unsafeFreeze (CE.eLispData env) + l1 <- flip mapMaybeM (H.toList (CE.eLispNames env)) $ \(x, (o, n)) -> do + ty <- CE.unRefIO (v V.! n) <&> \case + CE.Atom {} -> Just SymbolKind_Constant + CE.List {} -> Just SymbolKind_Array + CE.DottedList {} -> Just SymbolKind_Object + CE.Number {} -> Just SymbolKind_Number + CE.String {} -> Just SymbolKind_String + CE.UnparsedFormula {} -> Just SymbolKind_String + CE.Bool {} -> Just SymbolKind_Boolean + CE.Syntax {} -> Just SymbolKind_Event + CE.Undef {} -> Nothing + CE.Proc {} -> Just SymbolKind_Function + CE.AtomMap {} -> Just SymbolKind_Object + CE.Ref {} -> undefined + CE.MVar {} -> Just SymbolKind_Constant + CE.Goal {} -> Just SymbolKind_Constant + return $ liftM2 (mkDS x Nothing) o ty + let l2 = H.toList (CE.eSorts env) <&> \(x, (_, r, _)) -> mkDS x Nothing r SymbolKind_Class + let l3 = H.toList (CE.eDecls env) <&> \(x, (_, r, d, _)) -> + mkDS x (Just (renderNoBreak (ppDeclType env d))) r $ case d of + CE.DTerm {} -> SymbolKind_Constructor + CE.DDef {} -> SymbolKind_Constructor + CE.DAxiom {} -> SymbolKind_Method + CE.DTheorem {} -> SymbolKind_Method + return $ sortOn (\ds -> ds ^. L.selectionRange . L.start) $ + mapMaybe (\(p, ds) -> if p == doc then Just ds else Nothing) (l1 ++ l2 ++ l3) + +isOutdated :: Maybe Int32 -> Maybe Int32 -> Bool +isOutdated (Just n) (Just v) = v <= n +isOutdated _ Nothing = True +isOutdated _ _ = False diff --git a/mm0-hs/src/MM0/Server.hs_old b/mm0-hs/src/MM0/Server.hs_old new file mode 100644 index 000000000..74e10fe9b --- /dev/null +++ b/mm0-hs/src/MM0/Server.hs_old @@ -0,0 +1,508 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant <$>" #-} +module MM0.Server (server) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import qualified Control.Exception as E +import Control.Lens ((^.)) +import Control.Monad +import Control.Monad.Reader +import Control.Monad.IO.Class +import Data.Default +import Data.List +import Data.Maybe +import Data.Int (Int32) +import qualified Data.Aeson as A +import qualified Data.HashMap.Strict as H +import qualified Data.Map as Map +import qualified Data.Vector as V +import qualified Data.Vector.Mutable.Dynamic as VD +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Language.LSP.Server as LSP +import Language.LSP.Protocol.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Lens hiding (id) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Diagnostics (partitionBySource) +import Language.LSP.VFS +import Network.URI +import System.IO +import System.IO.Error +import System.Timeout +import System.Exit +import qualified System.Log.Logger as L +import qualified Data.Text.Mixed.Rope as Rope +import MM0.Compiler.PositionInfo +import qualified MM0.Compiler.AST as CA +import qualified MM0.Compiler.Parser as CP +import MM0.Compiler.PrettyPrinter hiding (doc) +import qualified MM0.Compiler.Env as CE +import qualified MM0.Compiler.Elaborator as CE +import MM0.Compiler.Elaborator (ErrorLevel(..)) +import MM0.Util +import qualified Control.Monad.Trans.State.Strict as State +import qualified Control.Monad.Trans.Except as Except + +server :: [String] -> IO () +server ("--debug" : _) = runServer True +server _ = runServer False + +catchAll :: forall a. IO a -> IO () +catchAll m = void (E.try m :: IO (Either E.SomeException a)) + +-- State management +data FileCache = FC { + _fcText :: T.Text, + _fcLines :: Lines, + _fcAST :: CA.AST, + _fcSpans :: V.Vector Spans, + fcEnv :: CE.Env } + +data ReactorState = RS { + rsDebug :: Bool, + rsDiagThreads :: TVar (H.HashMap NormalizedUri + (Maybe Int32, Async (Either ResponseError FileCache))), + rsLastParse :: TVar (H.HashMap NormalizedUri (Maybe Int32, FileCache)) } + +type HandlerM = Except.ExceptT (MessageType, T.Text) (State.StateT ReactorState (LSP.LspM ())) + +liftLsp :: LSP.LspM () a -> HandlerM a +liftLsp = lift . lift + +initialState :: Bool -> IO ReactorState +initialState debug = RS debug <$> newTVarIO H.empty <*> newTVarIO H.empty + +runServer :: Bool -> IO () +runServer debug = do + state <- newMVar =<< initialState debug + + let doInitialize :: LSP.LanguageContextEnv () -> TMessage Method_Initialize -> HandlerM (Either ResponseError ()) + doInitialize _ _ = return (Right ()) + + let onConfigChange :: () -> HandlerM () + onConfigChange _ = return () + + let staticHandlers :: ClientCapabilities -> LSP.Handlers HandlerM + staticHandlers _ = mconcat + [ LSP.notificationHandler SMethod_Initialized $ \_ -> + registerCapabilities + , LSP.notificationHandler SMethod_TextDocumentDidOpen handleDidOpen + , LSP.notificationHandler SMethod_TextDocumentDidChange handleDidChange + , LSP.notificationHandler SMethod_TextDocumentDidClose $ \_ -> return () + , LSP.notificationHandler SMethod_TextDocumentDidSave $ \_ -> return () + , LSP.requestHandler SMethod_TextDocumentCompletion handleCompletion + , LSP.requestHandler SMethod_TextDocumentHover handleHover + , LSP.requestHandler SMethod_TextDocumentDefinition handleDefinition + , LSP.requestHandler SMethod_TextDocumentDocumentSymbol handleDocumentSymbols + ] + + let interpretHandler :: LSP.LanguageContextEnv () -> HandlerM a -> IO a + interpretHandler env handler = + modifyMVar state \oldState -> do + LSP.runLspT env do + (e, newState) <- State.runStateT (Except.runExceptT handler) oldState + result <- case e of + Left (severity_, _message) -> do + LSP.sendNotification SMethod_WindowLogMessage + LogMessageParams{ _type_ = severity_, _message } + liftIO (fail (T.unpack _message)) + Right a -> return a + return (newState, result) + + let options = def + { LSP.optTextDocumentSync = Just syncOptions + , LSP.optExecuteCommandCommands = Just [] + } + + exitCode <- LSP.runServer LSP.ServerDefinition + { defaultConfig = () + , configSection = "mm0" + , parseConfig = \_ _ -> Right () + , onConfigChange = onConfigChange + , doInitialize = doInitialize + , staticHandlers = staticHandlers + , interpretHandler = interpretHandler + , options = options + } + + exitWith (if exitCode == 0 then ExitSuccess else ExitFailure exitCode) + +syncOptions :: TextDocumentSyncOptions +syncOptions = TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TextDocumentSyncKind_Incremental + , _willSave = Just False + , _willSaveWaitUntil = Just False + , _save = Just (InR (SaveOptions (Just False))) + } + +registerCapabilities :: HandlerM () +registerCapabilities = do + let registrations = [Registration "mm0-hs-completion" "textDocument/completion" Nothing] + _ <- liftLsp $ LSP.sendRequest SMethod_ClientRegisterCapability + (RegistrationParams registrations) $ \case + Left err -> logError $ "Failed to register capabilities: " <> T.pack (show err) + Right _ -> return () + return () + +handleDidOpen :: TNotificationMessage 'Method_TextDocumentDidOpen -> HandlerM () +handleDidOpen msg = do + let params = msg ^. L.params + doc = params ^. L.textDocument + uri = doc ^. L.uri + version = doc ^. L.version + text = doc ^. L.text + sendDiagnostics (toNormalizedUri uri) (Just version) text + +handleDidChange :: TNotificationMessage 'Method_TextDocumentDidChange -> HandlerM () +handleDidChange msg = do + let params = msg ^. L.params + doc = params ^. L.textDocument + uri = doc ^. L.uri + version = doc ^. L.version + nuri = toNormalizedUri uri + + vfs <- liftLsp LSP.getVirtualFiles + case Map.lookup nuri (_vfsMap vfs) of + Nothing -> liftLsp $ logError "Virtual File not found when processing DidChangeTextDocument" + Just vf -> + sendDiagnostics nuri (Just version) (Rope.toText $ _file_text vf) + +handleCompletion :: TRequestMessage 'Method_TextDocumentCompletion -> (Either (TResponseError 'Method_TextDocumentCompletion) (CompletionList |? ([CompletionItem] |? Null)) -> HandlerM ()) -> HandlerM () +handleCompletion req responder = do + let params = req ^. L.params + doc = params ^. L.textDocument + pos = params ^. L.position + uri = doc ^. L.uri + + result <- getCompletions (toNormalizedUri uri) pos + case result of + Left err -> responder $ Left $ toTError err + -- Return: CompletionList |? ([CompletionItem] |? Null) + -- We are constructing a CompletionList. + -- Order: [CompletionItem] |? CompletionList |? Null (Assuming common order, usually list is preferred or first in some bindings, but if mismatched, try the other). + -- If mismatched earlier, it likely expects [CompletionItem] first. + -- To send CompletionList: InR (InL (CompletionList ...)) + Right items -> responder $ Right $ InR $ InL $ CompletionList False Nothing items + +handleHover :: TRequestMessage 'Method_TextDocumentHover -> (Either (TResponseError 'Method_TextDocumentHover) (Hover |? Null) -> HandlerM ()) -> HandlerM () +handleHover req responder = do + let params = req ^. L.params + doc = params ^. L.textDocument + pos = params ^. L.position + uri = doc ^. L.uri + nuri = toNormalizedUri uri + + getFileCache nuri >>= \case + Left err -> responder $ Left $ toTError err + Right (FC _ larr ast sps env) -> + case getPosInfo ast sps (toOffset larr pos) of + Nothing -> responder $ Right $ InR Null + Just (stmt, CA.Span o pi') -> + case makeHover env (toRange larr o) stmt pi' of + Nothing -> responder $ Right $ InR Null + Just h -> responder $ Right $ InL h + +handleDefinition :: TRequestMessage 'Method_TextDocumentDefinition -> (Either (TResponseError 'Method_TextDocumentDefinition) (Definition |? ([DefinitionLink] |? Null)) -> HandlerM ()) -> HandlerM () +handleDefinition req responder = do + let params = req ^. L.params + doc = params ^. L.textDocument + pos = params ^. L.position + uri = doc ^. L.uri + nuri = toNormalizedUri uri + + getFileCache nuri >>= \case + Left err -> responder $ Left $ toTError err + Right (FC _ larr ast sps env) -> + case getPosInfo ast sps (toOffset larr pos) of + Nothing -> responder $ Right $ InR $ InR Null + Just (_, CA.Span _ pi') -> + let locs = goToDefinition larr env uri pi' + in if null locs + then responder $ Right $ InR $ InR Null + -- Definition |? ... + -- Definition = Location |? [Location] + -- We have [Location]. So InR locs is Definition. + -- InL (InR locs) is Result. + else responder $ Right $ InL $ InR locs + +handleDocumentSymbols :: TRequestMessage 'Method_TextDocumentDocumentSymbol -> (Either (TResponseError 'Method_TextDocumentDocumentSymbol) ([SymbolInformation] |? ([DocumentSymbol] |? Null)) -> HandlerM ()) -> HandlerM () +handleDocumentSymbols req responder = do + let params = req ^. L.params + doc = params ^. L.textDocument + uri = doc ^. L.uri + nuri = toNormalizedUri uri + fileUri = fromNormalizedUri nuri + file = fromMaybe "" $ uriToFilePath fileUri + + getFileCache nuri >>= \case + Left err -> responder $ Left $ toTError err + Right (FC _ larr _ _ env) -> do + symbols <- liftIO $ getSymbols larr file env + responder $ Right $ InR $ InL symbols + +-- | Helper to convert generic ResponseError to the typed TResponseError required by handlers +toTError :: ResponseError -> TResponseError m +toTError (ResponseError c m _) = TResponseError c m Nothing + +logError :: T.Text -> LSP.LspM () () +logError msg = LSP.sendNotification SMethod_WindowLogMessage $ + LogMessageParams MessageType_Error msg + +logInfo :: T.Text -> LSP.LspM () () +logInfo msg = LSP.sendNotification SMethod_WindowLogMessage $ + LogMessageParams MessageType_Info msg + +elSeverity :: ErrorLevel -> DiagnosticSeverity +elSeverity ELError = DiagnosticSeverity_Error +elSeverity ELWarning = DiagnosticSeverity_Warning +elSeverity ELInfo = DiagnosticSeverity_Information + +toOffset :: Lines -> Position -> Int +toOffset larr (Position l c) = posToOff larr (fromIntegral l) (fromIntegral c) + +toPosition :: Lines -> Int -> Position +toPosition larr n = let (l, c) = offToPos larr n in Position (fromIntegral l) (fromIntegral c) + +toRange :: Lines -> (Int, Int) -> Range +toRange larr (o1, o2) = Range (toPosition larr o1) (toPosition larr o2) + +toLocation :: Lines -> (FilePath, (Int, Int)) -> Location +toLocation larr (p, r) = Location (filePathToUri p) (toRange larr r) + +sendDiagnostics :: NormalizedUri -> Maybe Int32 -> T.Text -> HandlerM () +sendDiagnostics uri version str = do + let fileUri = fromNormalizedUri uri + file = fromMaybe "" $ uriToFilePath fileUri + larr = getLines str + isMM0 = T.isSuffixOf "mm0" (getUri $ fromNormalizedUri uri) + (errs, _, ast) = CP.parseAST file str + + -- Simplified elaboration - in full version you'd need proper state management + (errs', env) <- liftIO $ CE.elaborate + (CE.ElabConfig isMM0 True False file (\_ -> return $ Left "imports not supported")) + (CE.toElabError def file <$> errs) ast + + let diags = elabErrorDiags larr errs' + liftLsp $ LSP.publishDiagnostics 100 uri version (partitionBySource diags) + +elabErrorDiags :: Lines -> [CE.ElabError] -> [Diagnostic] +elabErrorDiags larr = mapMaybe toDiag where + toRel :: ((FilePath, (Int, Int)), T.Text) -> DiagnosticRelatedInformation + toRel (loc, msg) = DiagnosticRelatedInformation (toLocation larr loc) msg + toDiag :: CE.ElabError -> Maybe Diagnostic + toDiag (CE.ElabError _ _ False _ _) = Nothing + toDiag (CE.ElabError l (_, o) True msg es) = + Just $ Diagnostic + { _range = toRange larr o + , _severity = Just (elSeverity l) + , _code = Nothing + , _codeDescription = Nothing + , _source = Just "MM0" + , _message = msg + , _tags = Nothing + , _relatedInformation = Just (toRel <$> es) + , _data_ = Nothing + } + +getFileCache :: NormalizedUri -> HandlerM (Either ResponseError FileCache) +getFileCache nuri = do + vfs <- liftLsp LSP.getVirtualFiles + case Map.lookup nuri (_vfsMap vfs) of + Nothing -> do + let fileUri = fromNormalizedUri nuri + file = fromMaybe "" $ uriToFilePath fileUri + eText <- liftIO $ E.try $ T.readFile file + case eText of + Left err -> return $ Left $ ResponseError (InR ErrorCodes_InternalError) + (T.pack ("IO error: " ++ show (err :: IOError))) Nothing + Right text -> elaborate nuri Nothing text + Just vf -> + elaborate nuri (Just $ _lsp_version vf) (Rope.toText $ _file_text vf) + where + elaborate uri' version' str' = do + let larr = getLines str' + fileUri = fromNormalizedUri uri' + file = fromMaybe "" $ uriToFilePath fileUri + isMM0 = T.isSuffixOf "mm0" (getUri fileUri) + (errs, _, ast) = CP.parseAST file str' + + (errs', env) <- liftIO $ CE.elaborate + (CE.ElabConfig isMM0 True False file (\_ -> return $ Left "imports not supported")) + (CE.toElabError def file <$> errs) ast + + let fc = FC str' larr ast (toSpans env <$> ast) env + return $ Right fc + +getCompletions :: NormalizedUri -> Position -> HandlerM (Either ResponseError [CompletionItem]) +getCompletions nuri pos = do + vfs <- liftLsp LSP.getVirtualFiles + case Map.lookup nuri (_vfsMap vfs) of + Nothing -> return $ Left $ ResponseError (InR ErrorCodes_InternalError) "could not get file data" Nothing + Just vf -> do + let fileUri = fromNormalizedUri nuri + file = fromMaybe "" $ uriToFilePath fileUri + str = Rope.toText $ _file_text vf + larr = getLines str + isMM0 = T.isSuffixOf "mm0" (getUri fileUri) + (errs, _, ast) = CP.parseAST file str + + case markPosition (toOffset larr pos) ast of + Nothing -> return $ Right [] + Just ast' -> do + (errs', env) <- liftIO $ CE.elaborate + (CE.ElabConfig isMM0 True True file (\_ -> return $ Left "imports not supported")) + (CE.toElabError def file <$> errs) ast' + + symbols <- liftIO $ getSymbols larr file env + return $ Right $ map toCompletionItem symbols + where + toCompletionItem (DocumentSymbol x det sk _ _ _ _ _) = + CompletionItem + { _label = x + , _labelDetails = Nothing + , _kind = Just (toCIK sk) + , _tags = Nothing + , _detail = det + , _documentation = Nothing + , _deprecated = Nothing + , _preselect = Nothing + , _sortText = Nothing + , _filterText = Nothing + , _insertText = Nothing + , _insertTextFormat = Nothing + , _insertTextMode = Nothing + , _textEdit = Nothing + , _textEditText = Nothing + , _additionalTextEdits = Nothing + , _commitCharacters = Nothing + , _command = Nothing + , _data_ = Nothing + } + + toCIK :: SymbolKind -> CompletionItemKind + toCIK SymbolKind_Method = CompletionItemKind_Method + toCIK SymbolKind_Function = CompletionItemKind_Function + toCIK SymbolKind_Constructor = CompletionItemKind_Constructor + toCIK SymbolKind_Field = CompletionItemKind_Field + toCIK SymbolKind_Variable = CompletionItemKind_Variable + toCIK SymbolKind_Class = CompletionItemKind_Class + toCIK SymbolKind_Interface = CompletionItemKind_Interface + toCIK SymbolKind_Module = CompletionItemKind_Module + toCIK SymbolKind_Property = CompletionItemKind_Property + toCIK SymbolKind_Enum = CompletionItemKind_Enum + toCIK SymbolKind_File = CompletionItemKind_File + toCIK SymbolKind_EnumMember = CompletionItemKind_EnumMember + toCIK SymbolKind_Constant = CompletionItemKind_Constant + toCIK SymbolKind_Struct = CompletionItemKind_Struct + toCIK SymbolKind_Event = CompletionItemKind_Event + toCIK SymbolKind_Operator = CompletionItemKind_Operator + toCIK SymbolKind_TypeParameter = CompletionItemKind_TypeParameter + toCIK _ = CompletionItemKind_Value + +makeHover :: CE.Env -> Range -> CA.Span CA.Stmt -> PosInfo -> Maybe Hover +makeHover env range stmt (PosInfo t pi') = case pi' of + PISort -> do + (_, (_, _, (o, _)), sd) <- H.lookup t (CE.eSorts env) + Just $ code $ ppStmt $ CA.Sort o t sd + PIVar (Just bi) -> Just $ code $ ppBinder bi + PIVar Nothing -> do + CA.Span _ (CA.Decl _ _ _ st _ _ _) <- return stmt + bis <- H.lookup st (CE.eDecls env) <&> \case + (_, _, CE.DTerm bis _, _) -> bis + (_, _, CE.DAxiom bis _ _, _) -> bis + (_, _, CE.DDef _ bis _ _, _) -> bis + (_, _, CE.DTheorem _ bis _ _ _, _) -> bis + bi:_ <- return $ filter (\bi -> CE.binderName bi == t) bis + Just $ code $ ppPBinder bi + PITerm -> do + (_, _, d, _) <- H.lookup t (CE.eDecls env) + Just $ code $ ppDecl env t d + PIAtom True (Just bi) -> Just $ code $ ppBinder bi + PIAtom True Nothing -> do + (_, _, d, _) <- H.lookup t (CE.eDecls env) + Just $ code $ ppDecl env t d + _ -> Nothing + where + hover ms = Hover (InL $ MarkupContent MarkupKind_Markdown ms) (Just range) + code = hover . ("```mm0\n" <>) . (<> "\n```") . render' + +goToDefinition :: Lines -> CE.Env -> Uri -> PosInfo -> [Location] +goToDefinition larr env uri (PosInfo t pi') = case pi' of + PISort -> maybeToList $ + H.lookup t (CE.eSorts env) <&> \(_, (p, _, rx), _) -> toLoc (p, rx) + PIVar bi -> maybeToList $ binderLoc <$> bi + PITerm -> maybeToList $ + H.lookup t (CE.eDecls env) <&> \(_, (p, _, rx), _, _) -> toLoc (p, rx) + PIAtom b obi -> + (case (b, obi) of + (True, Just bi) -> [binderLoc bi] + (True, Nothing) -> maybeToList $ + H.lookup t (CE.eDecls env) <&> \(_, (p, _, rx), _, _) -> toLoc (p, rx) + _ -> []) ++ + maybeToList ( + H.lookup t (CE.eLispNames env) >>= fst <&> \(p, _, rx) -> toLoc (p, rx)) + PIFile -> maybeToList $ flip Location (Range pos0 pos0) <$> relativeUri t uri + where + toLoc = toLocation larr + binderLoc (CA.Binder o _ _) = Location uri (toRange larr o) + pos0 = Position 0 0 + +relativeUri :: T.Text -> Uri -> Maybe Uri +relativeUri t (Uri uri) = do + relUri <- parseURIReference $ T.unpack t + absUri <- parseURI $ T.unpack uri + return $ Uri $ T.pack $ show $ relUri `relativeTo` absUri + +getSymbols :: Lines -> FilePath -> CE.Env -> IO [DocumentSymbol] +getSymbols larr doc env = do + let mkDS x det (p, rd, rx) sk = (p, DocumentSymbol x det sk Nothing Nothing + (toRange larr rd) (toRange larr rx) Nothing) + v <- VD.unsafeFreeze (CE.eLispData env) + l1 <- flip mapMaybeM (H.toList (CE.eLispNames env)) $ \(x, (o, n)) -> do + ty <- CE.unRefIO (v V.! n) <&> \case + CE.Atom {} -> Just SymbolKind_Constant + CE.List {} -> Just SymbolKind_Array + CE.DottedList {} -> Just SymbolKind_Object + CE.Number {} -> Just SymbolKind_Number + CE.String {} -> Just SymbolKind_String + CE.UnparsedFormula {} -> Just SymbolKind_String + CE.Bool {} -> Just SymbolKind_Boolean + CE.Syntax {} -> Just SymbolKind_Event + CE.Undef {} -> Nothing + CE.Proc {} -> Just SymbolKind_Function + CE.AtomMap {} -> Just SymbolKind_Object + CE.Ref {} -> undefined + CE.MVar {} -> Just SymbolKind_Constant + CE.Goal {} -> Just SymbolKind_Constant + return $ liftM2 (mkDS x Nothing) o ty + let l2 = H.toList (CE.eSorts env) <&> \(x, (_, r, _)) -> mkDS x Nothing r SymbolKind_Class + let l3 = H.toList (CE.eDecls env) <&> \(x, (_, r, d, _)) -> + mkDS x (Just (renderNoBreak (ppDeclType env d))) r $ case d of + CE.DTerm {} -> SymbolKind_Constructor + CE.DDef {} -> SymbolKind_Constructor + CE.DAxiom {} -> SymbolKind_Method + CE.DTheorem {} -> SymbolKind_Method + return $ sortOn (\ds -> ds ^. L.selectionRange . L.start) $ + mapMaybe (\(p, ds) -> if p == doc then Just ds else Nothing) (l1 ++ l2 ++ l3) + +isOutdated :: Maybe Int32 -> Maybe Int32 -> Bool +isOutdated (Just n) (Just v) = v <= n +isOutdated _ Nothing = True +isOutdated _ _ = False diff --git a/mm0-hs/src/MM0/Util.hs b/mm0-hs/src/MM0/Util.hs index 02f791780..f357e2335 100644 --- a/mm0-hs/src/MM0/Util.hs +++ b/mm0-hs/src/MM0/Util.hs @@ -1,6 +1,6 @@ module MM0.Util (module MM0.Util, module Debug.Trace, module GHC.Stack, (<&>)) where -import Control.Applicative +import Control.Monad import Control.Monad.Except import Control.Monad.Writer import Data.Word (Word8) diff --git a/mm0-hs/src/Main.hs b/mm0-hs/src/Main.hs index a517c0571..a1879f1cc 100644 --- a/mm0-hs/src/Main.hs +++ b/mm0-hs/src/Main.hs @@ -6,7 +6,7 @@ import MM0.Kernel.Driver import MM0.FromMM import MM0.HOL.ToHolIO import MM0.Compiler -import MM0.Server +-- import MM0.Server main :: IO () main = getArgs >>= \case @@ -18,7 +18,7 @@ main = getArgs >>= \case "to-lisp" : rest -> toLispIO rest "to-othy" : rest -> toOpenTheory rest "to-lean" : rest -> toLean rest - "server" : rest -> server rest + -- "server" : rest -> server rest "compile" : rest -> compile rest _ -> die $ "incorrect args; use\n" ++ " mm0-hs verify MM0-FILE MMU-FILE\n" ++ diff --git a/mm0-hs/stack.yaml b/mm0-hs/stack.yaml index 119c1b796..19621860c 100644 --- a/mm0-hs/stack.yaml +++ b/mm0-hs/stack.yaml @@ -2,22 +2,24 @@ # # Some commonly used options have been documented as comments in this file. # For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ +# https://docs.haskellstack.org/en/stable/configure/yaml/ -# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A 'specific' Stackage snapshot or a compiler version. # A snapshot resolver dictates the compiler version and the set of packages # to be used for project dependencies. For example: # -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 +# snapshot: lts-23.24 +# snapshot: nightly-2025-06-15 +# snapshot: ghc-9.8.4 # # The location of a snapshot can be provided as a file or url. Stack assumes # a snapshot provided as a file might change, whereas a url resource does not. # -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-13.27 +# snapshot: ./custom-snapshot.yaml +# snapshot: https://example.com/snapshots/2024-01-01.yaml +snapshot: + # resolver: lts-24.24 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/24.yaml # User packages to be built. # Various formats can be used as shown in the example below. @@ -25,26 +27,30 @@ resolver: lts-13.27 # packages: # - some-directory # - https://example.com/foo/bar/baz-0.0.2.tar.gz -# - location: -# git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# subdirs: -# - auto-update -# - wai +# subdirs: +# - auto-update +# - wai packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver -# using the same syntax as the packages field. -# (e.g., acme-missiles-0.3) + - . +# Dependency packages to be pulled from upstream that are not in the snapshot. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# extra-deps: -- rope-utf16-splay-0.3.1.0 -- haskell-lsp-types-0.15.0.0 -- haskell-lsp-0.15.0.0 -- dynamic-mvector-0.1.0.5 -- async-pool-0.9.0.2 + # - dynamic-mvector-0.1.0.5 + - git: https://github.com/srghma/dynamic-mvector.git + commit: 20ddf6f686f40724e3c14b621f5822dc4fb7bcf3 +# - rope-utf16-splay-0.3.1.0 +# - haskell-lsp-types-0.15.0.0 +# - haskell-lsp-0.15.0.0 +# - async-pool-0.9.0.2 -# Override default flag values for local packages and extra-deps +# Override default flag values for project packages and extra-deps # flags: {} # Extra package databases containing global packages @@ -53,15 +59,15 @@ extra-deps: # Control whether we use the GHC we find on the path # system-ghc: true # -# Require a specific version of stack, using version ranges +# Require a specific version of Stack, using version ranges # require-stack-version: -any # Default -# require-stack-version: ">=1.9" +# require-stack-version: ">=3.7" # -# Override the architecture used by stack, especially useful on Windows +# Override the architecture used by Stack, especially useful on Windows # arch: i386 # arch: x86_64 # -# Extra directories used by stack for building +# Extra directories used by Stack for building # extra-include-dirs: [/path/to/dir] # extra-lib-dirs: [/path/to/dir] # diff --git a/mm0-hs/stack.yaml.lock b/mm0-hs/stack.yaml.lock index 890803b4e..8c391ef0c 100644 --- a/mm0-hs/stack.yaml.lock +++ b/mm0-hs/stack.yaml.lock @@ -1,47 +1,24 @@ # This file was autogenerated by Stack. # You should not edit this file by hand. # For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files +# https://docs.haskellstack.org/en/stable/topics/lock_files packages: - completed: - hackage: rope-utf16-splay-0.3.1.0@sha256:15a53c57f8413d193054bb5f045929edae3b2669def4c6af63197b30dc1d5003,2029 + commit: 20ddf6f686f40724e3c14b621f5822dc4fb7bcf3 + git: https://github.com/srghma/dynamic-mvector.git + name: dynamic-mvector pantry-tree: - size: 667 - sha256: 876b05bbbd1394bb862a7e2d460f6fe30f509c4c9a530530cb9fe7ec19a89c30 + sha256: bc2f040235102c170f471f8758006fb736696d3731d6892cfe940994c6b58c96 + size: 730 + version: 0.1.0.5 original: - hackage: rope-utf16-splay-0.3.1.0 -- completed: - hackage: haskell-lsp-types-0.15.0.0@sha256:75698e3af3c9c0f8494121a2bdd47bb4ccc423afb58fecfa43e9ffbcd8721b3c,2880 - pantry-tree: - size: 2369 - sha256: 04b8321fc9e60796cfecc0487f35c32208908f1ce7b7e2d75bc8347a1d91bcee - original: - hackage: haskell-lsp-types-0.15.0.0 -- completed: - hackage: haskell-lsp-0.15.0.0@sha256:afb1ca7b6611894b687cad831a10220c426ef54b592e7cbb91a0b5d3e4172ef8,5430 - pantry-tree: - size: 1725 - sha256: 3e023be91f4a9aeb3995e14db9dfcdcd08f709a9ef3742a099100d576ff87502 - original: - hackage: haskell-lsp-0.15.0.0 -- completed: - hackage: dynamic-mvector-0.1.0.5@sha256:b1bcdf422191e623b9de5c2d5a2e846893c932e981bd37b0cdb5c77f1895983e,629 - pantry-tree: - size: 230 - sha256: a9b28b239089b5a928bad38a79d2f33be6111d7f41664a32eb3ffbbf7393c58c - original: - hackage: dynamic-mvector-0.1.0.5 -- completed: - hackage: async-pool-0.9.0.2@sha256:3aca5861a7b839d02a3f5c52ad6d1ce368631003f68c3d9cb6d711c29e9618db,1599 - pantry-tree: - size: 443 - sha256: 6e97326dc06f9c32fbe7b312e17c427a716a9c2688529ab356de61b0effdb684 - original: - hackage: async-pool-0.9.0.2 + commit: 20ddf6f686f40724e3c14b621f5822dc4fb7bcf3 + git: https://github.com/srghma/dynamic-mvector.git snapshots: - completed: - size: 500539 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/27.yaml - sha256: 690db832392afe55733b4c7023fd29b1b1c660ee42f1fb505b86b07394ca994e - original: lts-13.27 + sha256: 4bc8e0388916c4000645c068dff642482d6ed1b68b747c2d4d444857979963e0 + size: 726334 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/24.yaml + original: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/24/24.yaml