github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 17:04:47 +03:00
Code Issues Projects Releases Wiki Activity

🔥 the Analysis env fields.

Browse Source
This commit is contained in:
Rob Rix 2019-11-04 12:12:59 -05:00
parent 17da79fe24
commit 961bf622ca
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
5 changed files with 20 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
semantic-analysis/src/Analysis/Analysis.hs
View File

@ -11,10 +11,7 @@ import GHC.Generics (Generic1)
--
-- This is intended to be replaced with a selection of algebraic effects providing these interfaces and carriers providing reusable implementations.
data Analysis term name address value m = Analysis
{ alloc :: name -> m address
, bind :: forall a . name -> address -> m a -> m a
, lookupEnv :: name -> m (Maybe address)
, deref :: address -> m (Maybe value)
{ deref :: address -> m (Maybe value)
, assign :: address -> value -> m ()
, abstract :: (term name -> m value) -> name -> term name -> m value
, apply :: (term name -> m value) -> value -> value -> m value

9
semantic-analysis/src/Analysis/Concrete.hs
View File

@ -130,10 +130,7 @@ concreteAnalysis :: ( Carrier sig m
)
=> Analysis term name Precise (Concrete term name) m
concreteAnalysis = Analysis{..}
where alloc = A.alloc
bind = A.bind
lookupEnv = A.lookupEnv
deref = gets . IntMap.lookup
where deref = gets . IntMap.lookup
assign addr value = modify (IntMap.insert addr value)
abstract _ name body = do
path <- ask
@ -142,7 +139,7 @@ concreteAnalysis = Analysis{..}
pure (Closure path span name body env)
apply eval (Closure path span name body env) a = do
local (const path) . local (const span) $ do
addr <- alloc name
addr <- A.alloc name
assign addr a
local (const (Map.insert name addr env)) (eval body)
apply _ f _ = fail $ "Cannot coerce " <> show f <> " to function"
@ -155,7 +152,7 @@ concreteAnalysis = Analysis{..}
asString v = fail $ "Cannot coerce " <> show v <> " to String"
record fields = do
fields' <- for fields $ \ (name, value) -> do
addr <- alloc name
addr <- A.alloc name
assign addr value
pure (name, addr)
pure (Record (Map.fromList fields'))

14
semantic-analysis/src/Analysis/ImportGraph.hs
View File

@ -96,7 +96,8 @@ runFile eval file = traverse run file
-- FIXME: decompose into a product domain and two atomic domains
importGraphAnalysis
:: ( Alternative m
:: forall term name m sig
. ( Alternative m
, Carrier sig m
, Member (Env name name) sig
, Member (Reader Path.AbsRelFile) sig
@ -110,19 +111,16 @@ importGraphAnalysis
)
=> Analysis term name name (Value term name) m
importGraphAnalysis = Analysis{..}
where alloc = A.alloc
bind = A.bind
lookupEnv = A.lookupEnv
deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
where deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
assign addr v = modify (Map.insertWith (<>) addr (Set.singleton v))
abstract _ name body = do
path <- ask
span <- ask
pure (Value (Closure path span name body) mempty)
apply eval (Value (Closure path span name body) _) a = local (const path) . local (const span) $ do
addr <- alloc name
addr <- alloc @name @name name
assign addr a
bind name addr (eval body)
A.bind name addr (eval body)
apply _ f _ = fail $ "Cannot coerce " <> show f <> " to function"
unit = pure mempty
bool _ = pure mempty
@ -132,7 +130,7 @@ importGraphAnalysis = Analysis{..}
asString _ = pure mempty
record fields = do
for_ fields $ \ (k, v) -> do
addr <- alloc k
addr <- A.alloc @name @name k
assign addr v
pure (Value Abstract (foldMap (valueGraph . snd) fields))
_ ... m = pure (Just m)

12
semantic-analysis/src/Analysis/ScopeGraph.hs
View File

@ -94,7 +94,8 @@ runFile eval file = traverse run file
. convergeTerm (Proxy @name) (fix (cacheTerm . eval scopeGraphAnalysis))
scopeGraphAnalysis
:: ( Alternative m
:: forall term name m sig
. ( Alternative m
, Carrier sig m
, Member (Reader Path.AbsRelFile) sig
, Member (Env name name) sig
@ -105,10 +106,7 @@ scopeGraphAnalysis
)
=> Analysis term name name (ScopeGraph name) m
scopeGraphAnalysis = Analysis{..}
where alloc = A.alloc
bind = A.bind
lookupEnv = A.lookupEnv
deref addr = do
where deref addr = do
ref <- askRef
bindRef <- asks (Map.lookup addr)
cell <- gets (Map.lookup addr >=> nonEmpty . Set.toList)
@ -119,9 +117,9 @@ scopeGraphAnalysis = Analysis{..}
bindRef <- asks (Map.lookup addr)
modify (Map.insertWith (<>) addr (Set.singleton (extendBinding addr ref bindRef <> v)))
abstract eval name body = do
addr <- alloc name
addr <- A.alloc @name @name name
assign name mempty
bind name addr (eval body)
A.bind name addr (eval body)
apply _ f a = pure (f <> a)
unit = pure mempty
bool _ = pure mempty

12
semantic-analysis/src/Analysis/Typecheck.hs
View File

@ -152,7 +152,8 @@ runFile eval file = traverse run file
. convergeTerm (Proxy @name) (fix (cacheTerm . eval typecheckingAnalysis))
typecheckingAnalysis
:: ( Alternative m
:: forall term name m sig
. ( Alternative m
, Carrier sig m
, Member (Env name name) sig
, Member Fresh sig
@ -162,14 +163,11 @@ typecheckingAnalysis
)
=> Analysis term name name (Type name) m
typecheckingAnalysis = Analysis{..}
where alloc = A.alloc
bind = A.bind
lookupEnv = A.lookupEnv
deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
where deref addr = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (foldMapA (pure . Just))
assign addr ty = modify (Map.insertWith (<>) addr (Set.singleton ty))
abstract eval name body = do
-- FIXME: construct the associated scope
addr <- alloc name
addr <- A.alloc @name @name name
arg <- meta
assign addr arg
ty <- eval body
@ -187,7 +185,7 @@ typecheckingAnalysis = Analysis{..}
asString s = unify (Alg String) s $> mempty
record fields = do
fields' <- for fields $ \ (k, v) -> do
addr <- alloc k
addr <- A.alloc @name @name k
(k, v) <$ assign addr v
-- FIXME: should records reference types by address instead?
pure (Alg (Record (Map.fromList fields')))