diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 43e8c72cc..107140d92 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -11,198 +11,35 @@ import Data.Scientific (Scientific) import Data.Scientific.Exts import Data.Semigroup.Reducer import qualified Data.Set as Set -import Data.Sum -import Prologue hiding (TypeError, project) -import Prelude hiding (Float, Integer, String, Rational) -import qualified Prelude +import Prologue -type ValueConstructors location - = '[Array - , Boolean - , Class location - , Closure location - , Float - , Hash - , Integer - , KVPair - , Namespace location - , Null - , Rational - , String - , Symbol - , Tuple - , Unit - , Hole - ] - --- | Open union of primitive values that terms can be evaluated to. --- Fix by another name. -newtype Value location = Value (Sum (ValueConstructors location) (Value location)) +data Value location + = Closure PackageInfo ModuleInfo [Name] Label (Environment location) + | Unit + | Boolean Bool + | Integer (Number.Number Integer) + | Rational (Number.Number Rational) + | Float (Number.Number Scientific) + | String ByteString + | Symbol ByteString + | Tuple [Value location] + | Array [Value location] + | Class Name (Environment location) + | Namespace Name (Environment location) + | KVPair (Value location) (Value location) + | Hash [Value location] + | Null + | Hole deriving (Eq, Show, Ord) --- | Identical to 'inject', but wraps the resulting sub-entity in a 'Value'. -injValue :: (f :< ValueConstructors location) => f (Value location) -> Value location -injValue = Value . inject - --- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper. -prjValue :: (f :< ValueConstructors location) => Value location -> Maybe (f (Value location)) -prjValue (Value v) = project v - --- | Convenience function for projecting two values. -prjPair :: (f :< ValueConstructors location , g :< ValueConstructors location) - => (Value location, Value location) - -> Maybe (f (Value location), g (Value location)) -prjPair = bitraverse prjValue prjValue - --- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. - --- | A function value consisting of a package & module info, a list of parameter 'Name's, a 'Label' to jump to the body of the function, and an 'Environment' of bindings captured by the body. -data Closure location value = Closure PackageInfo ModuleInfo [Name] Label (Environment location) - deriving (Eq, Generic1, Ord, Show) - -instance Eq location => Eq1 (Closure location) where liftEq = genericLiftEq -instance Ord location => Ord1 (Closure location) where liftCompare = genericLiftCompare -instance Show location => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec - --- | The unit value. Typically used to represent the result of imperative statements. -data Unit value = Unit - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Unit where liftEq = genericLiftEq -instance Ord1 Unit where liftCompare = genericLiftCompare -instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec - -data Hole value = Hole - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Hole where liftEq = genericLiftEq -instance Ord1 Hole where liftCompare = genericLiftCompare -instance Show1 Hole where liftShowsPrec = genericLiftShowsPrec - --- | Boolean values. -newtype Boolean value = Boolean { getBoolean :: Bool } - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Boolean where liftEq = genericLiftEq -instance Ord1 Boolean where liftCompare = genericLiftCompare -instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec - --- | Arbitrary-width integral values. -newtype Integer value = Integer (Number.Number Prelude.Integer) - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Integer where liftEq = genericLiftEq -instance Ord1 Integer where liftCompare = genericLiftCompare -instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec - --- | Arbitrary-width rational values values. -newtype Rational value = Rational (Number.Number Prelude.Rational) - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Rational where liftEq = genericLiftEq -instance Ord1 Rational where liftCompare = genericLiftCompare -instance Show1 Rational where liftShowsPrec = genericLiftShowsPrec - --- | String values. -newtype String value = String ByteString - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 String where liftEq = genericLiftEq -instance Ord1 String where liftCompare = genericLiftCompare -instance Show1 String where liftShowsPrec = genericLiftShowsPrec - --- | Possibly-interned Symbol values. --- TODO: Should this store a 'Text'? -newtype Symbol value = Symbol ByteString - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Symbol where liftEq = genericLiftEq -instance Ord1 Symbol where liftCompare = genericLiftCompare -instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec - --- | Float values. -newtype Float value = Float (Number.Number Scientific) - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Float where liftEq = genericLiftEq -instance Ord1 Float where liftCompare = genericLiftCompare -instance Show1 Float where liftShowsPrec = genericLiftShowsPrec - --- | Zero or more values. Fixed-size at interpretation time. --- TODO: Investigate whether we should use Vector for this. --- TODO: Should we have a Some type over a nonemmpty list? Or does this merit one? -newtype Tuple value = Tuple [value] - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Tuple where liftEq = genericLiftEq -instance Ord1 Tuple where liftCompare = genericLiftCompare -instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec - --- | Zero or more values. Dynamically resized as needed at interpretation time. --- TODO: Vector? Seq? -newtype Array value = Array [value] - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Array where liftEq = genericLiftEq -instance Ord1 Array where liftCompare = genericLiftCompare -instance Show1 Array where liftShowsPrec = genericLiftShowsPrec - --- | Class values. There will someday be a difference between classes and objects, --- but for the time being we're pretending all languages have prototypical inheritance. -data Class location value = Class - { _className :: Name - , _classScope :: Environment location - } deriving (Eq, Generic1, Ord, Show) - -instance Eq location => Eq1 (Class location) where liftEq = genericLiftEq -instance Ord location => Ord1 (Class location) where liftCompare = genericLiftCompare -instance Show location => Show1 (Class location) where liftShowsPrec = genericLiftShowsPrec - -data Namespace location value = Namespace - { namespaceName :: Name - , namespaceScope :: Environment location - } deriving (Eq, Generic1, Ord, Show) - -instance Eq location => Eq1 (Namespace location) where liftEq = genericLiftEq -instance Ord location => Ord1 (Namespace location) where liftCompare = genericLiftCompare -instance Show location => Show1 (Namespace location) where liftShowsPrec = genericLiftShowsPrec - -data KVPair value = KVPair value value - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 KVPair where liftEq = genericLiftEq -instance Ord1 KVPair where liftCompare = genericLiftCompare -instance Show1 KVPair where liftShowsPrec = genericLiftShowsPrec - --- You would think this would be a @Map value value@ or a @[(value, value)]. --- You would be incorrect, as we can't derive a Generic1 instance for the above, --- and in addition a 'Map' representation would lose information given hash literals --- that assigned multiple values to one given key. Instead, this holds KVPair --- values. The smart constructor for hashes in 'AbstractValue' ensures that these are --- only populated with pairs. -newtype Hash value = Hash [value] - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Hash where liftEq = genericLiftEq -instance Ord1 Hash where liftCompare = genericLiftCompare -instance Show1 Hash where liftShowsPrec = genericLiftShowsPrec - -data Null value = Null - deriving (Eq, Generic1, Ord, Show) - -instance Eq1 Null where liftEq = genericLiftEq -instance Ord1 Null where liftCompare = genericLiftCompare -instance Show1 Null where liftShowsPrec = genericLiftShowsPrec - - instance Ord location => ValueRoots location (Value location) where valueRoots v - | Just (Closure _ _ _ _ env) <- prjValue v = Env.addresses env - | otherwise = mempty + | Closure _ _ _ _ env <- v = Env.addresses env + | otherwise = mempty instance AbstractHole (Value location) where - hole = injValue Hole + hole = Hole instance ( Members '[ Allocator location (Value location) , Reader (Environment location) @@ -222,11 +59,11 @@ instance ( Members '[ Allocator location (Value location) packageInfo <- currentPackage moduleInfo <- currentModule l <- label body - injValue . Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv + Closure packageInfo moduleInfo parameters l . Env.bind (foldr Set.delete freeVariables parameters) <$> getEnv call op params = do - case prjValue op of - Just (Closure packageInfo moduleInfo names label env) -> do + case op of + Closure packageInfo moduleInfo names label env -> do body <- goto label -- Evaluate the bindings and body with the closure’s package/module info in scope in order to -- charge them to the closure's origin. @@ -237,7 +74,7 @@ instance ( Members '[ Allocator location (Value location) assign a v Env.insert name a <$> rest) (pure env) (zip names params) localEnv (mergeEnvs bindings) (body `catchReturn` \ (Return value) -> pure value) - Nothing -> throwValueError (CallError op) + _ -> throwValueError (CallError op) -- | Construct a 'Value' wrapping the value arguments (if any). @@ -256,51 +93,51 @@ instance ( Members '[ Allocator location (Value location) , Show location ) => AbstractValue location (Value location) (Goto effects (Value location) ': effects) where - unit = pure . injValue $ Unit - integer = pure . injValue . Integer . Number.Integer - boolean = pure . injValue . Boolean - string = pure . injValue . String - float = pure . injValue . Float . Number.Decimal - symbol = pure . injValue . Symbol - rational = pure . injValue . Rational . Number.Ratio + unit = pure Unit + integer = pure . Integer . Number.Integer + boolean = pure . Boolean + string = pure . String + float = pure . Float . Number.Decimal + symbol = pure . Symbol + rational = pure . Rational . Number.Ratio - multiple = pure . injValue . Tuple - array = pure . injValue . Array + multiple = pure . Tuple + array = pure . Array - kvPair k = pure . injValue . KVPair k + kvPair k = pure . KVPair k - null = pure . injValue $ Null + null = pure Null asPair val - | Just (KVPair k v) <- prjValue val = pure (k, v) + | KVPair k v <- val = pure (k, v) | otherwise = throwValueError $ KeyValueError val - hash = pure . injValue . Hash . fmap (injValue . uncurry KVPair) + hash = pure . Hash . map (uncurry KVPair) - klass n [] env = pure . injValue $ Class n env + klass n [] env = pure $ Class n env klass n supers env = do product <- foldl mergeEnvs emptyEnv . catMaybes <$> traverse scopedEnvironment supers - pure . injValue $ Class n (mergeEnvs product env) + pure $ Class n (mergeEnvs product env) namespace n env = do maybeAddr <- lookupEnv n env' <- maybe (pure emptyEnv) (asNamespaceEnv <=< deref) maybeAddr - pure (injValue (Namespace n (Env.mergeNewer env' env))) + pure (Namespace n (Env.mergeNewer env' env)) where asNamespaceEnv v - | Just (Namespace _ env') <- prjValue v = pure env' - | otherwise = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace") + | Namespace _ env' <- v = pure env' + | otherwise = throwValueError $ NamespaceError ("expected " <> show v <> " to be a namespace") scopedEnvironment o - | Just (Class _ env) <- prjValue o = pure (Just env) - | Just (Namespace _ env) <- prjValue o = pure (Just env) + | Class _ env <- o = pure (Just env) + | Namespace _ env <- o = pure (Just env) | otherwise = pure Nothing asString v - | Just (String n) <- prjValue v = pure n - | otherwise = throwValueError $ StringError v + | String n <- v = pure n + | otherwise = throwValueError $ StringError v ifthenelse cond if' else' = do - bool <- maybe (throwValueError (BoolError cond)) (pure . getBoolean) (prjValue cond) + bool <- case cond of { Boolean b -> pure b ; _ -> throwValueError (BoolError cond) } if bool then if' else else' index = go where @@ -308,26 +145,26 @@ instance ( Members '[ Allocator location (Value location) | ii > genericLength list = throwValueError (BoundsError list ii) | otherwise = pure (genericIndex list ii) go arr idx - | (Just (Array arr, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx arr i - | (Just (Tuple tup, Integer (Number.Integer i))) <- prjPair (arr, idx) = tryIdx tup i + | (Array arr, Integer (Number.Integer i)) <- (arr, idx) = tryIdx arr i + | (Tuple tup, Integer (Number.Integer i)) <- (arr, idx) = tryIdx tup i | otherwise = throwValueError (IndexError arr idx) liftNumeric f arg - | Just (Integer (Number.Integer i)) <- prjValue arg = integer $ f i - | Just (Float (Number.Decimal d)) <- prjValue arg = float $ f d - | Just (Rational (Number.Ratio r)) <- prjValue arg = rational $ f r + | Integer (Number.Integer i) <- arg = integer $ f i + | Float (Number.Decimal d) <- arg = float $ f d + | Rational (Number.Ratio r) <- arg = rational $ f r | otherwise = throwValueError (NumericError arg) liftNumeric2 f left right - | Just (Integer i, Integer j) <- prjPair pair = tentative f i j & specialize - | Just (Integer i, Rational j) <- prjPair pair = tentative f i j & specialize - | Just (Integer i, Float j) <- prjPair pair = tentative f i j & specialize - | Just (Rational i, Integer j) <- prjPair pair = tentative f i j & specialize - | Just (Rational i, Rational j) <- prjPair pair = tentative f i j & specialize - | Just (Rational i, Float j) <- prjPair pair = tentative f i j & specialize - | Just (Float i, Integer j) <- prjPair pair = tentative f i j & specialize - | Just (Float i, Rational j) <- prjPair pair = tentative f i j & specialize - | Just (Float i, Float j) <- prjPair pair = tentative f i j & specialize + | (Integer i, Integer j) <- pair = tentative f i j & specialize + | (Integer i, Rational j) <- pair = tentative f i j & specialize + | (Integer i, Float j) <- pair = tentative f i j & specialize + | (Rational i, Integer j) <- pair = tentative f i j & specialize + | (Rational i, Rational j) <- pair = tentative f i j & specialize + | (Rational i, Float j) <- pair = tentative f i j & specialize + | (Float i, Integer j) <- pair = tentative f i j & specialize + | (Float i, Rational j) <- pair = tentative f i j & specialize + | (Float i, Float j) <- pair = tentative f i j & specialize | otherwise = throwValueError (Numeric2Error left right) where tentative x i j = attemptUnsafeArithmetic (x i j) @@ -341,13 +178,13 @@ instance ( Members '[ Allocator location (Value location) pair = (left, right) liftComparison comparator left right - | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = go i j - | Just (Integer (Number.Integer i), Float (Number.Decimal j)) <- prjPair pair = go (fromIntegral i) j - | Just (Float (Number.Decimal i), Integer (Number.Integer j)) <- prjPair pair = go i (fromIntegral j) - | Just (Float (Number.Decimal i), Float (Number.Decimal j)) <- prjPair pair = go i j - | Just (String i, String j) <- prjPair pair = go i j - | Just (Boolean i, Boolean j) <- prjPair pair = go i j - | Just (Unit, Unit) <- prjPair pair = boolean True + | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = go i j + | (Integer (Number.Integer i), Float (Number.Decimal j)) <- pair = go (fromIntegral i) j + | (Float (Number.Decimal i), Integer (Number.Integer j)) <- pair = go i (fromIntegral j) + | (Float (Number.Decimal i), Float (Number.Decimal j)) <- pair = go i j + | (String i, String j) <- pair = go i j + | (Boolean i, Boolean j) <- pair = go i j + | (Unit, Unit) <- pair = boolean True | otherwise = throwValueError (ComparisonError left right) where -- Explicit type signature is necessary here because we're passing all sorts of things @@ -365,11 +202,11 @@ instance ( Members '[ Allocator location (Value location) liftBitwise operator target - | Just (Integer (Number.Integer i)) <- prjValue target = integer $ operator i + | Integer (Number.Integer i) <- target = integer $ operator i | otherwise = throwValueError (BitwiseError target) liftBitwise2 operator left right - | Just (Integer (Number.Integer i), Integer (Number.Integer j)) <- prjPair pair = integer $ operator i j + | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = integer $ operator i j | otherwise = throwValueError (Bitwise2Error left right) where pair = (left, right) diff --git a/src/Parsing/TreeSitter.hs b/src/Parsing/TreeSitter.hs index d81c7876f..20e4a3ead 100644 --- a/src/Parsing/TreeSitter.hs +++ b/src/Parsing/TreeSitter.hs @@ -7,7 +7,10 @@ module Parsing.TreeSitter import Prologue import Control.Concurrent.Async -import Control.Monad +import Control.Exception (throwIO) +import Control.Monad.Effect +import Control.Monad.Effect.Trace +import Control.Monad.IO.Class import Data.AST (AST, Node (Node)) import Data.Blob import Data.ByteString.Unsafe (unsafeUseAsCStringLen) @@ -18,6 +21,7 @@ import Data.Term import Foreign import Foreign.C.Types (CBool (..)) import Foreign.Marshal.Array (allocaArray) +import Semantic.IO hiding (Source) import System.Timeout import qualified TreeSitter.Language as TS @@ -27,50 +31,65 @@ import qualified TreeSitter.Tree as TS newtype Timeout = Milliseconds Int --- Change this to putStrLn if you want to debug the locking/cancellation code. --- TODO: Someday we should run this all in Eff so that we can 'trace'. -dbg :: String -> IO () -dbg = const (pure ()) +data Result grammar + = Failed + | Succeeded (AST [] grammar) -runParser :: (Enum grammar, Bounded grammar) => Ptr TS.Parser -> Source -> IO (Maybe (AST [] grammar)) -runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> +runParser :: (Enum grammar, Bounded grammar) => Ptr TS.Parser -> Source -> IO (Result grammar) +runParser parser blobSource = unsafeUseAsCStringLen (sourceBytes blobSource) $ \ (source, len) -> do alloca (\ rootPtr -> do let acquire = do - dbg "Starting parse" -- Change this to TS.ts_parser_loop_until_cancelled if you want to test out cancellation TS.ts_parser_parse_string parser nullPtr source len let release t - | t == nullPtr = dbg "Parse failed" - | otherwise = dbg "Parse completed" *> TS.ts_tree_delete t + | t == nullPtr = pure () + | otherwise = TS.ts_tree_delete t let go treePtr = do if treePtr == nullPtr - then pure Nothing + then pure Failed else do TS.ts_tree_root_node_p treePtr rootPtr - fmap Just (peek rootPtr >>= anaM toAST) + ptr <- peek rootPtr + Succeeded <$> anaM toAST ptr bracket acquire release go) +-- | The semantics of @bracket before after handler@ are as follows: +-- * Exceptions in @before@ and @after@ are thrown in IO. +-- * @after@ is called on IO exceptions in @handler@, and then rethrown in IO. +-- * If @handler@ completes successfully, @after@ is called +-- Call 'catchException' at the call site if you want to recover. +bracket' :: (Member IO r) => IO a -> (a -> IO b) -> (a -> Eff r c) -> Eff r c +bracket' before after action = do + a <- liftIO before + let cleanup = liftIO (after a) + res <- action a `catchException` (\(e :: SomeException) -> cleanup >> liftIO (throwIO e)) + res <$ cleanup + -- | Parse 'Source' with the given 'TS.Language' and return its AST. -- Returns Nothing if the operation timed out. -parseToAST :: (Bounded grammar, Enum grammar) => Timeout -> Ptr TS.Language -> Blob -> IO (Maybe (AST [] grammar)) -parseToAST (Milliseconds s) language Blob{..} = bracket TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do +parseToAST :: (Bounded grammar, Enum grammar, Members '[Trace, IO] effects) => Timeout -> Ptr TS.Language -> Blob -> Eff effects (Maybe (AST [] grammar)) +parseToAST (Milliseconds s) language Blob{..} = bracket' TS.ts_parser_new TS.ts_parser_delete $ \ parser -> do let parserTimeout = s * 1000 - TS.ts_parser_halt_on_error parser (CBool 1) - TS.ts_parser_set_language parser language + liftIO $ do + TS.ts_parser_halt_on_error parser (CBool 1) + TS.ts_parser_set_language parser language - parsing <- async (runParser parser blobSource) + trace "tree-sitter: beginning parsing" + + parsing <- liftIO . async $ runParser parser blobSource -- Kick the parser off asynchronously and wait according to the provided timeout. - res <- timeout parserTimeout (wait parsing) + res <- liftIO . timeout parserTimeout $ wait parsing - -- If we get a Nothing back, then we failed, so we need to disable the parser, which - -- will let the call to runParser terminate, cleaning up appropriately - when (isNothing res) (TS.ts_parser_set_enabled parser (CBool 0)) - - pure (join res) + case res of + Just Failed -> Nothing <$ trace "tree-sitter: parsing failed" + Just (Succeeded ast) -> Just ast <$ trace "tree-sitter: parsing succeeded" + Nothing -> do + trace "tree-sitter: parsing timed out" + Nothing <$ liftIO (TS.ts_parser_set_enabled parser (CBool 0)) toAST :: forall grammar . (Bounded grammar, Enum grammar) => TS.Node -> IO (Base (AST [] grammar) TS.Node) diff --git a/src/Semantic/IO.hs b/src/Semantic/IO.hs index 76131337c..a4ccd5314 100644 --- a/src/Semantic/IO.hs +++ b/src/Semantic/IO.hs @@ -1,34 +1,35 @@ {-# LANGUAGE DeriveAnyClass, DeriveDataTypeable, DuplicateRecordFields, GADTs, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Semantic.IO -( readFile -, readFilePair -, isDirectory -, readBlobPairsFromHandle -, readBlobsFromHandle -, readProjectFromPaths -, readBlobsFromDir -, findFiles -, languageForFilePath -, NoLanguageForBlob(..) -, noLanguageForBlob -, readBlob -, readBlobs -, readBlobPairs -, readProject -, findFilesInDir -, write +( Destination(..) +, Files , Handle(..) -, getHandle , IO.IOMode(..) +, NoLanguageForBlob(..) +, Source(..) +, catchException +, findFiles +, findFilesInDir +, getHandle +, isDirectory +, languageForFilePath +, noLanguageForBlob +, openFileForReading +, readBlob +, readBlobPairs +, readBlobPairsFromHandle +, readBlobs +, readBlobsFromDir +, readBlobsFromHandle +, readFile +, readFilePair +, readProject +, readProjectFromPaths +, rethrowing +, runFiles +, stderr , stdin , stdout -, stderr -, openFileForReading -, Source(..) -, Destination(..) -, Files -, runFiles -, rethrowing +, write ) where import qualified Control.Exception as Exc diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 20132f7a9..406df5bfd 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -195,7 +195,7 @@ runParser :: Members '[Reader Options, Telemetry, Exc SomeException, IO, Trace] runParser blob@Blob{..} parser = case parser of ASTParser language -> time "parse.tree_sitter_ast_parse" languageTag $ - IO.rethrowing (parseToAST defaultTimeout language blob) + parseToAST defaultTimeout language blob >>= maybeM (throwError (SomeException ParserTimedOut)) AssignmentParser parser assignment -> do diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index ae517e19b..657382f34 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -37,14 +37,14 @@ spec = parallel $ do it "subclasses" $ do ((res, _), _) <- evaluate "subclass.py" - res `shouldBe` Right [injValue (String "\"bar\"")] + res `shouldBe` Right [String "\"bar\""] it "handles multiple inheritance left-to-right" $ do ((res, _), _) <- evaluate "multiple_inheritance.py" - res `shouldBe` Right [injValue (String "\"foo!\"")] + res `shouldBe` Right [String "\"foo!\""] where - ns n = Just . Latest . Last . Just . injValue . Namespace n + ns n = Just . Latest . Last . Just . Namespace n addr = Address . Precise fixtures = "test/fixtures/python/analysis/" evaluate entry = evalPythonProject (fixtures <> entry) diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 7ede7371f..af5512099 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -22,7 +22,7 @@ spec = parallel $ do describe "Ruby" $ do it "evaluates require_relative" $ do ((res, state), _) <- evaluate "main.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 1))] + res `shouldBe` Right [Value.Integer (Number.Integer 1)] Env.names (environment state) `shouldContain` ["foo"] it "evaluates load" $ do @@ -36,47 +36,47 @@ spec = parallel $ do it "evaluates subclass" $ do ((res, state), _) <- evaluate "subclass.rb" - res `shouldBe` Right [injValue (String "\"\"")] + res `shouldBe` Right [String "\"\""] Env.names (environment state) `shouldContain` [ "Bar", "Foo" ] (derefQName (heap state) ("Bar" :| []) (environment state) >>= deNamespace) `shouldBe` Just ("Bar", ["baz", "foo", "inspect"]) it "evaluates modules" $ do ((res, state), _) <- evaluate "modules.rb" - res `shouldBe` Right [injValue (String "\"\"")] + res `shouldBe` Right [String "\"\""] Env.names (environment state) `shouldContain` [ "Bar" ] it "handles break correctly" $ do ((res, _), _) <- evaluate "break.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 3))] + res `shouldBe` Right [Value.Integer (Number.Integer 3)] it "handles break correctly" $ do ((res, _), _) <- evaluate "next.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 8))] + res `shouldBe` Right [Value.Integer (Number.Integer 8)] it "calls functions with arguments" $ do ((res, _), _) <- evaluate "call.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 579))] + res `shouldBe` Right [Value.Integer (Number.Integer 579)] it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 123))] + res `shouldBe` Right [Value.Integer (Number.Integer 123)] it "has prelude" $ do ((res, _), _) <- evaluate "preluded.rb" - res `shouldBe` Right [injValue (String "\"\"")] + res `shouldBe` Right [String "\"\""] it "evaluates __LINE__" $ do ((res, _), _) <- evaluate "line.rb" - res `shouldBe` Right [injValue (Value.Integer (Number.Integer 4))] + res `shouldBe` Right [Value.Integer (Number.Integer 4)] it "resolves builtins used in the prelude" $ do ((res, _), traces) <- evaluate "puts.rb" - res `shouldBe` Right [injValue Unit] + res `shouldBe` Right [Unit] traces `shouldContain` [ "\"hello\"" ] where - ns n = Just . Latest . Last . Just . injValue . Namespace n + ns n = Just . Latest . Last . Just . Namespace n addr = Address . Precise fixtures = "test/fixtures/ruby/analysis/" evaluate entry = evalRubyProject (fixtures <> entry) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 7558aa681..b53a93509 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -36,7 +36,7 @@ spec = parallel $ do it "evaluates early return statements" $ do ((res, _), _) <- evaluate "early-return.ts" - res `shouldBe` Right [injValue (Value.Float (Number.Decimal 123.0))] + res `shouldBe` Right [Value.Float (Number.Decimal 123.0)] where fixtures = "test/fixtures/typescript/analysis/" diff --git a/test/Control/Abstract/Evaluator/Spec.hs b/test/Control/Abstract/Evaluator/Spec.hs index 1c6a07744..b778beb9b 100644 --- a/test/Control/Abstract/Evaluator/Spec.hs +++ b/test/Control/Abstract/Evaluator/Spec.hs @@ -20,13 +20,13 @@ spec :: Spec spec = parallel $ do it "constructs integers" $ do (expected, _) <- evaluate (integer 123) - expected `shouldBe` Right (injValue (Value.Integer (Number.Integer 123))) + expected `shouldBe` Right (Value.Integer (Number.Integer 123)) it "calls functions" $ do (expected, _) <- evaluate $ do identity <- closure [name "x"] lowerBound (variable (name "x")) call identity [integer 123] - expected `shouldBe` Right (injValue (Value.Integer (Number.Integer 123))) + expected `shouldBe` Right (Value.Integer (Number.Integer 123)) evaluate = runM diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 9df506259..777f207c1 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -24,7 +24,7 @@ import Data.Abstract.FreeVariables as X import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X hiding (lookup) import Data.Abstract.Name as X -import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue, prjValue, runValueError) +import Data.Abstract.Value (Value(..), ValueError, runValueError) import Data.Bifunctor (first) import Data.Blob as X import Data.ByteString.Builder (toLazyByteString) @@ -92,13 +92,18 @@ testEvaluating . runTermEvaluator @_ @Precise deNamespace :: Value Precise -> Maybe (Name, [Name]) -deNamespace = fmap (namespaceName &&& Env.names . namespaceScope) . prjValue @(Namespace Precise) +deNamespace (Namespace name scope) = Just (name, Env.names scope) +deNamespace _ = Nothing + +namespaceScope :: Value Precise -> Maybe (Environment Precise) +namespaceScope (Namespace _ scope) = Just scope +namespaceScope _ = Nothing derefQName :: Heap Precise (Cell Precise) (Value Precise) -> NonEmpty Name -> Environment Precise -> Maybe (Value Precise) derefQName heap = go where go (n1 :| ns) env = Env.lookup n1 env >>= flip heapLookup heap >>= getLast . unLatest >>= case ns of [] -> Just - (n2 : ns) -> fmap namespaceScope . prjValue @(Namespace Precise) >=> go (n2 :| ns) + (n2 : ns) -> namespaceScope >=> go (n2 :| ns) newtype Verbatim = Verbatim ByteString deriving (Eq)