mirror of
https://github.com/github/semantic.git
synced 2024-11-24 08:54:07 +03:00
Merge remote-tracking branch 'origin/master' into less-fail
This commit is contained in:
joshvera
commit
e8db080923
@ -163,6 +163,7 @@ library
|
||||
, hashable
|
||||
, kdt
|
||||
, mersenne-random-pure64
|
||||
, microlens
|
||||
, mtl
|
||||
, network
|
||||
, network-uri
|
||||
|
||||
@ -1,9 +1,7 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, UndecidableInstances #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies, UndecidableInstances #-}
|
||||
module Analysis.Abstract.Evaluating
|
||||
( Evaluating
|
||||
, findValue
|
||||
, findEnv
|
||||
, findHeap
|
||||
, EvaluatingState(..)
|
||||
) where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
@ -11,11 +9,10 @@ import Control.Monad.Effect
|
||||
import Data.Abstract.Configuration
|
||||
import qualified Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Heap
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable
|
||||
import qualified Data.IntMap as IntMap
|
||||
import qualified Data.Map.Monoidal as Monoidal
|
||||
import Lens.Micro
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
|
||||
@ -34,74 +31,98 @@ type EvaluatingEffects term value
|
||||
, Resumable (LoadError term value)
|
||||
, Resumable (ValueExc value)
|
||||
, Resumable (Unspecialized value)
|
||||
, Fail -- Failure with an error message
|
||||
, Reader [Module term] -- The stack of currently-evaluating modules.
|
||||
, State (EnvironmentFor value) -- Environments (both local and global)
|
||||
, State (HeapFor value) -- The heap
|
||||
, Reader (ModuleTable [Module term]) -- Cache of unevaluated modules
|
||||
, Reader (EnvironmentFor value) -- Default environment used as a fallback in lookupEnv
|
||||
, State (ModuleTable (EnvironmentFor value, value)) -- Cache of evaluated modules
|
||||
, State (ExportsFor value) -- Exports (used to filter environments when they are imported)
|
||||
, State (IntMap.IntMap term) -- For jumps
|
||||
, Fail -- Failure with an error message
|
||||
, Reader [Module term] -- The stack of currently-evaluating modules.
|
||||
, Reader (ModuleTable [Module term]) -- Cache of unevaluated modules
|
||||
, Reader (EnvironmentFor value) -- Default environment used as a fallback in lookupEnv
|
||||
, State (EvaluatingState term value) -- Environment, heap, modules, exports, and jumps.
|
||||
]
|
||||
|
||||
-- | Find the value in the 'Final' result of running.
|
||||
findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects))
|
||||
=> Final effects value
|
||||
-> Either Prelude.String (
|
||||
Either (SomeExc (Unspecialized value)) (
|
||||
Either (SomeExc (ValueExc value)) (
|
||||
Either (SomeExc (LoadError term value)) (
|
||||
Either (SomeExc (EvalError value)) value)))) -- this is gnarly
|
||||
findValue (((((v, _), _), _), _), _) = v
|
||||
data EvaluatingState term value = EvaluatingState
|
||||
{ environment :: EnvironmentFor value
|
||||
, heap :: HeapFor value
|
||||
, modules :: ModuleTable (EnvironmentFor value, value)
|
||||
, exports :: ExportsFor value
|
||||
, jumps :: IntMap.IntMap term
|
||||
}
|
||||
|
||||
-- | Find the 'Environment' in the 'Final' result of running.
|
||||
findEnv :: (effects ~ RequiredEffects term value (Evaluating term value effects))
|
||||
=> Final effects value -> EnvironmentFor value
|
||||
findEnv (((((_, env), _), _), _), _) = env
|
||||
deriving instance (Eq (CellFor value), Eq (LocationFor value), Eq term, Eq value) => Eq (EvaluatingState term value)
|
||||
deriving instance (Ord (CellFor value), Ord (LocationFor value), Ord term, Ord value) => Ord (EvaluatingState term value)
|
||||
deriving instance (Show (CellFor value), Show (LocationFor value), Show term, Show value) => Show (EvaluatingState term value)
|
||||
|
||||
-- | Find the 'Heap' in the 'Final' result of running.
|
||||
findHeap :: (effects ~ RequiredEffects term value (Evaluating term value effects))
|
||||
=> Final effects value -> Monoidal.Map (LocationFor value) (CellFor value)
|
||||
findHeap (((((_, _), Heap heap), _), _), _) = heap
|
||||
instance (Ord (LocationFor value), Semigroup (CellFor value)) => Semigroup (EvaluatingState term value) where
|
||||
EvaluatingState e1 h1 m1 x1 j1 <> EvaluatingState e2 h2 m2 x2 j2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (x1 <> x2) (j1 <> j2)
|
||||
|
||||
instance (Ord (LocationFor value), Semigroup (CellFor value)) => Monoid (EvaluatingState term value) where
|
||||
mempty = EvaluatingState mempty mempty mempty mempty mempty
|
||||
mappend = (<>)
|
||||
|
||||
_environment :: Lens' (EvaluatingState term value) (EnvironmentFor value)
|
||||
_environment = lens environment (\ s e -> s {environment = e})
|
||||
|
||||
_heap :: Lens' (EvaluatingState term value) (HeapFor value)
|
||||
_heap = lens heap (\ s h -> s {heap = h})
|
||||
|
||||
_modules :: Lens' (EvaluatingState term value) (ModuleTable (EnvironmentFor value, value))
|
||||
_modules = lens modules (\ s m -> s {modules = m})
|
||||
|
||||
_exports :: Lens' (EvaluatingState term value) (ExportsFor value)
|
||||
_exports = lens exports (\ s e -> s {exports = e})
|
||||
|
||||
_jumps :: Lens' (EvaluatingState term value) (IntMap.IntMap term)
|
||||
_jumps = lens jumps (\ s j -> s {jumps = j})
|
||||
|
||||
|
||||
instance Members '[Fail, State (IntMap.IntMap term)] effects => MonadControl term (Evaluating term value effects) where
|
||||
(.=) :: Member (State (EvaluatingState term value)) effects => ASetter (EvaluatingState term value) (EvaluatingState term value) a b -> b -> Evaluating term value effects ()
|
||||
lens .= val = raise (modify' (lens .~ val))
|
||||
|
||||
view :: Member (State (EvaluatingState term value)) effects => Getting a (EvaluatingState term value) a -> Evaluating term value effects a
|
||||
view lens = raise (gets (^. lens))
|
||||
|
||||
localEvaluatingState :: Member (State (EvaluatingState term value)) effects => Lens' (EvaluatingState term value) prj -> (prj -> prj) -> Evaluating term value effects a -> Evaluating term value effects a
|
||||
localEvaluatingState lens f action = do
|
||||
original <- view lens
|
||||
lens .= f original
|
||||
v <- action
|
||||
v <$ lens .= original
|
||||
|
||||
|
||||
instance Members '[Fail, State (EvaluatingState term value)] effects => MonadControl term (Evaluating term value effects) where
|
||||
label term = do
|
||||
m <- raise get
|
||||
m <- view _jumps
|
||||
let i = IntMap.size m
|
||||
raise (put (IntMap.insert i term m))
|
||||
_jumps .= IntMap.insert i term m
|
||||
pure i
|
||||
|
||||
goto label = IntMap.lookup label <$> raise get >>= maybe (fail ("unknown label: " <> show label)) pure
|
||||
goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure
|
||||
|
||||
instance Members '[ State (ExportsFor value)
|
||||
, State (EnvironmentFor value)
|
||||
instance Members '[ State (EvaluatingState term value)
|
||||
, Reader (EnvironmentFor value)
|
||||
] effects => MonadEnvironment value (Evaluating term value effects) where
|
||||
getEnv = raise get
|
||||
putEnv = raise . put
|
||||
withEnv s = raise . localState s . lower
|
||||
] effects
|
||||
=> MonadEnvironment value (Evaluating term value effects) where
|
||||
getEnv = view _environment
|
||||
putEnv = (_environment .=)
|
||||
withEnv s = localEvaluatingState _environment (const s)
|
||||
|
||||
defaultEnvironment = raise ask
|
||||
withDefaultEnvironment e = raise . local (const e) . lower
|
||||
|
||||
getExports = raise get
|
||||
putExports = raise . put
|
||||
withExports s = raise . localState s . lower
|
||||
getExports = view _exports
|
||||
putExports = (_exports .=)
|
||||
withExports s = localEvaluatingState _exports (const s)
|
||||
|
||||
localEnv f a = do
|
||||
modifyEnv (f . Env.push)
|
||||
result <- a
|
||||
result <$ modifyEnv Env.pop
|
||||
|
||||
instance Member (State (HeapFor value)) effects => MonadHeap value (Evaluating term value effects) where
|
||||
getHeap = raise get
|
||||
putHeap = raise . put
|
||||
instance Member (State (EvaluatingState term value)) effects => MonadHeap value (Evaluating term value effects) where
|
||||
getHeap = view _heap
|
||||
putHeap = (_heap .=)
|
||||
|
||||
instance Members '[Reader (ModuleTable [Module term]), State (ModuleTable (EnvironmentFor value, value))] effects => MonadModuleTable term value (Evaluating term value effects) where
|
||||
getModuleTable = raise get
|
||||
putModuleTable = raise . put
|
||||
instance Members '[Reader (ModuleTable [Module term]), State (EvaluatingState term value)] effects => MonadModuleTable term value (Evaluating term value effects) where
|
||||
getModuleTable = view _modules
|
||||
putModuleTable = (_modules .=)
|
||||
|
||||
askModuleTable = raise ask
|
||||
localModuleTable f a = raise (local f (lower a))
|
||||
|
||||
@ -2,7 +2,6 @@
|
||||
module Analysis.Abstract.Quiet where
|
||||
|
||||
import Control.Abstract.Analysis
|
||||
import Control.Monad.Effect.Resumable
|
||||
import Data.Abstract.Evaluatable
|
||||
import Prologue
|
||||
|
||||
|
||||
@ -8,7 +8,7 @@ import Data.Semigroup.Reducer
|
||||
import Prologue
|
||||
|
||||
-- | A map of addresses onto cells holding their values.
|
||||
newtype Heap l a = Heap { unStore :: Monoidal.Map l (Cell l a) }
|
||||
newtype Heap l a = Heap { unHeap :: Monoidal.Map l (Cell l a) }
|
||||
deriving (Generic1)
|
||||
|
||||
deriving instance (Eq l, Eq (Cell l a)) => Eq (Heap l a)
|
||||
@ -26,7 +26,7 @@ deriving instance (Ord l, Reducer a (Cell l a)) => Reducer (l, a) (Heap l a)
|
||||
|
||||
-- | Look up the cell of values for an 'Address' in a 'Heap', if any.
|
||||
heapLookup :: Ord l => Address l a -> Heap l a -> Maybe (Cell l a)
|
||||
heapLookup (Address address) = Monoidal.lookup address . unStore
|
||||
heapLookup (Address address) = Monoidal.lookup address . unHeap
|
||||
|
||||
-- | Look up the list of values stored for a given address, if any.
|
||||
heapLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Heap l a -> Maybe [a]
|
||||
@ -42,7 +42,7 @@ heapInit (Address address) cell (Heap h) = Heap (Monoidal.insert address cell h)
|
||||
|
||||
-- | The number of addresses extant in a 'Heap'.
|
||||
heapSize :: Heap l a -> Int
|
||||
heapSize = Monoidal.size . unStore
|
||||
heapSize = Monoidal.size . unHeap
|
||||
|
||||
-- | Restrict a 'Heap' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest).
|
||||
heapRestrict :: Ord l => Heap l a -> Live l a -> Heap l a
|
||||
|
||||
@ -2,9 +2,6 @@
|
||||
module Analysis.Go.Spec (spec) where
|
||||
|
||||
import Data.Abstract.Value
|
||||
import Data.Map
|
||||
import Data.Either
|
||||
|
||||
import SpecHelpers
|
||||
|
||||
|
||||
@ -12,7 +9,7 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "evalutes Go" $ do
|
||||
it "imports and wildcard imports" $ do
|
||||
env <- findEnv <$> evaluate "main.go"
|
||||
env <- environment . snd <$> evaluate "main.go"
|
||||
env `shouldBe` [ (qualifiedName ["foo", "New"], addr 0)
|
||||
, (qualifiedName ["Rab"], addr 1)
|
||||
, (qualifiedName ["Bar"], addr 2)
|
||||
@ -20,7 +17,7 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "imports with aliases (and side effects only)" $ do
|
||||
env <- findEnv <$> evaluate "main1.go"
|
||||
env <- environment . snd <$> evaluate "main1.go"
|
||||
env `shouldBe` [ (qualifiedName ["f", "New"], addr 0)
|
||||
, (qualifiedName ["main"], addr 3) -- addr 3 is due to side effects of
|
||||
-- eval'ing `import _ "./bar"` which
|
||||
|
||||
@ -2,9 +2,6 @@
|
||||
module Analysis.PHP.Spec (spec) where
|
||||
|
||||
import Data.Abstract.Value
|
||||
import Data.Map
|
||||
import Data.Map.Monoidal as Map
|
||||
|
||||
import SpecHelpers
|
||||
|
||||
|
||||
@ -12,27 +9,26 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "PHP" $ do
|
||||
it "evaluates include and require" $ do
|
||||
env <- findEnv <$> evaluate "main.php"
|
||||
env <- environment . snd <$> evaluate "main.php"
|
||||
env `shouldBe` [ (name "foo", addr 0)
|
||||
, (name "bar", addr 1) ]
|
||||
|
||||
it "evaluates include_once and require_once" $ do
|
||||
env <- findEnv <$> evaluate "main_once.php"
|
||||
env <- environment . snd <$> evaluate "main_once.php"
|
||||
env `shouldBe` [ (name "foo", addr 0)
|
||||
, (name "bar", addr 1) ]
|
||||
|
||||
it "evaluates namespaces" $ do
|
||||
res <- evaluate "namespaces.php"
|
||||
findEnv res `shouldBe` [ (name "NS1", addr 0)
|
||||
, (name "Foo", addr 6) ]
|
||||
res <- snd <$> evaluate "namespaces.php"
|
||||
environment res `shouldBe` [ (name "NS1", addr 0)
|
||||
, (name "Foo", addr 6) ]
|
||||
|
||||
let heap = findHeap res
|
||||
Map.lookup (Precise 0) heap `shouldBe` ns "NS1" [ (name "Sub1", addr 1)
|
||||
, (name "b", addr 4)
|
||||
, (name "c", addr 5)
|
||||
]
|
||||
Map.lookup (Precise 1) heap `shouldBe` ns "Sub1" [ (name "Sub2", addr 2) ]
|
||||
Map.lookup (Precise 2) heap `shouldBe` ns "Sub2" [ (name "f", addr 3) ]
|
||||
heapLookup (Address (Precise 0)) (heap res) `shouldBe` ns "NS1" [ (name "Sub1", addr 1)
|
||||
, (name "b", addr 4)
|
||||
, (name "c", addr 5)
|
||||
]
|
||||
heapLookup (Address (Precise 1)) (heap res) `shouldBe` ns "Sub1" [ (name "Sub2", addr 2) ]
|
||||
heapLookup (Address (Precise 2)) (heap res) `shouldBe` ns "Sub2" [ (name "f", addr 3) ]
|
||||
|
||||
where
|
||||
ns n = Just . Latest . Just . injValue . Namespace (name n)
|
||||
|
||||
@ -11,29 +11,29 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "evalutes Python" $ do
|
||||
it "imports" $ do
|
||||
env <- findEnv <$> evaluate "main.py"
|
||||
env <- environment . snd <$> evaluate "main.py"
|
||||
env `shouldBe` [ (qualifiedName ["a", "foo"], addr 0)
|
||||
, (qualifiedName ["b", "c", "baz"], addr 1)
|
||||
]
|
||||
|
||||
it "imports with aliases" $ do
|
||||
env <- findEnv <$> evaluate "main1.py"
|
||||
env <- environment . snd <$> evaluate "main1.py"
|
||||
env `shouldBe` [ (qualifiedName ["b", "foo"], addr 0)
|
||||
, (qualifiedName ["e", "baz"], addr 1)
|
||||
]
|
||||
|
||||
it "imports using 'from' syntax" $ do
|
||||
env <- findEnv <$> evaluate "main2.py"
|
||||
env <- environment . snd <$> evaluate "main2.py"
|
||||
env `shouldBe` [ (qualifiedName ["foo"], addr 0)
|
||||
, (qualifiedName ["bar"], addr 1)
|
||||
]
|
||||
|
||||
it "subclasses" $ do
|
||||
v <- findValue <$> evaluate "subclass.py"
|
||||
v <- fst <$> evaluate "subclass.py"
|
||||
v `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"bar\""))))))
|
||||
|
||||
it "handles multiple inheritance left-to-right" $ do
|
||||
v <- findValue <$> evaluate "multiple_inheritance.py"
|
||||
v <- fst <$> evaluate "multiple_inheritance.py"
|
||||
v `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"foo!\""))))))
|
||||
|
||||
where
|
||||
|
||||
@ -16,40 +16,40 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "Ruby" $ do
|
||||
it "evaluates require_relative" $ do
|
||||
env <- findEnv <$> evaluate "main.rb"
|
||||
env <- environment . snd <$> evaluate "main.rb"
|
||||
env `shouldBe` [ (name "Object", addr 0)
|
||||
, (name "foo", addr 3) ]
|
||||
|
||||
it "evaluates load" $ do
|
||||
env <- findEnv <$> evaluate "load.rb"
|
||||
env <- environment . snd <$> evaluate "load.rb"
|
||||
env `shouldBe` [ (name "Object", addr 0)
|
||||
, (name "foo", addr 3) ]
|
||||
|
||||
it "evaluates load with wrapper" $ do
|
||||
res <- evaluate "load-wrap.rb"
|
||||
findValue res `shouldBe` Right (Right (Right (Right (Left (SomeExc (FreeVariableError ("foo" :| [])))))))
|
||||
findEnv res `shouldBe` [ (name "Object", addr 0) ]
|
||||
fst res `shouldBe` Right (Right (Right (Right (Left (SomeExc (FreeVariableError ("foo" :| [])))))))
|
||||
environment (snd res) `shouldBe` [ (name "Object", addr 0) ]
|
||||
|
||||
it "evaluates subclass" $ do
|
||||
res <- evaluate "subclass.rb"
|
||||
findValue res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<bar>\""))))))
|
||||
findEnv res `shouldBe` [ (name "Bar", addr 6)
|
||||
, (name "Foo", addr 3)
|
||||
, (name "Object", addr 0) ]
|
||||
fst res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<bar>\""))))))
|
||||
environment (snd res) `shouldBe` [ (name "Bar", addr 6)
|
||||
, (name "Foo", addr 3)
|
||||
, (name "Object", addr 0) ]
|
||||
|
||||
let heap = findHeap res
|
||||
Map.lookup (Precise 6) heap `shouldBe` ns "Bar" [ (name "baz", addr 8)
|
||||
, (name "foo", addr 5)
|
||||
, (name "inspect", addr 7) ]
|
||||
heapLookup (Address (Precise 6)) (heap (snd res))
|
||||
`shouldBe` ns "Bar" [ (name "baz", addr 8)
|
||||
, (name "foo", addr 5)
|
||||
, (name "inspect", addr 7) ]
|
||||
|
||||
it "evaluates modules" $ do
|
||||
res <- evaluate "modules.rb"
|
||||
findValue res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<hello>\""))))))
|
||||
findEnv res `shouldBe` [ (name "Object", addr 0)
|
||||
, (name "Bar", addr 3) ]
|
||||
fst res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<hello>\""))))))
|
||||
environment (snd res) `shouldBe` [ (name "Object", addr 0)
|
||||
, (name "Bar", addr 3) ]
|
||||
|
||||
it "has prelude" $ do
|
||||
res <- findValue <$> evaluate "preluded.rb"
|
||||
res <- fst <$> evaluate "preluded.rb"
|
||||
res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<foo>\""))))))
|
||||
|
||||
where
|
||||
|
||||
@ -11,11 +11,11 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "evalutes TypeScript" $ do
|
||||
it "imports with aliased symbols" $ do
|
||||
env <- findEnv <$> evaluate "main.ts"
|
||||
env <- environment . snd <$> evaluate "main.ts"
|
||||
env `shouldBe` [ (qualifiedName ["bar"], addr 0) ]
|
||||
|
||||
it "imports with qualified names" $ do
|
||||
env <- findEnv <$> evaluate "main1.ts"
|
||||
env <- environment . snd <$> evaluate "main1.ts"
|
||||
env `shouldBe` [ (qualifiedName ["b", "baz"], addr 0)
|
||||
, (qualifiedName ["b", "foo"], addr 2)
|
||||
, (qualifiedName ["z", "baz"], addr 0)
|
||||
@ -23,11 +23,11 @@ spec = parallel $ do
|
||||
]
|
||||
|
||||
it "side effect only imports" $ do
|
||||
env <- findEnv <$> evaluate "main2.ts"
|
||||
env <- environment . snd <$> evaluate "main2.ts"
|
||||
env `shouldBe` mempty
|
||||
|
||||
it "fails exporting symbols not defined in the module" $ do
|
||||
v <- findValue <$> evaluate "bad-export.ts"
|
||||
v <- fst <$> evaluate "bad-export.ts"
|
||||
v `shouldBe` Left "module \"foo\" does not export \"pip\""
|
||||
|
||||
where
|
||||
|
||||
@ -9,7 +9,7 @@ module SpecHelpers (
|
||||
, Verbatim(..)
|
||||
, ) where
|
||||
|
||||
import Analysis.Abstract.Evaluating as X (findValue, findEnv, findHeap)
|
||||
import Analysis.Abstract.Evaluating as X (EvaluatingState(..))
|
||||
import Data.Abstract.Address as X
|
||||
import Data.Abstract.FreeVariables as X hiding (dropExtension)
|
||||
import Data.Abstract.Heap as X
|
||||
|
||||
3
test/fixtures/ruby/analysis/src/foo.rb
vendored
Normal file
3
test/fixtures/ruby/analysis/src/foo.rb
vendored
Normal file
@ -0,0 +1,3 @@
|
||||
def foo()
|
||||
return "in foo"
|
||||
end
|
||||
2
vendor/effects
vendored
2
vendor/effects
vendored
@ -1 +1 @@
|
||||
Subproject commit 74c1ca98ae9007e64fdc3f819b7d096ff7f802f7
|
||||
Subproject commit 215ac5be57258a786959dac391db6bef83a70f28
|
||||
Loading…
Reference in New Issue
Block a user