From 1536590edbca1e37f9c1c30be14dade01d57a926 Mon Sep 17 00:00:00 2001 From: Kirill Andreev Date: Tue, 19 May 2020 21:26:57 +0400 Subject: [PATCH] TMP --- .gitignore | 3 + tools/lsp/squirrel/app/Main.hs | 136 +++++++++++-- tools/lsp/squirrel/package.yaml | 57 +++--- tools/lsp/squirrel/squirrel.cabal | 22 +- tools/lsp/squirrel/src/AST.hs | 1 + tools/lsp/squirrel/src/AST/Errors.hs | 292 +++++++++++++++++++++++++++ tools/lsp/squirrel/src/AST/Types.hs | 66 ++++-- tools/lsp/squirrel/src/Parser.hs | 38 +++- tools/lsp/squirrel/src/TH.hs | 13 ++ tools/lsp/squirrel/stack.yaml | 14 +- tools/lsp/squirrel/stack.yaml.lock | 8 +- 11 files changed, 569 insertions(+), 81 deletions(-) create mode 100644 tools/lsp/squirrel/src/AST/Errors.hs create mode 100644 tools/lsp/squirrel/src/TH.hs diff --git a/.gitignore b/.gitignore index e1612602f..0fc670a39 100644 --- a/.gitignore +++ b/.gitignore @@ -30,3 +30,6 @@ tools/lsp/camligo/src/ tools/lsp/camligo/index.js tools/lsp/camligo/node_modules nix/result +.idea +*.iml +stale_outputs_checked diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index ed00acd15..d019eab63 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -1,23 +1,129 @@ import Data.Foldable (for_) -import Control.Monad (unless) +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception as E +import Control.Lens +import Control.Monad -import ParseTree -import Parser -import AST -import Pretty +import qualified Data.Text as Text +import Data.String.Interpolate (i) -import System.Environment +import qualified Language.Haskell.LSP.Control as CTRL +import qualified Language.Haskell.LSP.Core as Core +import Language.Haskell.LSP.Diagnostics +import Language.Haskell.LSP.Messages as Msg +import qualified Language.Haskell.LSP.Types as J +import qualified Language.Haskell.LSP.Types.Lens as J +import qualified Language.Haskell.LSP.Utility as U +import Language.Haskell.LSP.VFS + +import System.Environment +import System.Exit +import qualified System.Log as L + +import ParseTree +import Parser +import Range +import AST +import Pretty main :: IO () main = do - [fin] <- getArgs - toParseTree fin >>= print - (res, errs) <- runParser contract fin - putStrLn "----------------------" - print (pp res) - unless (null errs) do - putStrLn "" - putStrLn "Errors:" - for_ errs (print . nest 2 . pp) \ No newline at end of file + errCode <- mainLoop + exit errCode + +mainLoop :: IO Int +mainLoop = do + chan <- atomically newTChan :: IO (TChan FromClientMessage) + + let + callbacks = Core.InitializeCallbacks + { Core.onInitialConfiguration = const $ Right () + , Core.onConfigurationChange = const $ Right () + , Core.onStartup = \lFuns -> do + _ <- forkIO $ eventLoop lFuns chan + return Nothing + } + + Core.setupLogger (Just "log.txt") [] L.INFO + return 0 + `catches` + [ Handler \(e :: SomeException) -> do + print e + return 1 + ] + +send :: Core.LspFuncs () -> FromServerMessage -> IO () +send = Core.sendFunc + +nextID :: Core.LspFuncs () -> IO J.LspId +nextID = Core.getNextReqId + +eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO () +eventLoop funs chan = do + forever do + msg <- atomically (readTChan chan) + + U.logs [i|Client: ${msg}|] + + case msg of + RspFromClient {} -> do + return () + + NotInitialized _notif -> do + let + registration = J.Registration + "lsp-haskell-registered" + J.WorkspaceExecuteCommand + Nothing + registrations = J.RegistrationParams $ J.List [registration] + + rid <- nextID funs + send funs + $ ReqRegisterCapability + $ fmServerRegisterCapabilityRequest rid registrations + + NotDidOpenTextDocument notif -> do + let + doc = notif + ^.J.params + .J.textDocument + .J.uri + + collectErrors funs + (J.toNormalizedUri doc) + (J.uriToFilePath doc) + (Just 0) + +collectErrors + :: Core.LspFuncs () + -> J.NormalizedUri + -> Maybe FilePath + -> Maybe Int + -> IO () +collectErrors funs uri path version = do + case path of + Just fin -> do + (tree, errs) <- runParser contract fin + Core.publishDiagnosticsFunc funs 100 uri version + $ partitionBySource + $ map errorToDiag (errs <> errors tree) + +errorToDiag :: Error -> J.Diagnostic +errorToDiag (Expected what instead (Range (sl, sc, _) (el, ec, _))) = + J.Diagnostic + (J.Range begin end) + (Just J.DsError) + Nothing + (Just "ligo-lsp") + (Text.pack [i|Expected ${what}|]) + (Just $ J.List[]) + where + begin = J.Position (sl - 1) (sc - 1) + end = J.Position (el - 1) (ec - 1) + +exit :: Int -> IO () +exit 0 = exitSuccess +exit n = exitWith (ExitFailure n) diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index 9cbd68da1..5177661ba 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -1,42 +1,53 @@ - name: squirrel dependencies: -- base -- bytestring -- mtl -- text -- tree-sitter -- pretty + - base + - bytestring + - data-default + - lens + - mtl + - template-haskell + - text + - tree-sitter + - pretty default-extensions: -- LambdaCase -- BlockArguments -- OverloadedStrings -- GeneralisedNewtypeDeriving -- DerivingStrategies -- DerivingVia -- NamedFieldPuns -- BangPatterns + - LambdaCase + - BlockArguments + - OverloadedStrings + - GeneralisedNewtypeDeriving + - DerivingStrategies + - DerivingVia + - FlexibleInstances + - NamedFieldPuns + - BangPatterns + - ScopedTypeVariables + - QuasiQuotes + - TemplateHaskell -ghc-options: -freverse-errors -Wall +ghc-options: -freverse-errors -Wall -threaded library: source-dirs: - - src/ + - src/ include-dirs: - - vendor + - vendor c-sources: - - vendor/parser.c + - vendor/parser.c executables: squirrel: + dependencies: + - base + - stm + - haskell-lsp + - squirrel + - hslogger + - interpolate + main: Main.hs source-dirs: - - app/ - - dependencies: - - squirrel + - app/ diff --git a/tools/lsp/squirrel/squirrel.cabal b/tools/lsp/squirrel/squirrel.cabal index f54d21ec3..eca3096ae 100644 --- a/tools/lsp/squirrel/squirrel.cabal +++ b/tools/lsp/squirrel/squirrel.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 265647f1e4ee30432d151c4651a52d5777306a54afa992c70c83d840f87d5365 +-- hash: 538d4e2f89a920b2395b5b445d883e29cf753fa91e443e1308a48a689018f4eb name: squirrel version: 0.0.0 @@ -13,18 +13,20 @@ build-type: Simple library exposed-modules: AST + AST.Errors AST.Parser AST.Types Parser ParseTree Pretty Range + TH other-modules: Paths_squirrel hs-source-dirs: src/ - default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia NamedFieldPuns BangPatterns - ghc-options: -freverse-errors -Wall + default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell + ghc-options: -freverse-errors -Wall -threaded include-dirs: vendor c-sources: @@ -32,8 +34,11 @@ library build-depends: base , bytestring + , data-default + , lens , mtl , pretty + , template-haskell , text , tree-sitter default-language: Haskell2010 @@ -44,14 +49,21 @@ executable squirrel Paths_squirrel hs-source-dirs: app/ - default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia NamedFieldPuns BangPatterns - ghc-options: -freverse-errors -Wall + default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell + ghc-options: -freverse-errors -Wall -threaded build-depends: base , bytestring + , data-default + , haskell-lsp + , hslogger + , interpolate + , lens , mtl , pretty , squirrel + , stm + , template-haskell , text , tree-sitter default-language: Haskell2010 diff --git a/tools/lsp/squirrel/src/AST.hs b/tools/lsp/squirrel/src/AST.hs index 5b11b277e..3e45b28ad 100644 --- a/tools/lsp/squirrel/src/AST.hs +++ b/tools/lsp/squirrel/src/AST.hs @@ -3,3 +3,4 @@ module AST (module M) where import AST.Types as M import AST.Parser as M +import AST.Errors as M diff --git a/tools/lsp/squirrel/src/AST/Errors.hs b/tools/lsp/squirrel/src/AST/Errors.hs new file mode 100644 index 000000000..96a82fc7d --- /dev/null +++ b/tools/lsp/squirrel/src/AST/Errors.hs @@ -0,0 +1,292 @@ + +{- + The AST and auxillary types along with their pretty-printers. + + TODO: Untangle pretty-printing mess into combinators. + TODO: Store offending text verbatim in Wrong*. +-} + +module AST.Errors where + +import Parser +import AST.Types + +class HasErrors h where + errors :: h -> [Error] + +instance {-# OVERLAPPABLE #-} (HasErrors a, Foldable f) => HasErrors (f a) where + errors = foldMap errors + +instance HasErrors (Contract i) where + errors = \case + Contract _ ds -> errors ds + WrongContract err -> return err + +-- data Contract info +-- = Contract info [Declaration info] +-- | WrongContract Error + +instance HasErrors (Declaration i) where + errors = \case + ValueDecl _ bind -> errors bind + TypeDecl _ n ty -> errors n <> errors ty + Action _ e -> errors e + Include _ _ -> fail "text" + WrongDecl err -> return err + +-- data Declaration info +-- = ValueDecl info (Binding info) +-- | TypeDecl info (Name info) (Type info) +-- | Action info (Expr info) +-- | Include info Text +-- | WrongDecl Error + +instance HasErrors (Binding i) where + errors = \case + Irrefutable _ a b -> errors a <> errors b + Function _ _ a b c d -> errors a <> errors b <> errors c <> errors d + Var _ a b c -> errors a <> errors b <> errors c + Const _ a b c -> errors a <> errors b <> errors c + WrongBinding e -> return e + +-- data Binding info +-- = Irrefutable info (Pattern info) (Expr info) +-- | Function info Bool (Name info) [VarDecl info] (Type info) (Expr info) +-- | Var info (Name info) (Type info) (Expr info) +-- | Const info (Name info) (Type info) (Expr info) +-- | WrongBinding Error + +instance HasErrors (VarDecl i) where + errors = \case + Decl _ a b c -> errors a <> errors b <> errors c + WrongVarDecl e -> return e + +-- data VarDecl info +-- = Decl info (Mutable info) (Name info) (Type info) +-- | WrongVarDecl Error + +instance HasErrors (Mutable i) where + errors = \case + WrongMutable e -> return e + _ -> fail "none" + +-- data Mutable info +-- = Mutable info +-- | Immutable info +-- | WrongMutable Error + +instance HasErrors (Type i) where + errors = \case + TArrow _ a b -> errors a <> errors b + TRecord _ fs -> errors fs + TVar _ a -> errors a + TSum _ cs -> errors cs + TProduct _ es -> errors es + TApply _ f xs -> errors f <> errors xs + +-- data Type info +-- = TArrow info (Type info) (Type info) +-- | TRecord info [TField info] +-- | TVar info (Name info) +-- | TSum info [Variant info] +-- | TProduct info [Type info] +-- | TApply info (Name info) [Type info] +-- | WrongType Error + +instance HasErrors (Variant i) where + errors = \case + Variant _ a b -> errors a <> errors b + WrongVariant e -> return e + +-- data Variant info +-- = Variant info (Name info) (Maybe (Type info)) +-- | WrongVariant Error + +instance HasErrors (TField i) where + errors = \case + TField _ a b -> errors a <> errors b + WrongTField e -> return e + +-- data TField info +-- = TField info (Name info) (Type info) +-- | WrongTField Error + +instance HasErrors (Expr i) where + errors = \case + Let _ ds b -> errors ds <> errors b + Apply _ f xs -> errors f <> errors xs + Constant _ c -> errors c + Ident _ q -> errors q + BinOp _ l _ r -> errors l <> errors r + UnOp _ _ o -> errors o + Record _ fs -> errors fs + If _ a b c -> errors a <> errors b <> errors c + Assign _ a b -> errors a <> errors b + List _ l -> errors l + Set _ l -> errors l + Tuple _ l -> errors l + Annot _ a b -> errors a <> errors b + Attrs _ _ -> fail "none" + BigMap _ l -> errors l + Map _ l -> errors l + MapRemove _ a b -> errors a <> errors b + SetRemove _ a b -> errors a <> errors b + Indexing _ a b -> errors a <> errors b + Case _ a bs -> errors a <> errors bs + Skip _ -> fail "none" + ForLoop _ a b c d -> errors a <> errors b <> errors c <> errors d + WhileLoop _ a b -> errors a <> errors b + Seq _ ds -> errors ds + Lambda _ ps b c -> errors ps <> errors b <> errors c + ForBox _ a b _ c d -> errors a <> errors b <> errors c <> errors d + MapPatch _ a bs -> errors a <> errors bs + SetPatch _ a bs -> errors a <> errors bs + RecordUpd _ a bs -> errors a <> errors bs + WrongExpr e -> return e + +-- data Expr info +-- = Let info [Declaration info] (Expr info) +-- | Apply info (Expr info) [Expr info] +-- | Constant info (Constant info) +-- | Ident info (QualifiedName info) +-- | BinOp info (Expr info) Text (Expr info) +-- | UnOp info Text (Expr info) +-- | Record info [Assignment info] +-- | If info (Expr info) (Expr info) (Expr info) +-- | Assign info (LHS info) (Expr info) +-- | List info [Expr info] +-- | Set info [Expr info] +-- | Tuple info [Expr info] +-- | Annot info (Expr info) (Type info) +-- | Attrs info [Text] +-- | BigMap info [MapBinding info] +-- | Map info [MapBinding info] +-- | MapRemove info (Expr info) (QualifiedName info) +-- | SetRemove info (Expr info) (QualifiedName info) +-- | Indexing info (QualifiedName info) (Expr info) +-- | Case info (Expr info) [Alt info] +-- | Skip info +-- | ForLoop info (Name info) (Expr info) (Expr info) (Expr info) +-- | WhileLoop info (Expr info) (Expr info) +-- | Seq info [Declaration info] +-- | Lambda info [VarDecl info] (Type info) (Expr info) +-- | ForBox info (Name info) (Maybe (Name info)) Text (Expr info) (Expr info) +-- | MapPatch info (QualifiedName info) [MapBinding info] +-- | SetPatch info (QualifiedName info) [Expr info] +-- | RecordUpd info (QualifiedName info) [FieldAssignment info] +-- | WrongExpr Error + +instance HasErrors (Alt i) where + errors = \case + Alt _ a b -> errors a <> errors b + WrongAlt e -> return e + +-- data Alt info +-- = Alt info (Pattern info) (Expr info) +-- | WrongAlt Error + +instance HasErrors (LHS i) where + errors = \case + LHS _ a b -> errors a <> errors b + WrongLHS e -> return e + +-- data LHS info +-- = LHS info (QualifiedName info) (Maybe (Expr info)) +-- | WrongLHS Error + +instance HasErrors (MapBinding i) where + errors = \case + MapBinding _ a b -> errors a <> errors b + WrongMapBinding e -> return e + +-- data MapBinding info +-- = MapBinding info (Expr info) (Expr info) +-- | WrongMapBinding Error + +instance HasErrors (Assignment i) where + errors = \case + Assignment _ a b -> errors a <> errors b + WrongAssignment e -> return e + +-- data Assignment info +-- = Assignment info (Name info) (Expr info) +-- | WrongAssignment Error + +instance HasErrors (FieldAssignment i) where + errors = \case + FieldAssignment _ a b -> errors a <> errors b + WrongFieldAssignment e -> return e + +-- data FieldAssignment info +-- = FieldAssignment info (QualifiedName info) (Expr info) +-- | WrongFieldAssignment Error + +instance HasErrors (Constant i) where + errors = \case + WrongConstant e -> return e + _ -> fail "none" + +-- data Constant info +-- = Int info Text +-- | Nat info Text +-- | String info Text +-- | Float info Text +-- | Bytes info Text +-- | Tez info Text +-- | WrongConstant Error + +instance HasErrors (Pattern i) where + errors = \case + IsConstr _ a b -> errors a <> errors b + IsConstant _ c -> errors c + IsVar _ a -> errors a + IsCons _ a b -> errors a <> errors b + IsWildcard _ -> fail "none" + IsList _ l -> errors l + IsTuple _ l -> errors l + WrongPattern e -> return e + +-- data Pattern info +-- = IsConstr info (Name info) (Maybe (Pattern info)) +-- | IsConstant info (Constant info) +-- | IsVar info (Name info) +-- | IsCons info (Pattern info) (Pattern info) +-- | IsWildcard info +-- | IsList info [Pattern info] +-- | IsTuple info [Pattern info] +-- | WrongPattern Error + +instance HasErrors (QualifiedName i) where + errors = \case + QualifiedName _ a b -> errors a <> errors b + WrongQualifiedName e -> return e + +-- data QualifiedName info +-- = QualifiedName +-- { qnInfo :: info +-- , qnSource :: Name info +-- , qnPath :: [Path info] +-- } +-- | WrongQualifiedName Error + +instance HasErrors (Path i) where + errors = \case + At _ a -> errors a + Ix _ _ -> fail "none" + WrongPath e -> return e + +-- data Path info +-- = At info (Name info) +-- | Ix info Text +-- | WrongPath Error + +instance HasErrors (Name i) where + errors = \case + WrongName e -> return e + _ -> fail "none" + +-- data Name info = Name +-- { info :: info +-- , raw :: Text +-- } +-- | WrongName Error diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs index 349f8218f..3f13eb296 100644 --- a/tools/lsp/squirrel/src/AST/Types.hs +++ b/tools/lsp/squirrel/src/AST/Types.hs @@ -9,6 +9,7 @@ module AST.Types where import Control.Monad.State +import Control.Lens hiding (Const, List) import qualified Data.Text as Text import Data.Text (Text) @@ -18,6 +19,8 @@ import Parser import ParseTree import Pretty +import TH + import Debug.Trace data Contract info @@ -25,8 +28,6 @@ data Contract info | WrongContract Error deriving (Show) via PP (Contract info) -instance Stubbed (Contract info) where stub = WrongContract - data Declaration info = ValueDecl info (Binding info) | TypeDecl info (Name info) (Type info) @@ -35,7 +36,6 @@ data Declaration info | WrongDecl Error deriving (Show) via PP (Declaration info) -instance Stubbed (Declaration info) where stub = WrongDecl data Binding info = Irrefutable info (Pattern info) (Expr info) @@ -45,14 +45,12 @@ data Binding info | WrongBinding Error deriving (Show) via PP (Binding info) -instance Stubbed (Binding info) where stub = WrongBinding data VarDecl info = Decl info (Mutable info) (Name info) (Type info) | WrongVarDecl Error deriving (Show) via PP (VarDecl info) -instance Stubbed (VarDecl info) where stub = WrongVarDecl data Mutable info = Mutable info @@ -61,7 +59,6 @@ data Mutable info deriving (Show) via PP (Mutable info) -instance Stubbed (Mutable info) where stub = WrongMutable data Type info = TArrow info (Type info) (Type info) @@ -73,21 +70,18 @@ data Type info | WrongType Error deriving (Show) via PP (Type info) -instance Stubbed (Type info) where stub = WrongType data Variant info = Variant info (Name info) (Maybe (Type info)) | WrongVariant Error deriving (Show) via PP (Variant info) -instance Stubbed (Variant info) where stub = WrongVariant data TField info = TField info (Name info) (Type info) | WrongTField Error deriving (Show) via PP (TField info) -instance Stubbed (TField info) where stub = WrongTField -- | TODO: break onto smaller types? Literals -> Constannt; mapOps; mmove Annots to Decls. data Expr info @@ -123,42 +117,36 @@ data Expr info | WrongExpr Error deriving (Show) via PP (Expr info) -instance Stubbed (Expr info) where stub = WrongExpr data Alt info = Alt info (Pattern info) (Expr info) | WrongAlt Error deriving (Show) via PP (Alt info) -instance Stubbed (Alt info) where stub = WrongAlt data LHS info = LHS info (QualifiedName info) (Maybe (Expr info)) | WrongLHS Error deriving (Show) via PP (LHS info) -instance Stubbed (LHS info) where stub = WrongLHS data MapBinding info = MapBinding info (Expr info) (Expr info) | WrongMapBinding Error deriving (Show) via PP (MapBinding info) -instance Stubbed (MapBinding info) where stub = WrongMapBinding data Assignment info = Assignment info (Name info) (Expr info) | WrongAssignment Error deriving (Show) via PP (Assignment info) -instance Stubbed (Assignment info) where stub = WrongAssignment data FieldAssignment info = FieldAssignment info (QualifiedName info) (Expr info) | WrongFieldAssignment Error deriving (Show) via PP (FieldAssignment info) -instance Stubbed (FieldAssignment info) where stub = WrongFieldAssignment data Constant info = Int info Text @@ -170,7 +158,6 @@ data Constant info | WrongConstant Error deriving (Show) via PP (Constant info) -instance Stubbed (Constant info) where stub = WrongConstant data Pattern info = IsConstr info (Name info) (Maybe (Pattern info)) @@ -183,7 +170,6 @@ data Pattern info | WrongPattern Error deriving (Show) via PP (Pattern info) -instance Stubbed (Pattern info) where stub = WrongPattern data QualifiedName info = QualifiedName @@ -194,7 +180,6 @@ data QualifiedName info | WrongQualifiedName Error deriving (Show) via PP (QualifiedName info) -instance Stubbed (QualifiedName info) where stub = WrongQualifiedName data Path info = At info (Name info) @@ -202,7 +187,6 @@ data Path info | WrongPath Error deriving (Show) via PP (Path info) -instance Stubbed (Path info) where stub = WrongPath data Name info = Name { info :: info @@ -211,8 +195,6 @@ data Name info = Name | WrongName Error deriving (Show) via PP (Name info) -instance Stubbed (Name info) where stub = WrongName - c :: HasComments i => i -> Doc -> Doc c i d = case getComments i of @@ -393,3 +375,45 @@ instance HasComments i => Pretty (LHS i) where pp = \case LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi WrongLHS err -> pp err + +foldMap makePrisms + [ ''Name + , ''Path + , ''QualifiedName + , ''Pattern + , ''Constant + , ''FieldAssignment + , ''Assignment + , ''MapBinding + , ''LHS + , ''Alt + , ''Expr + , ''TField + , ''Variant + , ''Type + , ''Mutable + , ''VarDecl + , ''Binding + , ''Declaration + , ''Contract + ] + +instance Stubbed (Name info) where stubbing = _WrongName +instance Stubbed (Path info) where stubbing = _WrongPath +instance Stubbed (QualifiedName info) where stubbing = _WrongQualifiedName +instance Stubbed (Pattern info) where stubbing = _WrongPattern +instance Stubbed (Constant info) where stubbing = _WrongConstant +instance Stubbed (FieldAssignment info) where stubbing = _WrongFieldAssignment +instance Stubbed (Assignment info) where stubbing = _WrongAssignment +instance Stubbed (MapBinding info) where stubbing = _WrongMapBinding +instance Stubbed (LHS info) where stubbing = _WrongLHS +instance Stubbed (Alt info) where stubbing = _WrongAlt +instance Stubbed (Expr info) where stubbing = _WrongExpr +instance Stubbed (TField info) where stubbing = _WrongTField +instance Stubbed (Variant info) where stubbing = _WrongVariant +instance Stubbed (Type info) where stubbing = _WrongType +instance Stubbed (Mutable info) where stubbing = _WrongMutable +instance Stubbed (VarDecl info) where stubbing = _WrongVarDecl +instance Stubbed (Binding info) where stubbing = _WrongBinding +instance Stubbed (Declaration info) where stubbing = _WrongDecl +instance Stubbed (Contract info) where stubbing = _WrongContract diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 07e10d7ab..c8fbb4765 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -54,11 +54,12 @@ module Parser , select , dump , stubbed - , Stubbed (stub) - , Error + , Stubbed (..) + , Error (..) , HasComments (getComments) ) where +import Control.Lens hiding (inside) import Control.Monad.State import Control.Monad.Writer import Control.Monad.Reader @@ -66,6 +67,7 @@ import Control.Monad.Except import Control.Monad.Identity import Data.Foldable +import Data.Traversable import Data.Functor import Data.Text (Text, pack, unpack) import qualified Data.Text as Text @@ -153,6 +155,25 @@ takeNext msg = do ) return t +--fields :: Text -> Parser a -> Parser [a] +--fields name parser = do +-- (fs, rest) <- gets $ splitForest name . fst +-- res <- for fs \f -> do +-- put f +-- parser +-- +-- put rest +-- return res +-- +--splitForest :: Text -> ParseForest -> [ParseForest] +--splitForest name = go . pfGrove +-- where +-- go [] acc fs = (fs, acc) +-- go ((tName, tree) : other) acc fs = +-- if tName == name +-- then go other [] (reverse (tree : acc) : fs) +-- else go other (tree : acc) fs + -- | Pick a tree with that /field name/ or die with name as msg. -- -- Will erase all subtrees with different names on the path! @@ -211,7 +232,7 @@ complain msg rng = tell . pure =<< makeError' msg rng unexpected :: ParseTree -> Error unexpected ParseTree { ptSource, ptRange } = - Expected "unexpected" ptSource ptRange + Expected "not that" ptSource ptRange -- | If a parser fails, return stub with error originating here. stubbed :: Stubbed a => Text -> Parser a -> Parser a @@ -370,12 +391,15 @@ notFollowedBy parser = do unless good do die "notFollowedBy" +stub :: Stubbed a => Error -> a +stub = (stubbing #) + -- | For types that have a default replacer with an `Error`. class Stubbed a where - stub :: Error -> a + stubbing :: Prism' a Error instance Stubbed Text where - stub = pack . show + stubbing = prism (pack . show) Left -- | This is bad, but I had to. -- @@ -383,11 +407,11 @@ instance Stubbed Text where -- I probably need a wrapper around '[]'. -- instance Stubbed [a] where - stub _ = [] + stubbing = prism (const []) Left -- | `Nothing` would be bad default replacer. instance Stubbed a => Stubbed (Maybe a) where - stub = Just . stub + stubbing = _Just . stubbing -- | Universal accessor. -- diff --git a/tools/lsp/squirrel/src/TH.hs b/tools/lsp/squirrel/src/TH.hs new file mode 100644 index 000000000..7e375fb52 --- /dev/null +++ b/tools/lsp/squirrel/src/TH.hs @@ -0,0 +1,13 @@ + +module TH () where + +import Control.Applicative + +import Language.Haskell.TH.Syntax (Q) + +instance Semigroup a => Semigroup (Q a) where + (<>) = liftA2 (<>) + +instance Monoid a => Monoid (Q a) where + mempty = pure mempty + diff --git a/tools/lsp/squirrel/stack.yaml b/tools/lsp/squirrel/stack.yaml index da98e5898..68c34293a 100644 --- a/tools/lsp/squirrel/stack.yaml +++ b/tools/lsp/squirrel/stack.yaml @@ -17,7 +17,7 @@ # # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-15.7 +resolver: lts-15.10 # User packages to be built. # Various formats can be used as shown in the example below. @@ -29,16 +29,16 @@ resolver: lts-15.7 # - auto-update # - wai packages: -- . + - . # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: # extra-deps: -- tree-sitter-0.9.0.0@sha256:4fd054b0a9651df9335c5fa0ffed723924dc4dcf7f2521c031323088ca719b05,3411 -- semantic-source-0.0.2.0@sha256:eac962ed1150d8647e703bc78369ecc4c1912db018e111f4ead8a62ae1a85542,2368 -- lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899 -- semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909 + - tree-sitter-0.9.0.0@sha256:4fd054b0a9651df9335c5fa0ffed723924dc4dcf7f2521c031323088ca719b05,3411 + - semantic-source-0.0.2.0@sha256:eac962ed1150d8647e703bc78369ecc4c1912db018e111f4ead8a62ae1a85542,2368 + - lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899 + - semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909 # - acme-missiles-0.3 # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a @@ -68,3 +68,5 @@ extra-deps: # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor +nix: + packages: [zlib] \ No newline at end of file diff --git a/tools/lsp/squirrel/stack.yaml.lock b/tools/lsp/squirrel/stack.yaml.lock index 408f7db7b..24724eadc 100644 --- a/tools/lsp/squirrel/stack.yaml.lock +++ b/tools/lsp/squirrel/stack.yaml.lock @@ -34,7 +34,7 @@ packages: hackage: semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909 snapshots: - completed: - size: 491389 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/7.yaml - sha256: 92ab6303fe20ec928461c82ce0980b4d17c06f4e66205a2967e476474f686c17 - original: lts-15.7 + size: 493124 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/10.yaml + sha256: 48bc6d1d59224a5166265ef6cdda6a512f29ecc8ef7331826312b82377e89507 + original: lts-15.10