mirror of
https://github.com/github/semantic.git
synced 2024-11-28 10:15:55 +03:00
Josh Vera
GitHub
commit
2b6dea75ef
@ -1,2 +1,3 @@
|
||||
def print(x):
|
||||
__semantic_print(x)
|
||||
return x
|
||||
|
||||
@ -7,3 +7,7 @@ class Object
|
||||
return "<object>"
|
||||
end
|
||||
end
|
||||
|
||||
def puts(obj)
|
||||
__semantic_print(obj)
|
||||
end
|
||||
|
||||
@ -8,6 +8,7 @@ module Control.Abstract.Context
|
||||
, Span
|
||||
, currentSpan
|
||||
, withCurrentSpan
|
||||
, withCurrentCallStack
|
||||
) where
|
||||
|
||||
import Control.Effect
|
||||
@ -15,6 +16,7 @@ import Control.Monad.Effect.Reader
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.Package
|
||||
import Data.Span
|
||||
import GHC.Stack
|
||||
import Prologue
|
||||
|
||||
-- | Get the currently evaluating 'ModuleInfo'.
|
||||
@ -40,3 +42,14 @@ currentSpan = raise ask
|
||||
-- | Run an action with a locally-replaced 'Span'.
|
||||
withCurrentSpan :: (Effectful m, Member (Reader Span) effects) => Span -> m effects a -> m effects a
|
||||
withCurrentSpan = raiseHandler . local . const
|
||||
|
||||
|
||||
-- | Run an action with locally-replaced 'ModuleInfo' & 'Span' derived from the passed 'SrcLoc'.
|
||||
withCurrentSrcLoc :: (Effectful m, Members '[Reader ModuleInfo, Reader Span] effects) => SrcLoc -> m effects a -> m effects a
|
||||
withCurrentSrcLoc loc = withCurrentModule (moduleInfoFromSrcLoc loc) . withCurrentSpan (spanFromSrcLoc loc)
|
||||
|
||||
-- | Run ana ction with locally replaced 'ModuleInfo' & 'Span' derived from the Haskell call stack.
|
||||
--
|
||||
-- This is suitable for contextualizing builtins & other functionality intended for use from client code but defined in Haskell source.
|
||||
withCurrentCallStack :: (Effectful m, Members '[Reader ModuleInfo, Reader Span] effects) => CallStack -> m effects a -> m effects a
|
||||
withCurrentCallStack = maybe id (withCurrentSrcLoc . snd) . listToMaybe . getCallStack
|
||||
|
||||
@ -9,12 +9,12 @@ module Control.Abstract.Goto
|
||||
) where
|
||||
|
||||
import Control.Abstract.Evaluator
|
||||
import Control.Monad.Effect (Eff, relayState)
|
||||
import Control.Monad.Effect (Eff)
|
||||
import qualified Data.IntMap as IntMap
|
||||
import Prelude hiding (fail)
|
||||
import Prologue
|
||||
|
||||
type GotoTable effects value = IntMap.IntMap (Eff effects value)
|
||||
type GotoTable inner value = IntMap.IntMap (Eff (Goto inner value ': inner) value)
|
||||
|
||||
-- | The type of labels.
|
||||
-- TODO: This should be rolled into 'Name' and tracked in the environment, both so that we can abstract over labels like any other location, and so that we can garbage collect unreachable labels.
|
||||
@ -27,7 +27,7 @@ type Label = Int
|
||||
label :: Evaluator location value (Goto effects value ': effects) value -> Evaluator location value (Goto effects value ': effects) Label
|
||||
label = send . Label . lower
|
||||
|
||||
-- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance).
|
||||
-- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated.
|
||||
goto :: Label -> Evaluator location value (Goto effects value ': effects) (Evaluator location value (Goto effects value ': effects) value)
|
||||
goto = fmap raise . send . Goto
|
||||
|
||||
@ -45,7 +45,34 @@ data Goto effects value return where
|
||||
Label :: Eff (Goto effects value ': effects) value -> Goto effects value Label
|
||||
Goto :: Label -> Goto effects value (Eff (Goto effects value ': effects) value)
|
||||
|
||||
runGoto :: Member Fail effects => GotoTable (Goto effects value ': effects) value -> Evaluator location value (Goto effects value ': effects) a -> Evaluator location value effects (a, GotoTable (Goto effects value ': effects) value)
|
||||
runGoto initial = raiseHandler (relayState (IntMap.size initial, initial) (\ (_, table) a -> pure (a, table)) (\ (supremum, table) goto yield -> case goto of
|
||||
Label action -> yield (succ supremum, IntMap.insert supremum action table) supremum
|
||||
Goto label -> maybe (fail ("unknown label: " <> show label)) (yield (supremum, table)) (IntMap.lookup label table)))
|
||||
-- | Run a 'Goto' effect in terms of a 'State' effect holding a 'GotoTable', accessed via wrap/unwrap functions.
|
||||
--
|
||||
-- The wrap/unwrap functions are necessary in order for ghc to be able to typecheck the table, since it necessarily contains references to its own effect list. Since @GotoTable (… ': State (GotoTable … value) ': …) value@ can’t be written, and a recursive type equality constraint won’t typecheck, callers will need to employ a @newtype@ to break the self-reference. The effect list of the table the @newtype@ contains will include all of the effects between the 'Goto' effect and the 'State' effect (including the 'State' but not the 'Goto'). E.g. if the 'State' is the next effect, a valid wrapper would be∷
|
||||
--
|
||||
-- @
|
||||
-- newtype Gotos effects value = Gotos { getGotos :: GotoTable (State (Gotos effects value) ': effects) value }
|
||||
-- @
|
||||
--
|
||||
-- Callers can then evaluate the high-level 'Goto' effect by passing @Gotos@ and @getGotos@ to 'runGoto'.
|
||||
runGoto :: Members '[ Fail
|
||||
, Fresh
|
||||
, State table
|
||||
] effects
|
||||
=> (GotoTable effects value -> table)
|
||||
-> (table -> GotoTable effects value)
|
||||
-> Evaluator location value (Goto effects value ': effects) a
|
||||
-> Evaluator location value effects a
|
||||
runGoto from to = runEffect (\ goto yield -> do
|
||||
table <- to <$> getTable
|
||||
case goto of
|
||||
Label action -> do
|
||||
supremum <- raise fresh
|
||||
putTable (from (IntMap.insert supremum action table))
|
||||
yield supremum
|
||||
Goto label -> maybe (raise (fail ("unknown label: " <> show label))) yield (IntMap.lookup label table))
|
||||
|
||||
getTable :: Member (State table) effects => Evaluator location value effects table
|
||||
getTable = raise get
|
||||
|
||||
putTable :: Member (State table) effects => table -> Evaluator location value effects ()
|
||||
putTable = raise . put
|
||||
|
||||
@ -37,44 +37,44 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||
-- | A LIFO stack of maps of names to addresses, representing a lexically-scoped evaluation environment.
|
||||
-- All behaviors can be assumed to be frontmost-biased: looking up "a" will check the most specific
|
||||
-- scope for "a", then the next, and so on.
|
||||
newtype Environment l a = Environment { unEnvironment :: NonEmpty (Map.Map Name (Address l a)) }
|
||||
newtype Environment location value = Environment { unEnvironment :: NonEmpty (Map.Map Name (Address location value)) }
|
||||
deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
|
||||
|
||||
instance Eq l => Eq1 (Environment l) where liftEq = genericLiftEq
|
||||
instance Ord l => Ord1 (Environment l) where liftCompare = genericLiftCompare
|
||||
instance Show l => Show1 (Environment l) where liftShowsPrec = genericLiftShowsPrec
|
||||
instance Eq location => Eq1 (Environment location) where liftEq = genericLiftEq
|
||||
instance Ord location => Ord1 (Environment location) where liftCompare = genericLiftCompare
|
||||
instance Show location => Show1 (Environment location) where liftShowsPrec = genericLiftShowsPrec
|
||||
|
||||
-- | The provided list will be put into an Environment with one member, so fromList is total
|
||||
-- (despite NonEmpty's instance being partial). Don't pass in multiple Addresses for the
|
||||
-- same Name or you violate the axiom that toList . fromList == id.
|
||||
instance IsList (Environment l a) where
|
||||
type Item (Environment l a) = (Name, Address l a)
|
||||
instance IsList (Environment location value) where
|
||||
type Item (Environment location value) = (Name, Address location value)
|
||||
fromList xs = Environment (Map.fromList xs :| [])
|
||||
toList (Environment (x :| _)) = Map.toList x
|
||||
|
||||
mergeEnvs :: Environment l a -> Environment l a -> Environment l a
|
||||
mergeEnvs :: Environment location value -> Environment location value -> Environment location value
|
||||
mergeEnvs (Environment (a :| as)) (Environment (b :| bs)) =
|
||||
Environment ((<>) a b :| alignWith (mergeThese (<>)) as bs)
|
||||
|
||||
emptyEnv :: Environment l a
|
||||
emptyEnv :: Environment location value
|
||||
emptyEnv = Environment (lowerBound :| [])
|
||||
|
||||
-- | Make and enter a new empty scope in the given environment.
|
||||
push :: Environment l a -> Environment l a
|
||||
push :: Environment location value -> Environment location value
|
||||
push (Environment (a :| as)) = Environment (mempty :| a : as)
|
||||
|
||||
-- | Remove the frontmost scope.
|
||||
pop :: Environment l a -> Environment l a
|
||||
pop :: Environment location value -> Environment location value
|
||||
pop (Environment (_ :| [])) = emptyEnv
|
||||
pop (Environment (_ :| a : as)) = Environment (a :| as)
|
||||
|
||||
-- | Drop all scopes save for the frontmost one.
|
||||
head :: Environment l a -> Environment l a
|
||||
head :: Environment location value -> Environment location value
|
||||
head (Environment (a :| _)) = Environment (a :| [])
|
||||
|
||||
-- | Take the union of two environments. When duplicate keys are found in the
|
||||
-- name to address map, the second definition wins.
|
||||
mergeNewer :: Environment l a -> Environment l a -> Environment l a
|
||||
mergeNewer :: Environment location value -> Environment location value -> Environment location value
|
||||
mergeNewer (Environment a) (Environment b) =
|
||||
Environment (NonEmpty.fromList . reverse $ alignWith (mergeThese combine) (reverse as) (reverse bs))
|
||||
where
|
||||
@ -86,45 +86,45 @@ mergeNewer (Environment a) (Environment b) =
|
||||
--
|
||||
-- >>> pairs shadowed
|
||||
-- [(Name {unName = "foo"},Address {unAddress = Precise {unPrecise = 1}})]
|
||||
pairs :: Environment l a -> [(Name, Address l a)]
|
||||
pairs :: Environment location value -> [(Name, Address location value)]
|
||||
pairs = Map.toList . fold . unEnvironment
|
||||
|
||||
unpairs :: [(Name, Address l a)] -> Environment l a
|
||||
unpairs :: [(Name, Address location value)] -> Environment location value
|
||||
unpairs = fromList
|
||||
|
||||
-- | Lookup a 'Name' in the environment.
|
||||
--
|
||||
-- >>> lookup (name "foo") shadowed
|
||||
-- Just (Address {unAddress = Precise {unPrecise = 1}})
|
||||
lookup :: Name -> Environment l a -> Maybe (Address l a)
|
||||
lookup :: Name -> Environment location value -> Maybe (Address location value)
|
||||
lookup k = foldMapA (Map.lookup k) . unEnvironment
|
||||
|
||||
-- | Insert a 'Name' in the environment.
|
||||
insert :: Name -> Address l a -> Environment l a -> Environment l a
|
||||
insert :: Name -> Address location value -> Environment location value -> Environment location value
|
||||
insert name value (Environment (a :| as)) = Environment (Map.insert name value a :| as)
|
||||
|
||||
-- | Remove a 'Name' from the environment.
|
||||
--
|
||||
-- >>> delete (name "foo") shadowed
|
||||
-- Environment {unEnvironment = fromList [] :| []}
|
||||
delete :: Name -> Environment l a -> Environment l a
|
||||
delete :: Name -> Environment location value -> Environment location value
|
||||
delete name = trim . Environment . fmap (Map.delete name) . unEnvironment
|
||||
|
||||
trim :: Environment l a -> Environment l a
|
||||
trim :: Environment location value -> Environment location value
|
||||
trim (Environment (a :| as)) = Environment (a :| filtered)
|
||||
where filtered = filter (not . Map.null) as
|
||||
|
||||
bind :: Foldable t => t Name -> Environment l a -> Environment l a
|
||||
bind :: Foldable t => t Name -> Environment location value -> Environment location value
|
||||
bind names env = fromList (mapMaybe lookupName (Prologue.toList names))
|
||||
where
|
||||
lookupName name = (,) name <$> lookup name env
|
||||
|
||||
-- | Get all bound 'Name's in an environment.
|
||||
names :: Environment l a -> [Name]
|
||||
names :: Environment location value -> [Name]
|
||||
names = fmap fst . pairs
|
||||
|
||||
-- | Lookup and alias name-value bindings from an environment.
|
||||
overwrite :: [(Name, Name)] -> Environment l a -> Environment l a
|
||||
overwrite :: [(Name, Name)] -> Environment location value -> Environment location value
|
||||
overwrite pairs env = fromList $ mapMaybe lookupAndAlias pairs
|
||||
where
|
||||
lookupAndAlias (oldName, newName) = (,) newName <$> lookup oldName env
|
||||
@ -132,10 +132,10 @@ overwrite pairs env = fromList $ mapMaybe lookupAndAlias pairs
|
||||
-- | Retrieve the 'Live' set of addresses to which the given free variable names are bound.
|
||||
--
|
||||
-- Unbound names are silently dropped.
|
||||
roots :: (Ord l, Foldable t) => Environment l a -> t Name -> Live l a
|
||||
roots :: (Ord location, Foldable t) => Environment location value -> t Name -> Live location value
|
||||
roots env = foldMap (maybe mempty liveSingleton . flip lookup env)
|
||||
|
||||
addresses :: Ord l => Environment l a -> Live l a
|
||||
addresses :: Ord location => Environment location value -> Live location value
|
||||
addresses = Live . fromList . fmap snd . pairs
|
||||
|
||||
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeOperators, UndecidableInstances #-}
|
||||
module Data.Abstract.Evaluatable
|
||||
( module X
|
||||
, Evaluatable(..)
|
||||
@ -12,6 +12,7 @@ module Data.Abstract.Evaluatable
|
||||
, evaluatePackageWith
|
||||
, throwEvalError
|
||||
, traceResolve
|
||||
, builtin
|
||||
, isolate
|
||||
, Modules
|
||||
) where
|
||||
@ -29,6 +30,7 @@ import Data.Abstract.FreeVariables as X
|
||||
import Data.Abstract.Module
|
||||
import Data.Abstract.ModuleTable as ModuleTable
|
||||
import Data.Abstract.Package as Package
|
||||
import Data.ByteString.Char8 (pack, unpack)
|
||||
import Data.Scientific (Scientific)
|
||||
import Data.Semigroup.App
|
||||
import Data.Semigroup.Foldable
|
||||
@ -166,11 +168,31 @@ traceResolve :: (Show a, Show b, Member Trace effects) => a -> b -> Evaluator lo
|
||||
traceResolve name path = traceE ("resolved " <> show name <> " -> " <> show path)
|
||||
|
||||
|
||||
builtin :: ( Addressable location effects
|
||||
, HasCallStack
|
||||
, Members '[ Reader (Environment location value)
|
||||
, Reader ModuleInfo
|
||||
, Reader Span
|
||||
, State (Environment location value)
|
||||
, State (Heap location value)
|
||||
] effects
|
||||
, Reducer value (Cell location value)
|
||||
)
|
||||
=> String
|
||||
-> Evaluator location value effects value
|
||||
-> Evaluator location value effects ()
|
||||
builtin n def = withCurrentCallStack callStack $ do
|
||||
let name = X.name ("__semantic_" <> pack n)
|
||||
addr <- alloc name
|
||||
modifyEnv (X.insert name addr)
|
||||
def >>= assign addr
|
||||
|
||||
-- | Evaluate a given package.
|
||||
evaluatePackageWith :: forall location term value inner inner' outer
|
||||
. ( Evaluatable (Base term)
|
||||
, EvaluatableConstraints location term value inner
|
||||
, Members '[ Fail
|
||||
, Fresh
|
||||
, Reader (Environment location value)
|
||||
, Resumable (LoadError location value)
|
||||
, State (Environment location value)
|
||||
@ -180,7 +202,7 @@ evaluatePackageWith :: forall location term value inner inner' outer
|
||||
] outer
|
||||
, Recursive term
|
||||
, inner ~ (Goto inner' value ': inner')
|
||||
, inner' ~ (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': Reader Span ': Reader PackageInfo ': outer)
|
||||
, inner' ~ (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer)
|
||||
)
|
||||
=> (SubtermAlgebra Module term (Evaluator location value inner value) -> SubtermAlgebra Module term (Evaluator location value inner value))
|
||||
-> (SubtermAlgebra (Base term) term (Evaluator location value inner value) -> SubtermAlgebra (Base term) term (Evaluator location value inner value))
|
||||
@ -189,6 +211,8 @@ evaluatePackageWith :: forall location term value inner inner' outer
|
||||
evaluatePackageWith analyzeModule analyzeTerm package
|
||||
= runReader (packageInfo package)
|
||||
. runReader lowerBound
|
||||
. fmap fst
|
||||
. runState (lowerBound :: Gotos location value (Reader Span ': Reader PackageInfo ': outer))
|
||||
. runReader (packageModules (packageBody package))
|
||||
. runModules evalModule
|
||||
. withPrelude (packagePrelude (packageBody package))
|
||||
@ -203,16 +227,18 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
||||
= runReader info
|
||||
. runReturn
|
||||
. runLoopControl
|
||||
. fmap fst
|
||||
. runGoto lowerBound
|
||||
. runGoto Gotos getGotos
|
||||
|
||||
evaluateEntryPoint :: ModulePath -> Maybe Name -> Evaluator location value (Modules location value ': Reader Span ': Reader PackageInfo ': outer) value
|
||||
evaluateEntryPoint :: ModulePath -> Maybe Name -> Evaluator location value (Modules location value ': State (Gotos location value (Reader Span ': Reader PackageInfo ': outer)) ': Reader Span ': Reader PackageInfo ': outer) value
|
||||
evaluateEntryPoint m sym = runInModule (ModuleInfo m) $ do
|
||||
v <- maybe unit (pure . snd) <$> require m
|
||||
maybe v ((`call` []) <=< variable) sym
|
||||
|
||||
withPrelude Nothing a = a
|
||||
withPrelude (Just prelude) a = do
|
||||
_ <- runInModule moduleInfoFromCallStack $ do
|
||||
builtin "print" (closure ["s"] lowerBound (variable "s" >>= asString >>= traceE . unpack >> unit))
|
||||
unit
|
||||
preludeEnv <- fst <$> evalModule prelude
|
||||
withDefaultEnvironment preludeEnv a
|
||||
|
||||
@ -224,6 +250,9 @@ evaluatePackageWith analyzeModule analyzeTerm package
|
||||
| otherwise = Exports.toEnvironment ports `mergeEnvs` overwrite (Exports.aliases ports) env
|
||||
pairValueWithEnv action = flip (,) <$> action <*> (filterEnv <$> getExports <*> getEnv)
|
||||
|
||||
newtype Gotos location value outer = Gotos { getGotos :: GotoTable (LoopControl value ': Return value ': Reader ModuleInfo ': Modules location value ': State (Gotos location value outer) ': outer) value }
|
||||
deriving (Lower)
|
||||
|
||||
|
||||
-- | Isolate the given action with an empty global environment and exports.
|
||||
isolate :: Members '[State (Environment location value), State (Exports location value)] effects => Evaluator location value effects a -> Evaluator location value effects a
|
||||
|
||||
@ -1,19 +1,17 @@
|
||||
module Data.Abstract.Module
|
||||
( Module(..)
|
||||
, ModuleInfo(..)
|
||||
, ModulePath
|
||||
, moduleForBlob
|
||||
, ModulePath
|
||||
, ModuleInfo(..)
|
||||
, moduleInfoFromSrcLoc
|
||||
, moduleInfoFromCallStack
|
||||
) where
|
||||
|
||||
import Data.Blob
|
||||
import GHC.Stack
|
||||
import Prologue
|
||||
import System.FilePath.Posix
|
||||
|
||||
type ModulePath = FilePath
|
||||
|
||||
newtype ModuleInfo = ModuleInfo { modulePath :: ModulePath }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data Module term = Module { moduleInfo :: ModuleInfo, moduleBody :: term }
|
||||
deriving (Eq, Foldable, Functor, Ord, Traversable)
|
||||
|
||||
@ -29,3 +27,16 @@ moduleForBlob :: Maybe FilePath -- ^ The root directory relative to which the mo
|
||||
moduleForBlob rootDir Blob{..} = Module info
|
||||
where root = fromMaybe (takeDirectory blobPath) rootDir
|
||||
info = ModuleInfo (makeRelative root blobPath)
|
||||
|
||||
|
||||
type ModulePath = FilePath
|
||||
|
||||
newtype ModuleInfo = ModuleInfo { modulePath :: ModulePath }
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
moduleInfoFromSrcLoc :: SrcLoc -> ModuleInfo
|
||||
moduleInfoFromSrcLoc = ModuleInfo . srcLocModule
|
||||
|
||||
-- | Produce 'ModuleInfo' from the top location on the Haskell call stack (i.e. the file where the call to 'moduleInfoFromCallStack' was made).
|
||||
moduleInfoFromCallStack :: HasCallStack => ModuleInfo
|
||||
moduleInfoFromCallStack = maybe (ModuleInfo "?") (moduleInfoFromSrcLoc . snd) (listToMaybe (getCallStack callStack))
|
||||
|
||||
@ -79,4 +79,4 @@ showCallStack :: Colourize -> CallStack -> ShowS
|
||||
showCallStack colourize callStack = foldr (.) id (intersperse (showChar '\n') (uncurry (showCallSite colourize) <$> getCallStack callStack))
|
||||
|
||||
showCallSite :: Colourize -> String -> SrcLoc -> ShowS
|
||||
showCallSite colourize symbol SrcLoc{..} = showString symbol . showChar ' ' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showParen True (showSpan (Just srcLocFile) (Span (Pos srcLocStartLine srcLocStartCol) (Pos srcLocEndLine srcLocEndCol))))
|
||||
showCallSite colourize symbol loc@SrcLoc{..} = showString symbol . showChar ' ' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showParen True (showSpan (Just srcLocFile) (spanFromSrcLoc loc)))
|
||||
|
||||
@ -6,6 +6,7 @@
|
||||
module Data.Span
|
||||
( Span(..)
|
||||
, Pos(..)
|
||||
, spanFromSrcLoc
|
||||
, emptySpan
|
||||
) where
|
||||
|
||||
@ -13,6 +14,7 @@ import Data.Aeson ((.=), (.:))
|
||||
import qualified Data.Aeson as A
|
||||
import Data.JSON.Fields
|
||||
import Data.Semilattice.Lower
|
||||
import GHC.Stack
|
||||
import Prologue
|
||||
|
||||
-- | Source position information
|
||||
@ -37,6 +39,9 @@ data Span = Span
|
||||
}
|
||||
deriving (Show, Read, Eq, Ord, Generic, Hashable)
|
||||
|
||||
spanFromSrcLoc :: SrcLoc -> Span
|
||||
spanFromSrcLoc = Span . (Pos . srcLocStartLine <*> srcLocStartCol) <*> (Pos . srcLocEndLine <*> srcLocEndCol)
|
||||
|
||||
emptySpan :: Span
|
||||
emptySpan = Span (Pos 1 1) (Pos 1 1)
|
||||
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
module Analysis.Go.Spec (spec) where
|
||||
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable (EvalError(..))
|
||||
import qualified Language.Go.Assignment as Go
|
||||
import qualified Data.Language as Language
|
||||
@ -12,22 +13,16 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "evaluates Go" $ do
|
||||
it "imports and wildcard imports" $ do
|
||||
res <- snd <$> evaluate "main.go"
|
||||
environment res `shouldBe` [ ("foo", addr 0)
|
||||
, ("Bar", addr 2)
|
||||
, ("Rab", addr 3)
|
||||
, ("main", addr 4)
|
||||
]
|
||||
((_, state), _) <- evaluate "main.go"
|
||||
Env.names (environment state) `shouldBe` [ "Bar", "Rab", "foo", "main" ]
|
||||
|
||||
heapLookup (Address (Precise 0)) (heap res) `shouldBe` ns "foo" [ ("New", addr 1) ]
|
||||
(derefQName (heap state) ("foo" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("foo", ["New"])
|
||||
|
||||
it "imports with aliases (and side effects only)" $ do
|
||||
res <- snd <$> evaluate "main1.go"
|
||||
environment res `shouldBe` [ ("f", addr 0)
|
||||
, ("main", addr 4) -- addr 4 is due to side effects of eval'ing `import _ "./bar"` which used addr 2 & 3. f defines New which got addr 1.
|
||||
]
|
||||
((_, state), _) <- evaluate "main1.go"
|
||||
Env.names (environment state) `shouldBe` [ "f", "main" ]
|
||||
|
||||
heapLookup (Address (Precise 0)) (heap res) `shouldBe` ns "f" [ ("New", addr 1) ]
|
||||
(derefQName (heap state) ("f" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("f", ["New"])
|
||||
|
||||
where
|
||||
fixtures = "test/fixtures/go/analysis/"
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
module Analysis.PHP.Spec (spec) where
|
||||
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable (EvalError(..))
|
||||
import qualified Language.PHP.Assignment as PHP
|
||||
import qualified Data.Language as Language
|
||||
@ -12,26 +13,20 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "PHP" $ do
|
||||
it "evaluates include and require" $ do
|
||||
env <- environment . snd <$> evaluate "main.php"
|
||||
env `shouldBe` [ ("foo", addr 0)
|
||||
, ("bar", addr 1) ]
|
||||
env <- environment . snd . fst <$> evaluate "main.php"
|
||||
Env.names env `shouldBe` [ "bar", "foo" ]
|
||||
|
||||
it "evaluates include_once and require_once" $ do
|
||||
env <- environment . snd <$> evaluate "main_once.php"
|
||||
env `shouldBe` [ ("foo", addr 0)
|
||||
, ("bar", addr 1) ]
|
||||
env <- environment . snd . fst <$> evaluate "main_once.php"
|
||||
Env.names env `shouldBe` [ "bar", "foo" ]
|
||||
|
||||
it "evaluates namespaces" $ do
|
||||
res <- snd <$> evaluate "namespaces.php"
|
||||
environment res `shouldBe` [ ("NS1", addr 0)
|
||||
, ("Foo", addr 6) ]
|
||||
((_, state), _) <- evaluate "namespaces.php"
|
||||
Env.names (environment state) `shouldBe` [ "Foo", "NS1" ]
|
||||
|
||||
heapLookup (Address (Precise 0)) (heap res) `shouldBe` ns "NS1" [ ("Sub1", addr 1)
|
||||
, ("b", addr 4)
|
||||
, ("c", addr 5)
|
||||
]
|
||||
heapLookup (Address (Precise 1)) (heap res) `shouldBe` ns "Sub1" [ ("Sub2", addr 2) ]
|
||||
heapLookup (Address (Precise 2)) (heap res) `shouldBe` ns "Sub2" [ ("f", addr 3) ]
|
||||
(derefQName (heap state) ("NS1" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("NS1", ["Sub1", "b", "c"])
|
||||
(derefQName (heap state) ("NS1" :| ["Sub1"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub1", ["Sub2"])
|
||||
(derefQName (heap state) ("NS1" :| ["Sub1", "Sub2"]) (environment state) >>= deNamespace) `shouldBe` Just ("Sub2", ["f"])
|
||||
|
||||
where
|
||||
fixtures = "test/fixtures/php/analysis/"
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE OverloadedLists, OverloadedStrings #-}
|
||||
module Analysis.Python.Spec (spec) where
|
||||
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable (EvalError(..))
|
||||
import Data.Abstract.Value
|
||||
import Data.Map
|
||||
@ -14,37 +15,28 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "evaluates Python" $ do
|
||||
it "imports" $ do
|
||||
res <- snd <$> evaluate "main.py"
|
||||
environment res `shouldBe` [ ("print", addr 0)
|
||||
, ("a", addr 1)
|
||||
, ("b", addr 3)
|
||||
]
|
||||
((_, state), _) <- evaluate "main.py"
|
||||
Env.names (environment state) `shouldContain` [ "a", "b" ]
|
||||
|
||||
heapLookup (Address (Precise 1)) (heap res) `shouldBe` ns "a" [ ("foo", addr 2) ]
|
||||
heapLookup (Address (Precise 3)) (heap res) `shouldBe` ns "b" [ ("c", addr 4) ]
|
||||
heapLookup (Address (Precise 4)) (heap res) `shouldBe` ns "c" [ ("baz", addr 5) ]
|
||||
(derefQName (heap state) ("a" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("a", ["foo"])
|
||||
(derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", ["c"])
|
||||
(derefQName (heap state) ("b" :| ["c"]) (environment state) >>= deNamespace) `shouldBe` Just ("c", ["baz"])
|
||||
|
||||
it "imports with aliases" $ do
|
||||
env <- environment . snd <$> evaluate "main1.py"
|
||||
env `shouldBe` [ ("print", addr 0)
|
||||
, ("b", addr 1)
|
||||
, ("e", addr 3)
|
||||
]
|
||||
env <- environment . snd . fst <$> evaluate "main1.py"
|
||||
Env.names env `shouldContain` [ "b", "e" ]
|
||||
|
||||
it "imports using 'from' syntax" $ do
|
||||
env <- environment . snd <$> evaluate "main2.py"
|
||||
env `shouldBe` [ ("print", addr 0)
|
||||
, ("foo", addr 1)
|
||||
, ("bar", addr 2)
|
||||
]
|
||||
env <- environment . snd . fst <$> evaluate "main2.py"
|
||||
Env.names env `shouldContain` [ "bar", "foo" ]
|
||||
|
||||
it "subclasses" $ do
|
||||
v <- fst <$> evaluate "subclass.py"
|
||||
v `shouldBe` Right [injValue (String "\"bar\"")]
|
||||
((res, _), _) <- evaluate "subclass.py"
|
||||
res `shouldBe` Right [injValue (String "\"bar\"")]
|
||||
|
||||
it "handles multiple inheritance left-to-right" $ do
|
||||
v <- fst <$> evaluate "multiple_inheritance.py"
|
||||
v `shouldBe` Right [injValue (String "\"foo!\"")]
|
||||
((res, _), _) <- evaluate "multiple_inheritance.py"
|
||||
res `shouldBe` Right [injValue (String "\"foo!\"")]
|
||||
|
||||
where
|
||||
ns n = Just . Latest . Just . injValue . Namespace n
|
||||
|
||||
@ -2,6 +2,7 @@
|
||||
|
||||
module Analysis.Ruby.Spec (spec) where
|
||||
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.Value as Value
|
||||
import Data.Abstract.Number as Number
|
||||
@ -20,62 +21,60 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "Ruby" $ do
|
||||
it "evaluates require_relative" $ do
|
||||
env <- environment . snd <$> evaluate "main.rb"
|
||||
env `shouldBe` [ ("Object", addr 0)
|
||||
, ("foo", addr 3) ]
|
||||
((res, state), _) <- evaluate "main.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 1))]
|
||||
Env.names (environment state) `shouldContain` ["foo"]
|
||||
|
||||
it "evaluates load" $ do
|
||||
env <- environment . snd <$> evaluate "load.rb"
|
||||
env `shouldBe` [ ("Object", addr 0)
|
||||
, ("foo", addr 3) ]
|
||||
env <- environment . snd . fst <$> evaluate "load.rb"
|
||||
Env.names env `shouldContain` ["foo"]
|
||||
|
||||
it "evaluates load with wrapper" $ do
|
||||
res <- evaluate "load-wrap.rb"
|
||||
fst res `shouldBe` Left (SomeExc (injectSum @(EnvironmentError (Value Precise)) (FreeVariable "foo")))
|
||||
environment (snd res) `shouldBe` [ ("Object", addr 0) ]
|
||||
((res, state), _) <- evaluate "load-wrap.rb"
|
||||
res `shouldBe` Left (SomeExc (injectSum @(EnvironmentError (Value Precise)) (FreeVariable "foo")))
|
||||
Env.names (environment state) `shouldContain` [ "Object" ]
|
||||
|
||||
it "evaluates subclass" $ do
|
||||
res <- evaluate "subclass.rb"
|
||||
fst res `shouldBe` Right [injValue (String "\"<bar>\"")]
|
||||
environment (snd res) `shouldBe` [ ("Bar", addr 6)
|
||||
, ("Foo", addr 3)
|
||||
, ("Object", addr 0) ]
|
||||
((res, state), _) <- evaluate "subclass.rb"
|
||||
res `shouldBe` Right [injValue (String "\"<bar>\"")]
|
||||
Env.names (environment state) `shouldContain` [ "Bar", "Foo" ]
|
||||
|
||||
heapLookup (Address (Precise 6)) (heap (snd res))
|
||||
`shouldBe` ns "Bar" [ ("baz", addr 8)
|
||||
, ("foo", addr 5)
|
||||
, ("inspect", addr 7) ]
|
||||
(derefQName (heap state) ("Bar" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"])
|
||||
|
||||
it "evaluates modules" $ do
|
||||
res <- evaluate "modules.rb"
|
||||
fst res `shouldBe` Right [injValue (String "\"<hello>\"")]
|
||||
environment (snd res) `shouldBe` [ ("Object", addr 0)
|
||||
, ("Bar", addr 3) ]
|
||||
((res, state), _) <- evaluate "modules.rb"
|
||||
res `shouldBe` Right [injValue (String "\"<hello>\"")]
|
||||
Env.names (environment state) `shouldContain` [ "Bar" ]
|
||||
|
||||
it "handles break correctly" $ do
|
||||
res <- evaluate "break.rb"
|
||||
fst res `shouldBe` Right [injValue (Value.Integer (Number.Integer 3))]
|
||||
((res, _), _) <- evaluate "break.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 3))]
|
||||
|
||||
it "handles break correctly" $ do
|
||||
res <- evaluate "next.rb"
|
||||
fst res `shouldBe` Right [injValue (Value.Integer (Number.Integer 8))]
|
||||
((res, _), _) <- evaluate "next.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 8))]
|
||||
|
||||
it "calls functions with arguments" $ do
|
||||
res <- evaluate "call.rb"
|
||||
fst res `shouldBe` Right [injValue (Value.Integer (Number.Integer 579))]
|
||||
((res, _), _) <- evaluate "call.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 579))]
|
||||
|
||||
it "evaluates early return statements" $ do
|
||||
res <- evaluate "early-return.rb"
|
||||
fst res `shouldBe` Right [injValue (Value.Integer (Number.Integer 123))]
|
||||
((res, _), _) <- evaluate "early-return.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 123))]
|
||||
|
||||
it "has prelude" $ do
|
||||
res <- fst <$> evaluate "preluded.rb"
|
||||
((res, _), _) <- evaluate "preluded.rb"
|
||||
res `shouldBe` Right [injValue (String "\"<foo>\"")]
|
||||
|
||||
it "evaluates __LINE__" $ do
|
||||
res <- fst <$> evaluate "line.rb"
|
||||
((res, _), _) <- evaluate "line.rb"
|
||||
res `shouldBe` Right [injValue (Value.Integer (Number.Integer 4))]
|
||||
|
||||
it "resolves builtins used in the prelude" $ do
|
||||
((res, _), traces) <- evaluate "puts.rb"
|
||||
res `shouldBe` Right [injValue Unit]
|
||||
traces `shouldContain` [ "\"hello\"" ]
|
||||
|
||||
where
|
||||
ns n = Just . Latest . Just . injValue . Namespace n
|
||||
addr = Address . Precise
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
module Analysis.TypeScript.Spec (spec) where
|
||||
|
||||
import Control.Arrow ((&&&))
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable
|
||||
import qualified Language.TypeScript.Assignment as TypeScript
|
||||
import Data.Abstract.Value as Value
|
||||
@ -14,32 +16,27 @@ spec :: Spec
|
||||
spec = parallel $ do
|
||||
describe "evaluates TypeScript" $ do
|
||||
it "imports with aliased symbols" $ do
|
||||
env <- environment . snd <$> evaluate "main.ts"
|
||||
env `shouldBe` [ ("bar", addr 0)
|
||||
, ("quz", addr 3)]
|
||||
env <- environment . snd . fst <$> evaluate "main.ts"
|
||||
Env.names env `shouldBe` [ "bar", "quz" ]
|
||||
|
||||
it "imports with qualified names" $ do
|
||||
res <- snd <$> evaluate "main1.ts"
|
||||
environment res `shouldBe` [ ("b", addr 0)
|
||||
, ("z", addr 4)
|
||||
]
|
||||
((_, state), _) <- evaluate "main1.ts"
|
||||
Env.names (environment state) `shouldBe` [ "b", "z" ]
|
||||
|
||||
heapLookup (Address (Precise 0)) (heap res) `shouldBe` ns "b" [ ("baz", addr 1)
|
||||
, ("foo", addr 3) ]
|
||||
heapLookup (Address (Precise 4)) (heap res) `shouldBe` ns "z" [ ("baz", addr 1)
|
||||
, ("foo", addr 3) ]
|
||||
(derefQName (heap state) ("b" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("b", [ "baz", "foo" ])
|
||||
(derefQName (heap state) ("z" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("z", [ "baz", "foo" ])
|
||||
|
||||
it "side effect only imports" $ do
|
||||
env <- environment . snd <$> evaluate "main2.ts"
|
||||
env <- environment . snd . fst <$> evaluate "main2.ts"
|
||||
env `shouldBe` emptyEnv
|
||||
|
||||
it "fails exporting symbols not defined in the module" $ do
|
||||
v <- fst <$> evaluate "bad-export.ts"
|
||||
v `shouldBe` Left (SomeExc (injectSum (ExportError "foo.ts" (Name "pip") :: EvalError (Value Precise) ())))
|
||||
((res, _), _) <- evaluate "bad-export.ts"
|
||||
res `shouldBe` Left (SomeExc (injectSum @(EvalError (Value Precise)) (ExportError "foo.ts" (Name "pip"))))
|
||||
|
||||
it "evaluates early return statements" $ do
|
||||
res <- evaluate "early-return.ts"
|
||||
fst res `shouldBe` Right [injValue (Value.Float (Number.Decimal 123.0))]
|
||||
((res, _), _) <- evaluate "early-return.ts"
|
||||
res `shouldBe` Right [injValue (Value.Float (Number.Decimal 123.0))]
|
||||
|
||||
where
|
||||
fixtures = "test/fixtures/typescript/analysis/"
|
||||
|
||||
@ -40,9 +40,12 @@ evaluate
|
||||
. runReturn
|
||||
. runLoopControl
|
||||
. fmap fst
|
||||
. runGoto lowerBound
|
||||
. runState (Gotos lowerBound)
|
||||
. runGoto Gotos getGotos
|
||||
. constraining
|
||||
|
||||
newtype Gotos effects = Gotos { getGotos :: GotoTable (State (Gotos effects) ': effects) (Value Precise) }
|
||||
|
||||
constraining :: Evaluator Precise (Value Precise) effects a -> Evaluator Precise (Value Precise) effects a
|
||||
constraining = id
|
||||
|
||||
|
||||
@ -4,8 +4,8 @@ module SpecHelpers
|
||||
, parseFilePath
|
||||
, readFilePair
|
||||
, testEvaluating
|
||||
, ns
|
||||
, addr
|
||||
, deNamespace
|
||||
, derefQName
|
||||
, verbatim
|
||||
, Verbatim(..)
|
||||
) where
|
||||
@ -14,18 +14,22 @@ import Analysis.Abstract.Evaluating
|
||||
import Analysis.Abstract.Evaluating as X (EvaluatingState(..))
|
||||
import Control.Abstract.Addressable
|
||||
import Control.Abstract.Value
|
||||
import Control.Arrow ((&&&))
|
||||
import Control.Effect as X (runIgnoringTraces)
|
||||
import Control.Monad ((>=>))
|
||||
import Data.Abstract.Address as X
|
||||
import Data.Abstract.Environment as Env
|
||||
import Data.Abstract.Evaluatable
|
||||
import Data.Abstract.FreeVariables as X hiding (dropExtension)
|
||||
import Data.Abstract.Heap as X
|
||||
import Data.Abstract.ModuleTable as X hiding (lookup)
|
||||
import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue, runValueError)
|
||||
import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue, prjValue, runValueError)
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Blob as X
|
||||
import Data.File as X
|
||||
import Data.Functor.Listable as X
|
||||
import Data.Language as X
|
||||
import Data.List.NonEmpty as X (NonEmpty(..))
|
||||
import Data.Output as X
|
||||
import Data.Range as X
|
||||
import Data.Record as X
|
||||
@ -70,9 +74,9 @@ readFilePair paths = let paths' = fmap file paths in
|
||||
|
||||
testEvaluating
|
||||
= run
|
||||
. runReturningTraces
|
||||
. fmap (first reassociate)
|
||||
. evaluating
|
||||
. runIgnoringTraces
|
||||
. runLoadError
|
||||
. runValueError
|
||||
. runUnspecialized
|
||||
@ -82,8 +86,14 @@ testEvaluating
|
||||
. runAddressError
|
||||
. constrainedToValuePrecise
|
||||
|
||||
ns n = Just . Latest . Just . injValue . Namespace n
|
||||
addr = Address . Precise
|
||||
deNamespace :: Value Precise -> Maybe (Name, [Name])
|
||||
deNamespace = fmap (namespaceName &&& Env.names . namespaceScope) . prjValue @(Namespace Precise)
|
||||
|
||||
derefQName :: Heap Precise (Value Precise) -> NonEmpty Name -> Environment Precise (Value Precise) -> Maybe (Value Precise)
|
||||
derefQName heap = go
|
||||
where go (n1 :| ns) env = Env.lookup n1 env >>= flip heapLookup heap >>= unLatest >>= case ns of
|
||||
[] -> Just
|
||||
(n2 : ns) -> fmap namespaceScope . prjValue @(Namespace Precise) >=> go (n2 :| ns)
|
||||
|
||||
newtype Verbatim = Verbatim ByteString
|
||||
deriving (Eq)
|
||||
|
||||
1
test/fixtures/ruby/analysis/puts.rb
vendored
Normal file
1
test/fixtures/ruby/analysis/puts.rb
vendored
Normal file
@ -0,0 +1 @@
|
||||
puts "hello"
|
||||
Loading…
Reference in New Issue
Block a user