diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 2ce86600e..7f6490cb3 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -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) diff --git a/tools/lsp/squirrel/package.yaml b/tools/lsp/squirrel/package.yaml index 7c0e255ef..e45d3e35c 100644 --- a/tools/lsp/squirrel/package.yaml +++ b/tools/lsp/squirrel/package.yaml @@ -5,10 +5,11 @@ dependencies: - bytestring - containers - data-default + - filepath + - exceptions - fastsum - mtl - pretty - - template-haskell - text - tree-sitter diff --git a/tools/lsp/squirrel/src/AST/Parser.hs b/tools/lsp/squirrel/src/AST/Parser.hs index 2a4a939e7..f3920a3ad 100644 --- a/tools/lsp/squirrel/src/AST/Parser.hs +++ b/tools/lsp/squirrel/src/AST/Parser.hs @@ -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" diff --git a/tools/lsp/squirrel/src/AST/Types.hs b/tools/lsp/squirrel/src/AST/Types.hs index a5ba6e6a3..2272d767b 100644 --- a/tools/lsp/squirrel/src/AST/Types.hs +++ b/tools/lsp/squirrel/src/AST/Types.hs @@ -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 diff --git a/tools/lsp/squirrel/src/Error.hs b/tools/lsp/squirrel/src/Error.hs index 8daf90e75..22a8ff38f 100644 --- a/tools/lsp/squirrel/src/Error.hs +++ b/tools/lsp/squirrel/src/Error.hs @@ -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 <> "▓" diff --git a/tools/lsp/squirrel/src/ParseTree.hs b/tools/lsp/squirrel/src/ParseTree.hs index 5576a2987..9869a265f 100644 --- a/tools/lsp/squirrel/src/ParseTree.hs +++ b/tools/lsp/squirrel/src/ParseTree.hs @@ -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 diff --git a/tools/lsp/squirrel/src/Parser.hs b/tools/lsp/squirrel/src/Parser.hs index 91c52b7ee..af4a2af6f 100644 --- a/tools/lsp/squirrel/src/Parser.hs +++ b/tools/lsp/squirrel/src/Parser.hs @@ -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 diff --git a/tools/lsp/squirrel/src/Pretty.hs b/tools/lsp/squirrel/src/Pretty.hs index d0ae1c343..6cdfff5ae 100644 --- a/tools/lsp/squirrel/src/Pretty.hs +++ b/tools/lsp/squirrel/src/Pretty.hs @@ -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" \ No newline at end of file + 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 \ No newline at end of file diff --git a/tools/lsp/squirrel/src/Product.hs b/tools/lsp/squirrel/src/Product.hs index 7edd93b95..ed69c63c4 100644 --- a/tools/lsp/squirrel/src/Product.hs +++ b/tools/lsp/squirrel/src/Product.hs @@ -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) \ No newline at end of file diff --git a/tools/lsp/squirrel/src/Range.hs b/tools/lsp/squirrel/src/Range.hs index 21de5827c..cb7eb95d5 100644 --- a/tools/lsp/squirrel/src/Range.hs +++ b/tools/lsp/squirrel/src/Range.hs @@ -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, _) 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) \ No newline at end of file + Range (l, c, _) (r, d, _) f == Range (l1, c1, _) (r1, d1, _) f1 = + (l, c, r, d, f) == (l1, c1, r1, d1, f1) \ No newline at end of file diff --git a/tools/lsp/squirrel/stack.yaml b/tools/lsp/squirrel/stack.yaml index 495510ee4..4a32efa94 100644 --- a/tools/lsp/squirrel/stack.yaml +++ b/tools/lsp/squirrel/stack.yaml @@ -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 diff --git a/tools/lsp/squirrel/stack.yaml.lock b/tools/lsp/squirrel/stack.yaml.lock index df29dffa7..8b0fa6203 100644 --- a/tools/lsp/squirrel/stack.yaml.lock +++ b/tools/lsp/squirrel/stack.yaml.lock @@ -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