github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 23:42:31 +03:00
Code Issues Projects Releases Wiki Activity

Analyze with names in User.

Browse Source
This commit is contained in:
Rob Rix 2019-07-18 16:34:41 -04:00
parent 122b631811
commit 03ed4cd3ae
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
4 changed files with 36 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
semantic-core/src/Analysis/Concrete.hs
View File

@ -22,7 +22,6 @@ import Control.Effect.State
import Control.Monad ((<=<), guard)
import qualified Data.Core as Core
import Data.File
import Data.Foldable (foldl')
import Data.Function (fix)
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
@ -35,13 +34,13 @@ import Data.Text (Text, pack)
import Prelude hiding (fail)
type Precise = Int
type Env = Map.Map Name Precise
type Env = Map.Map User Precise
newtype FrameId = FrameId { unFrameId :: Precise }
deriving (Eq, Ord, Show)
data Concrete
= Closure Loc Name (Term Core.Core Name) Precise
= Closure Loc User (Term Core.Core User) Precise
| Unit
| Bool Bool
| String Text
@ -65,22 +64,20 @@ type Heap = IntMap.IntMap Concrete
--
-- >>> map fileBody (snd (concrete [File (Loc "bool" emptySpan) (Core.bool True)]))
-- [Right (Bool True)]
concrete :: [File (Term Core.Core Name)] -> (Heap, [File (Either (Loc, String) Concrete)])
concrete :: [File (Term Core.Core User)] -> (Heap, [File (Either (Loc, String) Concrete)])
concrete
= run
. runFresh
. runNaming
. runHeap
. traverse runFile
runFile :: ( Carrier sig m
, Effect sig
, Member Fresh sig
, Member Naming sig
, Member (Reader FrameId) sig
, Member (State Heap) sig
)
=> File (Term Core.Core Name)
=> File (Term Core.Core User)
-> m (File (Either (Loc, String) Concrete))
runFile file = traverse run file
where run = runReader (fileLoc file)
@ -143,7 +140,7 @@ concreteAnalysis = Analysis{..}
assign addr (Obj (f frame))
lookupConcrete :: Heap -> Name -> Concrete -> Maybe Precise
lookupConcrete :: Heap -> User -> Concrete -> Maybe Precise
lookupConcrete heap name = run . evalState IntSet.empty . runNonDet . inConcrete
where -- look up the name in a concrete value
inConcrete = inFrame <=< maybeA . objectFrame
@ -171,7 +168,7 @@ runHeap m = do
-- > λ let (heap, res) = concrete [ruby]
-- > λ writeFile "/Users/rob/Desktop/heap.dot" (export (addressStyle heap) (heapAddressGraph heap))
-- > λ :!dot -Tsvg < ~/Desktop/heap.dot > ~/Desktop/heap.svg
heapGraph :: (Precise -> Concrete -> a) -> (Either Core.Edge Name -> Precise -> G.Graph a) -> Heap -> G.Graph a
heapGraph :: (Precise -> Concrete -> a) -> (Either Core.Edge User -> Precise -> G.Graph a) -> Heap -> G.Graph a
heapGraph vertex edge h = foldr (uncurry graph) G.empty (IntMap.toList h)
where graph k v rest = (G.vertex (vertex k v) `G.connect` outgoing v) `G.overlay` rest
outgoing = \case
@ -192,7 +189,7 @@ heapAddressGraph = heapGraph (\ addr v -> (Value v, addr)) (fmap G.vertex . (,)
addressStyle :: Heap -> G.Style (EdgeType, Precise) Text
addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
where vertex (_, addr) = pack (show addr) <> " = " <> maybe "?" fromConcrete (IntMap.lookup addr heap)
edgeAttributes _ (Slot name, _) = ["label" G.:= fromName name]
edgeAttributes _ (Slot name, _) = ["label" G.:= name]
edgeAttributes _ (Edge Core.Import, _) = ["color" G.:= "blue"]
edgeAttributes _ (Edge Core.Lexical, _) = ["color" G.:= "green"]
edgeAttributes _ _ = []
@ -200,15 +197,13 @@ addressStyle heap = (G.defaultStyle vertex) { G.edgeAttributes }
Unit -> "()"
Bool b -> pack $ show b
String s -> pack $ show s
Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> fromName n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
Closure (Loc p (Span s e)) n _ _ -> "\\\\ " <> n <> " [" <> p <> ":" <> showPos s <> "-" <> showPos e <> "]"
Obj _ -> "{}"
showPos (Pos l c) = pack (show l) <> ":" <> pack (show c)
fromName (User s) = s
fromName (Gen (Gensym ss i)) = foldl' (\ ss s -> ss <> "." <> s) (pack (show i)) ss
data EdgeType
= Edge Core.Edge
| Slot Name
| Slot User
| Value Concrete
deriving (Eq, Ord, Show)

23
semantic-core/src/Analysis/Eval.hs
View File

@ -20,20 +20,19 @@ import Data.Functor
import Data.Loc
import Data.Maybe (fromJust)
import Data.Name
import Data.Scope
import Data.Term
import Data.Text (Text)
import GHC.Stack
import Prelude hiding (fail)
eval :: (Carrier sig m, Member Naming sig, Member (Reader Loc) sig, MonadFail m) => Analysis address value m -> (Term Core Name -> m value) -> Term Core Name -> m value
eval :: (Carrier sig m, Member (Reader Loc) sig, MonadFail m) => Analysis address value m -> (Term Core User -> m value) -> Term Core User -> m value
eval Analysis{..} eval = \case
Var n -> lookupEnv' n >>= deref' n
Term c -> case c of
Let n -> alloc (User n) >>= bind (User n) >> unit
Let n -> alloc n >>= bind n >> unit
a :>> b -> eval a >> eval b
Lam _ b -> do
n <- Gen <$> fresh
abstract eval n (instantiate (const (pure n)) b)
Lam (Ignored n) b -> abstract eval n (incr (const n) id <$> fromScope b)
f :$ a -> do
f' <- eval f
a' <- eval a
@ -66,8 +65,8 @@ eval Analysis{..} eval = \case
Var n -> lookupEnv' n
Term c -> case c of
Let n -> do
addr <- alloc (User n)
addr <$ bind (User n) addr
addr <- alloc n
addr <$ bind n addr
If c t e -> do
c' <- eval c >>= asBool
if c' then ref t else ref e
@ -203,13 +202,13 @@ ruby = fromBody . ann . block $
data Analysis address value m = Analysis
{ alloc :: Name -> m address
, bind :: Name -> address -> m ()
, lookupEnv :: Name -> m (Maybe address)
{ alloc :: User -> m address
, bind :: User -> address -> m ()
, lookupEnv :: User -> m (Maybe address)
, deref :: address -> m (Maybe value)
, assign :: address -> value -> m ()
, abstract :: (Term Core Name -> m value) -> Name -> Term Core Name -> m value
, apply :: (Term Core Name -> m value) -> value -> value -> m value
, abstract :: (Term Core User -> m value) -> User -> Term Core User -> m value
, apply :: (Term Core User -> m value) -> value -> value -> m value
, unit :: m value
, bool :: Bool -> m value
, asBool :: value -> m Bool

23
semantic-core/src/Analysis/ImportGraph.hs
View File

@ -22,7 +22,6 @@ import Data.Loc
import qualified Data.Map as Map
import Data.Name
import qualified Data.Set as Set
import Data.Stack
import Data.Term
import Data.Text (Text)
import Prelude hiding (fail)
@ -42,29 +41,27 @@ instance Monoid Value where
mempty = Value Abstract mempty
data Semi
= Closure Loc Name (Term Core.Core Name) Name
= Closure Loc User (Term Core.Core User) User
-- FIXME: Bound String values.
| String Text
| Abstract
deriving (Eq, Ord, Show)
importGraph :: [File (Term Core.Core Name)] -> (Heap Name Value, [File (Either (Loc, String) Value)])
importGraph :: [File (Term Core.Core User)] -> (Heap User Value, [File (Either (Loc, String) Value)])
importGraph
= run
. runFresh
. runNaming
. runHeap (Gen (Gensym (Nil :> "root") 0))
. runHeap "__semantic_root"
. traverse runFile
runFile :: ( Carrier sig m
, Effect sig
, Member Fresh sig
, Member Naming sig
, Member (Reader (FrameId Name)) sig
, Member (State (Heap Name Value)) sig
, Member (Reader (FrameId User)) sig
, Member (State (Heap User Value)) sig
)
=> File (Term Core.Core Name)
=> File (Term Core.Core User)
-> m (File (Either (Loc, String) Value))
runFile file = traverse run file
where run = runReader (fileLoc file)
@ -75,12 +72,12 @@ runFile file = traverse run file
-- FIXME: decompose into a product domain and two atomic domains
importGraphAnalysis :: ( Alternative m
, Carrier sig m
, Member (Reader (FrameId Name)) sig
, Member (Reader (FrameId User)) sig
, Member (Reader Loc) sig
, Member (State (Heap Name Value)) sig
, Member (State (Heap User Value)) sig
, MonadFail m
)
=> Analysis Name Value m
=> Analysis User Value m
importGraphAnalysis = Analysis{..}
where alloc = pure
bind _ _ = pure ()
@ -104,7 +101,7 @@ importGraphAnalysis = Analysis{..}
asString (Value (String s) _) = pure s
asString _ = pure mempty
frame = pure mempty
edge Core.Import (User to) = do -- FIXME: figure out some other way to do this
edge Core.Import to = do -- FIXME: figure out some other way to do this
Loc{locPath=from} <- ask
() <$ pure (Value Abstract (Map.singleton from (Set.singleton to)))
edge _ _ = pure ()

15
semantic-core/src/Analysis/Typecheck.hs
View File

@ -31,7 +31,6 @@ import Data.Maybe (fromJust)
import Data.Name as Name
import Data.Scope
import qualified Data.Set as Set
import Data.Stack
import Data.Term
import Data.Void
import GHC.Generics (Generic1)
@ -83,28 +82,26 @@ generalize :: Term Monotype Meta -> Term (Polytype :+: Monotype) Void
generalize ty = fromJust (closed (forAlls (IntSet.toList (mvs ty)) (hoistTerm R ty)))
typecheckingFlowInsensitive :: [File (Term Core.Core Name)] -> (Heap Name (Term Monotype Meta), [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))])
typecheckingFlowInsensitive :: [File (Term Core.Core User)] -> (Heap User (Term Monotype Meta), [File (Either (Loc, String) (Term (Polytype :+: Monotype) Void))])
typecheckingFlowInsensitive
= run
. runFresh
. runNaming
. runHeap (Gen (Gensym (Nil :> "root") 0))
. runHeap "__semantic_root"
. fmap (fmap (fmap (fmap generalize)))
. traverse runFile
runFile :: ( Carrier sig m
, Effect sig
, Member Fresh sig
, Member Naming sig
, Member (State (Heap Name (Term Monotype Meta))) sig
, Member (State (Heap User (Term Monotype Meta))) sig
)
=> File (Term Core.Core Name)
=> File (Term Core.Core User)
-> m (File (Either (Loc, String) (Term Monotype Meta)))
runFile file = traverse run file
where run
= (\ m -> do
(subst, t) <- m
modify @(Heap Name (Term Monotype Meta)) (substAll subst)
modify @(Heap User (Term Monotype Meta)) (substAll subst)
pure (substAll subst <$> t))
. runState (mempty :: Substitution)
. runReader (fileLoc file)
@ -119,7 +116,7 @@ runFile file = traverse run file
v <$ for_ bs (unify v))
. convergeTerm (fix (cacheTerm . eval typecheckingAnalysis))
typecheckingAnalysis :: (Alternative m, Carrier sig m, Member Fresh sig, Member (State (Set.Set Constraint)) sig, Member (State (Heap Name (Term Monotype Meta))) sig, MonadFail m) => Analysis Name (Term Monotype Meta) m
typecheckingAnalysis :: (Alternative m, Carrier sig m, Member Fresh sig, Member (State (Set.Set Constraint)) sig, Member (State (Heap User (Term Monotype Meta))) sig, MonadFail m) => Analysis User (Term Monotype Meta) m
typecheckingAnalysis = Analysis{..}
where alloc = pure
bind _ _ = pure ()