Merge branch 'master' into call-graph-tests

.hlint.yaml

@@ -19,6 +19,12 @@
 # Generalise map to fmap, ++ to <>
 - group: {name: generalise, enabled: true}
 
+# Change the severity of the default group to warning
+- warn: {group: {name: default}}
+
+# Ignore the highly noisy module export list hint
+- ignore: {name: Use module export list}
+
 # Ignore some builtin hints
 - ignore: {name: Use mappend}
 - ignore: {name: Redundant do}

src/Data/Abstract/Declarations.hs

@@ -1,7 +1,6 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
 module Data.Abstract.Declarations  where
 
-import Data.Abstract.FreeVariables
 import Data.Abstract.Name
 import Data.Sum
 import Data.Term
@@ -12,19 +11,21 @@ class Declarations syntax where
   declaredName = const Nothing
 
 class Declarations1 syntax where
-  -- | Lift a function mapping each element to its set of free variables through a containing structure, collecting the results into a single set.
-  liftDeclaredName :: (a -> [Name]) -> syntax a -> Maybe Name
+  -- | Lift a function mapping each element to its declared name (if any) through a containing structure. This can be used to define the declared name for a composite piece of syntax in terms of the declared name of one of its components.
+  --
+  -- Note that not all syntax will have a declared name; in general it’s reserved for syntax where the user has provided a single, unambiguous name for whatever term is being introduced. Examples would be (non-anonymous) functions, methods, and classes; but not (generally) literals or blocks of imperative statements.
+  liftDeclaredName :: (a -> Maybe Name) -> syntax a -> Maybe Name
   liftDeclaredName _ _ = Nothing
 
 instance Declarations t => Declarations (Subterm t a) where
   declaredName = declaredName . subterm
 
-deriving instance (Declarations1 syntax, FreeVariables1 syntax) => Declarations (Term syntax ann)
+deriving instance Declarations1 syntax => Declarations (Term syntax ann)
 
-instance (FreeVariables recur, Declarations1 syntax) => Declarations (TermF syntax ann recur) where
-  declaredName = liftDeclaredName freeVariables . termFOut
+instance (Declarations recur, Declarations1 syntax) => Declarations (TermF syntax ann recur) where
+  declaredName = liftDeclaredName declaredName . termFOut
 
-instance (Apply Declarations1 fs) => Declarations1 (Sum fs) where
+instance Apply Declarations1 fs => Declarations1 (Sum fs) where
   liftDeclaredName f = apply @Declarations1 (liftDeclaredName f)
 
 instance Declarations1 []

src/Data/Abstract/Evaluatable.hs

@@ -206,7 +206,7 @@ instance HasPostlude 'JavaScript where
 
 -- | The type of error thrown when failing to evaluate a term.
 data EvalError return where
-  FreeVariablesError :: [Name] -> EvalError Name
+  NoNameError :: EvalError Name
   -- Indicates that our evaluator wasn't able to make sense of these literals.
   IntegerFormatError  :: Text -> EvalError Integer
   FloatFormatError    :: Text -> EvalError Scientific
@@ -218,7 +218,7 @@ deriving instance Eq (EvalError return)
 deriving instance Show (EvalError return)
 
 instance Eq1 EvalError where
-  liftEq _ (FreeVariablesError a) (FreeVariablesError b)   = a == b
+  liftEq _ NoNameError        NoNameError                  = True
   liftEq _ DefaultExportError DefaultExportError           = True
   liftEq _ (ExportError a b) (ExportError c d)             = (a == c) && (b == d)
   liftEq _ (IntegerFormatError a) (IntegerFormatError b)   = a == b

src/Data/Abstract/FreeVariables.hs

@@ -9,7 +9,7 @@ import           Prologue
 -- | Types which can contain unbound variables.
 class FreeVariables term where
   -- | The set of free variables in the given value.
-  freeVariables :: term -> [Name]
+  freeVariables :: term -> Set Name
 
 
 -- | A lifting of 'FreeVariables' to type constructors of kind @* -> *@.
@@ -17,20 +17,11 @@ class FreeVariables term where
 --   'Foldable' types requiring no additional semantics to the set of free variables (e.g. types which do not bind any variables) can use (and even derive, with @-XDeriveAnyClass@) the default implementation.
 class FreeVariables1 syntax where
   -- | Lift a function mapping each element to its set of free variables through a containing structure, collecting the results into a single set.
-  liftFreeVariables :: (a -> [Name]) -> syntax a -> [Name]
-  default liftFreeVariables :: (Foldable syntax) => (a -> [Name]) -> syntax a -> [Name]
+  liftFreeVariables :: (a -> Set Name) -> syntax a -> Set Name
+  default liftFreeVariables :: (Foldable syntax) => (a -> Set Name) -> syntax a -> Set Name
   liftFreeVariables = foldMap
 
--- | Lift the 'freeVariables' method through a containing structure.
-freeVariables1 :: (FreeVariables1 t, FreeVariables a) => t a -> [Name]
-freeVariables1 = liftFreeVariables freeVariables
-
-freeVariable :: FreeVariables term => term -> Either [Name] Name
-freeVariable term = case freeVariables term of
-  [n] -> Right n
-  xs -> Left xs
-
-instance (FreeVariables t) => FreeVariables (Subterm t a) where
+instance FreeVariables t => FreeVariables (Subterm t a) where
   freeVariables = freeVariables . subterm
 
 deriving instance FreeVariables1 syntax => FreeVariables (Term syntax ann)
@@ -38,10 +29,10 @@ deriving instance FreeVariables1 syntax => FreeVariables (Term syntax ann)
 instance (FreeVariables recur, FreeVariables1 syntax) => FreeVariables (TermF syntax ann recur) where
   freeVariables = liftFreeVariables freeVariables
 
-instance (FreeVariables1 syntax) => FreeVariables1 (TermF syntax ann) where
+instance FreeVariables1 syntax => FreeVariables1 (TermF syntax ann) where
   liftFreeVariables f (In _ s) = liftFreeVariables f s
 
-instance (Apply FreeVariables1 fs) => FreeVariables1 (Sum fs) where
+instance Apply FreeVariables1 fs => FreeVariables1 (Sum fs) where
   liftFreeVariables f = apply @FreeVariables1 (liftFreeVariables f)
 
 instance FreeVariables1 []

src/Data/Syntax.hs

@@ -5,12 +5,16 @@ module Data.Syntax where
 import Data.Abstract.Evaluatable
 import Data.Aeson (ToJSON(..), object)
 import Data.AST
+import Data.Char (toLower)
 import Data.JSON.Fields
 import Data.Range
 import Data.Record
+import qualified Data.Set as Set
 import Data.Span
 import Data.Sum
 import Data.Term
+import GHC.Types (Constraint)
+import GHC.TypeLits
 import Diffing.Algorithm hiding (Empty)
 import Prelude
 import Prologue
@@ -18,12 +22,9 @@ import qualified Assigning.Assignment as Assignment
 import qualified Data.Error as Error
 import Proto3.Suite.Class
 import Proto3.Wire.Types
-import GHC.Types (Constraint)
-import GHC.TypeLits
 import qualified Proto3.Suite.DotProto as Proto
 import qualified Proto3.Wire.Encode as Encode
 import qualified Proto3.Wire.Decode as Decode
-import Data.Char (toLower)
 
 -- Combinators
 
@@ -166,7 +167,7 @@ instance Evaluatable Identifier where
   eval (Identifier name) = pure (LvalLocal name)
 
 instance FreeVariables1 Identifier where
-  liftFreeVariables _ (Identifier x) = pure x
+  liftFreeVariables _ (Identifier x) = Set.singleton x
 
 instance Declarations1 Identifier where
   liftDeclaredName _ (Identifier x) = pure x

src/Data/Syntax/Declaration.hs

@@ -4,13 +4,13 @@ module Data.Syntax.Declaration where
 import qualified Data.Abstract.Environment as Env
 import           Data.Abstract.Evaluatable
 import           Data.JSON.Fields
-import qualified Data.Set as Set (fromList)
+import qualified Data.Set as Set
 import           Diffing.Algorithm
 import           Prologue
 import           Proto3.Suite.Class
 
 data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
-  deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, ToJSONFields1, Named1, Message1)
+  deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, ToJSONFields1, Named1, Message1)
 
 instance Diffable Function where
   equivalentBySubterm = Just . functionName
@@ -24,23 +24,21 @@ instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Function where
   eval Function{..} = do
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm functionName)
-    (_, addr) <- letrec name (closure (paramNames functionParameters) (Set.fromList (freeVariables functionBody)) (subtermAddress functionBody))
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm functionName))
+    (_, addr) <- letrec name (closure (paramNames functionParameters) (freeVariables functionBody) (subtermAddress functionBody))
     bind name addr
     pure (Rval addr)
-    where paramNames = foldMap (freeVariables . subterm)
-
-instance Declarations a => Declarations (Function a) where
-  declaredName Function{..} = declaredName functionName
+    where paramNames = foldMap (maybeToList . declaredName . subterm)
 
 instance Declarations1 Function where
-  liftDeclaredName declaredName Function{..} =
-    case declaredName functionName of
-      [] -> Nothing
-      (x:_) -> Just x
+  liftDeclaredName declaredName = declaredName . functionName
+
+instance FreeVariables1 Function where
+  liftFreeVariables freeVariables f@Function{..} = foldMap freeVariables f `Set.difference` foldMap freeVariables functionParameters
+
 
 data Method a = Method { methodContext :: ![a], methodReceiver :: !a, methodName :: !a, methodParameters :: ![a], methodBody :: !a }
-  deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, FreeVariables1, Declarations1, ToJSONFields1, Named1, Message1)
+  deriving (Eq, Ord, Show, Foldable, Traversable, Functor, Generic1, Hashable1, Mergeable, ToJSONFields1, Named1, Message1)
 
 instance Eq1 Method where liftEq = genericLiftEq
 instance Ord1 Method where liftCompare = genericLiftCompare
@@ -53,11 +51,17 @@ instance Diffable Method where
 -- local environment.
 instance Evaluatable Method where
   eval Method{..} = do
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm methodName)
-    (_, addr) <- letrec name (closure (paramNames methodParameters) (Set.fromList (freeVariables methodBody)) (subtermAddress methodBody))
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm methodName))
+    (_, addr) <- letrec name (closure (paramNames methodParameters) (freeVariables methodBody) (subtermAddress methodBody))
     bind name addr
     pure (Rval addr)
-    where paramNames = foldMap (freeVariables . subterm)
+    where paramNames = foldMap (maybeToList . declaredName . subterm)
+
+instance Declarations1 Method where
+  liftDeclaredName declaredName = declaredName . methodName
+
+instance FreeVariables1 Method where
+  liftFreeVariables freeVariables m@Method{..} = foldMap freeVariables m `Set.difference` foldMap freeVariables methodParameters
 
 
 -- | A method signature in TypeScript or a method spec in Go.
@@ -167,7 +171,7 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Class where
   eval Class{..} = do
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier))
     supers <- traverse subtermAddress classSuperclasses
     (_, addr) <- letrec name $ do
       void $ subtermValue classBody
@@ -249,7 +253,7 @@ instance Show1 TypeAlias where liftShowsPrec = genericLiftShowsPrec
 -- TODO: Implement Eval instance for TypeAlias
 instance Evaluatable TypeAlias where
   eval TypeAlias{..} = do
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable (subterm typeAliasIdentifier))
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm typeAliasIdentifier))
     v <- subtermValue typeAliasKind
     addr <- lookupOrAlloc name
     assign addr v

src/Data/Syntax/Statement.hs

@@ -99,7 +99,7 @@ instance Show1 Let where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Let where
   eval Let{..} = do
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm letVariable)
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm letVariable))
     addr <- snd <$> letrec name (subtermValue letValue)
     Rval <$> locally (bind name addr *> subtermAddress letBody)
 

src/Language/Go/Syntax.hs

@@ -84,7 +84,7 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable QualifiedImport where
   eval (QualifiedImport importPath aliasTerm) = do
     paths <- resolveGoImport importPath
-    alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
+    alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm))
     void . letrec' alias $ \addr -> do
       for_ paths $ \p -> do
         traceResolve (unPath importPath) p

src/Language/PHP/Assignment.hs

@@ -489,6 +489,9 @@ namespaceNameAsPrefix = symbol NamespaceNameAsPrefix *> children (term namespace
 namespaceName :: Assignment Term
 namespaceName = makeTerm <$> symbol NamespaceName <*> children (Syntax.NamespaceName <$> someTerm' name)
 
+namespaceName' :: Assignment (NonEmpty Term)
+namespaceName' = symbol NamespaceName *> children (someTerm' name)
+
 updateExpression :: Assignment Term
 updateExpression = makeTerm <$> symbol UpdateExpression <*> children (Syntax.Update <$> term expression)
 
@@ -704,7 +707,7 @@ traitAliasAsClause :: Assignment Term
 traitAliasAsClause = makeTerm <$> symbol TraitAliasAsClause <*> children (Syntax.AliasAs <$> term (classConstantAccessExpression <|> name) <*> (term visibilityModifier <|> emptyTerm) <*> (term name <|> emptyTerm))
 
 namespaceDefinition :: Assignment Term
-namespaceDefinition = makeTerm <$> symbol NamespaceDefinition <*> children (Syntax.Namespace <$> (term namespaceName <|> emptyTerm) <*> (term compoundStatement <|> emptyTerm))
+namespaceDefinition = makeTerm <$> symbol NamespaceDefinition <*> children (Syntax.Namespace <$> (toList <$> namespaceName' <|> pure []) <*> (term compoundStatement <|> emptyTerm))
 
 namespaceUseDeclaration :: Assignment Term
 namespaceUseDeclaration = makeTerm <$> symbol NamespaceUseDeclaration <*> children (Syntax.NamespaceUseDeclaration <$>

src/Language/PHP/Syntax.hs

@@ -361,7 +361,7 @@ instance Ord1 NamespaceUseGroupClause where liftCompare = genericLiftCompare
 instance Show1 NamespaceUseGroupClause where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable NamespaceUseGroupClause
 
-data Namespace a = Namespace { namespaceName :: a, namespaceBody :: a }
+data Namespace a = Namespace { namespaceName :: [a], namespaceBody :: a }
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)
 
 instance Eq1 Namespace where liftEq = genericLiftEq
@@ -369,16 +369,20 @@ instance Ord1 Namespace where liftCompare = genericLiftCompare
 instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Namespace where
-  eval Namespace{..} = rvalBox =<< go (freeVariables (subterm namespaceName))
+  eval Namespace{..} = rvalBox =<< go (declaredName . subterm <$> namespaceName)
     where
       -- Each namespace name creates a closure over the subsequent namespace closures
-      go (name:x:xs) = letrec' name $ \addr ->
-        go (x:xs) <* makeNamespace name addr Nothing
+      go (n:x:xs) = do
+        name <- maybeM (throwResumable NoNameError) n
+        letrec' name $ \addr ->
+          go (x:xs) <* makeNamespace name addr Nothing
       -- The last name creates a closure over the namespace body.
-      go names = do
-        name <- maybeM (throwEvalError (FreeVariablesError [])) (listToMaybe names)
+      go [n] = do
+        name <- maybeM (throwResumable NoNameError) n
         letrec' name $ \addr ->
           subtermValue namespaceBody *> makeNamespace name addr Nothing
+      -- The absence of names implies global scope, cf http://php.net/manual/en/language.namespaces.definitionmultiple.php
+      go [] = subtermValue namespaceBody
 
 data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] }
   deriving (Declarations1, Diffable, Eq, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Mergeable, Ord, Show, ToJSONFields1, Traversable)

src/Language/Python/Syntax.hs

@@ -171,7 +171,7 @@ instance Evaluatable QualifiedAliasedImport where
     for_ (NonEmpty.init modulePaths) require
 
     -- Evaluate and import the last module, aliasing and updating the environment
-    alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
+    alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm))
     rvalBox =<< letrec' alias (\addr -> do
       let path = NonEmpty.last modulePaths
       importedEnv <- fst <$> require path

src/Language/Ruby/Syntax.hs

@@ -132,7 +132,7 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable Class where
   eval Class{..} = do
     super <- traverse subtermAddress classSuperClass
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm classIdentifier)
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm classIdentifier))
     rvalBox =<< letrec' name (\addr ->
       subtermValue classBody <* makeNamespace name addr super)
 
@@ -145,7 +145,7 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Module where
   eval (Module iden xs) = do
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm iden))
     rvalBox =<< letrec' name (\addr ->
       value =<< (eval xs <* makeNamespace name addr Nothing))
 

src/Language/TypeScript/Syntax.hs

@@ -191,7 +191,7 @@ instance Show1 JavaScriptRequire where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable JavaScriptRequire where
   eval (JavaScriptRequire aliasTerm importPath) = do
     modulePath <- resolveWithNodejsStrategy importPath javascriptExtensions
-    alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
+    alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm))
     rvalBox =<< evalRequire modulePath alias
 
 
@@ -205,7 +205,7 @@ instance Show1 QualifiedAliasedImport where liftShowsPrec = genericLiftShowsPrec
 instance Evaluatable QualifiedAliasedImport where
   eval (QualifiedAliasedImport aliasTerm importPath) = do
     modulePath <- resolveWithNodejsStrategy importPath typescriptExtensions
-    alias <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm aliasTerm)
+    alias <- maybeM (throwEvalError NoNameError) (declaredName (subterm aliasTerm))
     rvalBox =<< evalRequire modulePath alias
 
 newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
@@ -676,7 +676,7 @@ instance Show1 Module where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable Module where
   eval (Module iden xs) = do
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm iden))
     rvalBox =<< letrec' name (\addr ->
       value =<< (eval xs <* makeNamespace name addr Nothing))
 
@@ -690,7 +690,7 @@ instance Show1 InternalModule where liftShowsPrec = genericLiftShowsPrec
 
 instance Evaluatable InternalModule where
   eval (InternalModule iden xs) = do
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm iden)
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm iden))
     rvalBox =<< letrec' name (\addr ->
       value =<< (eval xs <* makeNamespace name addr Nothing))
 
@@ -741,7 +741,7 @@ instance Declarations a => Declarations (AbstractClass a) where
 
 instance Evaluatable AbstractClass where
   eval AbstractClass{..} = do
-    name <- either (throwEvalError . FreeVariablesError) pure (freeVariable $ subterm abstractClassIdentifier)
+    name <- maybeM (throwEvalError NoNameError) (declaredName (subterm abstractClassIdentifier))
     supers <- traverse subtermAddress classHeritage
     (v, addr) <- letrec name $ do
       void $ subtermValue classBody

src/Semantic/Graph.hs

@@ -213,14 +213,14 @@ resumingResolutionError = runResolutionErrorWith (\ err -> trace ("ResolutionErr
 resumingLoadError :: (Member Trace effects, AbstractHole address, Effects effects) => Evaluator address value (Resumable (LoadError address) ': effects) a -> Evaluator address value effects a
 resumingLoadError = runLoadErrorWith (\ (ModuleNotFound path) -> trace ("LoadError: " <> path) $> (lowerBound, hole))
 
-resumingEvalError :: (Member Trace effects, Effects effects) => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a
+resumingEvalError :: (Member Fresh effects, Member Trace effects, Effects effects) => Evaluator address value (Resumable EvalError ': effects) a -> Evaluator address value effects a
 resumingEvalError = runEvalErrorWith (\ err -> trace ("EvalError" <> show err) *> case err of
-  DefaultExportError{}     -> pure ()
-  ExportError{}            -> pure ()
-  IntegerFormatError{}     -> pure 0
-  FloatFormatError{}       -> pure 0
-  RationalFormatError{}    -> pure 0
-  FreeVariablesError names -> pure (fromMaybeLast (name "unknown") names))
+  DefaultExportError{}  -> pure ()
+  ExportError{}         -> pure ()
+  IntegerFormatError{}  -> pure 0
+  FloatFormatError{}    -> pure 0
+  RationalFormatError{} -> pure 0
+  NoNameError           -> gensym)
 
 resumingUnspecialized :: (Member Trace effects, AbstractHole value, Effects effects) => Evaluator address value (Resumable (Unspecialized value) ': effects) a -> Evaluator address value effects a
 resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> trace ("Unspecialized:" <> show err) $> hole)