1
1
mirror of https://github.com/github/semantic.git synced 2024-12-25 16:02:43 +03:00

Analyze with names in User.

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

View File

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

View File

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

View File

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

View File

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