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

Add ability to recursively parse #included files

Browse Source
This commit is contained in:
Kirill Andreev 2020-07-03 19:52:06 +04:00
parent 583d7f8997
commit b35a28853b
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
12 changed files with 190 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -8,6 +8,7 @@ import Control.Monad
import Data.Default
import qualified Data.Text as Text
import Data.Text (Text)
import Data.Foldable
import Data.String.Interpolate (i)
import qualified Language.Haskell.LSP.Control as CTRL
@ -32,6 +33,8 @@ import Tree
main :: IO ()
main = do
-- for_ [1.. 100] \_ -> do
-- print =<< runParser contract example
errCode <- mainLoop
exit errCode
@ -165,13 +168,13 @@ eventLoop funs chan = do
_ -> U.logs "unknown msg"
posToRange :: J.Position -> Range
posToRange (J.Position l c) = Range (l, c, 0) (l, c, 0)
posToRange (J.Position l c) = Range (l, c, 0) (l, c, 0) ""
rangeToJRange :: Range -> J.Range
rangeToJRange (Range (a, b, _) (c, d, _)) = J.Range (J.Position a b) (J.Position c d)
rangeToJRange (Range (a, b, _) (c, d, _) _) = J.Range (J.Position a b) (J.Position c d)
rangeToLoc :: Range -> J.Range
rangeToLoc (Range (a, b, _) (c, d, _)) = J.Range (J.Position a b) (J.Position c d)
rangeToLoc (Range (a, b, _) (c, d, _) _) = J.Range (J.Position a b) (J.Position c d)
loadByURI :: J.Uri -> IO (Pascal (Product [[ScopedDecl], Range, [Text]]))
loadByURI uri = do
@ -197,7 +200,7 @@ collectErrors funs uri path version = do
Nothing -> error "TODO: implement URI file loading"
errorToDiag :: Error ASTInfo -> J.Diagnostic
errorToDiag (Expected what _ (getRange -> (Range (sl, sc, _) (el, ec, _)))) =
errorToDiag (Expected what _ (getRange -> (Range (sl, sc, _) (el, ec, _) _))) =
J.Diagnostic
(J.Range begin end)
(Just J.DsError)

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

@ -5,10 +5,11 @@ dependencies:
- bytestring
- containers
- data-default
- filepath
- exceptions
- fastsum
- mtl
- pretty
- template-haskell
- text
- tree-sitter

14
tools/lsp/squirrel/src/AST/Parser.hs
View File

@ -5,6 +5,7 @@
module AST.Parser (example, contract) where
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Sum
import AST.Types
@ -53,10 +54,11 @@ declaration
include :: Parser (Pascal ASTInfo)
include = do
subtree "include" do
ranged do
pure Include
<*> inside "filename" do
token "String"
inside "filename" do
ranged do
f <- token "String"
t <- restart contract (init $ tail $ Text.unpack f)
return $ Include f t
typedecl :: Parser (Pascal ASTInfo)
typedecl = do
@ -858,11 +860,11 @@ typeTuple = do
-- example = "../../../src/test/contracts/bytes_arithmetic.ligo"
-- example = "../../../src/test/contracts/bytes_unpack.ligo"
-- example = "../../../src/test/contracts/chain_id.ligo"
example = "../../../src/test/contracts/coase.ligo"
-- example = "../../../src/test/contracts/coase.ligo"
-- example = "../../../src/test/contracts/failwith.ligo"
-- example = "../../../src/test/contracts/loop.ligo"
-- example = "../../../src/test/contracts/redeclaration.ligo"
-- example = "../../../src/test/contracts/application.ligo"
example = "../../../src/test/contracts/includer.ligo"
-- example = "../../../src/test/contracts/application.ligo"
-- example = "../../../src/test/contracts/application.ligo"
-- example = "../../../src/test/contracts/application.ligo"

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

@ -32,7 +32,7 @@ data Declaration it
= ValueDecl it -- ^ Binding
| TypeDecl it it -- ^ Name Type
| Action it -- ^ Expr
| Include Text
| Include Text it
deriving (Show) via PP (Declaration it)
deriving stock (Functor, Foldable, Traversable)
@ -186,7 +186,11 @@ instance Pretty1 Declaration where
ValueDecl binding -> binding
TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty
Action e -> e
Include f -> "#include" <+> pp f
Include f t ->
"(* module" <+> pp f <+> "*)"
`indent` pp t
`above` "(* end" <+> pp f <+> "*)"
instance Pretty1 Binding where
pp1 = \case

11
tools/lsp/squirrel/src/Error.hs
View File

@ -1,5 +1,5 @@
{- | Parsing errors and utilities.
{- | Parsing Errors and utilities.
-}
module Error
@ -9,20 +9,25 @@ module Error
)
where
import Control.Monad.Catch
import Data.Text (Text, pack)
import Data.Typeable
import Pretty
-- | Parse error.
-- | Parse Error.
data Error info
= Expected
{ eMsg :: Text -- ^ Description of what was expected.
, eWhole :: Text -- ^ Offending text.
, eInfo :: info -- ^ Location of the error.
, eInfo :: info -- ^ Location of the Error.
}
deriving (Show) via PP (Error info)
deriving stock (Eq, Functor, Foldable, Traversable)
instance (Pretty i, Typeable i) => Exception (Error i)
instance Pretty1 Error where
pp1 (Expected msg found r) = "░" <> pp msg <> r <> "▒" <> pp found <> "▓"

3
tools/lsp/squirrel/src/ParseTree.hs
View File

@ -40,6 +40,8 @@ import Foreign.Storable ( peek
)
import Control.Monad ((>=>))
import System.FilePath
import Text.PrettyPrint hiding ((<>))
import Range
@ -144,6 +146,7 @@ toParseTree fin = do
, i $ pointColumn finish2D + 1
, i $ nodeEndByte node
)
, rFile = takeFileName fin
}
return $ ParseTree

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

@ -45,6 +45,7 @@ module Parser
, stubbed
, getInfo
, inside
, restart
-- * Error
, die
@ -63,16 +64,19 @@ module Parser
, ASTInfo(..)
) where
import Control.Monad.State
import Control.Monad.Writer hiding (Product)
import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.State
import Control.Monad.Catch
import qualified Control.Monad.Reader as MTL
import Data.Functor ((<&>))
import Data.Foldable
import Data.IORef
import Data.Text (Text, unpack)
import qualified Data.Text as Text
import System.FilePath
import ParseTree
import Range
import Pretty
@ -86,22 +90,45 @@ import Debug.Trace
--
-- TODO: separate state. Polysemy?
--
newtype Parser a = Parser
{ unParser
:: WriterT [Error ASTInfo] -- Early I though to report errors that way.
( StateT (ParseForest, [Text]) -- Current forest to recognise + comments.
( ExceptT (Error ASTInfo) -- Backtracking. Change `Error` to `()`?
( Identity ))) -- I forgot why. `#include`? Debug via `print`?
a
}
deriving newtype
( Functor
, Applicative
, Monad
, MonadState (ParseForest, [Text])
, MonadWriter [Error ASTInfo]
, MonadError (Error ASTInfo)
)
type Parser =
WriterT [Error ASTInfo]
(StateT (Product PList)
IO)
type PList = [ParseForest, [Text], FilePath]
-- | Auto-accumulated information to be put into AST being build.
type ASTInfo = Product [Range, [Text]]
runParser
:: Parser a
-> FilePath
-> IO (a, [Error ASTInfo])
runParser parser fin = do
pforest <- toParseTree fin
let dir = takeDirectory fin
runWriterT parser `evalStateT` Cons pforest (Cons [] (Cons dir Nil))
restart :: Parser a -> FilePath -> Parser a
restart p fin = do
dir <- get' @FilePath
(a, errs) <- liftIO do runParser p (dir </> fin)
tell errs
return a
get' :: forall x. Contains x PList => Parser x
get' = gets getElem
gets' :: forall x a. Contains x PList => (x -> a) -> Parser a
gets' f = gets (f . getElem)
put' :: forall x. Contains x PList => x -> Parser ()
put' x = modify $ modElem $ const x
mod' :: forall x. Contains x PList => (x -> x) -> Parser ()
mod' = modify . modElem
-- | Generate error originating at current location.
makeError :: Text -> Parser (Error ASTInfo)
@ -112,7 +139,7 @@ makeError msg = do
-- | Generate error originating at given location.
makeError' :: Text -> info -> Parser (Error info)
makeError' msg i = do
src <- gets (pfGrove . fst) <&> \case
src <- gets' pfGrove <&> \case
[] -> ""
(,) _ ParseTree { ptSource } : _ -> ptSource
return Expected
@ -124,23 +151,18 @@ makeError' msg i = do
-- | Pick next tree in a forest or die with msg.
takeNext :: Text -> Parser ParseTree
takeNext msg = do
(st@Forest {pfGrove, pfRange}, comms) <- get
case pfGrove of
gets' pfGrove >>= \case
[] -> die msg
(_, t) : f -> do
if "comment" `Text.isSuffixOf` ptName t
then do
(st', comms') <- get
put (st', ptSource t : comms')
mod' (ptSource t :)
takeNext msg
else do
put
( st
{ pfRange = diffRange pfRange (ptRange t)
, pfGrove = f
}
, comms
)
mod' \st -> st
{ pfRange = diffRange (pfRange st) (ptRange t)
, pfGrove = f
}
return t
--fields :: Text -> Parser a -> Parser [a]
@ -168,39 +190,35 @@ takeNext msg = do
--
field :: Text -> Parser a -> Parser a
field name parser = do
grove <- gets (pfGrove . fst)
case grove of
gets' pfGrove >>= \case
(name', t) : _
| name == name' -> do
sandbox True t
_ -> do
grove -> do
case lookup name grove of
Just tree -> sandbox False tree
Nothing -> die name
where
sandbox firstOne tree@ParseTree {ptID, ptRange} = do
(st@Forest {pfGrove = grove, pfRange = rng}, comments) <- get
st@Forest {pfGrove = grove, pfRange = rng} <- get'
let (errs, new_comments, grove') = delete name grove
put
( Forest
{ pfID = ptID
, pfGrove = [(name, tree)]
, pfRange = ptRange
}
, comments ++ new_comments
)
mod' (++ new_comments)
put' Forest
{ pfID = ptID
, pfGrove = [(name, tree)]
, pfRange = ptRange
}
res <- parser
put
( st
{ pfGrove = grove'
, pfRange = if firstOne then diffRange rng ptRange else rng
}
, []
)
put' st
{ pfGrove = grove'
, pfRange = if firstOne then diffRange rng ptRange else rng
}
put' @[Text] []
for_ errs (tell . pure . unexpected)
@ -211,10 +229,10 @@ fallback msg = pure . stub =<< makeError msg
-- | Produce "expected ${X}" error at this point.
die :: Text -> Parser a
die msg = throwError =<< makeError msg
die msg = throwM =<< makeError msg
die' ::Text -> ASTInfo -> Parser a
die' msg rng = throwError =<< makeError' msg rng
die' msg rng = throwM =<< makeError' msg rng
-- | When tree-sitter found something it was unable to process.
unexpected :: ParseTree -> Error ASTInfo
@ -233,18 +251,23 @@ subtree msg parser = do
ParseTree {ptChildren, ptName} <- takeNext msg
if ptName == msg
then do
(save, comms) <- get
put (ptChildren, comms)
rest <- gets (pfGrove . fst)
save <- get' @ParseForest
put' ptChildren
rest <- gets' pfGrove
collectErrors rest
(_, comms') <- get
parser <* put (save, comms')
parser <* put' save
else do
die msg
-- | Because `ExceptT` requires error to be `Monoid` for `Alternative`.
(<|>) :: Parser a -> Parser a -> Parser a
Parser l <|> Parser r = Parser (l `catchError` const r)
l <|> r = do
s <- get' @ParseForest
c <- get' @[Text]
l `catch` \(e :: Error ASTInfo) -> do
put' s
put' c
r
-- | Custom @foldl1 (<|>)@.
select :: [Parser a] -> Parser a
@ -278,22 +301,6 @@ some p = some'
xs <- many'
return (x : xs)
-- | Run parser on given file.
--
runParser :: Parser a -> FilePath -> IO (a, [Error ASTInfo])
runParser parser fin = do
pforest <- toParseTree fin
let
res =
runIdentity
$ runExceptT
$ flip runStateT (pforest, [])
$ runWriterT
$ unParser
$ parser
either (error . show) (return . fst) res
-- | Run parser on given file and pretty-print stuff.
--
debugParser :: Show a => Parser a -> FilePath -> IO ()
@ -301,7 +308,7 @@ debugParser parser fin = do
(res, errs) <- runParser parser fin
putStrLn "Result:"
print res
unless (null errs) do
MTL.unless (null errs) do
putStrLn ""
putStrLn "Errors:"
for_ errs (print . nest 2 . pp)
@ -324,12 +331,12 @@ anything = do
-- | Get range of the current tree (or forest) before the parser was run.
range :: Parser a -> Parser (a, Range)
range parser =
get >>= \case
(,) Forest {pfGrove = [(,) _ ParseTree {ptRange}]} _ -> do
get' >>= \case
Forest {pfGrove = [(,) _ ParseTree {ptRange}]} -> do
a <- parser
return (a, ptRange)
(,) Forest {pfRange} _ -> do
Forest {pfRange} -> do
a <- parser
return (a, pfRange)
@ -367,7 +374,7 @@ delete k ((k', v) : rest) =
collectErrors :: [(Text, ParseTree)] -> Parser ()
collectErrors vs =
for_ vs \(_, v) -> do
when (ptName v == "ERROR") do
MTL.when (ptName v == "ERROR") do
tell [unexpected v]
-- | Universal accessor.
@ -398,9 +405,6 @@ inside sig parser = do
subtree st do
parser
-- | Auto-accumulated information to be put into AST being build.
type ASTInfo = Product [Range, [Text]]
-- | Equip given constructor with info.
getInfo :: Parser ASTInfo
getInfo = Cons <$> currentRange <*> do Cons <$> grabComments <*> pure Nil
@ -408,10 +412,10 @@ getInfo = Cons <$> currentRange <*> do Cons <$> grabComments <*> pure Nil
-- | Take the accumulated comments, clean the accumulator.
grabComments :: Parser [Text]
grabComments = do
(st, comms) <- get
put (st, [])
comms <- get'
mod' @[Text] $ const []
return comms
-- | /Actual/ debug pring.
dump :: Parser ()
dump = gets (pfGrove . fst) >>= traceShowM
dump = gets' pfGrove >>= traceShowM

10
tools/lsp/squirrel/src/Pretty.hs
View File

@ -37,6 +37,8 @@ import Data.Text (Text, pack)
import Text.PrettyPrint hiding ((<>))
import Product
-- | Pretty-print to `Text`. Through `String`. Yep.
ppToText :: Pretty a => a -> Text
ppToText = pack . show . pp
@ -131,4 +133,10 @@ color :: Color -> Doc -> Doc
color c d = zeroWidthText begin <> d <> zeroWidthText end
where
begin = "\x1b[" ++ show (30 + c) ++ "m"
end = "\x1b[0m"
end = "\x1b[0m"
instance Pretty (Product '[]) where
pp _ = "{}"
instance (Pretty x, Pretty (Product xs)) => Pretty (Product (x : xs)) where
pp (Cons x xs) = pp x <+> "&" <+> pp xs

51
tools/lsp/squirrel/src/Product.hs
View File

@ -1,39 +1,44 @@
{-|
The heterogeneous list.
-}
module Product where
import qualified Data.Text as Text
import Pretty
-- | `Product xs` contains elements of each of the types from the `xs` list.
data Product xs where
Cons :: x -> Product xs -> Product (x : xs)
Nil :: Product '[]
Cons :: { pHead :: x, pTail :: Product xs } -> Product (x : xs)
instance Pretty (Product xs) => Show (Product xs) where
show = show . PP
-- | Find/modify the element with a given type.
--
-- If you want to have same-types, use newtype wrappers.
--
class Contains x xs where
getElem :: Product xs -> x
putElem :: x -> Product xs -> Product xs
modElem :: (x -> x) -> Product xs -> Product xs
instance {-# OVERLAPS #-} Contains x (x : xs) where
getElem (Cons x _) = x
putElem x (Cons _ xs) = Cons x xs
getElem (Cons x _) = x
modElem f (Cons x xs) = Cons (f x) xs
instance Contains x xs => Contains x (y : xs) where
getElem (Cons _ xs) = getElem xs
putElem x (Cons y xs) = Cons y (putElem x xs)
modElem f (Cons x xs) = Cons x (modElem f xs)
modElem :: Contains x xs => (x -> x) -> Product xs -> Product xs
modElem f xs = putElem (f $ getElem xs) xs
-- | Add a name to the type.
--
newtype (s :: String) := t = Tag { unTag :: t }
instance Pretty (Product '[]) where
pp _ = "{}"
-- | Retrieve a type associated with the given name.
--
getTag :: forall s t xs. Contains (s := t) xs => Product xs -> t
getTag = unTag . getElem @(s := t)
instance (Pretty x, Pretty (Product xs)) => Pretty (Product (x : xs)) where
pp (Cons x xs) =
if Text.null $ Text.strip ppx
then pp xs
else pp ppx <+> "&" <+> pp xs
where
ppx = ppToText x
-- | Modify a type associated with the given name.
--
modTag
:: forall s t xs
. Contains (s := t) xs
=> (t -> t)
-> Product xs -> Product xs
modTag f = modElem @(s := t) (Tag . f . unTag)

21
tools/lsp/squirrel/src/Range.hs
View File

@ -15,6 +15,8 @@ import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Text.Encoding
import System.FilePath
import Pretty
import Lattice
import Product
@ -23,19 +25,24 @@ import Product
data Range = Range
{ rStart :: (Int, Int, Int) -- ^ [Start: line, col, byte-offset...
, rFinish :: (Int, Int, Int) -- ^ ... End: line, col, byte-offset).
, rFile :: FilePath
}
deriving (Show) via PP Range
deriving stock (Ord)
-- | TODO: Ugh. Purge it.
diffRange :: Range -> Range -> Range
diffRange (Range ws wf) (Range ps _) = Range (max ws ps) wf
diffRange (Range ws wf f) (Range ps _ _) = Range (max ws ps) wf f
instance Pretty Range where
pp (Range (ll, lc, _) (rl, rc, _)) =
pp (Range (ll, lc, _) (rl, rc, _) f) =
color 2 do
brackets do
int ll <> ":" <> int lc <> "-" <> int rl <> ":" <> int rc
text f <> ":"
<> int ll <> ":"
<> int lc <> "-"
<> int rl <> ":"
<> int rc
-- | Ability to get range out of something.
class HasRange a where
@ -49,17 +56,17 @@ instance Contains Range xs => HasRange (Product xs) where
-- | Extract textual representation of given range.
cutOut :: Range -> ByteString -> Text
cutOut (Range (_, _, s) (_, _, f)) bs =
cutOut (Range (_, _, s) (_, _, f) _) bs =
decodeUtf8
$ BS.take (f - s)
$ BS.drop s
bs
instance Lattice Range where
Range (ll1, lc1, _) (ll2, lc2, _) <? Range (rl1, rc1, _) (rl2, rc2, _) =
Range (ll1, lc1, _) (ll2, lc2, _) _ <? Range (rl1, rc1, _) (rl2, rc2, _) _ =
(rl1 < ll1 || rl1 == ll1 && rc1 <= lc1) &&
(rl2 > ll2 || rl2 == ll2 && rc2 >= lc2)
instance Eq Range where
Range (l, c, _) (r, d, _) == Range (l1, c1, _) (r1, d1, _) =
(l, c, r, d) == (l1, c1, r1, d1)
Range (l, c, _) (r, d, _) f == Range (l1, c1, _) (r1, d1, _) f1 =
(l, c, r, d, f) == (l1, c1, r1, d1, f1)

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

@ -40,7 +40,8 @@ extra-deps:
- lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899
- semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
- fastsum-0.1.1.1
- git: https://github.com/Heimdell/dual-effects.git
commit: dc3e8bcd0aa00b9264e86293ec42c0b5835e930c
# - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

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

@ -39,6 +39,20 @@ packages:
sha256: 1c89d4034e6d06e15ff0ec421a95206c030ddc2d35b9eee7f0a02aa30c6051c1
original:
hackage: fastsum-0.1.1.1
- completed:
cabal-file:
size: 1569
sha256: 828a5bc60b97347d491038b435da664ae281a6dab26e9beb261d319c2601c4dc
name: eff
version: 0.0.0
git: https://github.com/Heimdell/dual-effects.git
pantry-tree:
size: 972
sha256: 4443705f2fc31929822a3cda4036f9a93950686f4729cd28280253e981828391
commit: dc3e8bcd0aa00b9264e86293ec42c0b5835e930c
original:
git: https://github.com/Heimdell/dual-effects.git
commit: dc3e8bcd0aa00b9264e86293ec42c0b5835e930c
snapshots:
- completed:
size: 493124