From 80197edb67ffc10bfb8def3a79552c69fe45b4bf Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 13:27:01 -0700 Subject: [PATCH 01/45] Let's evaluate PHP --- src/Language/PHP/Syntax.hs | 204 ++++++++++++++++++++++++------------- src/Semantic/Util.hs | 4 + 2 files changed, 135 insertions(+), 73 deletions(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 3e4058312..5c355bee9 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -1,394 +1,452 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.PHP.Syntax where -import Prologue hiding (Text) +import Data.Abstract.Evaluatable import Diffing.Algorithm +import Prologue hiding (Text) newtype Text a = Text ByteString - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Text where liftEq = genericLiftEq instance Ord1 Text where liftCompare = genericLiftCompare instance Show1 Text where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Text + newtype VariableName a = VariableName a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 VariableName where liftEq = genericLiftEq instance Ord1 VariableName where liftCompare = genericLiftCompare instance Show1 VariableName where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable VariableName + newtype RequireOnce a = RequireOnce a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 RequireOnce where liftEq = genericLiftEq instance Ord1 RequireOnce where liftCompare = genericLiftCompare instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable RequireOnce newtype Require a = Require a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Require where liftEq = genericLiftEq instance Ord1 Require where liftCompare = genericLiftCompare instance Show1 Require where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Require newtype Include a = Include a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Include where liftEq = genericLiftEq instance Ord1 Include where liftCompare = genericLiftCompare instance Show1 Include where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Include newtype IncludeOnce a = IncludeOnce a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 IncludeOnce where liftEq = genericLiftEq instance Ord1 IncludeOnce where liftCompare = genericLiftCompare instance Show1 IncludeOnce where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable IncludeOnce newtype ArrayElement a = ArrayElement a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ArrayElement where liftEq = genericLiftEq instance Ord1 ArrayElement where liftCompare = genericLiftCompare instance Show1 ArrayElement where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ArrayElement newtype GlobalDeclaration a = GlobalDeclaration [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 GlobalDeclaration where liftEq = genericLiftEq instance Ord1 GlobalDeclaration where liftCompare = genericLiftCompare instance Show1 GlobalDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable GlobalDeclaration newtype SimpleVariable a = SimpleVariable a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 SimpleVariable where liftEq = genericLiftEq instance Ord1 SimpleVariable where liftCompare = genericLiftCompare instance Show1 SimpleVariable where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable SimpleVariable -- | TODO: Unify with TypeScript's PredefinedType newtype CastType a = CastType { _castType :: ByteString } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 CastType where liftEq = genericLiftEq instance Ord1 CastType where liftCompare = genericLiftCompare instance Show1 CastType where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable CastType newtype ErrorControl a = ErrorControl a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ErrorControl where liftEq = genericLiftEq instance Ord1 ErrorControl where liftCompare = genericLiftCompare instance Show1 ErrorControl where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ErrorControl newtype Clone a = Clone a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Clone where liftEq = genericLiftEq instance Ord1 Clone where liftCompare = genericLiftCompare instance Show1 Clone where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Clone newtype ShellCommand a = ShellCommand ByteString - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ShellCommand where liftEq = genericLiftEq instance Ord1 ShellCommand where liftCompare = genericLiftCompare instance Show1 ShellCommand where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ShellCommand -- | TODO: Combine with TypeScript update expression. newtype Update a = Update { _updateSubject :: a } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Update where liftEq = genericLiftEq instance Ord1 Update where liftCompare = genericLiftCompare instance Show1 Update where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Update newtype NewVariable a = NewVariable [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 NewVariable where liftEq = genericLiftEq instance Ord1 NewVariable where liftCompare = genericLiftCompare instance Show1 NewVariable where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable NewVariable newtype RelativeScope a = RelativeScope ByteString - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 RelativeScope where liftEq = genericLiftEq instance Ord1 RelativeScope where liftCompare = genericLiftCompare instance Show1 RelativeScope where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable RelativeScope data QualifiedName a = QualifiedName a a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 QualifiedName where liftEq = genericLiftEq instance Ord1 QualifiedName where liftCompare = genericLiftCompare instance Show1 QualifiedName where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable QualifiedName -data NamespaceName a = NamespaceName [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype NamespaceName a = NamespaceName [a] + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 NamespaceName where liftEq = genericLiftEq instance Ord1 NamespaceName where liftCompare = genericLiftCompare instance Show1 NamespaceName where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable NamespaceName -data ConstDeclaration a = ConstDeclaration [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype ConstDeclaration a = ConstDeclaration [a] + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ConstDeclaration where liftEq = genericLiftEq instance Ord1 ConstDeclaration where liftCompare = genericLiftCompare instance Show1 ConstDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ConstDeclaration data ClassConstDeclaration a = ClassConstDeclaration a [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ClassConstDeclaration where liftEq = genericLiftEq instance Ord1 ClassConstDeclaration where liftCompare = genericLiftCompare instance Show1 ClassConstDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ClassConstDeclaration -data ClassInterfaceClause a = ClassInterfaceClause [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype ClassInterfaceClause a = ClassInterfaceClause [a] + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ClassInterfaceClause where liftEq = genericLiftEq instance Ord1 ClassInterfaceClause where liftCompare = genericLiftCompare instance Show1 ClassInterfaceClause where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ClassInterfaceClause -data ClassBaseClause a = ClassBaseClause a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype ClassBaseClause a = ClassBaseClause a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ClassBaseClause where liftEq = genericLiftEq instance Ord1 ClassBaseClause where liftCompare = genericLiftCompare instance Show1 ClassBaseClause where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ClassBaseClause -data UseClause a = UseClause [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype UseClause a = UseClause [a] + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 UseClause where liftEq = genericLiftEq instance Ord1 UseClause where liftCompare = genericLiftCompare instance Show1 UseClause where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable UseClause -data ReturnType a = ReturnType a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype ReturnType a = ReturnType a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ReturnType where liftEq = genericLiftEq instance Ord1 ReturnType where liftCompare = genericLiftCompare instance Show1 ReturnType where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ReturnType -data TypeDeclaration a = TypeDeclaration a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype TypeDeclaration a = TypeDeclaration a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 TypeDeclaration where liftEq = genericLiftEq instance Ord1 TypeDeclaration where liftCompare = genericLiftCompare instance Show1 TypeDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable TypeDeclaration -data BaseTypeDeclaration a = BaseTypeDeclaration a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype BaseTypeDeclaration a = BaseTypeDeclaration a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 BaseTypeDeclaration where liftEq = genericLiftEq instance Ord1 BaseTypeDeclaration where liftCompare = genericLiftCompare instance Show1 BaseTypeDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable BaseTypeDeclaration -data ScalarType a = ScalarType ByteString - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype ScalarType a = ScalarType ByteString + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ScalarType where liftEq = genericLiftEq instance Ord1 ScalarType where liftCompare = genericLiftCompare instance Show1 ScalarType where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ScalarType -data EmptyIntrinsic a = EmptyIntrinsic a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype EmptyIntrinsic a = EmptyIntrinsic a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 EmptyIntrinsic where liftEq = genericLiftEq instance Ord1 EmptyIntrinsic where liftCompare = genericLiftCompare instance Show1 EmptyIntrinsic where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable EmptyIntrinsic -data ExitIntrinsic a = ExitIntrinsic a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype ExitIntrinsic a = ExitIntrinsic a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ExitIntrinsic where liftEq = genericLiftEq instance Ord1 ExitIntrinsic where liftCompare = genericLiftCompare instance Show1 ExitIntrinsic where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ExitIntrinsic -data IssetIntrinsic a = IssetIntrinsic a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype IssetIntrinsic a = IssetIntrinsic a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 IssetIntrinsic where liftEq = genericLiftEq instance Ord1 IssetIntrinsic where liftCompare = genericLiftCompare instance Show1 IssetIntrinsic where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable IssetIntrinsic -data EvalIntrinsic a = EvalIntrinsic a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype EvalIntrinsic a = EvalIntrinsic a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 EvalIntrinsic where liftEq = genericLiftEq instance Ord1 EvalIntrinsic where liftCompare = genericLiftCompare instance Show1 EvalIntrinsic where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable EvalIntrinsic -data PrintIntrinsic a = PrintIntrinsic a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype PrintIntrinsic a = PrintIntrinsic a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 PrintIntrinsic where liftEq = genericLiftEq instance Ord1 PrintIntrinsic where liftCompare = genericLiftCompare instance Show1 PrintIntrinsic where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable PrintIntrinsic -data NamespaceAliasingClause a = NamespaceAliasingClause a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype NamespaceAliasingClause a = NamespaceAliasingClause a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 NamespaceAliasingClause where liftEq = genericLiftEq instance Ord1 NamespaceAliasingClause where liftCompare = genericLiftCompare instance Show1 NamespaceAliasingClause where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable NamespaceAliasingClause newtype NamespaceUseDeclaration a = NamespaceUseDeclaration [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 NamespaceUseDeclaration where liftEq = genericLiftEq instance Ord1 NamespaceUseDeclaration where liftCompare = genericLiftCompare instance Show1 NamespaceUseDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable NamespaceUseDeclaration newtype NamespaceUseClause a = NamespaceUseClause [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 NamespaceUseClause where liftEq = genericLiftEq instance Ord1 NamespaceUseClause where liftCompare = genericLiftCompare instance Show1 NamespaceUseClause where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable NamespaceUseClause newtype NamespaceUseGroupClause a = NamespaceUseGroupClause [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 NamespaceUseGroupClause where liftEq = genericLiftEq instance Ord1 NamespaceUseGroupClause where liftCompare = genericLiftCompare instance Show1 NamespaceUseGroupClause where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable NamespaceUseGroupClause data Namespace a = Namespace { namespaceName :: a, namespaceBody :: a} - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Namespace where liftEq = genericLiftEq instance Ord1 Namespace where liftCompare = genericLiftCompare instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Namespace data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 TraitDeclaration where liftEq = genericLiftEq instance Ord1 TraitDeclaration where liftCompare = genericLiftCompare instance Show1 TraitDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable TraitDeclaration data AliasAs a = AliasAs { aliasAsName :: a, aliasAsModifier :: a, aliasAsClause :: a } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 AliasAs where liftEq = genericLiftEq instance Ord1 AliasAs where liftCompare = genericLiftCompare instance Show1 AliasAs where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable AliasAs data InsteadOf a = InsteadOf a a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 InsteadOf where liftEq = genericLiftEq instance Ord1 InsteadOf where liftCompare = genericLiftCompare instance Show1 InsteadOf where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable InsteadOf newtype TraitUseSpecification a = TraitUseSpecification [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 TraitUseSpecification where liftEq = genericLiftEq instance Ord1 TraitUseSpecification where liftCompare = genericLiftCompare instance Show1 TraitUseSpecification where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable TraitUseSpecification data TraitUseClause a = TraitUseClause [a] a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 TraitUseClause where liftEq = genericLiftEq instance Ord1 TraitUseClause where liftCompare = genericLiftCompare instance Show1 TraitUseClause where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable TraitUseClause data DestructorDeclaration a = DestructorDeclaration [a] a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 DestructorDeclaration where liftEq = genericLiftEq instance Ord1 DestructorDeclaration where liftCompare = genericLiftCompare instance Show1 DestructorDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable DestructorDeclaration newtype Static a = Static ByteString - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Static where liftEq = genericLiftEq instance Ord1 Static where liftCompare = genericLiftCompare instance Show1 Static where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Static newtype ClassModifier a = ClassModifier ByteString - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ClassModifier where liftEq = genericLiftEq instance Ord1 ClassModifier where liftCompare = genericLiftCompare instance Show1 ClassModifier where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ClassModifier data ConstructorDeclaration a = ConstructorDeclaration [a] [a] a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 ConstructorDeclaration where liftEq = genericLiftEq instance Ord1 ConstructorDeclaration where liftCompare = genericLiftCompare instance Show1 ConstructorDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable ConstructorDeclaration data PropertyDeclaration a = PropertyDeclaration a [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 PropertyDeclaration where liftEq = genericLiftEq instance Ord1 PropertyDeclaration where liftCompare = genericLiftCompare instance Show1 PropertyDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable PropertyDeclaration data PropertyModifier a = PropertyModifier a a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 PropertyModifier where liftEq = genericLiftEq instance Ord1 PropertyModifier where liftCompare = genericLiftCompare instance Show1 PropertyModifier where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable PropertyModifier data InterfaceDeclaration a = InterfaceDeclaration a a [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable InterfaceDeclaration newtype InterfaceBaseClause a = InterfaceBaseClause [a] - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 InterfaceBaseClause where liftEq = genericLiftEq instance Ord1 InterfaceBaseClause where liftCompare = genericLiftCompare instance Show1 InterfaceBaseClause where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable InterfaceBaseClause newtype Echo a = Echo a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Echo where liftEq = genericLiftEq instance Ord1 Echo where liftCompare = genericLiftCompare instance Show1 Echo where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Echo newtype Unset a = Unset a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Unset where liftEq = genericLiftEq instance Ord1 Unset where liftCompare = genericLiftCompare instance Show1 Unset where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Unset data Declare a = Declare a a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 Declare where liftEq = genericLiftEq instance Ord1 Declare where liftCompare = genericLiftCompare instance Show1 Declare where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable Declare -data DeclareDirective a = DeclareDirective a - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype DeclareDirective a = DeclareDirective a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 DeclareDirective where liftEq = genericLiftEq instance Ord1 DeclareDirective where liftCompare = genericLiftCompare instance Show1 DeclareDirective where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable DeclareDirective -data LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a } - deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +newtype LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a } + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) instance Eq1 LabeledStatement where liftEq = genericLiftEq instance Ord1 LabeledStatement where liftCompare = genericLiftCompare instance Show1 LabeledStatement where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable LabeledStatement diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 0d8520ec7..a885fba25 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -48,6 +48,10 @@ typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser path evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term Value) . evaluateModule . snd <$> parseFile pythonParser path +-- PHP +evaluatePHPFile = evaluateFile phpParser +evaluatePHPFiles = evaluateFiles phpParser + -- TypeScript typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule . snd <$> parseFile typescriptParser path evaluateTypeScriptFile = evaluateFile typescriptParser From 811370a767b0554d34ef21292f4123cd32a102bf Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 14:08:00 -0700 Subject: [PATCH 02/45] First PHP fixtures to work with --- test/fixtures/php/analysis/foo.php | 4 ++++ test/fixtures/php/analysis/main.php | 4 ++++ 2 files changed, 8 insertions(+) create mode 100644 test/fixtures/php/analysis/foo.php create mode 100644 test/fixtures/php/analysis/main.php diff --git a/test/fixtures/php/analysis/foo.php b/test/fixtures/php/analysis/foo.php new file mode 100644 index 000000000..64c09f591 --- /dev/null +++ b/test/fixtures/php/analysis/foo.php @@ -0,0 +1,4 @@ + Date: Mon, 19 Mar 2018 14:08:12 -0700 Subject: [PATCH 03/45] Strip both single and double quotes --- src/Data/Abstract/Path.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Data/Abstract/Path.hs b/src/Data/Abstract/Path.hs index ce29e69bd..491507b57 100644 --- a/src/Data/Abstract/Path.hs +++ b/src/Data/Abstract/Path.hs @@ -3,7 +3,6 @@ module Data.Abstract.Path where import Prologue import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString as B -import Data.Char (ord) -- | Split a 'ByteString' path on `/`, stripping quotes and any `./` prefix. splitOnPathSeparator :: ByteString -> [ByteString] @@ -13,7 +12,7 @@ splitOnPathSeparator' :: (ByteString -> ByteString) -> ByteString -> [ByteString splitOnPathSeparator' f = BC.split '/' . f . dropRelativePrefix . stripQuotes stripQuotes :: ByteString -> ByteString -stripQuotes = B.filter (/= fromIntegral (ord '\"')) +stripQuotes = B.filter (`B.notElem` "\'\"") dropRelativePrefix :: ByteString -> ByteString dropRelativePrefix = BC.dropWhile (== '/') . BC.dropWhile (== '.') From 9ca7b7f9830eebf92a97a4dc90291911ea34b235 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 14:08:41 -0700 Subject: [PATCH 04/45] Update assignment for PHP include and eval it --- src/Language/PHP/Assignment.hs | 6 +++++- src/Language/PHP/Syntax.hs | 18 +++++++++++++++++- 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index d048661de..a2e850081 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -13,6 +13,7 @@ import Language.PHP.Grammar as Grammar import Prologue import qualified Assigning.Assignment as Assignment import qualified Data.Abstract.FreeVariables as FV +import qualified Data.Abstract.Path as Path import qualified Data.Syntax as Syntax import qualified Data.Syntax.Comment as Comment import qualified Data.Syntax.Declaration as Declaration @@ -715,8 +716,11 @@ arrayElementInitializer :: Assignment arrayElementInitializer = makeTerm <$> symbol ArrayElementInitializer <*> children (Literal.KeyValue <$> term expression <*> term expression) <|> (symbol ArrayElementInitializer *> children (term expression)) includeExpression :: Assignment -includeExpression = makeTerm <$> symbol IncludeExpression <*> children (Syntax.Include <$> term expression) +includeExpression = makeTerm <$> symbol IncludeExpression <*> children (Syntax.Include <$> term includePath) +-- TODO: Dropping the .php file extension here means we loose diff-ability. +includePath :: Assignment +includePath = makeTerm <$> symbol Grammar.String <*> (Syntax.Identifier . FV.pathToQualifiedName . Path.dropExtension <$> source) includeOnceExpression :: Assignment includeOnceExpression = makeTerm <$> symbol IncludeOnceExpression <*> children (Syntax.IncludeOnce <$> term expression) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 5c355bee9..d2f950648 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -1,9 +1,11 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.PHP.Syntax where +import Data.Abstract.Environment import Data.Abstract.Evaluatable import Diffing.Algorithm import Prologue hiding (Text) +import qualified Data.Map as Map newtype Text a = Text ByteString deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) @@ -45,7 +47,21 @@ newtype Include a = Include a instance Eq1 Include where liftEq = genericLiftEq instance Ord1 Include where liftCompare = genericLiftCompare instance Show1 Include where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable Include + +instance Evaluatable Include where + eval (Include path) = do + let name = freeVariable (subterm path) + importedEnv <- isolate (require name) + modifyGlobalEnv (flip (Map.foldrWithKey envInsert) (unEnvironment importedEnv)) + unit + +data IncludePath a = IncludePath { includePath :: a, includePathExtension :: a } + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + +instance Eq1 IncludePath where liftEq = genericLiftEq +instance Ord1 IncludePath where liftCompare = genericLiftCompare +instance Show1 IncludePath where liftShowsPrec = genericLiftShowsPrec +instance Evaluatable IncludePath newtype IncludeOnce a = IncludeOnce a deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) From 7fdc5e2fda24861d6fed7f597b35fcc47aacfc7f Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 14:42:00 -0700 Subject: [PATCH 05/45] Write a small spec for evaluating PHP includes --- semantic.cabal | 1 + test/Analysis/PHP/Spec.hs | 26 ++++++++++++++++++++++++++ test/Spec.hs | 2 ++ 3 files changed, 29 insertions(+) create mode 100644 test/Analysis/PHP/Spec.hs diff --git a/semantic.cabal b/semantic.cabal index 132722e06..ae976ff0e 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -210,6 +210,7 @@ test-suite test main-is: Spec.hs other-modules: Assigning.Assignment.Spec , Analysis.Go.Spec + , Analysis.PHP.Spec , Analysis.Python.Spec , Analysis.Ruby.Spec , Analysis.TypeScript.Spec diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs new file mode 100644 index 000000000..0579544e5 --- /dev/null +++ b/test/Analysis/PHP/Spec.hs @@ -0,0 +1,26 @@ +module Analysis.PHP.Spec (spec) where + +import Data.Abstract.Value +import Data.Map + +import SpecHelpers + + +spec :: Spec +spec = parallel $ do + describe "evalutes PHP" $ do + it "include" $ do + env <- evaluate "main.php" + let expectedEnv = Environment $ fromList + [ (qualifiedName ["foo"], addr 0) + ] + env `shouldBe` expectedEnv + + where + addr = Address . Precise + fixtures = "test/fixtures/php/analysis/" + evaluate entry = snd . fst . fst . fst . fst <$> + evaluateFiles phpParser + [ fixtures <> entry + , fixtures <> "foo.php" + ] diff --git a/test/Spec.hs b/test/Spec.hs index 1fd244248..5a9b9bafa 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,6 +1,7 @@ module Main where import qualified Analysis.Go.Spec +import qualified Analysis.PHP.Spec import qualified Analysis.Python.Spec import qualified Analysis.Ruby.Spec import qualified Analysis.TypeScript.Spec @@ -27,6 +28,7 @@ main = hspec $ do describe "Semantic.Stat" Semantic.Stat.Spec.spec parallel $ do describe "Analysis.Go" Analysis.Go.Spec.spec + describe "Analysis.PHP" Analysis.PHP.Spec.spec describe "Analysis.Python" Analysis.Python.Spec.spec describe "Analysis.Ruby" Analysis.Ruby.Spec.spec describe "Analysis.TypeScript" Analysis.TypeScript.Spec.spec From 3b284cb4019a9be9bcdf3b84eb3811bac4706e07 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 14:42:15 -0700 Subject: [PATCH 06/45] Alternative assignment of qualified names to make spec pass --- src/Language/PHP/Assignment.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index a2e850081..01b2c0bd1 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -454,10 +454,12 @@ relativeScope :: Assignment relativeScope = makeTerm <$> symbol RelativeScope <*> (Syntax.RelativeScope <$> source) qualifiedName :: Assignment -qualifiedName = makeTerm <$> symbol QualifiedName <*> children (Syntax.QualifiedName <$> (term namespaceNameAsPrefix <|> emptyTerm) <*> term name) - -namespaceNameAsPrefix :: Assignment -namespaceNameAsPrefix = symbol NamespaceNameAsPrefix *> children (term namespaceName <|> emptyTerm) +qualifiedName = makeTerm <$> symbol QualifiedName <*> children (Syntax.Identifier . FV.qualifiedName <$> names) + where + names = (\a b -> a <> [b]) <$> (namespaceNameAsPrefix <|> pure []) <*> name' + namespaceNameAsPrefix = symbol NamespaceNameAsPrefix *> children (namespaceName' <|> pure []) + namespaceName' = symbol NamespaceName *> children (some name') + name' = (symbol Name <|> symbol Name') *> source namespaceName :: Assignment namespaceName = makeTerm <$> symbol NamespaceName <*> children (Syntax.NamespaceName <$> someTerm name) From 31f7746c26185418401831f3913a7ce6ea37b303 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 14:48:06 -0700 Subject: [PATCH 07/45] Fix for latest version of env handling --- src/Language/PHP/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index d2f950648..380a5f43e 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -52,7 +52,7 @@ instance Evaluatable Include where eval (Include path) = do let name = freeVariable (subterm path) importedEnv <- isolate (require name) - modifyGlobalEnv (flip (Map.foldrWithKey envInsert) (unEnvironment importedEnv)) + modifyEnv (mappend importedEnv) unit data IncludePath a = IncludePath { includePath :: a, includePathExtension :: a } From 8522af6492c9204e2804204ac50cf8f4738cc646 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 14:53:47 -0700 Subject: [PATCH 08/45] Use OverloadedLists here --- test/Analysis/PHP/Spec.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 0579544e5..39368a7a2 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedLists #-} module Analysis.PHP.Spec (spec) where import Data.Abstract.Value @@ -11,9 +12,7 @@ spec = parallel $ do describe "evalutes PHP" $ do it "include" $ do env <- evaluate "main.php" - let expectedEnv = Environment $ fromList - [ (qualifiedName ["foo"], addr 0) - ] + let expectedEnv = [ (qualifiedName ["foo"], addr 0) ] env `shouldBe` expectedEnv where From 1a7f0e4b77017aefcf3e68995bb8fd9fa2393344 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 14:53:55 -0700 Subject: [PATCH 09/45] TypeApplications not necessary anymore --- test/Analysis/Go/Spec.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Analysis/Go/Spec.hs b/test/Analysis/Go/Spec.hs index 4611cb4bb..6436af0dc 100644 --- a/test/Analysis/Go/Spec.hs +++ b/test/Analysis/Go/Spec.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedLists, TypeApplications #-} +{-# LANGUAGE OverloadedLists #-} module Analysis.Go.Spec (spec) where import Data.Abstract.Value From a7a8c7121a2a73f29f05d47bb564d8989d9d0a40 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 15:01:48 -0700 Subject: [PATCH 10/45] These are not needed --- src/Language/PHP/Syntax.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 380a5f43e..5d0491d9b 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -1,11 +1,9 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.PHP.Syntax where -import Data.Abstract.Environment import Data.Abstract.Evaluatable import Diffing.Algorithm import Prologue hiding (Text) -import qualified Data.Map as Map newtype Text a = Text ByteString deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) From 992e721281735bd390fcdaa52ed1eabe46ce9ae7 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 15:11:43 -0700 Subject: [PATCH 11/45] We actually want load semantics here --- src/Language/PHP/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 5d0491d9b..5ada0d0ff 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -49,7 +49,7 @@ instance Show1 Include where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Include where eval (Include path) = do let name = freeVariable (subterm path) - importedEnv <- isolate (require name) + importedEnv <- isolate (load name) modifyEnv (mappend importedEnv) unit From fc5d22f7a5bca989d827879463cc36abedb202d6 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 15:32:51 -0700 Subject: [PATCH 12/45] Clean up path helper functions --- src/Data/Abstract/FreeVariables.hs | 5 ----- src/Data/Abstract/Path.hs | 6 +----- src/Language/Go/Assignment.hs | 8 ++++++-- src/Language/Ruby/Syntax.hs | 10 ++++++---- src/Language/TypeScript/Assignment.hs | 5 ++++- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/src/Data/Abstract/FreeVariables.hs b/src/Data/Abstract/FreeVariables.hs index fbfbfc079..266c9ca74 100644 --- a/src/Data/Abstract/FreeVariables.hs +++ b/src/Data/Abstract/FreeVariables.hs @@ -5,7 +5,6 @@ import Prologue import Data.Term import Data.ByteString (intercalate) import qualified Data.List.NonEmpty as NonEmpty -import Data.Abstract.Path -- | The type of variable names. type Name = NonEmpty ByteString @@ -18,10 +17,6 @@ name x = x :| [] qualifiedName :: [ByteString] -> Name qualifiedName = NonEmpty.fromList --- | Construct a qualified 'Name' from a `/` delimited path. -pathToQualifiedName :: ByteString -> Name -pathToQualifiedName = qualifiedName . splitOnPathSeparator - -- | User friendly 'ByteString' of a qualified 'Name'. friendlyName :: Name -> ByteString friendlyName xs = intercalate "." (NonEmpty.toList xs) diff --git a/src/Data/Abstract/Path.hs b/src/Data/Abstract/Path.hs index 491507b57..d40a0631a 100644 --- a/src/Data/Abstract/Path.hs +++ b/src/Data/Abstract/Path.hs @@ -4,12 +4,8 @@ import Prologue import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString as B --- | Split a 'ByteString' path on `/`, stripping quotes and any `./` prefix. splitOnPathSeparator :: ByteString -> [ByteString] -splitOnPathSeparator = splitOnPathSeparator' id - -splitOnPathSeparator' :: (ByteString -> ByteString) -> ByteString -> [ByteString] -splitOnPathSeparator' f = BC.split '/' . f . dropRelativePrefix . stripQuotes +splitOnPathSeparator = BC.split '/' stripQuotes :: ByteString -> ByteString stripQuotes = B.filter (`B.notElem` "\'\"") diff --git a/src/Language/Go/Assignment.hs b/src/Language/Go/Assignment.hs index 1bbd21dae..0aa85273a 100644 --- a/src/Language/Go/Assignment.hs +++ b/src/Language/Go/Assignment.hs @@ -393,7 +393,7 @@ importDeclaration = makeTerm'' <$> symbol ImportDeclaration <*> children (manyTe namedImport = inj <$> (flip Declaration.QualifiedImport <$> packageIdentifier <*> importFromPath <*> pure []) -- `import "lib/Math"` plainImport = inj <$> (symbol InterpretedStringLiteral >>= \loc -> do - names <- splitOnPathSeparator <$> source + names <- toName <$> source let from = makeTerm loc (Syntax.Identifier (qualifiedName names)) let alias = makeTerm loc (Syntax.Identifier (name (last names))) -- Go takes `import "lib/Math"` and uses `Math` as the qualified name (e.g. `Math.Sin()`) Declaration.QualifiedImport <$> pure from <*> pure alias <*> pure []) @@ -403,7 +403,11 @@ importDeclaration = makeTerm'' <$> symbol ImportDeclaration <*> children (manyTe underscore = makeTerm <$> symbol BlankIdentifier <*> (Literal.TextElement <$> source) importSpec = makeTerm' <$> symbol ImportSpec <*> children (sideEffectImport <|> dotImport <|> namedImport <|> plainImport) importSpecList = makeTerm <$> symbol ImportSpecList <*> children (manyTerm (importSpec <|> comment)) - importFromPath = makeTerm <$> symbol InterpretedStringLiteral <*> (Syntax.Identifier <$> (pathToQualifiedName <$> source)) + importFromPath = makeTerm <$> symbol InterpretedStringLiteral <*> (Syntax.Identifier <$> (toQualifiedName <$> source)) + + toQualifiedName = qualifiedName . toName + toName = splitOnPathSeparator . dropRelativePrefix . stripQuotes + indexExpression :: Assignment indexExpression = makeTerm <$> symbol IndexExpression <*> children (Expression.Subscript <$> expression <*> manyTerm expression) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 3b254ee41..debc13f43 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -19,10 +19,12 @@ instance Show1 Require where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Require where eval (Require _ x) = do - name <- pathToQualifiedName <$> (subtermValue x >>= asString) + name <- toName <$> (subtermValue x >>= asString) importedEnv <- isolate (require name) modifyEnv (mappend importedEnv) unit + where + toName = qualifiedName . splitOnPathSeparator . dropRelativePrefix . stripQuotes newtype Load a = Load { loadArgs :: [a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) @@ -43,10 +45,10 @@ instance Evaluatable Load where doLoad :: (MonadAnalysis term value m, MonadValue value m, Ord (LocationFor value)) => ByteString -> Bool -> m value doLoad path shouldWrap = do - let name = pathToQualifiedName path - importedEnv <- isolate (load name) + importedEnv <- isolate (load (toName path)) unless shouldWrap $ modifyEnv (mappend importedEnv) unit - where pathToQualifiedName = qualifiedName . splitOnPathSeparator' dropExtension + where + toName = qualifiedName . splitOnPathSeparator . dropExtension . dropRelativePrefix . stripQuotes -- TODO: autoload diff --git a/src/Language/TypeScript/Assignment.hs b/src/Language/TypeScript/Assignment.hs index ab0df4765..3aa127e30 100644 --- a/src/Language/TypeScript/Assignment.hs +++ b/src/Language/TypeScript/Assignment.hs @@ -9,6 +9,7 @@ module Language.TypeScript.Assignment import Assigning.Assignment hiding (Assignment, Error) import qualified Assigning.Assignment as Assignment import Data.Abstract.FreeVariables +import Data.Abstract.Path import Data.Record import Data.Syntax (emptyTerm, handleError, parseError, infixContext, makeTerm, makeTerm', makeTerm'', makeTerm1, contextualize, postContextualize) import qualified Data.Syntax as Syntax @@ -672,7 +673,9 @@ importStatement = makeImportTerm <$> symbol Grammar.ImportStatement <*> childr makeNameAliasPair from Nothing = (from, from) fromClause :: Assignment -fromClause = makeTerm <$> symbol Grammar.String <*> (Syntax.Identifier <$> (pathToQualifiedName <$> source)) +fromClause = makeTerm <$> symbol Grammar.String <*> (Syntax.Identifier <$> (toName <$> source)) + where + toName = qualifiedName . splitOnPathSeparator . dropRelativePrefix . stripQuotes debuggerStatement :: Assignment debuggerStatement = makeTerm <$> symbol Grammar.DebuggerStatement <*> (TypeScript.Syntax.Debugger <$ source) From dc2bfc5736ac221110c0411bb14b8733eaa53c15 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 15:33:06 -0700 Subject: [PATCH 13/45] PHP includes just have to eval to a string --- src/Language/PHP/Assignment.hs | 7 +------ src/Language/PHP/Syntax.hs | 5 ++++- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index 01b2c0bd1..44a9186ff 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -13,7 +13,6 @@ import Language.PHP.Grammar as Grammar import Prologue import qualified Assigning.Assignment as Assignment import qualified Data.Abstract.FreeVariables as FV -import qualified Data.Abstract.Path as Path import qualified Data.Syntax as Syntax import qualified Data.Syntax.Comment as Comment import qualified Data.Syntax.Declaration as Declaration @@ -718,11 +717,7 @@ arrayElementInitializer :: Assignment arrayElementInitializer = makeTerm <$> symbol ArrayElementInitializer <*> children (Literal.KeyValue <$> term expression <*> term expression) <|> (symbol ArrayElementInitializer *> children (term expression)) includeExpression :: Assignment -includeExpression = makeTerm <$> symbol IncludeExpression <*> children (Syntax.Include <$> term includePath) - --- TODO: Dropping the .php file extension here means we loose diff-ability. -includePath :: Assignment -includePath = makeTerm <$> symbol Grammar.String <*> (Syntax.Identifier . FV.pathToQualifiedName . Path.dropExtension <$> source) +includeExpression = makeTerm <$> symbol IncludeExpression <*> children (Syntax.Include <$> term expression) includeOnceExpression :: Assignment includeOnceExpression = makeTerm <$> symbol IncludeOnceExpression <*> children (Syntax.IncludeOnce <$> term expression) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 5ada0d0ff..c69e17080 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -2,6 +2,7 @@ module Language.PHP.Syntax where import Data.Abstract.Evaluatable +import Data.Abstract.Path import Diffing.Algorithm import Prologue hiding (Text) @@ -48,10 +49,12 @@ instance Show1 Include where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Include where eval (Include path) = do - let name = freeVariable (subterm path) + name <- toName <$> (subtermValue path >>= asString) importedEnv <- isolate (load name) modifyEnv (mappend importedEnv) unit + where + toName = qualifiedName . splitOnPathSeparator . dropExtension . dropRelativePrefix . stripQuotes data IncludePath a = IncludePath { includePath :: a, includePathExtension :: a } deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) From cb915cc95befcd3a347859da85f05c45e1359c75 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 15:34:32 -0700 Subject: [PATCH 14/45] No more IncludePath --- src/Language/PHP/Syntax.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index c69e17080..fd367f4a4 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -56,13 +56,6 @@ instance Evaluatable Include where where toName = qualifiedName . splitOnPathSeparator . dropExtension . dropRelativePrefix . stripQuotes -data IncludePath a = IncludePath { includePath :: a, includePathExtension :: a } - deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) - -instance Eq1 IncludePath where liftEq = genericLiftEq -instance Ord1 IncludePath where liftCompare = genericLiftCompare -instance Show1 IncludePath where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable IncludePath newtype IncludeOnce a = IncludeOnce a deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) From 6a0c5e8714c2c0b61b85cbcb3f80aeb1837c2556 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 15:35:06 -0700 Subject: [PATCH 15/45] Gonna use this help for other instances --- src/Language/PHP/Syntax.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index fd367f4a4..3878914d2 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -6,6 +6,10 @@ import Data.Abstract.Path import Diffing.Algorithm import Prologue hiding (Text) + +toQualifiedName :: ByteString -> Name +toQualifiedName = qualifiedName . splitOnPathSeparator . dropExtension . dropRelativePrefix . stripQuotes + newtype Text a = Text ByteString deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) @@ -49,13 +53,10 @@ instance Show1 Include where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Include where eval (Include path) = do - name <- toName <$> (subtermValue path >>= asString) + name <- toQualifiedName <$> (subtermValue path >>= asString) importedEnv <- isolate (load name) modifyEnv (mappend importedEnv) unit - where - toName = qualifiedName . splitOnPathSeparator . dropExtension . dropRelativePrefix . stripQuotes - newtype IncludeOnce a = IncludeOnce a deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) From 47f00e4ec32c8c896ed4b371ddfcbed1a65a7775 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Mon, 19 Mar 2018 15:42:42 -0700 Subject: [PATCH 16/45] Fill in IncludeOnce, Require, and RequireOnce --- src/Language/PHP/Syntax.hs | 53 ++++++++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 16 deletions(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 3878914d2..8af7dc49b 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -2,14 +2,12 @@ module Language.PHP.Syntax where import Data.Abstract.Evaluatable +import Data.Abstract.Value (LocationFor) import Data.Abstract.Path import Diffing.Algorithm import Prologue hiding (Text) -toQualifiedName :: ByteString -> Name -toQualifiedName = qualifiedName . splitOnPathSeparator . dropExtension . dropRelativePrefix . stripQuotes - newtype Text a = Text ByteString deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) @@ -28,13 +26,22 @@ instance Show1 VariableName where liftShowsPrec = genericLiftShowsPrec instance Evaluatable VariableName -newtype RequireOnce a = RequireOnce a - deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) +toQualifiedName :: ByteString -> Name +toQualifiedName = qualifiedName . splitOnPathSeparator . dropExtension . dropRelativePrefix . stripQuotes -instance Eq1 RequireOnce where liftEq = genericLiftEq -instance Ord1 RequireOnce where liftCompare = genericLiftCompare -instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable RequireOnce +doInclude :: (MonadValue value m, MonadAnalysis term value m, Ord (LocationFor value)) => Subterm t (m value) -> m value +doInclude path = do + name <- toQualifiedName <$> (subtermValue path >>= asString) + importedEnv <- isolate (load name) + modifyEnv (mappend importedEnv) + unit + +doIncludeOnce :: (MonadValue value m, MonadAnalysis term value m, Ord (LocationFor value)) => Subterm t (m value) -> m value +doIncludeOnce path = do + name <- toQualifiedName <$> (subtermValue path >>= asString) + importedEnv <- isolate (require name) + modifyEnv (mappend importedEnv) + unit newtype Require a = Require a deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) @@ -42,7 +49,21 @@ newtype Require a = Require a instance Eq1 Require where liftEq = genericLiftEq instance Ord1 Require where liftCompare = genericLiftCompare instance Show1 Require where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable Require + +instance Evaluatable Require where + eval (Require path) = doInclude path + + +newtype RequireOnce a = RequireOnce a + deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) + +instance Eq1 RequireOnce where liftEq = genericLiftEq +instance Ord1 RequireOnce where liftCompare = genericLiftCompare +instance Show1 RequireOnce where liftShowsPrec = genericLiftShowsPrec + +instance Evaluatable RequireOnce where + eval (RequireOnce path) = doIncludeOnce path + newtype Include a = Include a deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) @@ -52,11 +73,8 @@ instance Ord1 Include where liftCompare = genericLiftCompare instance Show1 Include where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Include where - eval (Include path) = do - name <- toQualifiedName <$> (subtermValue path >>= asString) - importedEnv <- isolate (load name) - modifyEnv (mappend importedEnv) - unit + eval (Include path) = doInclude path + newtype IncludeOnce a = IncludeOnce a deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) @@ -64,7 +82,10 @@ newtype IncludeOnce a = IncludeOnce a instance Eq1 IncludeOnce where liftEq = genericLiftEq instance Ord1 IncludeOnce where liftCompare = genericLiftCompare instance Show1 IncludeOnce where liftShowsPrec = genericLiftShowsPrec -instance Evaluatable IncludeOnce + +instance Evaluatable IncludeOnce where + eval (IncludeOnce path) = doIncludeOnce path + newtype ArrayElement a = ArrayElement a deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) From d30e832e1170ccdaec239b73dc3df0158a5e5255 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 20 Mar 2018 16:33:53 -0700 Subject: [PATCH 17/45] Move require/load so we can return values --- src/Analysis/Abstract/Evaluating.hs | 67 ++++++++++++++++++++++++++++- src/Control/Abstract/Analysis.hs | 48 +-------------------- src/Data/Syntax/Declaration.hs | 1 + src/Language/PHP/Syntax.hs | 1 + src/Language/Ruby/Syntax.hs | 1 + 5 files changed, 69 insertions(+), 49 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index cb89fea6a..45a4200db 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -3,6 +3,10 @@ module Analysis.Abstract.Evaluating ( type Evaluating , evaluate , evaluates +, require +, require' +, load +, load' ) where import Control.Abstract.Evaluator @@ -12,6 +16,9 @@ import Control.Monad.Effect.Reader import Control.Monad.Effect.State import Data.Abstract.Configuration import qualified Data.Abstract.Environment as Env +import Data.Abstract.Environment (Environment) +import qualified Data.Abstract.Exports as Export +import Data.Abstract.Exports (Exports) import Data.Abstract.Evaluatable import Data.Abstract.ModuleTable import Data.Abstract.Value @@ -67,6 +74,62 @@ withModules Blob{..} pairs = localModuleTable (const moduleTable) _ -> toName path toName str = qualifiedName (fmap BC.pack (splitWhen (== pathSeparator) str)) + +-- | Require/import another module by name and return it's environment +-- +-- Looks up the term's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. +require :: (MonadAnalysis term value m, MonadValue value m) + => ModuleName + -> m (EnvironmentFor value) +require name = fst <$> require' name + +-- | Require/import another module by name and return it's environment and value. +require' :: (MonadAnalysis term value m, MonadValue value m) + => ModuleName + -> m (EnvironmentFor value, value) +require' name = getModuleTable >>= maybe (load' name) pure . moduleTableLookup name + +-- | Load another module by name and return it's environment +-- +-- Always loads/evaluates. +load :: (MonadAnalysis term value m, MonadValue value m) + => ModuleName + -> m (EnvironmentFor value) +load name = fst <$> load' name + +-- | Load another module by name and return it's environment and value. +load' :: (MonadAnalysis term value m, MonadValue value m) + => ModuleName + -> m (EnvironmentFor value, value) +load' name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name + where + notFound = fail ("cannot load module: " <> show name) + evalAndCache :: (MonadAnalysis term value m, MonadValue value m) => [term] -> m (EnvironmentFor value, value) + evalAndCache [] = (,) <$> pure mempty <*> unit + evalAndCache [x] = evalAndCache' x + evalAndCache (x:xs) = do + -- v <- evaluateModule x + -- env <- filterEnv <$> getExports <*> getEnv + -- modifyModuleTable (moduleTableInsert name (env, v)) + (env, _) <- evalAndCache' x + (env', v') <- evalAndCache xs + pure (env <> env', v') + + evalAndCache' :: (MonadAnalysis term value m) => term -> m (EnvironmentFor value, value) + evalAndCache' x = do + v <- evaluateModule x + env <- filterEnv <$> getExports <*> getEnv + modifyModuleTable (moduleTableInsert name (env, v)) + pure (env, v) + + -- TODO: If the set of exports is empty because no exports have been + -- defined, do we export all terms, or no terms? This behavior varies across + -- languages. We need better semantics rather than doing it ad-hoc. + filterEnv :: Exports l a -> Environment l a -> Environment l a + filterEnv ports env + | Export.null ports = env + | otherwise = Export.toEnvironment ports <> Env.overwrite (Export.aliases ports) env + -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. newtype Evaluating term value effects a = Evaluating (Eff effects a) deriving (Applicative, Functor, Effectful, Monad) @@ -82,7 +145,7 @@ type EvaluatingEffects term value , State (EnvironmentFor value) -- Environments (both local and global) , State (HeapFor value) -- The heap , Reader (ModuleTable [term]) -- Cache of unevaluated modules - , State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules + , State (ModuleTable (EnvironmentFor value, value)) -- Cache of evaluated modules , State (ExportsFor value) -- Exports (used to filter environments when they are imported) , State (IntMap.IntMap term) -- For jumps ] @@ -114,7 +177,7 @@ instance Member (State (HeapFor value)) effects => MonadHeap value (Evaluating t getHeap = raise get putHeap = raise . put -instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentFor value))] effects => MonadModuleTable term value (Evaluating term value effects) where +instance Members '[Reader (ModuleTable [term]), State (ModuleTable (EnvironmentFor value, value))] effects => MonadModuleTable term value (Evaluating term value effects) where getModuleTable = raise get putModuleTable = raise . put diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 8b215ee07..d9620042a 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -3,8 +3,6 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm -, require -, load , liftAnalyze , runAnalysis , module X @@ -20,14 +18,8 @@ import qualified Control.Monad.Effect as Effect import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X -import Data.Abstract.Environment (Environment) -import qualified Data.Abstract.Environment as Env -import Data.Abstract.Exports (Exports) -import qualified Data.Abstract.Exports as Export -import Data.Abstract.ModuleTable -import Data.Abstract.Value import Data.Coerce -import Prelude hiding (fail) +import Prelude import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. @@ -54,44 +46,6 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value evaluateTerm :: MonadAnalysis term value m => term -> m value evaluateTerm = foldSubterms analyzeTerm - --- | Require/import another term/file and return an Effect. --- --- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. -require :: ( MonadAnalysis term value m - , Ord (LocationFor value) - ) - => ModuleName - -> m (EnvironmentFor value) -require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup name - --- | Load another term/file and return an Effect. --- --- Always loads/evaluates. -load :: ( MonadAnalysis term value m - , Ord (LocationFor value) - ) - => ModuleName - -> m (EnvironmentFor value) -load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name - where - notFound = fail ("cannot load module: " <> show name) - evalAndCache :: (MonadAnalysis term value m, Ord (LocationFor value)) => [term] -> m (EnvironmentFor value) - evalAndCache [] = pure mempty - evalAndCache (x:xs) = do - void $ evaluateModule x - env <- filterEnv <$> getExports <*> getEnv - modifyModuleTable (moduleTableInsert name env) - (env <>) <$> evalAndCache xs - - -- TODO: If the set of exports is empty because no exports have been - -- defined, do we export all terms, or no terms? This behavior varies across - -- languages. We need better semantics rather than doing it ad-hoc. - filterEnv :: (Ord l) => Exports l a -> Environment l a -> Environment l a - filterEnv ports env - | Export.null ports = env - | otherwise = Export.toEnvironment ports <> Env.overwrite (Export.aliases ports) env - -- | Lift a 'SubtermAlgebra' for an underlying analysis into a containing analysis. Use this when defining an analysis which can be composed onto other analyses to ensure that a call to 'analyzeTerm' occurs in the inner analysis and not the outer one. liftAnalyze :: ( Coercible ( m term value (effects :: [* -> *]) value) (t m term value effects value) , Coercible (t m term value effects value) ( m term value effects value) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index f17fc4d07..9c622b29b 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} module Data.Syntax.Declaration where +import Analysis.Abstract.Evaluating import qualified Data.Abstract.Environment as Env import Data.Abstract.Evaluatable import Diffing.Algorithm diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 8af7dc49b..3c940484b 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.PHP.Syntax where +import Analysis.Abstract.Evaluating import Data.Abstract.Evaluatable import Data.Abstract.Value (LocationFor) import Data.Abstract.Path diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index debc13f43..17eb30d89 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} module Language.Ruby.Syntax where +import Analysis.Abstract.Evaluating import Control.Monad (unless) import Control.Abstract.Value (MonadValue) import Data.Abstract.Evaluatable From 26f2fc4f9ad0c8390ce28c646d5c38343871c758 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 20 Mar 2018 16:34:17 -0700 Subject: [PATCH 18/45] Store off a tuple of env value in the module table --- src/Control/Abstract/Evaluator.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index f7456094b..f99b8b565 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -123,9 +123,9 @@ assign address = modifyHeap . heapInsert address -- | A 'Monad' abstracting tables of modules available for import. class Monad m => MonadModuleTable term value m | m -> term, m -> value where -- | Retrieve the table of evaluated modules. - getModuleTable :: m (ModuleTable (EnvironmentFor value)) + getModuleTable :: m (ModuleTable (EnvironmentFor value, value)) -- | Set the table of evaluated modules. - putModuleTable :: ModuleTable (EnvironmentFor value) -> m () + putModuleTable :: ModuleTable (EnvironmentFor value, value) -> m () -- | Retrieve the table of unevaluated modules. askModuleTable :: m (ModuleTable [term]) @@ -133,7 +133,7 @@ class Monad m => MonadModuleTable term value m | m -> term, m -> value where localModuleTable :: (ModuleTable [term] -> ModuleTable [term]) -> m a -> m a -- | Update the evaluated module table. -modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentFor value) -> ModuleTable (EnvironmentFor value)) -> m () +modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentFor value, value) -> ModuleTable (EnvironmentFor value, value)) -> m () modifyModuleTable f = do table <- getModuleTable putModuleTable $! f table From 8d3de3e6403ea2215b93c6e103847cebeec5528c Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 20 Mar 2018 16:34:31 -0700 Subject: [PATCH 19/45] PHP includes can now return proper values --- src/Language/PHP/Syntax.hs | 36 +++++++++++++++++++++--------------- 1 file changed, 21 insertions(+), 15 deletions(-) diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 3c940484b..2361a5a30 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -3,7 +3,6 @@ module Language.PHP.Syntax where import Analysis.Abstract.Evaluating import Data.Abstract.Evaluatable -import Data.Abstract.Value (LocationFor) import Data.Abstract.Path import Diffing.Algorithm import Prologue hiding (Text) @@ -26,24 +25,31 @@ instance Ord1 VariableName where liftCompare = genericLiftCompare instance Show1 VariableName where liftShowsPrec = genericLiftShowsPrec instance Evaluatable VariableName +-- TODO: Variables defined in an included file take on scope of the source line +-- on which the inclusion occurs in the including file. However, functions and +-- classes defined in the included file are always in global scope. + +-- TODO: If inclusion occurs inside a function definition within the including +-- file, the complete contents of the included file are treated as though it +-- were defined inside that function. + +doInclude :: (MonadValue value m, MonadAnalysis term value m) => Subterm t (m value) -> m value +doInclude path = do + name <- toQualifiedName <$> (subtermValue path >>= asString) + (importedEnv, v) <- isolate (load' name) + modifyEnv (mappend importedEnv) + pure v + +doIncludeOnce :: (MonadValue value m, MonadAnalysis term value m) => Subterm t (m value) -> m value +doIncludeOnce path = do + name <- toQualifiedName <$> (subtermValue path >>= asString) + (importedEnv, v) <- isolate (require' name) + modifyEnv (mappend importedEnv) + pure v toQualifiedName :: ByteString -> Name toQualifiedName = qualifiedName . splitOnPathSeparator . dropExtension . dropRelativePrefix . stripQuotes -doInclude :: (MonadValue value m, MonadAnalysis term value m, Ord (LocationFor value)) => Subterm t (m value) -> m value -doInclude path = do - name <- toQualifiedName <$> (subtermValue path >>= asString) - importedEnv <- isolate (load name) - modifyEnv (mappend importedEnv) - unit - -doIncludeOnce :: (MonadValue value m, MonadAnalysis term value m, Ord (LocationFor value)) => Subterm t (m value) -> m value -doIncludeOnce path = do - name <- toQualifiedName <$> (subtermValue path >>= asString) - importedEnv <- isolate (require name) - modifyEnv (mappend importedEnv) - unit - newtype Require a = Require a deriving (Diffable, Eq, Foldable, Functor, FreeVariables1, GAlign, Generic1, Mergeable, Ord, Show, Traversable) From 038af3ccb2a045210b36fd745f9b6f5d9f585100 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 20 Mar 2018 16:34:46 -0700 Subject: [PATCH 20/45] Ruby require/load now return proper values too --- src/Language/Ruby/Syntax.hs | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 17eb30d89..04a6792ad 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -5,8 +5,9 @@ import Analysis.Abstract.Evaluating import Control.Monad (unless) import Control.Abstract.Value (MonadValue) import Data.Abstract.Evaluatable +import Data.Abstract.ModuleTable import Data.Abstract.Path -import Data.Abstract.Value (LocationFor) +import Data.Abstract.Value (EnvironmentFor) import Diffing.Algorithm import Prelude hiding (fail) import Prologue @@ -21,12 +22,22 @@ instance Show1 Require where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Require where eval (Require _ x) = do name <- toName <$> (subtermValue x >>= asString) - importedEnv <- isolate (require name) + (importedEnv, v) <- isolate (doRequire name) modifyEnv (mappend importedEnv) - unit + pure v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require where toName = qualifiedName . splitOnPathSeparator . dropRelativePrefix . stripQuotes +doRequire :: (MonadAnalysis term value m, MonadValue value m) + => ModuleName + -> m (EnvironmentFor value, value) +doRequire name = do + moduleTable <- getModuleTable + case moduleTableLookup name moduleTable of + Nothing -> (,) <$> load name <*> boolean True + Just (env, _) -> (,) <$> pure env <*> boolean False + + newtype Load a = Load { loadArgs :: [a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) @@ -44,11 +55,11 @@ instance Evaluatable Load where doLoad path shouldWrap eval (Load _) = fail "invalid argument supplied to load, path is required" -doLoad :: (MonadAnalysis term value m, MonadValue value m, Ord (LocationFor value)) => ByteString -> Bool -> m value +doLoad :: (MonadAnalysis term value m, MonadValue value m) => ByteString -> Bool -> m value doLoad path shouldWrap = do importedEnv <- isolate (load (toName path)) unless shouldWrap $ modifyEnv (mappend importedEnv) - unit + boolean Prelude.True -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load where toName = qualifiedName . splitOnPathSeparator . dropExtension . dropRelativePrefix . stripQuotes From 69e2eda8dbf1c7f049dddb8f05e72ca89391be10 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Tue, 20 Mar 2018 16:46:32 -0700 Subject: [PATCH 21/45] Couple more tests --- test/Analysis/PHP/Spec.hs | 12 ++++++++++-- test/fixtures/php/analysis/bar.php | 4 ++++ test/fixtures/php/analysis/main.php | 2 ++ test/fixtures/php/analysis/main_once.php | 6 ++++++ 4 files changed, 22 insertions(+), 2 deletions(-) create mode 100644 test/fixtures/php/analysis/bar.php create mode 100644 test/fixtures/php/analysis/main_once.php diff --git a/test/Analysis/PHP/Spec.hs b/test/Analysis/PHP/Spec.hs index 39368a7a2..1094af671 100644 --- a/test/Analysis/PHP/Spec.hs +++ b/test/Analysis/PHP/Spec.hs @@ -10,9 +10,16 @@ import SpecHelpers spec :: Spec spec = parallel $ do describe "evalutes PHP" $ do - it "include" $ do + it "include and require" $ do env <- evaluate "main.php" - let expectedEnv = [ (qualifiedName ["foo"], addr 0) ] + let expectedEnv = [ (qualifiedName ["foo"], addr 0) + , (qualifiedName ["bar"], addr 1) ] + env `shouldBe` expectedEnv + + it "include_once and require_once" $ do + env <- evaluate "main_once.php" + let expectedEnv = [ (qualifiedName ["foo"], addr 0) + , (qualifiedName ["bar"], addr 1) ] env `shouldBe` expectedEnv where @@ -22,4 +29,5 @@ spec = parallel $ do evaluateFiles phpParser [ fixtures <> entry , fixtures <> "foo.php" + , fixtures <> "bar.php" ] diff --git a/test/fixtures/php/analysis/bar.php b/test/fixtures/php/analysis/bar.php new file mode 100644 index 000000000..03e99baf3 --- /dev/null +++ b/test/fixtures/php/analysis/bar.php @@ -0,0 +1,4 @@ + Date: Tue, 20 Mar 2018 16:47:36 -0700 Subject: [PATCH 22/45] Remove this --- src/Analysis/Abstract/Evaluating.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 45a4200db..01d47c0b1 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -108,9 +108,6 @@ load' name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup evalAndCache [] = (,) <$> pure mempty <*> unit evalAndCache [x] = evalAndCache' x evalAndCache (x:xs) = do - -- v <- evaluateModule x - -- env <- filterEnv <$> getExports <*> getEnv - -- modifyModuleTable (moduleTableInsert name (env, v)) (env, _) <- evalAndCache' x (env', v') <- evalAndCache xs pure (env <> env', v') From b59fc64dd8edff087e0a07781df2b95a5761a8ee Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 21 Mar 2018 12:17:16 -0400 Subject: [PATCH 23/45] Implement single-inheritance subclassing. Pretty straightforward stuff: we augment `klass` to take an optional superclass, match to ensure it's a class, then, when defining that new class, push its definition onto the environment provided by the superclass. --- src/Control/Abstract/Value.hs | 14 +++++++++++--- src/Data/Syntax/Declaration.hs | 3 ++- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 2bd15f435..4e2137776 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -87,7 +87,10 @@ class (Monad m, Show value) => MonadValue value m where ifthenelse :: value -> m a -> m a -> m a -- | Build a class value from a name and environment. - klass :: Name -> EnvironmentFor value -> m value + klass :: Name -- ^ The new class's identifier + -> Maybe value -- ^ A list of superclasses + -> EnvironmentFor value -- ^ The environment to capture + -> m value -- | Extract the environment from a class. objectEnvironment :: value -> m (EnvironmentFor value) @@ -152,7 +155,11 @@ instance ( Monad m multiple = pure . injValue . Value.Tuple array = pure . injValue . Value.Array - klass n = pure . injValue . Class n + klass n Nothing env = pure . injValue $ Class n env + klass n (Just super) env + | Just (Class _ superEnv) <- prjValue super = pure . injValue $ Class n (Env.push superEnv <> env) + | otherwise = fail ("Attempted to inherit from a non-class object: " <> show super) + objectEnvironment o | Just (Class _ env) <- prjValue o = pure env @@ -260,7 +267,8 @@ instance (Alternative m, MonadEnvironment Type m, MonadFail m, MonadFresh m, Mon rational _ = pure Type.Rational multiple = pure . Type.Product array = pure . Type.Array - klass _ _ = pure Object + + klass _ _ _ = pure Object objectEnvironment _ = pure mempty diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index f17fc4d07..fef446bc9 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -146,10 +146,11 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Class where eval Class{..} = do let name = freeVariable (subterm classIdentifier) + supers <- traverse subtermValue classSuperclasses (v, addr) <- letrec name $ do void $ subtermValue classBody classEnv <- Env.head <$> getEnv - klass name classEnv + klass name (listToMaybe supers) classEnv v <$ modifyEnv (Env.insert name addr) data Module a = Module { moduleIdentifier :: !a, moduleScope :: ![a] } From a740f2938ab3b8e5ff7b0e90f1a6dce146575311 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 21 Mar 2018 09:19:32 -0700 Subject: [PATCH 24/45] Don't change assignment for namespaces just yet --- src/Language/PHP/Assignment.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index 4f9be14ce..28c5930dd 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -453,12 +453,10 @@ relativeScope :: Assignment relativeScope = makeTerm <$> symbol RelativeScope <*> (Syntax.RelativeScope <$> source) qualifiedName :: Assignment -qualifiedName = makeTerm <$> symbol QualifiedName <*> children (Syntax.Identifier . FV.qualifiedName <$> names) - where - names = (\a b -> a <> [b]) <$> (namespaceNameAsPrefix <|> pure []) <*> name' - namespaceNameAsPrefix = symbol NamespaceNameAsPrefix *> children (namespaceName' <|> pure []) - namespaceName' = symbol NamespaceName *> children (some name') - name' = (symbol Name <|> symbol Name') *> source +qualifiedName = makeTerm <$> symbol QualifiedName <*> children (Syntax.QualifiedName <$> (term namespaceNameAsPrefix <|> emptyTerm) <*> term name) + +namespaceNameAsPrefix :: Assignment +namespaceNameAsPrefix = symbol NamespaceNameAsPrefix *> children (term namespaceName <|> emptyTerm) namespaceName :: Assignment namespaceName = makeTerm <$> symbol NamespaceName <*> children (Syntax.NamespaceName <$> someTerm name) From 166c66766e9c777c74623ccc27f232e789fb5575 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 21 Mar 2018 09:20:07 -0700 Subject: [PATCH 25/45] Whitespace --- src/Language/PHP/Assignment.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Language/PHP/Assignment.hs b/src/Language/PHP/Assignment.hs index 28c5930dd..8a908ecdc 100644 --- a/src/Language/PHP/Assignment.hs +++ b/src/Language/PHP/Assignment.hs @@ -717,6 +717,7 @@ arrayElementInitializer = makeTerm <$> symbol ArrayElementInitializer <*> childr includeExpression :: Assignment includeExpression = makeTerm <$> symbol IncludeExpression <*> children (Syntax.Include <$> term expression) + includeOnceExpression :: Assignment includeOnceExpression = makeTerm <$> symbol IncludeOnceExpression <*> children (Syntax.IncludeOnce <$> term expression) From 0b2b27ff218f08178536cdb41136e1dffe8619b4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 16:40:56 -0400 Subject: [PATCH 26/45] Stub in an AppMerge semigroup. --- semantic.cabal | 1 + src/Data/Semigroup/App.hs | 7 +++++++ 2 files changed, 8 insertions(+) create mode 100644 src/Data/Semigroup/App.hs diff --git a/semantic.cabal b/semantic.cabal index 132722e06..9b8c4b9af 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -72,6 +72,7 @@ library , Data.Patch , Data.Range , Data.Record + , Data.Semigroup.App , Data.Source , Data.Span , Data.SplitDiff diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs new file mode 100644 index 000000000..7f183d5eb --- /dev/null +++ b/src/Data/Semigroup/App.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Data.Semigroup.App where + +import Control.Applicative + +newtype AppMerge f a = AppMerge { runAppMerge :: f a } + deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) From 541e23043148cc626c15de951c6eb16c80b60eb7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 16:41:32 -0400 Subject: [PATCH 27/45] Define a Semigroup instance for AppMerge. --- src/Data/Semigroup/App.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 7f183d5eb..07d5c0ec0 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -2,6 +2,10 @@ module Data.Semigroup.App where import Control.Applicative +import Data.Semigroup newtype AppMerge f a = AppMerge { runAppMerge :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) + +instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where + AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b) From 794a03a49c124887ff3b3a172386d76688fda05b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 16:41:41 -0400 Subject: [PATCH 28/45] :memo: AppMerge. --- src/Data/Semigroup/App.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 07d5c0ec0..9b393f126 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -4,6 +4,7 @@ module Data.Semigroup.App where import Control.Applicative import Data.Semigroup +-- | 'Semigroup' under '<*>' and '<>'. newtype AppMerge f a = AppMerge { runAppMerge :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) From 88230df1fe910acd5c7cf4840313b488413f90b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 16:41:49 -0400 Subject: [PATCH 29/45] Define a Monoid instance for AppMerge. --- src/Data/Semigroup/App.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 9b393f126..639c1c87c 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -10,3 +10,7 @@ newtype AppMerge f a = AppMerge { runAppMerge :: f a } instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b) + +instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where + mempty = AppMerge (pure mempty) + mappend = (<>) From 8f22cb26f885e9a302a0233de71cc5bea62cc724 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 16:44:35 -0400 Subject: [PATCH 30/45] Explicitly list the exports. --- src/Data/Semigroup/App.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 639c1c87c..875d3319d 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Data.Semigroup.App where +module Data.Semigroup.App +( AppMerge(..) +) where import Control.Applicative import Data.Semigroup From d39db0db062b83483056f2fcc19093edaf72db9d Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Wed, 21 Mar 2018 16:56:52 -0400 Subject: [PATCH 31/45] fix comment --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 4e2137776..4ad6d5afd 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -88,7 +88,7 @@ class (Monad m, Show value) => MonadValue value m where -- | Build a class value from a name and environment. klass :: Name -- ^ The new class's identifier - -> Maybe value -- ^ A list of superclasses + -> Maybe value -- ^ An optional superclass. -> EnvironmentFor value -- ^ The environment to capture -> m value From 6399cb3c58a3d0963b58331f266e2d36c7a452d8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:07:49 -0400 Subject: [PATCH 32/45] Define an App semigroup. --- src/Data/Semigroup/App.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 875d3319d..6fec42eb1 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Semigroup.App ( AppMerge(..) +, App(..) ) where import Control.Applicative @@ -16,3 +17,7 @@ instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where mempty = AppMerge (pure mempty) mappend = (<>) + + +newtype App f a = App { runApp :: f a } + deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) From 5ea6482e96571f026780686f0c7d1068f3460ea1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:07:55 -0400 Subject: [PATCH 33/45] :memo: App. --- src/Data/Semigroup/App.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 6fec42eb1..4708edb27 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -19,5 +19,6 @@ instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where mappend = (<>) +-- | 'Semigroup' under '*>'. newtype App f a = App { runApp :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) From 3329bd0a5176ca5d17f39b9e39497368895d6ddd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:08:06 -0400 Subject: [PATCH 34/45] Define a Semigroup instance for App. --- src/Data/Semigroup/App.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 4708edb27..4218a110c 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -22,3 +22,6 @@ instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where -- | 'Semigroup' under '*>'. newtype App f a = App { runApp :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) + +instance Applicative f => Semigroup (App f a) where + App a <> App b = App (a *> b) From e0245ed7524cbfbbb0021769a2642d037ced7680 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:08:14 -0400 Subject: [PATCH 35/45] Define a Monoid instance for App. --- src/Data/Semigroup/App.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 4218a110c..414ce1c9b 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -25,3 +25,7 @@ newtype App f a = App { runApp :: f a } instance Applicative f => Semigroup (App f a) where App a <> App b = App (a *> b) + +instance (Applicative f, Monoid a) => Monoid (App f a) where + mempty = App (pure mempty) + mappend = (<>) From 256623a81816f02703d336d246febe8fd50a8f90 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:08:25 -0400 Subject: [PATCH 36/45] eval lists in App. --- src/Data/Abstract/Evaluatable.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index adf41de29..21d7c6a98 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -16,6 +16,7 @@ import Data.Abstract.Value import Data.Functor.Classes import Data.Proxy import Data.Semigroup.Foldable +import Data.Semigroup.App import Data.Term import Prelude hiding (fail) import Prologue @@ -51,7 +52,7 @@ instance Evaluatable s => Evaluatable (TermF s a) where -- 3. Only the last statement’s return value is returned. instance Evaluatable [] where -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists. - eval = maybe unit (runImperative . foldMap1 (Imperative . subtermValue)) . nonEmpty + eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty -- | A 'Semigroup' providing an imperative context which extends the local environment with new bindings. newtype Imperative m a = Imperative { runImperative :: m a } From 69a4e4cc2eff281725274f3bff8018e0bb8e9fa8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:08:52 -0400 Subject: [PATCH 37/45] :fire: Imperative. --- src/Data/Abstract/Evaluatable.hs | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 21d7c6a98..c4cb0ff63 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -53,13 +53,3 @@ instance Evaluatable s => Evaluatable (TermF s a) where instance Evaluatable [] where -- 'nonEmpty' and 'foldMap1' enable us to return the last statement’s result instead of 'unit' for non-empty lists. eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty - --- | A 'Semigroup' providing an imperative context which extends the local environment with new bindings. -newtype Imperative m a = Imperative { runImperative :: m a } - -instance MonadEnvironment value m => Semigroup (Imperative m a) where - Imperative a <> Imperative b = Imperative (a *> b) - -instance (MonadEnvironment value m, MonadValue value m) => Monoid (Imperative m value) where - mempty = Imperative unit - mappend = (<>) From c6148c6cad3f5322ab5a6bcc54f6319fb1815859 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:16:09 -0400 Subject: [PATCH 38/45] Test the associativity of the semigroup instances. --- src/Data/Semigroup/App.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 414ce1c9b..78922f68c 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -7,10 +7,17 @@ module Data.Semigroup.App import Control.Applicative import Data.Semigroup +-- $setup +-- >>> import Test.QuickCheck +-- >>> instance Arbitrary (f a) => Arbitrary (App f a) where arbitrary = App <$> arbitrary +-- >>> instance Arbitrary (f a) => Arbitrary (AppMerge f a) where arbitrary = AppMerge <$> arbitrary + -- | 'Semigroup' under '<*>' and '<>'. newtype AppMerge f a = AppMerge { runAppMerge :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) +-- $ Associativity: +-- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String) instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b) @@ -23,6 +30,8 @@ instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where newtype App f a = App { runApp :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) +-- $ Associativity: +-- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: App Maybe Integer) instance Applicative f => Semigroup (App f a) where App a <> App b = App (a *> b) From 6be056bd9ad6ac5fdce2b38754932d77a2b43255 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:16:31 -0400 Subject: [PATCH 39/45] Swap the order of the types. --- src/Data/Semigroup/App.hs | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 78922f68c..8292024e7 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Semigroup.App -( AppMerge(..) -, App(..) +( App(..) +, AppMerge(..) ) where import Control.Applicative @@ -12,20 +12,6 @@ import Data.Semigroup -- >>> instance Arbitrary (f a) => Arbitrary (App f a) where arbitrary = App <$> arbitrary -- >>> instance Arbitrary (f a) => Arbitrary (AppMerge f a) where arbitrary = AppMerge <$> arbitrary --- | 'Semigroup' under '<*>' and '<>'. -newtype AppMerge f a = AppMerge { runAppMerge :: f a } - deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) - --- $ Associativity: --- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String) -instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where - AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b) - -instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where - mempty = AppMerge (pure mempty) - mappend = (<>) - - -- | 'Semigroup' under '*>'. newtype App f a = App { runApp :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) @@ -38,3 +24,17 @@ instance Applicative f => Semigroup (App f a) where instance (Applicative f, Monoid a) => Monoid (App f a) where mempty = App (pure mempty) mappend = (<>) + + +-- | 'Semigroup' under '<*>' and '<>'. +newtype AppMerge f a = AppMerge { runAppMerge :: f a } + deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) + +-- $ Associativity: +-- prop> \ a b c -> a <> (b <> c) == (a <> b) <> (c :: AppMerge Maybe String) +instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where + AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b) + +instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where + mempty = AppMerge (pure mempty) + mappend = (<>) From b55010c2c1e5339bd311287a28dd10ec329a98a7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:22:34 -0400 Subject: [PATCH 40/45] Define shrinking. --- src/Data/Semigroup/App.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 8292024e7..506fafe80 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -9,8 +9,8 @@ import Data.Semigroup -- $setup -- >>> import Test.QuickCheck --- >>> instance Arbitrary (f a) => Arbitrary (App f a) where arbitrary = App <$> arbitrary --- >>> instance Arbitrary (f a) => Arbitrary (AppMerge f a) where arbitrary = AppMerge <$> arbitrary +-- >>> instance Arbitrary (f a) => Arbitrary (App f a) where arbitrary = App <$> arbitrary ; shrink = map App . shrink . runApp +-- >>> instance Arbitrary (f a) => Arbitrary (AppMerge f a) where arbitrary = AppMerge <$> arbitrary ; shrink = map AppMerge . shrink . runAppMerge -- | 'Semigroup' under '*>'. newtype App f a = App { runApp :: f a } From aab509cf63ea1d858e39b64f75f00c79a2a2c6f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:26:07 -0400 Subject: [PATCH 41/45] Test the identity properties. --- src/Data/Semigroup/App.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 506fafe80..ccd10f4f5 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -21,6 +21,9 @@ newtype App f a = App { runApp :: f a } instance Applicative f => Semigroup (App f a) where App a <> App b = App (a *> b) +-- $ Identity: +-- prop> \ a -> mempty <> a == (a :: App Maybe String) +-- prop> \ a -> a <> mempty == (a :: App Maybe String) instance (Applicative f, Monoid a) => Monoid (App f a) where mempty = App (pure mempty) mappend = (<>) @@ -35,6 +38,9 @@ newtype AppMerge f a = AppMerge { runAppMerge :: f a } instance (Applicative f, Semigroup a) => Semigroup (AppMerge f a) where AppMerge a <> AppMerge b = AppMerge ((<>) <$> a <*> b) +-- $ Identity: +-- prop> \ a -> mempty <> a == (a :: AppMerge Maybe String) +-- prop> \ a -> a <> mempty == (a :: AppMerge Maybe String) instance (Applicative f, Monoid a, Semigroup a) => Monoid (AppMerge f a) where mempty = AppMerge (pure mempty) mappend = (<>) From 6a785e0b30beb64d8feda6666f54a36c7816b8d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:26:32 -0400 Subject: [PATCH 42/45] =?UTF-8?q?Remove=20the=20Monoid=20instance=20for=20?= =?UTF-8?q?App,=20as=20it=E2=80=99s=20unlawful.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Semigroup/App.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index ccd10f4f5..58d666076 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -21,13 +21,6 @@ newtype App f a = App { runApp :: f a } instance Applicative f => Semigroup (App f a) where App a <> App b = App (a *> b) --- $ Identity: --- prop> \ a -> mempty <> a == (a :: App Maybe String) --- prop> \ a -> a <> mempty == (a :: App Maybe String) -instance (Applicative f, Monoid a) => Monoid (App f a) where - mempty = App (pure mempty) - mappend = (<>) - -- | 'Semigroup' under '<*>' and '<>'. newtype AppMerge f a = AppMerge { runAppMerge :: f a } From d645481dcfd182b2d3fbd5d68359087d3bd4838b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 21 Mar 2018 17:29:48 -0400 Subject: [PATCH 43/45] :memo: AppMerge is a Monoid too. --- src/Data/Semigroup/App.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Semigroup/App.hs b/src/Data/Semigroup/App.hs index 58d666076..4ed13ff3c 100644 --- a/src/Data/Semigroup/App.hs +++ b/src/Data/Semigroup/App.hs @@ -22,7 +22,7 @@ instance Applicative f => Semigroup (App f a) where App a <> App b = App (a *> b) --- | 'Semigroup' under '<*>' and '<>'. +-- | 'Semigroup' and 'Monoid' under '<*>' and '<>'. newtype AppMerge f a = AppMerge { runAppMerge :: f a } deriving (Alternative, Applicative, Bounded, Enum, Eq, Foldable, Functor, Monad, Ord, Show, Traversable) From 9a91728d4e7edd2c4375ad54627e2762a3398e74 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Thu, 22 Mar 2018 09:28:11 -0700 Subject: [PATCH 44/45] Only one require/load Co-Authored-By: Josh Vera --- src/Analysis/Abstract/Evaluating.hs | 23 ++++------------------- src/Data/Syntax/Declaration.hs | 6 +++--- src/Language/PHP/Syntax.hs | 4 ++-- src/Language/Ruby/Syntax.hs | 4 ++-- 4 files changed, 11 insertions(+), 26 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 01d47c0b1..ad21ae6ec 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -4,9 +4,7 @@ module Analysis.Abstract.Evaluating , evaluate , evaluates , require -, require' , load -, load' ) where import Control.Abstract.Evaluator @@ -74,34 +72,21 @@ withModules Blob{..} pairs = localModuleTable (const moduleTable) _ -> toName path toName str = qualifiedName (fmap BC.pack (splitWhen (== pathSeparator) str)) - --- | Require/import another module by name and return it's environment +-- | Require/import another module by name and return it's environment and value. -- -- Looks up the term's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. require :: (MonadAnalysis term value m, MonadValue value m) - => ModuleName - -> m (EnvironmentFor value) -require name = fst <$> require' name - --- | Require/import another module by name and return it's environment and value. -require' :: (MonadAnalysis term value m, MonadValue value m) => ModuleName -> m (EnvironmentFor value, value) -require' name = getModuleTable >>= maybe (load' name) pure . moduleTableLookup name +require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup name --- | Load another module by name and return it's environment +-- | Load another module by name and return it's environment and value. -- -- Always loads/evaluates. load :: (MonadAnalysis term value m, MonadValue value m) - => ModuleName - -> m (EnvironmentFor value) -load name = fst <$> load' name - --- | Load another module by name and return it's environment and value. -load' :: (MonadAnalysis term value m, MonadValue value m) => ModuleName -> m (EnvironmentFor value, value) -load' name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name +load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name where notFound = fail ("cannot load module: " <> show name) evalAndCache :: (MonadAnalysis term value m, MonadValue value m) => [term] -> m (EnvironmentFor value, value) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 9c622b29b..d5abbdde4 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -244,7 +244,7 @@ instance Show1 QualifiedExportFrom where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedExportFrom where eval (QualifiedExportFrom from exportSymbols) = do let moduleName = freeVariable (subterm from) - importedEnv <- isolate (require moduleName) + (importedEnv, _) <- isolate (require moduleName) -- Look up addresses in importedEnv and insert the aliases with addresses into the exports. for_ exportSymbols $ \(name, alias) -> do let address = Env.lookup name importedEnv @@ -277,7 +277,7 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec instance Evaluatable QualifiedImport where eval (QualifiedImport from alias xs) = do - importedEnv <- isolate (require moduleName) + (importedEnv, _) <- isolate (require moduleName) modifyEnv (mappend (Env.overwrite (renames importedEnv) importedEnv)) unit where @@ -300,7 +300,7 @@ instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where eval (Import from xs _) = do - importedEnv <- isolate (require moduleName) + (importedEnv, _) <- isolate (require moduleName) modifyEnv (mappend (renamed importedEnv)) unit where diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 2361a5a30..116565cef 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -36,14 +36,14 @@ instance Evaluatable VariableName doInclude :: (MonadValue value m, MonadAnalysis term value m) => Subterm t (m value) -> m value doInclude path = do name <- toQualifiedName <$> (subtermValue path >>= asString) - (importedEnv, v) <- isolate (load' name) + (importedEnv, v) <- isolate (load name) modifyEnv (mappend importedEnv) pure v doIncludeOnce :: (MonadValue value m, MonadAnalysis term value m) => Subterm t (m value) -> m value doIncludeOnce path = do name <- toQualifiedName <$> (subtermValue path >>= asString) - (importedEnv, v) <- isolate (require' name) + (importedEnv, v) <- isolate (require name) modifyEnv (mappend importedEnv) pure v diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 04a6792ad..0da7d083d 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -34,7 +34,7 @@ doRequire :: (MonadAnalysis term value m, MonadValue value m) doRequire name = do moduleTable <- getModuleTable case moduleTableLookup name moduleTable of - Nothing -> (,) <$> load name <*> boolean True + Nothing -> (,) <$> (fst <$> load name) <*> boolean True Just (env, _) -> (,) <$> pure env <*> boolean False @@ -57,7 +57,7 @@ instance Evaluatable Load where doLoad :: (MonadAnalysis term value m, MonadValue value m) => ByteString -> Bool -> m value doLoad path shouldWrap = do - importedEnv <- isolate (load (toName path)) + (importedEnv, _) <- isolate (load (toName path)) unless shouldWrap $ modifyEnv (mappend importedEnv) boolean Prelude.True -- load always returns true. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-load where From 9d97b8f6c7bff846e70b898a1c20d4390bfcfeed Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Thu, 22 Mar 2018 12:31:53 -0400 Subject: [PATCH 45/45] Add a spec for subclassing --- test/Analysis/Ruby/Spec.hs | 4 ++++ test/fixtures/ruby/analysis/subclass.rb | 13 +++++++++++++ 2 files changed, 17 insertions(+) create mode 100644 test/fixtures/ruby/analysis/subclass.rb diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index b948e45e3..52eab9fd2 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -26,6 +26,10 @@ spec = parallel $ do fst res `shouldBe` Left "free variable: \"foo\"" snd res `shouldBe` [] + it "subclass" $ do + res <- evaluate' "subclass.rb" + fst res `shouldBe` Right (injValue (String "\"\"")) + where addr = Address . Precise fixtures = "test/fixtures/ruby/analysis/" diff --git a/test/fixtures/ruby/analysis/subclass.rb b/test/fixtures/ruby/analysis/subclass.rb new file mode 100644 index 000000000..caae510a9 --- /dev/null +++ b/test/fixtures/ruby/analysis/subclass.rb @@ -0,0 +1,13 @@ +class Foo + def inspect + "" + end +end + +class Bar < Foo + def inspect + "" + end +end + +Bar.inspect()