Merge branch 'master' into boolean-value-effect

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
 

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

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

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

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)

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)

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 <>)

test/fixtures/typescript/analysis/await.ts

@@ -0,0 +1,5 @@
+async function f2() {
+  var y = await 20;
+  return y;
+}
+f2();

test/fixtures/typescript/analysis/band.ts

@@ -0,0 +1 @@
+1 & 2;

test/fixtures/typescript/analysis/bor.ts

@@ -0,0 +1 @@
+1 | 2;

test/fixtures/typescript/analysis/bxor.ts

@@ -0,0 +1 @@
+1 ^ 2;

test/fixtures/typescript/analysis/complement.ts

@@ -0,0 +1 @@
+~1;

test/fixtures/typescript/analysis/lshift.ts

@@ -0,0 +1 @@
+1 << 2;

test/fixtures/typescript/analysis/rshift.ts

@@ -0,0 +1 @@
+1 >> 2;

test/fixtures/typescript/analysis/unsignedrshift.ts

@@ -0,0 +1 @@
+1 >>> 2;