Clean the comments

This commit is contained in:
Kirill Andreev 2020-07-01 16:56:21 +04:00
parent 03b89bc5b7
commit 583d7f8997
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
2 changed files with 36 additions and 178 deletions

View File

@ -160,7 +160,7 @@ eventLoop funs chan = do
case Find.definitionOf pos tree of case Find.definitionOf pos tree of
Just defPos -> do Just defPos -> do
error "do later" 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" _ -> U.logs "unknown msg"

View File

@ -5,25 +5,12 @@
-} -}
module AST.Scope module AST.Scope
-- ( -- * Monad ( HasLocalScope (..)
-- CollectM , addLocalScopes
-- , evalCollectM , lookupEnv
-- , collectEnv , Kind (..)
, ScopedDecl (..)
-- -- * Scope )
-- , Env(..)
-- , ScopedDecl(..)
-- , Kind(..)
-- , HasEnv(..)
-- , lookupEnv
-- -- * Methods
-- , enter
-- , leave
-- , define
-- , defType
-- , def
-- )
where where
import Control.Arrow (second) import Control.Arrow (second)
@ -31,25 +18,26 @@ import Control.Monad.State
import Control.Monad.Writer.Strict hiding (Alt, Product) import Control.Monad.Writer.Strict hiding (Alt, Product)
import Data.Function import Data.Function
import qualified Data.Map as Map import qualified Data.List as List
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust, listToMaybe)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Maybe (fromJust, listToMaybe)
import qualified Data.List as List
import Range
import AST.Types
import AST.Parser import AST.Parser
import Parser import AST.Types
import Tree
import Comment import Comment
import Lattice
import Parser
import Pretty import Pretty
import Product import Product
import Lattice import Range
import Tree
import Debug.Trace import Debug.Trace
-- | Ability to contain a list of declarations.
class HasLocalScope x where class HasLocalScope x where
getLocalScope :: x -> [ScopedDecl] getLocalScope :: x -> [ScopedDecl]
@ -62,6 +50,9 @@ type AddRefsM = State FullEnv
type FullEnv = Map Range [ScopedDecl] type FullEnv = Map Range [ScopedDecl]
-- | Calculate scopes and attach to all tree points declarations that are
-- visible there.
--
addLocalScopes addLocalScopes
:: HasRange (Product xs) :: HasRange (Product xs)
=> Pascal (Product xs) => Pascal (Product xs)
@ -104,11 +95,6 @@ addRef r n env = Map.union (go range) env
$ filter (r <?) $ filter (r <?)
$ Map.keys env $ Map.keys env
-- decls' list = do
-- r' <- range
-- decls <- Map.lookup r' env
-- return $ (r', updateOnly n r addRefToDecl decls)
addRefToDecl sd = sd addRefToDecl sd = sd
{ _sdRefs = r : _sdRefs sd { _sdRefs = r : _sdRefs sd
} }
@ -175,49 +161,10 @@ data Kind = Star
instance Pretty Kind where instance Pretty Kind where
pp _ = "TYPE" pp _ = "TYPE"
-- observe :: String -> CollectM a -> CollectM a -- | Search for a name inside a local scope.
-- observe what act = do
-- s <- get
-- traceShowM (what, "BEFORE", s)
-- a <- act
-- s1 <- get
-- traceShowM (what, "AFTER", s1)
-- return a
lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl
lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName) 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. -- | Add a type declaration to the current scope.
defType :: HasRange a => Pascal a -> Kind -> Pascal a -> CollectM () defType :: HasRange a => Pascal a -> Kind -> Pascal a -> CollectM ()
defType name kind body = do defType name kind body = do
@ -229,37 +176,11 @@ defType name kind body = do
(Just (Right kind)) (Just (Right kind))
[] []
observe :: Pretty i => Pretty res => Text -> i -> res -> res -- observe :: Pretty i => Pretty res => Text -> i -> res -> res
observe msg i res -- observe msg i res
= traceShow (pp msg, "INPUT", pp i) -- = traceShow (pp msg, "INPUT", pp i)
$ traceShow (pp msg, "OUTPUT", pp res) -- $ traceShow (pp msg, "OUTPUT", pp res)
$ 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 <?) ranges
-- affected' = foldMap (\r -> 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
-- | Add a value declaration to the current scope. -- | Add a value declaration to the current scope.
def def
@ -352,66 +273,3 @@ instance HasRange a => UpdateOver CollectM Pattern (Pascal a) where
instance UpdateOver CollectM QualifiedName (Pascal a) instance UpdateOver CollectM QualifiedName (Pascal a)
instance UpdateOver CollectM Path (Pascal a) instance UpdateOver CollectM Path (Pascal a)
instance UpdateOver CollectM Name (Pascal a) where 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