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

3
.gitignore vendored
View File

@ -30,3 +30,6 @@ tools/lsp/camligo/src/
tools/lsp/camligo/index.js tools/lsp/camligo/index.js
tools/lsp/camligo/node_modules tools/lsp/camligo/node_modules
nix/result nix/result
.idea
*.iml
stale_outputs_checked

View File

@ -1,23 +1,129 @@
import Data.Foldable (for_) 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 ParseTree
import Parser import Parser
import Range
import AST import AST
import Pretty import Pretty
import System.Environment
main :: IO () main :: IO ()
main = do 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)

View File

@ -1,25 +1,31 @@
name: squirrel name: squirrel
dependencies: dependencies:
- base - base
- bytestring - bytestring
- mtl - data-default
- text - lens
- tree-sitter - mtl
- pretty - template-haskell
- text
- tree-sitter
- pretty
default-extensions: 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: library:
source-dirs: source-dirs:
@ -33,10 +39,15 @@ library:
executables: executables:
squirrel: squirrel:
dependencies:
- base
- stm
- haskell-lsp
- squirrel
- hslogger
- interpolate
main: Main.hs main: Main.hs
source-dirs: source-dirs:
- app/ - app/
dependencies:
- squirrel

View File

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 265647f1e4ee30432d151c4651a52d5777306a54afa992c70c83d840f87d5365 -- hash: 538d4e2f89a920b2395b5b445d883e29cf753fa91e443e1308a48a689018f4eb
name: squirrel name: squirrel
version: 0.0.0 version: 0.0.0
@ -13,18 +13,20 @@ build-type: Simple
library library
exposed-modules: exposed-modules:
AST AST
AST.Errors
AST.Parser AST.Parser
AST.Types AST.Types
Parser Parser
ParseTree ParseTree
Pretty Pretty
Range Range
TH
other-modules: other-modules:
Paths_squirrel Paths_squirrel
hs-source-dirs: hs-source-dirs:
src/ 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: include-dirs:
vendor vendor
c-sources: c-sources:
@ -32,8 +34,11 @@ library
build-depends: build-depends:
base base
, bytestring , bytestring
, data-default
, lens
, mtl , mtl
, pretty , pretty
, template-haskell
, text , text
, tree-sitter , tree-sitter
default-language: Haskell2010 default-language: Haskell2010
@ -44,14 +49,21 @@ executable squirrel
Paths_squirrel Paths_squirrel
hs-source-dirs: hs-source-dirs:
app/ 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: build-depends:
base base
, bytestring , bytestring
, data-default
, haskell-lsp
, hslogger
, interpolate
, lens
, mtl , mtl
, pretty , pretty
, squirrel , squirrel
, stm
, template-haskell
, text , text
, tree-sitter , tree-sitter
default-language: Haskell2010 default-language: Haskell2010

View File

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

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

View File

@ -9,6 +9,7 @@
module AST.Types where module AST.Types where
import Control.Monad.State import Control.Monad.State
import Control.Lens hiding (Const, List)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text (Text) import Data.Text (Text)
@ -18,6 +19,8 @@ import Parser
import ParseTree import ParseTree
import Pretty import Pretty
import TH
import Debug.Trace import Debug.Trace
data Contract info data Contract info
@ -25,8 +28,6 @@ data Contract info
| WrongContract Error | WrongContract Error
deriving (Show) via PP (Contract info) deriving (Show) via PP (Contract info)
instance Stubbed (Contract info) where stub = WrongContract
data Declaration info data Declaration info
= ValueDecl info (Binding info) = ValueDecl info (Binding info)
| TypeDecl info (Name info) (Type info) | TypeDecl info (Name info) (Type info)
@ -35,7 +36,6 @@ data Declaration info
| WrongDecl Error | WrongDecl Error
deriving (Show) via PP (Declaration info) deriving (Show) via PP (Declaration info)
instance Stubbed (Declaration info) where stub = WrongDecl
data Binding info data Binding info
= Irrefutable info (Pattern info) (Expr info) = Irrefutable info (Pattern info) (Expr info)
@ -45,14 +45,12 @@ data Binding info
| WrongBinding Error | WrongBinding Error
deriving (Show) via PP (Binding info) deriving (Show) via PP (Binding info)
instance Stubbed (Binding info) where stub = WrongBinding
data VarDecl info data VarDecl info
= Decl info (Mutable info) (Name info) (Type info) = Decl info (Mutable info) (Name info) (Type info)
| WrongVarDecl Error | WrongVarDecl Error
deriving (Show) via PP (VarDecl info) deriving (Show) via PP (VarDecl info)
instance Stubbed (VarDecl info) where stub = WrongVarDecl
data Mutable info data Mutable info
= Mutable info = Mutable info
@ -61,7 +59,6 @@ data Mutable info
deriving (Show) via PP (Mutable info) deriving (Show) via PP (Mutable info)
instance Stubbed (Mutable info) where stub = WrongMutable
data Type info data Type info
= TArrow info (Type info) (Type info) = TArrow info (Type info) (Type info)
@ -73,21 +70,18 @@ data Type info
| WrongType Error | WrongType Error
deriving (Show) via PP (Type info) deriving (Show) via PP (Type info)
instance Stubbed (Type info) where stub = WrongType
data Variant info data Variant info
= Variant info (Name info) (Maybe (Type info)) = Variant info (Name info) (Maybe (Type info))
| WrongVariant Error | WrongVariant Error
deriving (Show) via PP (Variant info) deriving (Show) via PP (Variant info)
instance Stubbed (Variant info) where stub = WrongVariant
data TField info data TField info
= TField info (Name info) (Type info) = TField info (Name info) (Type info)
| WrongTField Error | WrongTField Error
deriving (Show) via PP (TField info) 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. -- | TODO: break onto smaller types? Literals -> Constannt; mapOps; mmove Annots to Decls.
data Expr info data Expr info
@ -123,42 +117,36 @@ data Expr info
| WrongExpr Error | WrongExpr Error
deriving (Show) via PP (Expr info) deriving (Show) via PP (Expr info)
instance Stubbed (Expr info) where stub = WrongExpr
data Alt info data Alt info
= Alt info (Pattern info) (Expr info) = Alt info (Pattern info) (Expr info)
| WrongAlt Error | WrongAlt Error
deriving (Show) via PP (Alt info) deriving (Show) via PP (Alt info)
instance Stubbed (Alt info) where stub = WrongAlt
data LHS info data LHS info
= LHS info (QualifiedName info) (Maybe (Expr info)) = LHS info (QualifiedName info) (Maybe (Expr info))
| WrongLHS Error | WrongLHS Error
deriving (Show) via PP (LHS info) deriving (Show) via PP (LHS info)
instance Stubbed (LHS info) where stub = WrongLHS
data MapBinding info data MapBinding info
= MapBinding info (Expr info) (Expr info) = MapBinding info (Expr info) (Expr info)
| WrongMapBinding Error | WrongMapBinding Error
deriving (Show) via PP (MapBinding info) deriving (Show) via PP (MapBinding info)
instance Stubbed (MapBinding info) where stub = WrongMapBinding
data Assignment info data Assignment info
= Assignment info (Name info) (Expr info) = Assignment info (Name info) (Expr info)
| WrongAssignment Error | WrongAssignment Error
deriving (Show) via PP (Assignment info) deriving (Show) via PP (Assignment info)
instance Stubbed (Assignment info) where stub = WrongAssignment
data FieldAssignment info data FieldAssignment info
= FieldAssignment info (QualifiedName info) (Expr info) = FieldAssignment info (QualifiedName info) (Expr info)
| WrongFieldAssignment Error | WrongFieldAssignment Error
deriving (Show) via PP (FieldAssignment info) deriving (Show) via PP (FieldAssignment info)
instance Stubbed (FieldAssignment info) where stub = WrongFieldAssignment
data Constant info data Constant info
= Int info Text = Int info Text
@ -170,7 +158,6 @@ data Constant info
| WrongConstant Error | WrongConstant Error
deriving (Show) via PP (Constant info) deriving (Show) via PP (Constant info)
instance Stubbed (Constant info) where stub = WrongConstant
data Pattern info data Pattern info
= IsConstr info (Name info) (Maybe (Pattern info)) = IsConstr info (Name info) (Maybe (Pattern info))
@ -183,7 +170,6 @@ data Pattern info
| WrongPattern Error | WrongPattern Error
deriving (Show) via PP (Pattern info) deriving (Show) via PP (Pattern info)
instance Stubbed (Pattern info) where stub = WrongPattern
data QualifiedName info data QualifiedName info
= QualifiedName = QualifiedName
@ -194,7 +180,6 @@ data QualifiedName info
| WrongQualifiedName Error | WrongQualifiedName Error
deriving (Show) via PP (QualifiedName info) deriving (Show) via PP (QualifiedName info)
instance Stubbed (QualifiedName info) where stub = WrongQualifiedName
data Path info data Path info
= At info (Name info) = At info (Name info)
@ -202,7 +187,6 @@ data Path info
| WrongPath Error | WrongPath Error
deriving (Show) via PP (Path info) deriving (Show) via PP (Path info)
instance Stubbed (Path info) where stub = WrongPath
data Name info = Name data Name info = Name
{ info :: info { info :: info
@ -211,8 +195,6 @@ data Name info = Name
| WrongName Error | WrongName Error
deriving (Show) via PP (Name info) deriving (Show) via PP (Name info)
instance Stubbed (Name info) where stub = WrongName
c :: HasComments i => i -> Doc -> Doc c :: HasComments i => i -> Doc -> Doc
c i d = c i d =
case getComments i of case getComments i of
@ -393,3 +375,45 @@ instance HasComments i => Pretty (LHS i) where
pp = \case pp = \case
LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi LHS i qn mi -> c i $ pp qn <> foldMap (brackets . pp) mi
WrongLHS err -> pp err 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

View File

@ -54,11 +54,12 @@ module Parser
, select , select
, dump , dump
, stubbed , stubbed
, Stubbed (stub) , Stubbed (..)
, Error , Error (..)
, HasComments (getComments) , HasComments (getComments)
) where ) where
import Control.Lens hiding (inside)
import Control.Monad.State import Control.Monad.State
import Control.Monad.Writer import Control.Monad.Writer
import Control.Monad.Reader import Control.Monad.Reader
@ -66,6 +67,7 @@ import Control.Monad.Except
import Control.Monad.Identity import Control.Monad.Identity
import Data.Foldable import Data.Foldable
import Data.Traversable
import Data.Functor import Data.Functor
import Data.Text (Text, pack, unpack) import Data.Text (Text, pack, unpack)
import qualified Data.Text as Text import qualified Data.Text as Text
@ -153,6 +155,25 @@ takeNext msg = do
) )
return t 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. -- | Pick a tree with that /field name/ or die with name as msg.
-- --
-- Will erase all subtrees with different names on the path! -- 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 -> Error
unexpected ParseTree { ptSource, ptRange } = unexpected ParseTree { ptSource, ptRange } =
Expected "unexpected" ptSource ptRange Expected "not that" ptSource ptRange
-- | If a parser fails, return stub with error originating here. -- | If a parser fails, return stub with error originating here.
stubbed :: Stubbed a => Text -> Parser a -> Parser a stubbed :: Stubbed a => Text -> Parser a -> Parser a
@ -370,12 +391,15 @@ notFollowedBy parser = do
unless good do unless good do
die "notFollowedBy" die "notFollowedBy"
stub :: Stubbed a => Error -> a
stub = (stubbing #)
-- | For types that have a default replacer with an `Error`. -- | For types that have a default replacer with an `Error`.
class Stubbed a where class Stubbed a where
stub :: Error -> a stubbing :: Prism' a Error
instance Stubbed Text where instance Stubbed Text where
stub = pack . show stubbing = prism (pack . show) Left
-- | This is bad, but I had to. -- | This is bad, but I had to.
-- --
@ -383,11 +407,11 @@ instance Stubbed Text where
-- I probably need a wrapper around '[]'. -- I probably need a wrapper around '[]'.
-- --
instance Stubbed [a] where instance Stubbed [a] where
stub _ = [] stubbing = prism (const []) Left
-- | `Nothing` would be bad default replacer. -- | `Nothing` would be bad default replacer.
instance Stubbed a => Stubbed (Maybe a) where instance Stubbed a => Stubbed (Maybe a) where
stub = Just . stub stubbing = _Just . stubbing
-- | Universal accessor. -- | Universal accessor.
-- --

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

View File

@ -17,7 +17,7 @@
# #
# resolver: ./custom-snapshot.yaml # resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-15.7 resolver: lts-15.10
# User packages to be built. # User packages to be built.
# Various formats can be used as shown in the example below. # Various formats can be used as shown in the example below.
@ -29,16 +29,16 @@ resolver: lts-15.7
# - auto-update # - auto-update
# - wai # - wai
packages: packages:
- . - .
# Dependency packages to be pulled from upstream that are not in the resolver. # Dependency packages to be pulled from upstream that are not in the resolver.
# These entries can reference officially published versions as well as # These entries can reference officially published versions as well as
# forks / in-progress versions pinned to a git hash. For example: # forks / in-progress versions pinned to a git hash. For example:
# #
extra-deps: 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 # - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git # - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
@ -68,3 +68,5 @@ extra-deps:
# #
# Allow a newer minor version of GHC than the snapshot specifies # Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor # compiler-check: newer-minor
nix:
packages: [zlib]

View File

@ -34,7 +34,7 @@ packages:
hackage: semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909 hackage: semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
snapshots: snapshots:
- completed: - 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