Add ability to recursively parse #included files

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)

tools/lsp/squirrel/package.yaml

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

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
+    inside "filename" do
       ranged do
-      pure Include
+        f <- token "String"
-        <*> inside "filename" do
+        t <- restart contract (init $ tail $ Text.unpack f)
-              token "String"
+        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"

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

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 <> "▓"
 

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

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.State
-import Control.Monad.Identity
+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
+type Parser =
-  { unParser
+   WriterT [Error ASTInfo]
-      :: WriterT [Error ASTInfo]        -- Early I though to report errors that way.
+  (StateT (Product PList)
-      (  StateT  (ParseForest, [Text])  -- Current forest to recognise + comments.
+   IO)
-      (  ExceptT (Error ASTInfo)        -- Backtracking. Change `Error` to `()`?
+
-      (  Identity )))                   -- I forgot why. `#include`? Debug via `print`?
+type PList = [ParseForest, [Text], FilePath]
-         a
+
-  }
+-- | Auto-accumulated information to be put into AST being build.
-  deriving newtype
+type ASTInfo = Product [Range, [Text]]
-    ( Functor
+
-    , Applicative
+runParser
-    , Monad
+  :: Parser a
-    , MonadState   (ParseForest, [Text])
+  -> FilePath
-    , MonadWriter [Error ASTInfo]
+  -> IO (a, [Error ASTInfo])
-    , MonadError  (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
+  gets' pfGrove >>= \case
-  case pfGrove of
     [] -> die msg
     (_, t) : f -> do
       if "comment" `Text.isSuffixOf` ptName t
       then do
-        (st', comms') <- get
+        mod' (ptSource t :)
-        put (st', ptSource t : comms')
         takeNext msg
       else do
-        put
+        mod' \st -> st
-          ( st
+          { pfRange = diffRange (pfRange st) (ptRange t)
-            { pfRange = diffRange pfRange (ptRange t)
           , pfGrove = f
           }
-          , comms
-          )
         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)
+  gets' pfGrove >>= \case
-  case grove of
     (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
+      mod' (++ new_comments)
-        ( Forest
+      put' Forest
         { pfID    = ptID
         , pfGrove = [(name, tree)]
         , pfRange = ptRange
         }
-        , comments ++ new_comments
-        )
 
       res <- parser
 
-      put
+      put' st
-        ( 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
+    save <- get' @ParseForest
-    put (ptChildren, comms)
+    put' ptChildren
-    rest <- gets (pfGrove . fst)
+    rest <- gets' pfGrove
     collectErrors rest
-    (_, comms') <- get
+    parser <* put' save
-    parser <* put (save, comms')
   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
+  get' >>= \case
-    (,) Forest {pfGrove = [(,) _ ParseTree {ptRange}]} _ -> do
+    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
+  comms <- get'
-  put (st, [])
+  mod' @[Text] $ const []
   return comms
 
 -- | /Actual/ debug pring.
 dump :: Parser ()
-dump = gets (pfGrove . fst) >>= traceShowM
+dump = gets' pfGrove >>= traceShowM

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
@@ -132,3 +134,9 @@ color c d = zeroWidthText begin <> d <> zeroWidthText end
   where
     begin = "\x1b[" ++ show (30 + c) ++ "m"
     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

tools/lsp/squirrel/src/Product.hs

@@ -1,39 +1,44 @@
+{-|
+  The heterogeneous list.
+-}
 
 module Product where
 
-import qualified Data.Text as Text
+-- | `Product xs` contains elements of each of the types from the `xs` list.
-
-import Pretty
-
 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
+  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
+-- | Add a name to the type.
-modElem f xs = putElem (f $ getElem xs) xs
+--
+newtype (s :: String) := t = Tag { unTag :: t }
 
-instance Pretty (Product '[]) where
+-- | Retrieve a type associated with the given name.
-  pp _ = "{}"
+--
+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
+-- | Modify a type associated with the given name.
-  pp (Cons x xs) =
+--
-    if Text.null $ Text.strip ppx
+modTag
-    then pp xs
+  :: forall s t xs
-    else pp ppx <+> "&" <+> pp xs
+  .  Contains (s := t) xs
-    where
+  => (t -> t)
-      ppx = ppToText x
+  -> Product xs -> Product xs
+modTag f = modElem @(s := t) (Tag . f . unTag)

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, _) <? 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, _) =
+  Range (l, c, _) (r, d, _) f == Range (l1, c1, _) (r1, d1, _) f1 =
-    (l, c, r, d) == (l1, c1, r1, d1)
+    (l, c, r, d, f) == (l1, c1, r1, d1, f1)

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

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