balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

TMP

Browse Source
This commit is contained in:
Kirill Andreev 2020-05-19 21:26:57 +04:00
parent bc155bea16
commit 1536590edb
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
11 changed files with 569 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

@ -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

130
tools/lsp/squirrel/app/Main.hs
View File

@ -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 qualified Data.Text as Text
import Data.String.Interpolate (i)
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
import System.Environment
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)
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)

49
tools/lsp/squirrel/package.yaml
View File

@ -1,25 +1,31 @@
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:
@ -33,10 +39,15 @@ library:
executables:
squirrel:
dependencies:
- base
- stm
- haskell-lsp
- squirrel
- hslogger
- interpolate
main: Main.hs
source-dirs:
- app/
dependencies:
- squirrel

22
tools/lsp/squirrel/squirrel.cabal
View File

@ -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

1
tools/lsp/squirrel/src/AST.hs
View File

@ -3,3 +3,4 @@ module AST (module M) where
import AST.Types as M
import AST.Parser as M
import AST.Errors as M

292
tools/lsp/squirrel/src/AST/Errors.hs Normal file
View File

@ -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

66
tools/lsp/squirrel/src/AST/Types.hs
View File

@ -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

38
tools/lsp/squirrel/src/Parser.hs
View File

@ -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.
--

13
tools/lsp/squirrel/src/TH.hs Normal file
View File

@ -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

14
tools/lsp/squirrel/stack.yaml
View File

@ -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]

8
tools/lsp/squirrel/stack.yaml.lock
View File

@ -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