diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index d0ac70c3b..887c9eedb 100644 --- a/src/Data/Syntax/Expression.hs +++ b/src/Data/Syntax/Expression.hs @@ -22,14 +22,83 @@ instance Evaluatable Call where op <- subtermValue callFunction Rval <$> call op (map subtermAddress callParams) -data Comparison a - = LessThan !a !a - | LessThanEqual !a !a - | GreaterThan !a !a - | GreaterThanEqual !a !a - | Equal !a !a - | StrictEqual !a !a - | Comparison !a !a +data LessThan a = LessThan { lhs :: a, rhs :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + +instance Eq1 LessThan where liftEq = genericLiftEq +instance Ord1 LessThan where liftCompare = genericLiftCompare +instance Show1 LessThan where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable LessThan where + eval t = rvalBox =<< (traverse subtermValue t >>= go) where + go x = case x of + (LessThan a b) -> liftComparison (Concrete (<)) a b + +data LessThanEqual a = LessThanEqual { lhs :: a, rhs :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + +instance Eq1 LessThanEqual where liftEq = genericLiftEq +instance Ord1 LessThanEqual where liftCompare = genericLiftCompare +instance Show1 LessThanEqual where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable LessThanEqual where + eval t = rvalBox =<< (traverse subtermValue t >>= go) where + go x = case x of + (LessThanEqual a b) -> liftComparison (Concrete (<=)) a b + +data GreaterThan a = GreaterThan { lhs :: a, rhs :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + +instance Eq1 GreaterThan where liftEq = genericLiftEq +instance Ord1 GreaterThan where liftCompare = genericLiftCompare +instance Show1 GreaterThan where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable GreaterThan where + eval t = rvalBox =<< (traverse subtermValue t >>= go) where + go x = case x of + (GreaterThan a b) -> liftComparison (Concrete (>)) a b + +data GreaterThanEqual a = GreaterThanEqual { lhs :: a, rhs :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + +instance Eq1 GreaterThanEqual where liftEq = genericLiftEq +instance Ord1 GreaterThanEqual where liftCompare = genericLiftCompare +instance Show1 GreaterThanEqual where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable GreaterThanEqual where + eval t = rvalBox =<< (traverse subtermValue t >>= go) where + go x = case x of + (GreaterThanEqual a b) -> liftComparison (Concrete (>=)) a b + +data Equal a = Equal { lhs :: a, rhs :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + +instance Eq1 Equal where liftEq = genericLiftEq +instance Ord1 Equal where liftCompare = genericLiftCompare +instance Show1 Equal where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable Equal where + eval t = rvalBox =<< (traverse subtermValue t >>= go) where + go x = case x of + -- TODO: in PHP and JavaScript, the equals operator performs type coercion. + -- We need some mechanism to customize this behavior per-language. + (Equal a b) -> liftComparison (Concrete (==)) a b + +data StrictEqual a = StrictEqual { lhs :: a, rhs :: a } + deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) + +instance Eq1 StrictEqual where liftEq = genericLiftEq +instance Ord1 StrictEqual where liftCompare = genericLiftCompare +instance Show1 StrictEqual where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable StrictEqual where + eval t = rvalBox =<< (traverse subtermValue t >>= go) where + go x = case x of + -- TODO: in PHP and JavaScript, the equals operator performs type coercion. + -- We need some mechanism to customize this behavior per-language. + (StrictEqual a b) -> liftComparison (Concrete (==)) a b + +data Comparison a = Comparison { lhs :: a, rhs :: a } deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable, Named1, Message1) instance Eq1 Comparison where liftEq = genericLiftEq @@ -39,15 +108,7 @@ instance Show1 Comparison where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Comparison where eval t = rvalBox =<< (traverse subtermValue t >>= go) where go x = case x of - (LessThan a b) -> liftComparison (Concrete (<)) a b - (LessThanEqual a b) -> liftComparison (Concrete (<=)) a b - (GreaterThan a b) -> liftComparison (Concrete (>)) a b - (GreaterThanEqual a b) -> liftComparison (Concrete (>=)) a b - -- TODO: in PHP and JavaScript, the equals operator performs type coercion. - -- We need some mechanism to customize this behavior per-language. - (Equal a b) -> liftComparison (Concrete (==)) a b - (StrictEqual a b) -> liftComparison (Concrete (==)) a b - (Comparison a b) -> liftComparison Generalized a b + (Comparison a b) -> liftComparison (Concrete (==)) a b -- | Binary arithmetic operators. data Arithmetic a diff --git a/src/Language/Java/Assignment.hs b/src/Language/Java/Assignment.hs index a5959d3e3..7e3448f05 100644 --- a/src/Language/Java/Assignment.hs +++ b/src/Language/Java/Assignment.hs @@ -36,6 +36,12 @@ type Syntax = , Declaration.VariableDeclaration , Expression.Arithmetic , Expression.Call + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual , Expression.Comparison , Expression.BOr , Expression.BXOr diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index 945cee9b5..ecdc4ef18 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -53,6 +53,12 @@ type Syntax = '[ , Expression.XOr , Expression.Call , Expression.Cast + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual , Expression.Comparison , Expression.InstanceOf , Expression.MemberAccess diff --git a/src/Language/Python/Assignment.hs b/src/Language/Python/Assignment.hs index fc49cd68c..4f6489642 100644 --- a/src/Language/Python/Assignment.hs +++ b/src/Language/Python/Assignment.hs @@ -60,6 +60,12 @@ type Syntax = , Expression.RShift , Expression.Complement , Expression.Call + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual , Expression.Comparison , Expression.Enumeration , Expression.ScopeResolution diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index 9b187929a..a7e09eb4d 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -61,6 +61,12 @@ type Syntax = '[ , Expression.XOr , Expression.Call , Expression.Cast + , Expression.LessThan + , Expression.LessThanEqual + , Expression.GreaterThan + , Expression.GreaterThanEqual + , Expression.Equal + , Expression.StrictEqual , Expression.Comparison , Expression.Enumeration , Expression.MemberAccess