diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 57d6ccb2e..73f904e56 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -142,6 +142,10 @@ class Show value => AbstractIntro value where -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. class AbstractIntro value => AbstractValue address value effects where + -- | Cast numbers to integers + castToInteger :: value -> Evaluator address value effects value + + -- | Lift a unary operator over a 'Num' to a function on 'value's. liftNumeric :: (forall a . Num a => a -> a) -> (value -> Evaluator address value effects value) @@ -166,6 +170,8 @@ class AbstractIntro value => AbstractValue address value effects where liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a) -> (value -> value -> Evaluator address value effects value) + unsignedRShift :: value -> value -> Evaluator address value effects value + -- | Construct an N-ary tuple of multiple (possibly-disjoint) values tuple :: [address] -> Evaluator address value effects value diff --git a/src/Data/Abstract/Value/Abstract.hs b/src/Data/Abstract/Value/Abstract.hs index 19e1b180f..504f32213 100644 --- a/src/Data/Abstract/Value/Abstract.hs +++ b/src/Data/Abstract/Value/Abstract.hs @@ -97,6 +97,10 @@ instance ( Member (Allocator address) effects liftBitwise _ _ = pure Abstract liftBitwise2 _ _ _ = pure Abstract + unsignedRShift _ _ = pure Abstract + liftComparison _ _ _ = pure Abstract loop f = f empty + + castToInteger _ = pure Abstract diff --git a/src/Data/Abstract/Value/Concrete.hs b/src/Data/Abstract/Value/Concrete.hs index f55a6f331..0551e74e0 100644 --- a/src/Data/Abstract/Value/Concrete.hs +++ b/src/Data/Abstract/Value/Concrete.hs @@ -17,11 +17,13 @@ import Data.Abstract.Environment (Environment, Bindings, EvalContext(..)) import qualified Data.Abstract.Environment as Env import Data.Abstract.Name import qualified Data.Abstract.Number as Number +import Data.Bits import Data.Coerce import Data.List (genericIndex, genericLength) -import Data.Scientific (Scientific) +import Data.Scientific (Scientific, coefficient, normalize) import Data.Scientific.Exts import qualified Data.Set as Set +import Data.Word import Prologue data Value address body @@ -173,6 +175,7 @@ instance ( Coercible body (Eff effects) , Member (Resumable (BaseError (ValueError address body))) effects , Member (Resumable (BaseError (AddressError address (Value address body)))) effects , Member (State (Heap address (Value address body))) effects + , Member Trace effects , Ord address , Show address ) @@ -282,11 +285,24 @@ instance ( Coercible body (Eff effects) | otherwise = throwValueError (Bitwise2Error left right) where pair = (left, right) + unsignedRShift left right + | (Integer (Number.Integer i), Integer (Number.Integer j)) <- pair = + if i >= 0 then pure . integer $ ourShift (fromIntegral i) (fromIntegral j) + else throwValueError (Bitwise2Error left right) + | otherwise = throwValueError (Bitwise2Error left right) + where + pair = (left, right) + ourShift :: Word64 -> Int -> Integer + ourShift a b = toInteger (shiftR a b) + loop x = catchLoopControl (fix x) (\ control -> case control of Break value -> deref value -- FIXME: Figure out how to deal with this. Ruby treats this as the result of the current block iteration, while PHP specifies a breakout level and TypeScript appears to take a label. Continue _ -> loop x) + castToInteger (Integer (Number.Integer i)) = pure (Integer (Number.Integer i)) + castToInteger (Float (Number.Decimal i)) = pure (Integer (Number.Integer (coefficient (normalize i)))) + castToInteger i = throwValueError (NumericError i) -- | The type of exceptions that can be thrown when constructing values in 'Value'’s 'MonadValue' instance. data ValueError address body resume where diff --git a/src/Data/Abstract/Value/Type.hs b/src/Data/Abstract/Value/Type.hs index c058b2dda..b30598b36 100644 --- a/src/Data/Abstract/Value/Type.hs +++ b/src/Data/Abstract/Value/Type.hs @@ -340,6 +340,8 @@ instance ( Member (Allocator address) effects liftBitwise _ = unify Int liftBitwise2 _ t1 t2 = unify Int t1 >>= flip unify t2 + unsignedRShift t1 t2 = unify Int t2 *> unify Int t1 + liftComparison (Concrete _) left right = case (left, right) of (Float, Int) -> pure Bool (Int, Float) -> pure Bool @@ -350,3 +352,5 @@ instance ( Member (Allocator address) effects _ -> unify left right $> Bool loop f = f empty + + castToInteger t = unify t (Int :+ Float :+ Rational) $> Int diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index bfef3d48d..3b3696be5 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -4,6 +4,7 @@ module Data.Syntax.Expression where import Data.Abstract.Evaluatable hiding (Member) import Data.Abstract.Number (liftIntegralFrac, liftReal, liftedExponent, liftedFloorDiv) +import Data.Bits import Data.Fixed import Data.JSON.Fields import Diffing.Algorithm hiding (Delete) @@ -272,7 +273,6 @@ instance Eq1 Delete where liftEq = genericLiftEq instance Ord1 Delete where liftCompare = genericLiftCompare instance Show1 Delete where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Delete instance Evaluatable Delete where eval (Delete a) = do valueRef <- subtermRef a @@ -288,7 +288,6 @@ instance Eq1 SequenceExpression where liftEq = genericLiftEq instance Ord1 SequenceExpression where liftCompare = genericLiftCompare instance Show1 SequenceExpression where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for SequenceExpression instance Evaluatable SequenceExpression where eval (SequenceExpression a b) = subtermValue a >> subtermRef b @@ -301,7 +300,6 @@ instance Eq1 Void where liftEq = genericLiftEq instance Ord1 Void where liftCompare = genericLiftCompare instance Show1 Void where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Void instance Evaluatable Void where eval (Void a) = subtermValue a >> rvalBox null @@ -325,6 +323,10 @@ instance Eq1 BOr where liftEq = genericLiftEq instance Ord1 BOr where liftCompare = genericLiftCompare instance Show1 BOr where liftShowsPrec = genericLiftShowsPrec instance Evaluatable BOr where + eval (BOr a b) = do + a' <- subtermValue a >>= castToInteger + b' <- subtermValue b >>= castToInteger + liftBitwise2 (.|.) a' b' >>= rvalBox data BAnd a = BAnd { left :: a, right :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) @@ -333,6 +335,11 @@ instance Eq1 BAnd where liftEq = genericLiftEq instance Ord1 BAnd where liftCompare = genericLiftCompare instance Show1 BAnd where liftShowsPrec = genericLiftShowsPrec instance Evaluatable BAnd where + eval (BAnd a b) = do + a' <- subtermValue a >>= castToInteger + b' <- subtermValue b >>= castToInteger + liftBitwise2 (.&.) a' b' >>= rvalBox + data BXOr a = BXOr { left :: a, right :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) @@ -341,6 +348,10 @@ instance Eq1 BXOr where liftEq = genericLiftEq instance Ord1 BXOr where liftCompare = genericLiftCompare instance Show1 BXOr where liftShowsPrec = genericLiftShowsPrec instance Evaluatable BXOr where + eval (BXOr a b) = do + a' <- subtermValue a >>= castToInteger + b' <- subtermValue b >>= castToInteger + liftBitwise2 xor a' b' >>= rvalBox data LShift a = LShift { left :: a, right :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) @@ -349,6 +360,12 @@ instance Eq1 LShift where liftEq = genericLiftEq instance Ord1 LShift where liftCompare = genericLiftCompare instance Show1 LShift where liftShowsPrec = genericLiftShowsPrec instance Evaluatable LShift where + eval (LShift a b) = do + a' <- subtermValue a >>= castToInteger + b' <- subtermValue b >>= castToInteger + liftBitwise2 shiftL' a' b' >>= rvalBox + where + shiftL' a b = shiftL a (fromIntegral (toInteger b)) data RShift a = RShift { left :: a, right :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) @@ -357,6 +374,12 @@ instance Eq1 RShift where liftEq = genericLiftEq instance Ord1 RShift where liftCompare = genericLiftCompare instance Show1 RShift where liftShowsPrec = genericLiftShowsPrec instance Evaluatable RShift where + eval (RShift a b) = do + a' <- subtermValue a >>= castToInteger + b' <- subtermValue b >>= castToInteger + liftBitwise2 shiftR' a' b' >>= rvalBox + where + shiftR' a b = shiftR a (fromIntegral (toInteger b)) data UnsignedRShift a = UnsignedRShift { left :: a, right :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) @@ -365,6 +388,10 @@ instance Eq1 UnsignedRShift where liftEq = genericLiftEq instance Ord1 UnsignedRShift where liftCompare = genericLiftCompare instance Show1 UnsignedRShift where liftShowsPrec = genericLiftShowsPrec instance Evaluatable UnsignedRShift where + eval (UnsignedRShift a b) = do + a' <- subtermValue a >>= castToInteger + b' <- subtermValue b >>= castToInteger + unsignedRShift a' b' >>= rvalBox newtype Complement a = Complement { value :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) @@ -374,6 +401,9 @@ instance Ord1 Complement where liftCompare = genericLiftCompare instance Show1 Complement where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Complement where + eval (Complement a) = do + a' <- subtermValue a >>= castToInteger + liftBitwise complement a' >>= rvalBox -- | Member Access (e.g. a.b) data MemberAccess a = MemberAccess { lhs :: a, rhs :: Name } @@ -469,9 +499,10 @@ instance Eq1 Await where liftEq = genericLiftEq instance Ord1 Await where liftCompare = genericLiftCompare instance Show1 Await where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Await -instance Evaluatable Await - +-- TODO: Improve this to model asynchrony or capture some data suggesting async calls are not a problem. +-- We are currently dealing with an asynchronous construct synchronously. +instance Evaluatable Await where + eval (Await a) = subtermRef a -- | An object constructor call in Javascript, Java, etc. newtype New a = New { newSubject :: [a] } @@ -492,7 +523,6 @@ instance Eq1 Cast where liftEq = genericLiftEq instance Ord1 Cast where liftCompare = genericLiftCompare instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Cast instance Evaluatable Cast data Super a = Super @@ -501,7 +531,8 @@ data Super a = Super instance Eq1 Super where liftEq = genericLiftEq instance Ord1 Super where liftCompare = genericLiftCompare instance Show1 Super where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable Super +instance Evaluatable Super where + eval Super = Rval <$> (maybeM (box unit) =<< self) data This a = This deriving (Diffable, Eq, Foldable, Functor, Generic1, Ord, Show, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1, Named1, Message1) diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index 699830e96..2b40e195b 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -295,7 +295,8 @@ awaitExpression = makeTerm <$> symbol Grammar.AwaitExpression <*> children (Expr unaryExpression :: Assignment Term unaryExpression = symbol Grammar.UnaryExpression >>= \ loc -> - makeTerm loc . Expression.Not <$> children ((symbol AnonTilde <|> symbol AnonBang) *> term expression) + makeTerm loc . Expression.Not <$> children (symbol AnonBang *> term expression) + <|> makeTerm loc . Expression.Complement <$> children (symbol AnonTilde *> term expression) <|> makeTerm loc . Expression.Negate <$> children ((symbol AnonMinus <|> symbol AnonPlus) *> term expression) <|> makeTerm loc . Expression.Typeof <$> children (symbol AnonTypeof *> term expression) <|> makeTerm loc . Expression.Void <$> children (symbol AnonVoid *> term expression) diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index b4f20090c..6ebd635ff 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -69,6 +69,51 @@ spec config = parallel $ do Env.names env `shouldBe` [ "x" ] other -> expectationFailure (show other) + it "evaluates await" $ do + (_, (heap, res)) <- evaluate ["await.ts"] + case ModuleTable.lookup "await.ts" <$> res of + Right (Just (Module _ (env, addr) :| [])) -> do + Env.names env `shouldBe` [ "f2" ] + (derefQName heap ("y" :| []) env) `shouldBe` Nothing + other -> expectationFailure (show other) + + it "evaluates BOr statements" $ do + (_, (heap, res)) <- evaluate ["bor.ts"] + case ModuleTable.lookup "bor.ts" <$> res of + Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)] + other -> expectationFailure (show other) + + it "evaluates BAnd statements" $ do + (_, (heap, res)) <- evaluate ["band.ts"] + case ModuleTable.lookup "band.ts" <$> res of + Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)] + other -> expectationFailure (show other) + + it "evaluates BXOr statements" $ do + (_, (heap, res)) <- evaluate ["bxor.ts"] + case ModuleTable.lookup "bxor.ts" <$> res of + Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 3)] + other -> expectationFailure (show other) + + it "evaluates LShift statements" $ do + (_, (heap, res)) <- evaluate ["lshift.ts"] + case ModuleTable.lookup "lshift.ts" <$> res of + Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 4)] + other -> expectationFailure (show other) + + it "evaluates RShift statements" $ do + (_, (heap, res)) <- evaluate ["rshift.ts"] + case ModuleTable.lookup "rshift.ts" <$> res of + Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer 0)] + other -> expectationFailure (show other) + + it "evaluates Complement statements" $ do + (_, (heap, res)) <- evaluate ["complement.ts"] + case ModuleTable.lookup "complement.ts" <$> res of + Right (Just (Module _ (_, addr) :| [])) -> heapLookupAll addr heap `shouldBe` Just [Value.Integer (Number.Integer (-2))] + other -> expectationFailure (show other) + + where fixtures = "test/fixtures/typescript/analysis/" evaluate = evalTypeScriptProject . map (fixtures <>) diff --git a/test/fixtures/typescript/analysis/await.ts b/test/fixtures/typescript/analysis/await.ts new file mode 100644 index 000000000..c7c0102bf --- /dev/null +++ b/test/fixtures/typescript/analysis/await.ts @@ -0,0 +1,5 @@ +async function f2() { + var y = await 20; + return y; +} +f2(); diff --git a/test/fixtures/typescript/analysis/band.ts b/test/fixtures/typescript/analysis/band.ts new file mode 100644 index 000000000..53908aadc --- /dev/null +++ b/test/fixtures/typescript/analysis/band.ts @@ -0,0 +1 @@ +1 & 2; diff --git a/test/fixtures/typescript/analysis/bor.ts b/test/fixtures/typescript/analysis/bor.ts new file mode 100644 index 000000000..e1c9efd6e --- /dev/null +++ b/test/fixtures/typescript/analysis/bor.ts @@ -0,0 +1 @@ +1 | 2; diff --git a/test/fixtures/typescript/analysis/bxor.ts b/test/fixtures/typescript/analysis/bxor.ts new file mode 100644 index 000000000..10a02890b --- /dev/null +++ b/test/fixtures/typescript/analysis/bxor.ts @@ -0,0 +1 @@ +1 ^ 2; diff --git a/test/fixtures/typescript/analysis/complement.ts b/test/fixtures/typescript/analysis/complement.ts new file mode 100644 index 000000000..f6c761f5d --- /dev/null +++ b/test/fixtures/typescript/analysis/complement.ts @@ -0,0 +1 @@ +~1; diff --git a/test/fixtures/typescript/analysis/lshift.ts b/test/fixtures/typescript/analysis/lshift.ts new file mode 100644 index 000000000..c95bf5341 --- /dev/null +++ b/test/fixtures/typescript/analysis/lshift.ts @@ -0,0 +1 @@ +1 << 2; diff --git a/test/fixtures/typescript/analysis/rshift.ts b/test/fixtures/typescript/analysis/rshift.ts new file mode 100644 index 000000000..0eae5322b --- /dev/null +++ b/test/fixtures/typescript/analysis/rshift.ts @@ -0,0 +1 @@ +1 >> 2; diff --git a/test/fixtures/typescript/analysis/unsignedrshift.ts b/test/fixtures/typescript/analysis/unsignedrshift.ts new file mode 100644 index 000000000..a85780469 --- /dev/null +++ b/test/fixtures/typescript/analysis/unsignedrshift.ts @@ -0,0 +1 @@ +1 >>> 2;