TMP

.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

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 qualified Data.Text                             as Text
-import Parser
+import           Data.String.Interpolate (i)
-import AST
-import Pretty
 
-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
+  errCode <- mainLoop
-  toParseTree fin >>= print
+  exit errCode
-  (res, errs) <- runParser contract fin
+
-  putStrLn "----------------------"
+mainLoop :: IO Int
-  print (pp res)
+mainLoop = do
-  unless (null errs) do
+    chan <- atomically newTChan :: IO (TChan FromClientMessage)
-    putStrLn ""
+
-    putStrLn "Errors:"
+    let
-    for_ errs (print . nest 2 . pp)
+      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)

tools/lsp/squirrel/package.yaml

@@ -1,42 +1,53 @@
-
 name: squirrel
 
 dependencies:
-- base
+  - base
-- bytestring
+  - bytestring
-- mtl
+  - data-default
-- text
+  - lens
-- tree-sitter
+  - mtl
-- pretty
+  - template-haskell
+  - text
+  - tree-sitter
+  - pretty
 
 default-extensions:
-- LambdaCase
+  - LambdaCase
-- BlockArguments
+  - BlockArguments
-- OverloadedStrings
+  - OverloadedStrings
-- GeneralisedNewtypeDeriving
+  - GeneralisedNewtypeDeriving
-- DerivingStrategies
+  - DerivingStrategies
-- DerivingVia
+  - DerivingVia
-- NamedFieldPuns
+  - FlexibleInstances
-- BangPatterns
+  - 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/
+      - app/
-
-    dependencies:
-    - squirrel

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
+  default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell
-  ghc-options: -freverse-errors -Wall
+  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
+  default-extensions: LambdaCase BlockArguments OverloadedStrings GeneralisedNewtypeDeriving DerivingStrategies DerivingVia FlexibleInstances NamedFieldPuns BangPatterns ScopedTypeVariables QuasiQuotes TemplateHaskell
-  ghc-options: -freverse-errors -Wall
+  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

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

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

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

tools/lsp/squirrel/src/Parser.hs

@@ -54,11 +54,12 @@ module Parser
   , select
   , dump
   , stubbed
-  , Stubbed (stub)
+  , Stubbed (..)
-  , Error
+  , 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.
 --

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
+

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
+  - tree-sitter-0.9.0.0@sha256:4fd054b0a9651df9335c5fa0ffed723924dc4dcf7f2521c031323088ca719b05,3411
-- semantic-source-0.0.2.0@sha256:eac962ed1150d8647e703bc78369ecc4c1912db018e111f4ead8a62ae1a85542,2368
+  - semantic-source-0.0.2.0@sha256:eac962ed1150d8647e703bc78369ecc4c1912db018e111f4ead8a62ae1a85542,2368
-- lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899
+  - lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899
-- semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
+  - 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]

tools/lsp/squirrel/stack.yaml.lock

@@ -34,7 +34,7 @@ packages:
     hackage: semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
 snapshots:
 - completed:
-    size: 491389
+    size: 493124
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/7.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/10.yaml
-    sha256: 92ab6303fe20ec928461c82ce0980b4d17c06f4e66205a2967e476474f686c17
+    sha256: 48bc6d1d59224a5166265ef6cdda6a512f29ecc8ef7331826312b82377e89507
-  original: lts-15.7
+  original: lts-15.10