diff --git a/tools/lsp/squirrel/app/Main.hs b/tools/lsp/squirrel/app/Main.hs index 78e9f765b..2ce86600e 100644 --- a/tools/lsp/squirrel/app/Main.hs +++ b/tools/lsp/squirrel/app/Main.hs @@ -160,7 +160,7 @@ eventLoop funs chan = do case Find.definitionOf pos tree of Just defPos -> do error "do later" - -- Core.sendFunc funs $ RspDefinition $ _ $ J.SingleLoc $ J.Location uri $ rangeToLoc defPos + Core.sendFunc funs $ RspDefinition $ _ $ J.SingleLoc $ J.Location uri $ rangeToLoc defPos _ -> U.logs "unknown msg" diff --git a/tools/lsp/squirrel/src/AST/Scope.hs b/tools/lsp/squirrel/src/AST/Scope.hs index f9ba2cd20..8e3e2eb2e 100644 --- a/tools/lsp/squirrel/src/AST/Scope.hs +++ b/tools/lsp/squirrel/src/AST/Scope.hs @@ -5,51 +5,39 @@ -} module AST.Scope - -- ( -- * Monad - -- CollectM - -- , evalCollectM - -- , collectEnv - - -- -- * Scope - -- , Env(..) - -- , ScopedDecl(..) - -- , Kind(..) - -- , HasEnv(..) - -- , lookupEnv - - -- -- * Methods - -- , enter - -- , leave - -- , define - -- , defType - -- , def - -- ) + ( HasLocalScope (..) + , addLocalScopes + , lookupEnv + , Kind (..) + , ScopedDecl (..) + ) where -import Control.Arrow (second) -import Control.Monad.State -import Control.Monad.Writer.Strict hiding (Alt, Product) +import Control.Arrow (second) +import Control.Monad.State +import Control.Monad.Writer.Strict hiding (Alt, Product) import Data.Function -import qualified Data.Map as Map -import Data.Map (Map) -import Data.Text (Text) -import qualified Data.Text as Text -import Data.Maybe (fromJust, listToMaybe) -import qualified Data.List as List +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromJust, listToMaybe) +import Data.Text (Text) +import qualified Data.Text as Text -import Range -import AST.Types -import AST.Parser -import Parser -import Tree -import Comment -import Pretty -import Product -import Lattice +import AST.Parser +import AST.Types +import Comment +import Lattice +import Parser +import Pretty +import Product +import Range +import Tree -import Debug.Trace +import Debug.Trace +-- | Ability to contain a list of declarations. class HasLocalScope x where getLocalScope :: x -> [ScopedDecl] @@ -62,6 +50,9 @@ type AddRefsM = State FullEnv type FullEnv = Map Range [ScopedDecl] +-- | Calculate scopes and attach to all tree points declarations that are +-- visible there. +-- addLocalScopes :: HasRange (Product xs) => Pascal (Product xs) @@ -104,11 +95,6 @@ addRef r n env = Map.union (go range) env $ filter (r CollectM a -> CollectM a --- observe what act = do --- s <- get --- traceShowM (what, "BEFORE", s) --- a <- act --- s1 <- get --- traceShowM (what, "AFTER", s1) --- return a - +-- | Search for a name inside a local scope. lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName) --- -- | Make a new scope out of enclosing parent one. --- enter :: Range -> CollectM () --- enter r = observe "enter" do --- modify \rest -> --- mk r (ScopeTree Map.empty []) : rest - --- -- | Leave current scope, return to parent one. --- leave :: CollectM () --- leave = observe "leave" do --- modify \case --- (a : parent : rest) -> --- fromJust do --- -- traceShowM ("MOVE", a) --- -- traceShowM ("TO ", parent) --- (r, ScopeTree e cs) <- match parent --- -- traceShowM ("== ", mk r (ScopeTree e (a : cs))) --- -- traceShowM ("--") --- return $ mk r (ScopeTree e (a : cs)) : rest - --- [x] -> error $ "trying to leave \n" ++ show x - --- -- | Add a declaration to the current scope. --- define :: Text -> ScopedDecl -> CollectM () --- define name d = observe "define" do --- s <- get --- traceShowM ("DEFINE", s) --- modify \(top : rest) -> --- fromJust do --- (r, ScopeTree a cs) <- match top --- return $ mk r (ScopeTree (Map.insert name d a) cs) : rest - -- | Add a type declaration to the current scope. defType :: HasRange a => Pascal a -> Kind -> Pascal a -> CollectM () defType name kind body = do @@ -229,37 +176,11 @@ defType name kind body = do (Just (Right kind)) [] -observe :: Pretty i => Pretty res => Text -> i -> res -> res -observe msg i res - = traceShow (pp msg, "INPUT", pp i) - $ traceShow (pp msg, "OUTPUT", pp res) - $ res - --- addRef --- :: Pascal () --- -> Range --- -> FullEnv --- -> FullEnv --- addRef name pos (AppendMap envs) = --- AppendMap $ envs <> affected'' --- where --- ranges = Map.keys envs --- (affected, other) = List.partition (pos Map.singleton r (envs Map.! r)) affected --- affected'' = Map.map (\decls -> observe "addRef" decls $ addRefScopedDecls decls) affected' - --- addRefScopedDecls :: [ScopedDecl] -> [ScopedDecl] --- addRefScopedDecls decls = --- case after of --- decl : after -> before ++ [addRefScopedDecl decl] ++ after --- [] -> before --- where --- (before, after) = break (\sd -> ppToText (_sdName sd) == ppName) decls - --- addRefScopedDecl :: ScopedDecl -> ScopedDecl --- addRefScopedDecl decl = decl { _sdRefs = pos : _sdRefs decl } - --- ppName = ppToText name +-- observe :: Pretty i => Pretty res => Text -> i -> res -> res +-- observe msg i res +-- = traceShow (pp msg, "INPUT", pp i) +-- $ traceShow (pp msg, "OUTPUT", pp res) +-- $ res -- | Add a value declaration to the current scope. def @@ -352,66 +273,3 @@ instance HasRange a => UpdateOver CollectM Pattern (Pascal a) where instance UpdateOver CollectM QualifiedName (Pascal a) instance UpdateOver CollectM Path (Pascal a) instance UpdateOver CollectM Name (Pascal a) where - before range (Name raw) = do - -- traceShowM ("name", raw) - skip - -- modify $ modElem $ addRef range (mk () (Name raw)) - --- class HasEnv a where --- getEnv :: a -> Env - --- instance HasEnv Env where --- getEnv = id - --- instance Contains Env xs => HasEnv (Product xs) where --- getEnv = getElem - --- data Scope = Scope { unScope :: [Text] } - --- instance HasComments Scope where --- getComments = unScope - --- -- pinEnv :: Product xs -> CollectM (Product (Env : xs)) --- -- pinEnv xs = (`Cons` xs) <$> gets head - --- collectEnv :: Contains Range xs => Product xs -> CollectM (Product (Scopes : xs)) --- collectEnv xs = do --- gets \case --- st : _ -> Cons st xs --- [] -> Cons (mk (getRange xs) $ ScopeTree Map.empty []) xs - --- instance UpdateOver (State [Env]) ScopeTree Scopes where --- before r (ScopeTree e _) = modify (e :) --- after r _ = modify tail - --- distributeEnv :: ScopeTree Scopes -> State [Env] (ScopeTree Scopes) --- distributeEnv (ScopeTree e' cs) = do --- e <- gets (Map.unions . (e' :)) --- return $ ScopeTree e cs - --- pinEnv :: Contains Range xs => Scopes -> Product xs -> CollectM (Product (Env : xs)) --- pinEnv scopes info = do --- let (_, ScopeTree e _) = fromJust $ match =<< lookupTree (getElem info) scopes --- return (Cons e info) - --- instance HasComments Range where --- getComments _ = [] - --- instance Pretty (Product xs) => HasComments (Product xs) where --- getComments xs = if Text.null $ Text.strip x then [] else [x] --- where --- x = ppToText $ color 3 $ pp $ xs - --- ascribeEnv :: (Contains Range xs, Pretty (Product xs)) => Pascal (Product xs) -> Scopes -- Pascal (Product (Env : xs)) --- ascribeEnv tree = --- let --- scopes = --- evalCollectM do --- traverseTree collectEnv tree --- gets head - --- -- distributed = evalState (traverseOnly distributeEnv scopes) [] --- in --- scopes --- -- distributed --- -- evalCollectM $ traverseTree (pinEnv distributed) tree \ No newline at end of file