From a7e9d510224bbf629c6a5d11e4f2c2cbb851c6c5 Mon Sep 17 00:00:00 2001 From: Patrick Thomson <patrickt@github.com> Date: Mon, 26 Mar 2018 13:54:01 -0400 Subject: [PATCH 01/38] Evaluate let-clauses. I don't know if I did this right. @robrix, can you check my work? --- src/Data/Syntax/Statement.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index d55eb2f9e..9b09810c1 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -77,8 +77,11 @@ instance Eq1 Let where liftEq = genericLiftEq instance Ord1 Let where liftCompare = genericLiftCompare instance Show1 Let where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Let -instance Evaluatable Let +instance Evaluatable Let where + eval Let{..} = do + addr <- snd <$> letrec name (subtermValue letValue) + localEnv (Env.insert name addr) (subtermValue letBody) + where name = freeVariable (subterm letVariable) -- Assignment From 414e100d5e8a6187655ff97034ffbe384abc7df9 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Mon, 26 Mar 2018 16:29:32 -0400 Subject: [PATCH 02/38] Add NamespaceError --- src/Control/Abstract/Value.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 366d47b1c..7fe3c7ddb 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -177,10 +177,12 @@ class ValueRoots value where data ValueExc value resume where ValueExc :: Prelude.String -> ValueExc value value StringExc :: Prelude.String -> ValueExc value ByteString + NamespaceError :: Prelude.String -> ValueExc value (EnvironmentFor value) instance Eq1 (ValueExc value) where liftEq _ (ValueExc a) (ValueExc b) = a == b liftEq _ (StringExc a) (StringExc b) = a == b + liftEq _ (NamespaceError a) (NamespaceError b) = a == b liftEq _ _ _ = False deriving instance Show (ValueExc value resume) From 09506958102a3ac9619ae93bac22cc48ac720a83 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Mon, 26 Mar 2018 17:00:42 -0400 Subject: [PATCH 03/38] Add ValueExc to MonadEvaluatable --- src/Data/Abstract/Evaluatable.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 9cfdbca11..8e0dba477 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -31,6 +31,7 @@ type MonadEvaluatable term value m = , MonadAddressable (LocationFor value) value m , MonadAnalysis term value m , MonadThrow (Unspecialized value) m + , MonadThrow (ValueExc value) m , MonadValue value m , Recursive term , Show (LocationFor value) From aaefc8f4e3dd10d5278dd3c85cc1e9b5fa2f77e1 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Mon, 26 Mar 2018 17:03:23 -0400 Subject: [PATCH 04/38] Throw a NamespaceError --- src/Data/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index b3ec5bb85..f9b36df10 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -227,7 +227,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where pure (injValue (Namespace n (env' <> env))) where asNamespaceEnv v | Just (Namespace _ env') <- prjValue v = pure env' - | otherwise = fail ("expected " <> show v <> " to be a namespace") + | otherwise = throwException $ NamespaceError ("expected " <> show v <> " to be a namespace") scopedEnvironment o | Just (Class _ env) <- prjValue o = pure env From 9ef46dabe6ff1803cbe77ab5125fb35359e6f54a Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Tue, 27 Mar 2018 12:46:00 -0400 Subject: [PATCH 05/38] Add a couple of exceptions --- src/Control/Abstract/Value.hs | 12 +++++++----- src/Data/Abstract/Value.hs | 4 ++-- 2 files changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 7fe3c7ddb..4e786aea9 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -21,7 +21,7 @@ import Control.Abstract.Evaluator import Data.Abstract.FreeVariables import Data.Abstract.Number as Number import Data.Scientific (Scientific) -import Prologue +import Prologue hiding (TypeError) -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP -- have built-in generalized-comparison ("spaceship") operators. If you want to @@ -175,14 +175,16 @@ class ValueRoots value where -- The type of exceptions that can be thrown when constructing values in `MonadValue`. data ValueExc value resume where - ValueExc :: Prelude.String -> ValueExc value value - StringExc :: Prelude.String -> ValueExc value ByteString + TypeError :: Prelude.String -> ValueExc value value + StringError :: Prelude.String -> ValueExc value ByteString NamespaceError :: Prelude.String -> ValueExc value (EnvironmentFor value) + ScopedEnvironmentError :: Prelude.String -> ValueExc value (EnvironmentFor value) instance Eq1 (ValueExc value) where - liftEq _ (ValueExc a) (ValueExc b) = a == b - liftEq _ (StringExc a) (StringExc b) = a == b + liftEq _ (TypeError a) (TypeError b) = a == b + liftEq _ (StringError a) (StringError b) = a == b liftEq _ (NamespaceError a) (NamespaceError b) = a == b + liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b liftEq _ _ _ = False deriving instance Show (ValueExc value resume) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index f9b36df10..02de633b4 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -232,7 +232,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where scopedEnvironment o | Just (Class _ env) <- prjValue o = pure env | Just (Namespace _ env) <- prjValue o = pure env - | otherwise = fail ("object type passed to scopedEnvironment doesn't have an environment: " <> show o) + | otherwise = throwException $ ScopedEnvironmentError ("object type passed to scopedEnvironment doesn't have an environment: " <> show o) asString v | Just (String n) <- prjValue v = pure n @@ -305,7 +305,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where injValue . Closure names l . Env.bind (foldr Set.delete (Set.fromList (freeVariables body)) names) <$> getEnv apply op params = do - Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) + Closure names label env <- maybe (throwException $ TypeError ("expected a closure, got: " <> show op)) pure (prjValue op) bindings <- foldr (\ (name, param) rest -> do v <- param a <- alloc name From 3070481500e12b271f3860bd7b3c57493152ba83 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Tue, 27 Mar 2018 12:53:51 -0400 Subject: [PATCH 06/38] indentation --- src/Control/Abstract/Value.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 4e786aea9..644bee011 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -175,17 +175,17 @@ class ValueRoots value where -- The type of exceptions that can be thrown when constructing values in `MonadValue`. data ValueExc value resume where - TypeError :: Prelude.String -> ValueExc value value - StringError :: Prelude.String -> ValueExc value ByteString - NamespaceError :: Prelude.String -> ValueExc value (EnvironmentFor value) + TypeError :: Prelude.String -> ValueExc value value + StringError :: Prelude.String -> ValueExc value ByteString + NamespaceError :: Prelude.String -> ValueExc value (EnvironmentFor value) ScopedEnvironmentError :: Prelude.String -> ValueExc value (EnvironmentFor value) instance Eq1 (ValueExc value) where - liftEq _ (TypeError a) (TypeError b) = a == b - liftEq _ (StringError a) (StringError b) = a == b - liftEq _ (NamespaceError a) (NamespaceError b) = a == b + liftEq _ (TypeError a) (TypeError b) = a == b + liftEq _ (StringError a) (StringError b) = a == b + liftEq _ (NamespaceError a) (NamespaceError b) = a == b liftEq _ (ScopedEnvironmentError a) (ScopedEnvironmentError b) = a == b - liftEq _ _ _ = False + liftEq _ _ _ = False deriving instance Show (ValueExc value resume) instance Show1 (ValueExc value) where From d0cdd123348ff391776181dd475ea4c14fa602a3 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Tue, 27 Mar 2018 13:11:51 -0400 Subject: [PATCH 07/38] Add EvalError and throw FreeVariableError --- src/Analysis/Abstract/Evaluating.hs | 5 +++-- src/Data/Abstract/Evaluatable.hs | 5 +++++ src/Data/Abstract/Value.hs | 4 ++-- src/Data/Syntax.hs | 3 +-- 4 files changed, 11 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 5d4f51792..134fdbf04 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -30,7 +30,8 @@ deriving instance Member NonDet effects => MonadNonDet (Evaluating term value -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects term value - = '[ Resumable (ValueExc value) + = '[ Resumable (EvalError value) + , Resumable (ValueExc value) , Resumable (Unspecialized value) , Fail -- Failure with an error message , Reader [Module term] -- The stack of currently-evaluating modules. @@ -45,7 +46,7 @@ type EvaluatingEffects term value -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) - => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) value)) + => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) (Either (SomeExc (EvalError value)) value))) findValue (((((v, _), _), _), _), _) = v -- | Find the 'Environment' in the 'Final' result of running. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 8e0dba477..0f6220ba7 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -4,6 +4,7 @@ module Data.Abstract.Evaluatable , MonadEvaluatable , Evaluatable(..) , Unspecialized(..) +, EvalError(..) , evaluateTerm , evaluateModule , withModules @@ -32,11 +33,15 @@ type MonadEvaluatable term value m = , MonadAnalysis term value m , MonadThrow (Unspecialized value) m , MonadThrow (ValueExc value) m + , MonadThrow (EvalError value) m , MonadValue value m , Recursive term , Show (LocationFor value) ) +data EvalError value resume where + FreeVariableError :: Prelude.String -> EvalError value value + data Unspecialized a b where Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 02de633b4..35a9d0b88 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -9,7 +9,7 @@ import Data.Abstract.Evaluatable import qualified Data.Abstract.Number as Number import Data.Scientific (Scientific) import qualified Data.Set as Set -import Prologue +import Prologue hiding (TypeError) import Prelude hiding (Float, Integer, String, Rational, fail) import qualified Prelude @@ -305,7 +305,7 @@ instance (Monad m, MonadEvaluatable term Value m) => MonadValue Value m where injValue . Closure names l . Env.bind (foldr Set.delete (Set.fromList (freeVariables body)) names) <$> getEnv apply op params = do - Closure names label env <- maybe (throwException $ TypeError ("expected a closure, got: " <> show op)) pure (prjValue op) + Closure names label env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op) bindings <- foldr (\ (name, param) rest -> do v <- param a <- alloc name diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index cd22c7328..06cc237e0 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -2,7 +2,6 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack module Data.Syntax where -import Control.Monad.Fail import Data.Abstract.Evaluatable import Data.AST import Data.Range @@ -107,7 +106,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Identifier where - eval (Identifier name) = lookupWith deref name >>= maybe (fail ("free variable: " <> show (friendlyName name))) pure + eval (Identifier name) = lookupWith deref name >>= maybe (throwException $ FreeVariableError ("free variable: " <> show (friendlyName name))) pure instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = pure x From 68423dd298788630a3f8ada09bfabe367584ddac Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Tue, 27 Mar 2018 16:11:43 -0400 Subject: [PATCH 08/38] Store enough information in LoadError --- src/Analysis/Abstract/Evaluating.hs | 4 +-- src/Data/Abstract/Evaluatable.hs | 42 ++++++++++++++++++----------- src/Data/Syntax.hs | 2 +- 3 files changed, 29 insertions(+), 19 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 134fdbf04..a8b65466e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -30,7 +30,7 @@ deriving instance Member NonDet effects => MonadNonDet (Evaluating term value -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects term value - = '[ Resumable (EvalError value) + = '[ Resumable (EvalError term value) , Resumable (ValueExc value) , Resumable (Unspecialized value) , Fail -- Failure with an error message @@ -46,7 +46,7 @@ type EvaluatingEffects term value -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) - => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) (Either (SomeExc (EvalError value)) value))) + => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) (Either (SomeExc (EvalError term value)) value))) findValue (((((v, _), _), _), _), _) = v -- | Find the 'Environment' in the 'Final' result of running. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 0f6220ba7..e788f0dae 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -9,22 +9,23 @@ module Data.Abstract.Evaluatable , evaluateModule , withModules , evaluateModules +, throwEvalError , require , load ) where -import Control.Abstract.Addressable as X -import Control.Abstract.Analysis as X +import Control.Abstract.Addressable as X +import Control.Abstract.Analysis as X import qualified Data.Abstract.Environment as Env import qualified Data.Abstract.Exports as Exports -import Data.Abstract.FreeVariables as X -import Data.Abstract.Module -import Data.Abstract.ModuleTable as ModuleTable -import Data.Semigroup.App -import Data.Semigroup.Foldable -import Data.Term -import Prelude hiding (fail) -import Prologue +import Data.Abstract.FreeVariables as X +import Data.Abstract.Module +import Data.Abstract.ModuleTable as ModuleTable +import Data.Semigroup.App +import Data.Semigroup.Foldable +import Data.Term +import Prelude hiding (fail) +import Prologue type MonadEvaluatable term value m = ( Evaluatable (Base term) @@ -33,14 +34,23 @@ type MonadEvaluatable term value m = , MonadAnalysis term value m , MonadThrow (Unspecialized value) m , MonadThrow (ValueExc value) m - , MonadThrow (EvalError value) m + , MonadThrow (EvalError term value) m , MonadValue value m , Recursive term , Show (LocationFor value) ) -data EvalError value resume where - FreeVariableError :: Prelude.String -> EvalError value value +data EvalError term value resume where + FreeVariableError :: Prelude.String -> EvalError term value value + LoadError :: ModuleName -> EvalError term value [Module term] + +deriving instance Eq (EvalError term a b) +deriving instance Show (EvalError term a b) +instance Show1 (EvalError term value) where + liftShowsPrec _ _ = showsPrec + +throwEvalError :: MonadEvaluatable term value m => EvalError term value resume -> m resume +throwEvalError = throwException data Unspecialized a b where Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value @@ -94,9 +104,9 @@ require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup nam load :: MonadEvaluatable term value m => ModuleName -> m (EnvironmentFor value, value) -load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name +load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= evalAndCache where - notFound = fail ("cannot load module: " <> show name) + notFound = throwEvalError (LoadError name) evalAndCache [] = (,) <$> pure mempty <*> unit evalAndCache [x] = evalAndCache' x @@ -146,5 +156,5 @@ withModules = localModuleTable . const . ModuleTable.fromList evaluateModules :: MonadEvaluatable term value m => [Module term] -> m value -evaluateModules [] = fail "evaluateModules: empty list" +evaluateModules [] = fail "evaluateModules: empty list" evaluateModules (m:ms) = withModules ms (evaluateModule m) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 06cc237e0..de8dcf54f 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -106,7 +106,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Identifier where - eval (Identifier name) = lookupWith deref name >>= maybe (throwException $ FreeVariableError ("free variable: " <> show (friendlyName name))) pure + eval (Identifier name) = lookupWith deref name >>= maybe (throwEvalError (FreeVariableError ("free variable: " <> show (friendlyName name)) :: EvalError term value value)) pure instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = pure x From a3399f92f582d0e6301df3bbe623161d941edc32 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Tue, 27 Mar 2018 16:17:38 -0400 Subject: [PATCH 09/38] remove FreeVariableError for now --- src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Syntax.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index e788f0dae..d72028e82 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -41,7 +41,7 @@ type MonadEvaluatable term value m = ) data EvalError term value resume where - FreeVariableError :: Prelude.String -> EvalError term value value + -- FreeVariableError :: Prelude.String -> EvalError term value value LoadError :: ModuleName -> EvalError term value [Module term] deriving instance Eq (EvalError term a b) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index de8dcf54f..e398368d9 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -106,7 +106,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Identifier where - eval (Identifier name) = lookupWith deref name >>= maybe (throwEvalError (FreeVariableError ("free variable: " <> show (friendlyName name)) :: EvalError term value value)) pure + eval (Identifier name) = lookupWith deref name >>= maybe (fail ("free variable: " <> show (friendlyName name))) pure instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = pure x From ff54bb747508d5e4a4d6afa11ecb05cd73944f94 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Tue, 27 Mar 2018 16:59:23 -0400 Subject: [PATCH 10/38] Export Resumable from Analysis --- src/Control/Abstract/Analysis.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 939a6a457..bd53c2e52 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -19,6 +19,7 @@ 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 Control.Monad.Effect.Resumable as X import Data.Abstract.Module import Data.Coerce import Data.Type.Coercion From ac14425fdcab227334877c6e298e33b22a77aa2c Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Tue, 27 Mar 2018 16:59:40 -0400 Subject: [PATCH 11/38] Add an evaluateRubyImportGraph function --- src/Semantic/Util.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 27e968800..9f5c40012 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -7,6 +7,7 @@ import Analysis.Abstract.Caching import Analysis.Abstract.Dead import Analysis.Abstract.Evaluating as X import Analysis.Abstract.Tracing +import Analysis.Abstract.ImportGraph import Analysis.Declaration import Control.Abstract.Analysis import Control.Monad.IO.Class @@ -34,11 +35,13 @@ import System.FilePath.Posix import qualified Language.Go.Assignment as Go import qualified Language.Python.Assignment as Python +import qualified Language.Ruby.Assignment as Ruby import qualified Language.TypeScript.Assignment as TypeScript -- Ruby evaluateRubyFile = evaluateWithPrelude rubyParser evaluateRubyFiles = evaluateFilesWithPrelude rubyParser +evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing Evaluating Ruby.Term Value) . evaluateModules <$> parseFiles rubyParser paths -- Go evaluateGoFile = evaluateFile goParser From 9ca6b66665467e365084cb70179988be7730f689 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Tue, 27 Mar 2018 16:59:51 -0400 Subject: [PATCH 12/38] hide catchError --- src/Data/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index e398368d9..40bd84dd5 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For HasCallStack module Data.Syntax where -import Data.Abstract.Evaluatable +import Data.Abstract.Evaluatable hiding (catchError) import Data.AST import Data.Range import Data.Record From 4eaffa9f49da13f523a4236a0b711e4bc0b45cd9 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Tue, 27 Mar 2018 17:00:25 -0400 Subject: [PATCH 13/38] Catch LoadErrors in ImportGraph analysis and inject them into the Import Graph --- src/Analysis/Abstract/ImportGraph.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index bdf98caef..9ba76282d 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -11,6 +11,7 @@ import Algebra.Graph.Export.Dot import Control.Abstract.Analysis import Data.Abstract.FreeVariables import Data.Abstract.Module +import Data.Abstract.Evaluatable (EvalError(..)) import Prologue hiding (empty) -- | The graph of function definitions to symbols used in a given program. @@ -34,11 +35,18 @@ deriving instance MonadEvaluator term value (m term value effects) => MonadEvalu instance ( Effectful (m term value) , Member (State ImportGraph) effects , MonadAnalysis term value (m term value effects) + , Member (Resumable (EvalError term value)) effects ) => MonadAnalysis term value (ImportGraphing m term value effects) where type RequiredEffects term value (ImportGraphing m term value effects) = State ImportGraph ': RequiredEffects term value (m term value effects) - analyzeTerm = liftAnalyze analyzeTerm + analyzeTerm eval term = resumeException @(EvalError term value) (liftAnalyze analyzeTerm eval term) (\yield (LoadError name) -> + do + ms <- askModuleStack + let parent = maybe empty (vertex . moduleName) (listToMaybe ms) + modifyImportGraph (parent >< vertex name <>) + yield [] + ) analyzeModule recur m = do ms <- askModuleStack From 7abffcf7bcf012d45b779413b7a39cfa7ea944a3 Mon Sep 17 00:00:00 2001 From: Charlie Somerville <charlie@charlie.bz> Date: Wed, 28 Mar 2018 11:11:19 +1100 Subject: [PATCH 14/38] rename EvalError type to LoadError --- src/Analysis/Abstract/Evaluating.hs | 4 ++-- src/Analysis/Abstract/ImportGraph.hs | 6 +++--- src/Data/Abstract/Evaluatable.hs | 23 +++++++++++------------ 3 files changed, 16 insertions(+), 17 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index a8b65466e..38233afb3 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -30,7 +30,7 @@ deriving instance Member NonDet effects => MonadNonDet (Evaluating term value -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects term value - = '[ Resumable (EvalError term value) + = '[ Resumable (LoadError term value) , Resumable (ValueExc value) , Resumable (Unspecialized value) , Fail -- Failure with an error message @@ -46,7 +46,7 @@ type EvaluatingEffects term value -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) - => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) (Either (SomeExc (EvalError term value)) value))) + => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) (Either (SomeExc (LoadError term value)) value))) findValue (((((v, _), _), _), _), _) = v -- | Find the 'Environment' in the 'Final' result of running. diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 9ba76282d..b21f2c059 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -11,7 +11,7 @@ import Algebra.Graph.Export.Dot import Control.Abstract.Analysis import Data.Abstract.FreeVariables import Data.Abstract.Module -import Data.Abstract.Evaluatable (EvalError(..)) +import Data.Abstract.Evaluatable (LoadError(..)) import Prologue hiding (empty) -- | The graph of function definitions to symbols used in a given program. @@ -35,12 +35,12 @@ deriving instance MonadEvaluator term value (m term value effects) => MonadEvalu instance ( Effectful (m term value) , Member (State ImportGraph) effects , MonadAnalysis term value (m term value effects) - , Member (Resumable (EvalError term value)) effects + , Member (Resumable (LoadError term value)) effects ) => MonadAnalysis term value (ImportGraphing m term value effects) where type RequiredEffects term value (ImportGraphing m term value effects) = State ImportGraph ': RequiredEffects term value (m term value effects) - analyzeTerm eval term = resumeException @(EvalError term value) (liftAnalyze analyzeTerm eval term) (\yield (LoadError name) -> + analyzeTerm eval term = resumeException @(LoadError term value) (liftAnalyze analyzeTerm eval term) (\yield (LoadError name) -> do ms <- askModuleStack let parent = maybe empty (vertex . moduleName) (listToMaybe ms) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index d72028e82..bcb88108e 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -4,12 +4,12 @@ module Data.Abstract.Evaluatable , MonadEvaluatable , Evaluatable(..) , Unspecialized(..) -, EvalError(..) +, LoadError(..) , evaluateTerm , evaluateModule , withModules , evaluateModules -, throwEvalError +, throwLoadError , require , load ) where @@ -34,23 +34,22 @@ type MonadEvaluatable term value m = , MonadAnalysis term value m , MonadThrow (Unspecialized value) m , MonadThrow (ValueExc value) m - , MonadThrow (EvalError term value) m + , MonadThrow (LoadError term value) m , MonadValue value m , Recursive term , Show (LocationFor value) ) -data EvalError term value resume where - -- FreeVariableError :: Prelude.String -> EvalError term value value - LoadError :: ModuleName -> EvalError term value [Module term] +data LoadError term value resume where + LoadError :: ModuleName -> LoadError term value [Module term] -deriving instance Eq (EvalError term a b) -deriving instance Show (EvalError term a b) -instance Show1 (EvalError term value) where +deriving instance Eq (LoadError term a b) +deriving instance Show (LoadError term a b) +instance Show1 (LoadError term value) where liftShowsPrec _ _ = showsPrec -throwEvalError :: MonadEvaluatable term value m => EvalError term value resume -> m resume -throwEvalError = throwException +throwLoadError :: MonadEvaluatable term value m => LoadError term value resume -> m resume +throwLoadError = throwException data Unspecialized a b where Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value @@ -106,7 +105,7 @@ load :: MonadEvaluatable term value m -> m (EnvironmentFor value, value) load name = askModuleTable >>= maybe notFound pure . moduleTableLookup name >>= evalAndCache where - notFound = throwEvalError (LoadError name) + notFound = throwLoadError (LoadError name) evalAndCache [] = (,) <$> pure mempty <*> unit evalAndCache [x] = evalAndCache' x From b1a195f7e764843e824c4e7370ce95ece7b1306c Mon Sep 17 00:00:00 2001 From: Charlie Somerville <charlie@charlie.bz> Date: Wed, 28 Mar 2018 11:24:37 +1100 Subject: [PATCH 15/38] add EvalError type with FreeVariableError constructor --- src/Analysis/Abstract/Evaluating.hs | 10 ++++++++-- src/Data/Abstract/Evaluatable.hs | 10 ++++++++++ 2 files changed, 18 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 38233afb3..ef8566f51 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -30,7 +30,8 @@ deriving instance Member NonDet effects => MonadNonDet (Evaluating term value -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects term value - = '[ Resumable (LoadError term value) + = '[ Resumable (EvalError value) + , Resumable (LoadError term value) , Resumable (ValueExc value) , Resumable (Unspecialized value) , Fail -- Failure with an error message @@ -46,7 +47,12 @@ type EvaluatingEffects term value -- | Find the value in the 'Final' result of running. findValue :: (effects ~ RequiredEffects term value (Evaluating term value effects)) - => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) (Either (SomeExc (LoadError term value)) value))) + => Final effects value + -> Either Prelude.String ( + Either (SomeExc (Unspecialized value)) ( + Either (SomeExc (ValueExc value)) ( + Either (SomeExc (LoadError term value)) ( + Either (SomeExc (EvalError value)) value)))) -- this is gnarly findValue (((((v, _), _), _), _), _) = v -- | Find the 'Environment' in the 'Final' result of running. diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index bcb88108e..a0c5e6ac8 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -5,6 +5,7 @@ module Data.Abstract.Evaluatable , Evaluatable(..) , Unspecialized(..) , LoadError(..) +, EvalError(..) , evaluateTerm , evaluateModule , withModules @@ -35,6 +36,7 @@ type MonadEvaluatable term value m = , MonadThrow (Unspecialized value) m , MonadThrow (ValueExc value) m , MonadThrow (LoadError term value) m + , MonadThrow (EvalError value) m , MonadValue value m , Recursive term , Show (LocationFor value) @@ -48,6 +50,14 @@ deriving instance Show (LoadError term a b) instance Show1 (LoadError term value) where liftShowsPrec _ _ = showsPrec +data EvalError value resume where + FreeVariableError :: Name -> EvalError value value + +deriving instance Eq (EvalError a b) +deriving instance Show (EvalError a b) +instance Show1 (EvalError value) where + liftShowsPrec _ _ = showsPrec + throwLoadError :: MonadEvaluatable term value m => LoadError term value resume -> m resume throwLoadError = throwException From d5baf53ebdc2946bfedadf13070d48bf16c3e786 Mon Sep 17 00:00:00 2001 From: Charlie Somerville <charlie@charlie.bz> Date: Wed, 28 Mar 2018 11:24:58 +1100 Subject: [PATCH 16/38] throw FreeVariableError rather than failing in identifier eval --- src/Data/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 40bd84dd5..1f0b00c10 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -106,7 +106,7 @@ instance Ord1 Identifier where liftCompare = genericLiftCompare instance Show1 Identifier where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Identifier where - eval (Identifier name) = lookupWith deref name >>= maybe (fail ("free variable: " <> show (friendlyName name))) pure + eval (Identifier name) = lookupWith deref name >>= maybe (throwException $ FreeVariableError name) pure instance FreeVariables1 Identifier where liftFreeVariables _ (Identifier x) = pure x From 3fe504c97e080d3909d9eb8cefdfc81e1a984ff6 Mon Sep 17 00:00:00 2001 From: Charlie Somerville <charlie@charlie.bz> Date: Wed, 28 Mar 2018 12:06:33 +1100 Subject: [PATCH 17/38] add BadVariable analysis catching FreeVariableError --- semantic.cabal | 3 ++- src/Analysis/Abstract/BadVariables.hs | 30 +++++++++++++++++++++++++++ 2 files changed, 32 insertions(+), 1 deletion(-) create mode 100644 src/Analysis/Abstract/BadVariables.hs diff --git a/semantic.cabal b/semantic.cabal index e2a8746e5..7dfeea779 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -15,7 +15,8 @@ library hs-source-dirs: src exposed-modules: -- Analyses & term annotations - Analysis.Abstract.Caching + Analysis.Abstract.BadVariables + , Analysis.Abstract.Caching , Analysis.Abstract.Collecting , Analysis.Abstract.Dead , Analysis.Abstract.Evaluating diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs new file mode 100644 index 000000000..9dd8ed56c --- /dev/null +++ b/src/Analysis/Abstract/BadVariables.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators #-} +module Analysis.Abstract.BadVariables where + +import Control.Abstract.Analysis +import Data.Abstract.Evaluatable +import Prologue + +newtype BadVariables m term value (effects :: [* -> *]) a = BadVariables (m term value effects a) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) + +deriving instance MonadControl term (m term value effects) => MonadControl term (BadVariables m term value effects) +deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (BadVariables m term value effects) +deriving instance MonadHeap value (m term value effects) => MonadHeap value (BadVariables m term value effects) +deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (BadVariables m term value effects) +deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (BadVariables m term value effects) + +instance ( Effectful (m term value) + , Member (Resumable (EvalError value)) effects + , Member (State [Name]) effects + , MonadAnalysis term value (m term value effects) + , MonadValue value (BadVariables m term value effects) + ) + => MonadAnalysis term value (BadVariables m term value effects) where + type RequiredEffects term value (BadVariables m term value effects) = State [Name] ': RequiredEffects term value (m term value effects) + + analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) ( + \yield (FreeVariableError name) -> + raise (modify (name :)) >> unit >>= yield) + + analyzeModule = liftAnalyze analyzeModule From 713e0f1301bef0b8c393893ee38288e2414c3bbb Mon Sep 17 00:00:00 2001 From: Charlie Somerville <charlie@charlie.bz> Date: Wed, 28 Mar 2018 12:06:47 +1100 Subject: [PATCH 18/38] add evaluateRubyBadVariables helper function in Semantic.Util --- src/Semantic/Util.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 9f5c40012..ca7a89157 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -3,11 +3,12 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.Util where +import Analysis.Abstract.BadVariables import Analysis.Abstract.Caching import Analysis.Abstract.Dead import Analysis.Abstract.Evaluating as X -import Analysis.Abstract.Tracing import Analysis.Abstract.ImportGraph +import Analysis.Abstract.Tracing import Analysis.Declaration import Control.Abstract.Analysis import Control.Monad.IO.Class @@ -42,6 +43,7 @@ import qualified Language.TypeScript.Assignment as TypeScript evaluateRubyFile = evaluateWithPrelude rubyParser evaluateRubyFiles = evaluateFilesWithPrelude rubyParser evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing Evaluating Ruby.Term Value) . evaluateModules <$> parseFiles rubyParser paths +evaluateRubyBadVariables paths = runAnalysis @(BadVariables Evaluating Ruby.Term Value) . evaluateModules <$> parseFiles rubyParser paths -- Go evaluateGoFile = evaluateFile goParser From af0793a7ad1e3a039cb9ab1cc8dc7f25fc69fd74 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Wed, 28 Mar 2018 12:58:12 -0400 Subject: [PATCH 19/38] Add Eq1 error instances and fix tests --- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 4 ++++ test/Analysis/Python/Spec.hs | 4 ++-- test/Analysis/Ruby/Spec.hs | 11 +++++++---- 4 files changed, 14 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index a0ab65937..e880edf50 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -26,7 +26,7 @@ import Data.Abstract.Number as Number import Data.Scientific (Scientific) import Data.Semigroup.Reducer hiding (unit) import Prelude -import Prologue +import Prologue hiding (TypeError) -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP -- have built-in generalized-comparison ("spaceship") operators. If you want to diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index a0c5e6ac8..596493413 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -49,6 +49,8 @@ deriving instance Eq (LoadError term a b) deriving instance Show (LoadError term a b) instance Show1 (LoadError term value) where liftShowsPrec _ _ = showsPrec +instance Eq1 (LoadError term a) where + liftEq _ (LoadError a) (LoadError b) = a == b data EvalError value resume where FreeVariableError :: Name -> EvalError value value @@ -57,6 +59,8 @@ deriving instance Eq (EvalError a b) deriving instance Show (EvalError a b) instance Show1 (EvalError value) where liftShowsPrec _ _ = showsPrec +instance Eq1 (EvalError term) where + liftEq _ (FreeVariableError a) (FreeVariableError b) = a == b throwLoadError :: MonadEvaluatable term value m => LoadError term value resume -> m resume throwLoadError = throwException diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index c5fec4f2c..e383f390b 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -30,11 +30,11 @@ spec = parallel $ do it "subclasses" $ do v <- findValue <$> evaluate "subclass.py" - v `shouldBe` Right (Right (Right (injValue (String "\"bar\"")))) + v `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"bar\"")))))) it "handles multiple inheritance left-to-right" $ do v <- findValue <$> evaluate "multiple_inheritance.py" - v `shouldBe` Right (Right (Right (injValue (String "\"foo!\"")))) + v `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"foo!\"")))))) where addr = Address . Precise diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index ef406ab1c..b4043b6f7 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -2,7 +2,10 @@ module Analysis.Ruby.Spec (spec) where +import Data.Abstract.Evaluatable (EvalError(..)) import Data.Abstract.Value +import Control.Monad.Effect (SomeExc(..)) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Map import Data.Map.Monoidal as Map @@ -24,12 +27,12 @@ spec = parallel $ do it "evaluates load with wrapper" $ do res <- evaluate "load-wrap.rb" - findValue res `shouldBe` Left "free variable: \"foo\"" + findValue res `shouldBe` Right (Right (Right (Right (Left (SomeExc (FreeVariableError ("foo" :| []))))))) findEnv res `shouldBe` [ (name "Object", addr 0) ] it "evaluates subclass" $ do res <- evaluate "subclass.rb" - findValue res `shouldBe` Right (Right (Right (injValue (String "\"<bar>\"")))) + findValue res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<bar>\"")))))) findEnv res `shouldBe` [ (name "Bar", addr 6) , (name "Foo", addr 3) , (name "Object", addr 0) ] @@ -41,13 +44,13 @@ spec = parallel $ do it "evaluates modules" $ do res <- evaluate "modules.rb" - findValue res `shouldBe` Right (Right (Right (injValue (String "\"<hello>\"")))) + findValue res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<hello>\"")))))) findEnv res `shouldBe` [ (name "Object", addr 0) , (name "Bar", addr 3) ] it "has prelude" $ do res <- findValue <$> evaluate "preluded.rb" - res `shouldBe` Right (Right (Right (injValue (String "\"<foo>\"")))) + res `shouldBe` Right (Right (Right (Right (Right (injValue (String "\"<foo>\"")))))) where ns n = Just . Latest . Just . injValue . Namespace (name n) From 281af6e2310c5daeafd4c011a32090c167232624 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Wed, 28 Mar 2018 13:19:16 -0400 Subject: [PATCH 20/38] hlint --- src/Data/Syntax.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 1f0b00c10..68a43b086 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -9,7 +9,7 @@ import Data.Record import Data.Span import Data.Term import Diffing.Algorithm hiding (Empty) -import Prelude hiding (fail) +import Prelude import Prologue import qualified Assigning.Assignment as Assignment import qualified Data.Error as Error From 46274ad9efaba24deb741120d3bc8957620d43e2 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Thu, 29 Mar 2018 11:22:58 -0400 Subject: [PATCH 21/38] Move insertVertexName to its own function --- src/Analysis/Abstract/ImportGraph.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index b21f2c059..1b35149fb 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -40,19 +40,19 @@ instance ( Effectful (m term value) => MonadAnalysis term value (ImportGraphing m term value effects) where type RequiredEffects term value (ImportGraphing m term value effects) = State ImportGraph ': RequiredEffects term value (m term value effects) - analyzeTerm eval term = resumeException @(LoadError term value) (liftAnalyze analyzeTerm eval term) (\yield (LoadError name) -> - do - ms <- askModuleStack - let parent = maybe empty (vertex . moduleName) (listToMaybe ms) - modifyImportGraph (parent >< vertex name <>) - yield [] - ) + analyzeTerm eval term = resumeException + @(LoadError term value) + (liftAnalyze analyzeTerm eval term) + (\yield (LoadError name) -> insertVertexName name >> yield []) analyzeModule recur m = do + insertVertexName (moduleName m) + liftAnalyze analyzeModule recur m + +insertVertexName name = do ms <- askModuleStack let parent = maybe empty (vertex . moduleName) (listToMaybe ms) - modifyImportGraph (parent >< vertex (moduleName m) <>) - liftAnalyze analyzeModule recur m + modifyImportGraph (parent >< vertex name <>) (><) :: Graph a => a -> a -> a (><) = connect From 9832779676fc26e191f1c3c42beb2d340ed1941c Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Thu, 29 Mar 2018 11:27:41 -0400 Subject: [PATCH 22/38] Add type signature --- src/Analysis/Abstract/ImportGraph.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 1b35149fb..66586055e 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -49,6 +49,11 @@ instance ( Effectful (m term value) insertVertexName (moduleName m) liftAnalyze analyzeModule recur m +insertVertexName :: (Effectful (m term value) + , Member (State ImportGraph) effects + , MonadEvaluator term value (m term value effects)) + => NonEmpty ByteString + -> ImportGraphing m term value effects () insertVertexName name = do ms <- askModuleStack let parent = maybe empty (vertex . moduleName) (listToMaybe ms) From bcd202d4428e660d36ee773a574af29262b493f0 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Thu, 29 Mar 2018 11:28:01 -0400 Subject: [PATCH 23/38] format --- src/Analysis/Abstract/ImportGraph.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 66586055e..39a1eba90 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, + TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.ImportGraph ( ImportGraph(..) , renderImportGraph @@ -6,13 +7,13 @@ module Analysis.Abstract.ImportGraph ) where import qualified Algebra.Graph as G -import Algebra.Graph.Class -import Algebra.Graph.Export.Dot -import Control.Abstract.Analysis -import Data.Abstract.FreeVariables -import Data.Abstract.Module -import Data.Abstract.Evaluatable (LoadError(..)) -import Prologue hiding (empty) +import Algebra.Graph.Class +import Algebra.Graph.Export.Dot +import Control.Abstract.Analysis +import Data.Abstract.Evaluatable (LoadError (..)) +import Data.Abstract.FreeVariables +import Data.Abstract.Module +import Prologue hiding (empty) -- | The graph of function definitions to symbols used in a given program. newtype ImportGraph = ImportGraph { unImportGraph :: G.Graph Name } From 578e719edeceed54a760f3f2cf14bfadb0bf2443 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Thu, 29 Mar 2018 11:28:39 -0400 Subject: [PATCH 24/38] indentation --- src/Data/Abstract/Evaluatable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 596493413..19acf4db7 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -43,7 +43,7 @@ type MonadEvaluatable term value m = ) data LoadError term value resume where - LoadError :: ModuleName -> LoadError term value [Module term] + LoadError :: ModuleName -> LoadError term value [Module term] deriving instance Eq (LoadError term a b) deriving instance Show (LoadError term a b) From f743e0b1d52393dc992df24ad32198f6f8897d71 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Thu, 29 Mar 2018 11:34:28 -0400 Subject: [PATCH 25/38] docs --- src/Data/Abstract/Evaluatable.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 19acf4db7..1aa0d3728 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -42,6 +42,8 @@ type MonadEvaluatable term value m = , Show (LocationFor value) ) + +-- | An error thrown when loading a module from the list of provided modules. Indicates we weren't able to find a module with the given name. data LoadError term value resume where LoadError :: ModuleName -> LoadError term value [Module term] @@ -52,7 +54,9 @@ instance Show1 (LoadError term value) where instance Eq1 (LoadError term a) where liftEq _ (LoadError a) (LoadError b) = a == b +-- | The type of error thrown when failing to evaluate a term. data EvalError value resume where + -- Indicates we weren't able to dereference a name from the evaluated environment. FreeVariableError :: Name -> EvalError value value deriving instance Eq (EvalError a b) From e56781741c0dbf7aafb2b747e508448ac7dc8ed4 Mon Sep 17 00:00:00 2001 From: joshvera <josh@joshvera.com> Date: Thu, 29 Mar 2018 11:36:02 -0400 Subject: [PATCH 26/38] Add docs --- src/Analysis/Abstract/BadVariables.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 9dd8ed56c..59d2abee6 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -5,6 +5,7 @@ import Control.Abstract.Analysis import Data.Abstract.Evaluatable import Prologue +-- An analysis that resumes from evaluation errors and records the list of unresolved free variables. newtype BadVariables m term value (effects :: [* -> *]) a = BadVariables (m term value effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) From ca9533b06e59a104605468fec77245a5047c9110 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 17:56:22 -0400 Subject: [PATCH 27/38] :fire: the term & value parameters. --- src/Analysis/Abstract/BadVariables.hs | 24 ++++++++++----------- src/Analysis/Abstract/Caching.hs | 30 +++++++++++++-------------- src/Analysis/Abstract/Collecting.hs | 26 +++++++++++------------ src/Analysis/Abstract/Dead.hs | 26 +++++++++++------------ src/Analysis/Abstract/ImportGraph.hs | 28 ++++++++++++------------- src/Analysis/Abstract/Quiet.hs | 24 ++++++++++----------- src/Analysis/Abstract/Tracing.hs | 28 ++++++++++++------------- src/Control/Abstract/Analysis.hs | 6 +++--- src/Semantic/Util.hs | 14 ++++++------- 9 files changed, 103 insertions(+), 103 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 59d2abee6..85476f994 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.BadVariables where import Control.Abstract.Analysis @@ -6,23 +6,23 @@ import Data.Abstract.Evaluatable import Prologue -- An analysis that resumes from evaluation errors and records the list of unresolved free variables. -newtype BadVariables m term value (effects :: [* -> *]) a = BadVariables (m term value effects a) +newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m term value effects) => MonadControl term (BadVariables m term value effects) -deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (BadVariables m term value effects) -deriving instance MonadHeap value (m term value effects) => MonadHeap value (BadVariables m term value effects) -deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (BadVariables m term value effects) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (BadVariables m term value effects) +deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (BadVariables m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (BadVariables m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (BadVariables m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects) -instance ( Effectful (m term value) +instance ( Effectful m , Member (Resumable (EvalError value)) effects , Member (State [Name]) effects - , MonadAnalysis term value (m term value effects) - , MonadValue value (BadVariables m term value effects) + , MonadAnalysis term value (m effects) + , MonadValue value (BadVariables m effects) ) - => MonadAnalysis term value (BadVariables m term value effects) where - type RequiredEffects term value (BadVariables m term value effects) = State [Name] ': RequiredEffects term value (m term value effects) + => MonadAnalysis term value (BadVariables m effects) where + type RequiredEffects term value (BadVariables m effects) = State [Name] ': RequiredEffects term value (m effects) analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) ( \yield (FreeVariableError name) -> diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 24ab099f9..4b6f1d6b4 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -22,14 +22,14 @@ type CachingEffects term value effects type CacheFor term value = Cache (LocationFor value) term value -- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs. -newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value effects a) +newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m term value effects) => MonadControl term (Caching m term value effects) -deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Caching m term value effects) -deriving instance MonadHeap value (m term value effects) => MonadHeap value (Caching m term value effects) -deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Caching m term value effects) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects) +deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Caching m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (Caching m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Caching m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m effects) -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons. class MonadEvaluator term value m => MonadCaching term value m where @@ -46,15 +46,15 @@ class MonadEvaluator term value m => MonadCaching term value m where -- | Run an action starting from an empty out-cache, and return the out-cache afterwards. isolateCache :: m a -> m (CacheFor term value) -instance ( Effectful (m term value) +instance ( Effectful m , Members (CachingEffects term value '[]) effects - , MonadEvaluator term value (m term value effects) + , MonadEvaluator term value (m effects) , Ord (CellFor value) , Ord (LocationFor value) , Ord term , Ord value ) - => MonadCaching term value (Caching m term value effects) where + => MonadCaching term value (Caching m effects) where consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask) withOracle cache = raise . local (const cache) . lower @@ -69,19 +69,19 @@ instance ( Effectful (m term value) -- | This instance coinductively iterates the analysis of a term until the results converge. instance ( Corecursive term - , Effectful (m term value) - , MonadAnalysis term value (m term value effects) - , MonadFresh (m term value effects) - , MonadNonDet (m term value effects) + , Effectful m + , MonadAnalysis term value (m effects) + , MonadFresh (m effects) + , MonadNonDet (m effects) , Members (CachingEffects term value '[]) effects , Ord (CellFor value) , Ord (LocationFor value) , Ord term , Ord value ) - => MonadAnalysis term value (Caching m term value effects) where + => MonadAnalysis term value (Caching m effects) where -- We require the 'CachingEffects' in addition to the underlying analysis’ 'RequiredEffects'. - type RequiredEffects term value (Caching m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) + type RequiredEffects term value (Caching m effects) = CachingEffects term value (RequiredEffects term value (m effects)) -- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. analyzeTerm recur e = do diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 1ee038c8e..73a9695d0 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -10,35 +10,35 @@ import Data.Abstract.Heap import Data.Abstract.Live import Prologue -newtype Collecting m term value (effects :: [* -> *]) a = Collecting (m term value effects a) +newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m term value effects) => MonadControl term (Collecting m term value effects) -deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Collecting m term value effects) -deriving instance MonadHeap value (m term value effects) => MonadHeap value (Collecting m term value effects) -deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Collecting m term value effects) +deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Collecting m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (Collecting m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Collecting m effects) -instance ( Effectful (m term value) +instance ( Effectful m , Member (Reader (Live (LocationFor value) value)) effects - , MonadEvaluator term value (m term value effects) + , MonadEvaluator term value (m effects) ) - => MonadEvaluator term value (Collecting m term value effects) where + => MonadEvaluator term value (Collecting m effects) where getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap askModuleStack = Collecting askModuleStack -instance ( Effectful (m term value) +instance ( Effectful m , Foldable (Cell (LocationFor value)) , Member (Reader (Live (LocationFor value) value)) effects - , MonadAnalysis term value (m term value effects) + , MonadAnalysis term value (m effects) , Ord (LocationFor value) , ValueRoots value ) - => MonadAnalysis term value (Collecting m term value effects) where - type RequiredEffects term value (Collecting m term value effects) + => MonadAnalysis term value (Collecting m effects) where + type RequiredEffects term value (Collecting m effects) = Reader (Live (LocationFor value) value) - ': RequiredEffects term value (m term value effects) + ': RequiredEffects term value (m effects) -- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term. analyzeTerm recur term = do diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 1b1a17f57..4d4eff3c0 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Dead ( type DeadCode ) where @@ -10,14 +10,14 @@ import Data.Set (delete) import Prologue -- | An analysis tracking dead (unreachable) code. -newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a) +newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m term value effects) => MonadControl term (DeadCode m term value effects) -deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (DeadCode m term value effects) -deriving instance MonadHeap value (m term value effects) => MonadHeap value (DeadCode m term value effects) -deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (DeadCode m term value effects) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects) +deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (DeadCode m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (DeadCode m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (DeadCode m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } @@ -26,11 +26,11 @@ newtype Dead term = Dead { unDead :: Set term } deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: (Effectful (m term value), Member (State (Dead term)) effects) => Dead term -> DeadCode m term value effects () +killAll :: (Effectful m, Member (State (Dead term)) effects) => Dead term -> DeadCode m effects () killAll = raise . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful (m term value), Member (State (Dead term)) effects) => Ord term => term -> DeadCode m term value effects () +revive :: (Effectful m, Member (State (Dead term)) effects) => Ord term => term -> DeadCode m effects () revive t = raise (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -39,15 +39,15 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term instance ( Corecursive term - , Effectful (m term value) + , Effectful m , Foldable (Base term) , Member (State (Dead term)) effects - , MonadAnalysis term value (m term value effects) + , MonadAnalysis term value (m effects) , Ord term , Recursive term ) - => MonadAnalysis term value (DeadCode m term value effects) where - type RequiredEffects term value (DeadCode m term value effects) = State (Dead term) ': RequiredEffects term value (m term value effects) + => MonadAnalysis term value (DeadCode m effects) where + type RequiredEffects term value (DeadCode m effects) = State (Dead term) ': RequiredEffects term value (m effects) analyzeTerm recur term = do revive (embedSubterm term) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 39a1eba90..d529d307a 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -23,23 +23,23 @@ newtype ImportGraph = ImportGraph { unImportGraph :: G.Graph Name } renderImportGraph :: ImportGraph -> ByteString renderImportGraph = export (defaultStyle friendlyName) . unImportGraph -newtype ImportGraphing m term value (effects :: [* -> *]) a = ImportGraphing (m term value effects a) +newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m term value effects) => MonadControl term (ImportGraphing m term value effects) -deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (ImportGraphing m term value effects) -deriving instance MonadHeap value (m term value effects) => MonadHeap value (ImportGraphing m term value effects) -deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (ImportGraphing m term value effects) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (ImportGraphing m term value effects) +deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (ImportGraphing m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (ImportGraphing m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (ImportGraphing m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects) -instance ( Effectful (m term value) +instance ( Effectful m , Member (State ImportGraph) effects - , MonadAnalysis term value (m term value effects) + , MonadAnalysis term value (m effects) , Member (Resumable (LoadError term value)) effects ) - => MonadAnalysis term value (ImportGraphing m term value effects) where - type RequiredEffects term value (ImportGraphing m term value effects) = State ImportGraph ': RequiredEffects term value (m term value effects) + => MonadAnalysis term value (ImportGraphing m effects) where + type RequiredEffects term value (ImportGraphing m effects) = State ImportGraph ': RequiredEffects term value (m effects) analyzeTerm eval term = resumeException @(LoadError term value) @@ -50,11 +50,11 @@ instance ( Effectful (m term value) insertVertexName (moduleName m) liftAnalyze analyzeModule recur m -insertVertexName :: (Effectful (m term value) +insertVertexName :: (Effectful m , Member (State ImportGraph) effects - , MonadEvaluator term value (m term value effects)) + , MonadEvaluator term value (m effects)) => NonEmpty ByteString - -> ImportGraphing m term value effects () + -> ImportGraphing m effects () insertVertexName name = do ms <- askModuleStack let parent = maybe empty (vertex . moduleName) (listToMaybe ms) @@ -65,7 +65,7 @@ insertVertexName name = do infixr 7 >< -modifyImportGraph :: (Effectful (m term value), Member (State ImportGraph) effects) => (ImportGraph -> ImportGraph) -> ImportGraphing m term value effects () +modifyImportGraph :: (Effectful m, Member (State ImportGraph) effects) => (ImportGraph -> ImportGraph) -> ImportGraphing m effects () modifyImportGraph = raise . modify diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 50c172d69..81423cd6c 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.Quiet where import Control.Abstract.Analysis @@ -12,22 +12,22 @@ import Prologue -- > runAnalysis @(Quietly Evaluating term value) (…) -- -- Note that exceptions thrown by other analyses may not be caught if 'Quietly' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery. -newtype Quietly m term value (effects :: [* -> *]) a = Quietly (m term value effects a) +newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m term value effects) => MonadControl term (Quietly m term value effects) -deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Quietly m term value effects) -deriving instance MonadHeap value (m term value effects) => MonadHeap value (Quietly m term value effects) -deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Quietly m term value effects) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Quietly m term value effects) +deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Quietly m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (Quietly m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Quietly m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects) -instance ( Effectful (m term value) +instance ( Effectful m , Member (Resumable (Unspecialized value)) effects - , MonadAnalysis term value (m term value effects) - , MonadValue value (Quietly m term value effects) + , MonadAnalysis term value (m effects) + , MonadValue value (Quietly m effects) ) - => MonadAnalysis term value (Quietly m term value effects) where - type RequiredEffects term value (Quietly m term value effects) = RequiredEffects term value (m term value effects) + => MonadAnalysis term value (Quietly m effects) where + type RequiredEffects term value (Quietly m effects) = RequiredEffects term value (m effects) analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 40e0be3da..6bf5429fc 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing ( type Tracing ) where @@ -12,36 +12,36 @@ import Prologue hiding (trace) -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing (m term value effects a) +newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m term value effects) => MonadControl term (Tracing trace m term value effects) -deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Tracing trace m term value effects) -deriving instance MonadHeap value (m term value effects) => MonadHeap value (Tracing trace m term value effects) -deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Tracing trace m term value effects) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects) +deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Tracing trace m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (Tracing trace m effects) +deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Tracing trace m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects) instance ( Corecursive term - , Effectful (m term value) + , Effectful m , Member (Writer (trace (ConfigurationFor term value))) effects - , MonadAnalysis term value (m term value effects) + , MonadAnalysis term value (m effects) , Ord (LocationFor value) , Reducer (ConfigurationFor term value) (trace (ConfigurationFor term value)) ) - => MonadAnalysis term value (Tracing trace m term value effects) where - type RequiredEffects term value (Tracing trace m term value effects) = Writer (trace (ConfigurationFor term value)) ': RequiredEffects term value (m term value effects) + => MonadAnalysis term value (Tracing trace m effects) where + type RequiredEffects term value (Tracing trace m effects) = Writer (trace (ConfigurationFor term value)) ': RequiredEffects term value (m effects) analyzeTerm recur term = do config <- getConfiguration (embedSubterm term) - trace (Reducer.unit config) + trace @m @trace @term @value (Reducer.unit config) liftAnalyze analyzeTerm recur term analyzeModule = liftAnalyze analyzeModule -- | Log the given trace of configurations. -trace :: ( Effectful (m term value) +trace :: ( Effectful m , Member (Writer (trace (ConfigurationFor term value))) effects ) => trace (ConfigurationFor term value) - -> Tracing trace m term value effects () + -> Tracing trace m effects () trace = raise . tell diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index bd53c2e52..216d8297e 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -46,9 +46,9 @@ class MonadEvaluator term value m => MonadAnalysis term value m where -- | 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) - => ((base (Subterm term (outer value)) -> m term value effects value) -> (base (Subterm term (outer value)) -> m term value effects value)) - -> ((base (Subterm term (outer value)) -> t m term value effects value) -> (base (Subterm term (outer value)) -> t m term value effects value)) +liftAnalyze :: Coercible ( m effects value) (t m (effects :: [* -> *]) value) + => ((base (Subterm term (outer value)) -> m effects value) -> (base (Subterm term (outer value)) -> m effects value)) + -> ((base (Subterm term (outer value)) -> t m effects value) -> (base (Subterm term (outer value)) -> t m effects value)) liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . recur) term) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ca7a89157..0d5111fe6 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -42,27 +42,27 @@ import qualified Language.TypeScript.Assignment as TypeScript -- Ruby evaluateRubyFile = evaluateWithPrelude rubyParser evaluateRubyFiles = evaluateFilesWithPrelude rubyParser -evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing Evaluating Ruby.Term Value) . evaluateModules <$> parseFiles rubyParser paths -evaluateRubyBadVariables paths = runAnalysis @(BadVariables Evaluating Ruby.Term Value) . evaluateModules <$> parseFiles rubyParser paths +evaluateRubyImportGraph paths = runAnalysis @(ImportGraphing (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths +evaluateRubyBadVariables paths = runAnalysis @(BadVariables (Evaluating Ruby.Term Value)) . evaluateModules <$> parseFiles rubyParser paths -- Go evaluateGoFile = evaluateFile goParser evaluateGoFiles = evaluateFiles goParser -typecheckGoFile path = runAnalysis @(Caching Evaluating Go.Term Type) . evaluateModule <$> parseFile goParser Nothing path +typecheckGoFile path = runAnalysis @(Caching (Evaluating Go.Term Type)) . evaluateModule <$> parseFile goParser Nothing path -- Python evaluatePythonFile = evaluateWithPrelude pythonParser evaluatePythonFiles = evaluateFilesWithPrelude pythonParser -typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule <$> parseFile pythonParser Nothing path -tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term Value) . evaluateModule <$> parseFile pythonParser Nothing path -evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term Value) . evaluateModule <$> parseFile pythonParser Nothing path +typecheckPythonFile path = runAnalysis @(Caching (Evaluating Python.Term Type)) . evaluateModule <$> parseFile pythonParser Nothing path +tracePythonFile path = runAnalysis @(Tracing [] (Evaluating Python.Term Value)) . evaluateModule <$> parseFile pythonParser Nothing path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] (Evaluating Python.Term Value))) . evaluateModule <$> parseFile pythonParser Nothing path -- PHP evaluatePHPFile = evaluateFile phpParser evaluatePHPFiles = evaluateFiles phpParser -- TypeScript -typecheckTypeScriptFile path = runAnalysis @(Caching Evaluating TypeScript.Term Type) . evaluateModule <$> parseFile typescriptParser Nothing path +typecheckTypeScriptFile path = runAnalysis @(Caching (Evaluating TypeScript.Term Type)) . evaluateModule <$> parseFile typescriptParser Nothing path evaluateTypeScriptFile = evaluateFile typescriptParser evaluateTypeScriptFiles = evaluateFiles typescriptParser From 90b79c73f95e6bd96f5e959aca060dd2801dac74 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 17:58:59 -0400 Subject: [PATCH 28/38] Modify strictly. --- src/Analysis/Abstract/BadVariables.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 85476f994..df33e9ba0 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -26,6 +26,6 @@ instance ( Effectful m analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) ( \yield (FreeVariableError name) -> - raise (modify (name :)) >> unit >>= yield) + raise (modify' (name :)) >> unit >>= yield) analyzeModule = liftAnalyze analyzeModule From 7f019d44e0b19f16110a4831bb74c6e8adcbab22 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 17:59:25 -0400 Subject: [PATCH 29/38] :fire: some indentation. --- src/Analysis/Abstract/Evaluating.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index da9504913..3bc431e23 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -20,10 +20,10 @@ import Prologue newtype Evaluating term value effects a = Evaluating (Eff effects a) deriving (Applicative, Functor, Effectful, Monad) -deriving instance Member Fail effects => MonadFail (Evaluating term value effects) -deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects) -deriving instance Member NonDet effects => Alternative (Evaluating term value effects) -deriving instance Member NonDet effects => MonadNonDet (Evaluating term value effects) +deriving instance Member Fail effects => MonadFail (Evaluating term value effects) +deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects) +deriving instance Member NonDet effects => Alternative (Evaluating term value effects) +deriving instance Member NonDet effects => MonadNonDet (Evaluating term value effects) -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects term value From dd9e454583b3604f8687262e3b052c96c33d3ef3 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 18:01:16 -0400 Subject: [PATCH 30/38] Inline the definition of trace. --- src/Analysis/Abstract/Tracing.hs | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 6bf5429fc..f9f86872a 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -33,15 +33,7 @@ instance ( Corecursive term analyzeTerm recur term = do config <- getConfiguration (embedSubterm term) - trace @m @trace @term @value (Reducer.unit config) + raise (tell @(trace (ConfigurationFor term value)) (Reducer.unit config)) liftAnalyze analyzeTerm recur term analyzeModule = liftAnalyze analyzeModule - --- | Log the given trace of configurations. -trace :: ( Effectful m - , Member (Writer (trace (ConfigurationFor term value))) effects - ) - => trace (ConfigurationFor term value) - -> Tracing trace m effects () -trace = raise . tell From 9673375765148fb8821be1017de83bd1cab57fe0 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 18:01:39 -0400 Subject: [PATCH 31/38] :fire: a redundant hide. --- src/Analysis/Abstract/Tracing.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index f9f86872a..274ed455a 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -7,7 +7,7 @@ import Control.Abstract.Analysis import Control.Monad.Effect.Writer import Data.Semigroup.Reducer as Reducer import Data.Union -import Prologue hiding (trace) +import Prologue -- | Trace analysis. -- From 5f4b68804c690fee0aaf60fd7d08c9ebcab792d4 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 18:03:48 -0400 Subject: [PATCH 32/38] Export the types only but without the explicit namespace. --- src/Analysis/Abstract/BadVariables.hs | 4 +++- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Collecting.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Quiet.hs | 4 +++- src/Analysis/Abstract/Tracing.hs | 2 +- 6 files changed, 10 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index df33e9ba0..791f3e3a3 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Analysis.Abstract.BadVariables where +module Analysis.Abstract.BadVariables +( BadVariables +) where import Control.Abstract.Analysis import Data.Abstract.Evaluatable diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 4b6f1d6b4..11c003a6e 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Caching -( type Caching +( Caching ) where import Control.Abstract.Analysis diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 73a9695d0..e43ac4d56 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Collecting -( type Collecting +( Collecting ) where import Control.Abstract.Analysis diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 4d4eff3c0..e0a114d0c 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Dead -( type DeadCode +( DeadCode ) where import Control.Abstract.Analysis diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 81423cd6c..3dd45d9b7 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -1,5 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-} -module Analysis.Abstract.Quiet where +module Analysis.Abstract.Quiet +( Quietly +) where import Control.Abstract.Analysis import Data.Abstract.Evaluatable diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 274ed455a..96d4e7ff3 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,6 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing -( type Tracing +( Tracing ) where import Control.Abstract.Analysis From de14ef7625aa5e176be4789bdb9aad4d3cf23622 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 18:07:00 -0400 Subject: [PATCH 33/38] Align all the derived instances. --- src/Analysis/Abstract/BadVariables.hs | 8 ++++---- src/Analysis/Abstract/Caching.hs | 8 ++++---- src/Analysis/Abstract/Collecting.hs | 10 +++++----- src/Analysis/Abstract/Dead.hs | 8 ++++---- src/Analysis/Abstract/ImportGraph.hs | 8 ++++---- src/Analysis/Abstract/Quiet.hs | 8 ++++---- src/Analysis/Abstract/Tracing.hs | 8 ++++---- 7 files changed, 29 insertions(+), 29 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 791f3e3a3..8e6c4c94f 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -11,11 +11,11 @@ import Prologue newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (BadVariables m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (BadVariables m effects) +deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (BadVariables m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (BadVariables m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (BadVariables m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (BadVariables m effects) instance ( Effectful m , Member (Resumable (EvalError value)) effects diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 11c003a6e..6c6817e63 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -25,11 +25,11 @@ type CacheFor term value = Cache (LocationFor value) term value newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Caching m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (Caching m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Caching m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (Caching m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Caching m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Caching m effects) -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons. class MonadEvaluator term value m => MonadCaching term value m where diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index e43ac4d56..ea036d6e0 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -13,16 +13,16 @@ import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Collecting m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (Collecting m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Collecting m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (Collecting m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Collecting m effects) instance ( Effectful m , Member (Reader (Live (LocationFor value) value)) effects , MonadEvaluator term value (m effects) ) - => MonadEvaluator term value (Collecting m effects) where + => MonadEvaluator term value (Collecting m effects) where getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap askModuleStack = Collecting askModuleStack @@ -35,7 +35,7 @@ instance ( Effectful m , Ord (LocationFor value) , ValueRoots value ) - => MonadAnalysis term value (Collecting m effects) where + => MonadAnalysis term value (Collecting m effects) where type RequiredEffects term value (Collecting m effects) = Reader (Live (LocationFor value) value) ': RequiredEffects term value (m effects) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index e0a114d0c..2e7f46cf4 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,11 +13,11 @@ import Prologue newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (DeadCode m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (DeadCode m effects) +deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (DeadCode m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (DeadCode m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (DeadCode m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (DeadCode m effects) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index d529d307a..4019a551b 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -26,11 +26,11 @@ renderImportGraph = export (defaultStyle friendlyName) . unImportGraph newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (ImportGraphing m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (ImportGraphing m effects) +deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (ImportGraphing m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (ImportGraphing m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (ImportGraphing m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (ImportGraphing m effects) instance ( Effectful m diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 3dd45d9b7..c7fa4a046 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -17,11 +17,11 @@ import Prologue newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Quietly m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (Quietly m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Quietly m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (Quietly m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Quietly m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Quietly m effects) instance ( Effectful m , Member (Resumable (Unspecialized value)) effects diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 96d4e7ff3..292cb728e 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -15,11 +15,11 @@ import Prologue newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects) -deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Tracing trace m effects) -deriving instance MonadHeap value (m effects) => MonadHeap value (Tracing trace m effects) +deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects) +deriving instance MonadEnvironment value (m effects) => MonadEnvironment value (Tracing trace m effects) +deriving instance MonadHeap value (m effects) => MonadHeap value (Tracing trace m effects) deriving instance MonadModuleTable term value (m effects) => MonadModuleTable term value (Tracing trace m effects) -deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects) +deriving instance MonadEvaluator term value (m effects) => MonadEvaluator term value (Tracing trace m effects) instance ( Corecursive term , Effectful m From 14b65fd32b46f597c67b678d3de8aca95bb2546a Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 18:13:48 -0400 Subject: [PATCH 34/38] Explicitly list the Control.Effect exports. --- src/Control/Effect.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 55b9ef349..9bc638335 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -1,5 +1,12 @@ {-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Control.Effect where +module Control.Effect +( Control.Effect.run +, RunEffects(..) +, RunEffect(..) +, Effectful(..) +, resumeException +, mergeEither +) where import Control.Monad.Effect as Effect import Control.Monad.Effect.Fail From 3337a405171ea012140a9e7e6360cf52d3d93c48 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 18:25:49 -0400 Subject: [PATCH 35/38] Rename RequiredEffects to Effects. --- src/Analysis/Abstract/BadVariables.hs | 2 +- src/Analysis/Abstract/Caching.hs | 4 ++-- src/Analysis/Abstract/Collecting.hs | 4 ++-- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/ImportGraph.hs | 2 +- src/Analysis/Abstract/Quiet.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Analysis.hs | 8 ++++---- src/Semantic/Util.hs | 12 ++++++------ 10 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 8e6c4c94f..192792335 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -24,7 +24,7 @@ instance ( Effectful m , MonadValue value (BadVariables m effects) ) => MonadAnalysis term value (BadVariables m effects) where - type RequiredEffects term value (BadVariables m effects) = State [Name] ': RequiredEffects term value (m effects) + type Effects term value (BadVariables m effects) = State [Name] ': Effects term value (m effects) analyzeTerm eval term = resumeException @(EvalError value) (liftAnalyze analyzeTerm eval term) ( \yield (FreeVariableError name) -> diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 6c6817e63..cdbe6822b 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -80,8 +80,8 @@ instance ( Corecursive term , Ord value ) => MonadAnalysis term value (Caching m effects) where - -- We require the 'CachingEffects' in addition to the underlying analysis’ 'RequiredEffects'. - type RequiredEffects term value (Caching m effects) = CachingEffects term value (RequiredEffects term value (m effects)) + -- We require the 'CachingEffects' in addition to the underlying analysis’ 'Effects'. + type Effects term value (Caching m effects) = CachingEffects term value (Effects term value (m effects)) -- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. analyzeTerm recur e = do diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index ea036d6e0..9a42356a6 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -36,9 +36,9 @@ instance ( Effectful m , ValueRoots value ) => MonadAnalysis term value (Collecting m effects) where - type RequiredEffects term value (Collecting m effects) + type Effects term value (Collecting m effects) = Reader (Live (LocationFor value) value) - ': RequiredEffects term value (m effects) + ': Effects term value (m effects) -- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term. analyzeTerm recur term = do diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 2e7f46cf4..1820b739b 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -47,7 +47,7 @@ instance ( Corecursive term , Recursive term ) => MonadAnalysis term value (DeadCode m effects) where - type RequiredEffects term value (DeadCode m effects) = State (Dead term) ': RequiredEffects term value (m effects) + type Effects term value (DeadCode m effects) = State (Dead term) ': Effects term value (m effects) analyzeTerm recur term = do revive (embedSubterm term) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 3bc431e23..29de7bebd 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -136,7 +136,7 @@ instance ( Members (EvaluatingEffects term value) effects , MonadValue value (Evaluating term value effects) ) => MonadAnalysis term value (Evaluating term value effects) where - type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value + type Effects term value (Evaluating term value effects) = EvaluatingEffects term value analyzeTerm = id diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 4019a551b..e36a17bd6 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -39,7 +39,7 @@ instance ( Effectful m , Member (Resumable (LoadError term value)) effects ) => MonadAnalysis term value (ImportGraphing m effects) where - type RequiredEffects term value (ImportGraphing m effects) = State ImportGraph ': RequiredEffects term value (m effects) + type Effects term value (ImportGraphing m effects) = State ImportGraph ': Effects term value (m effects) analyzeTerm eval term = resumeException @(LoadError term value) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index c7fa4a046..422f9b0fc 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -29,7 +29,7 @@ instance ( Effectful m , MonadValue value (Quietly m effects) ) => MonadAnalysis term value (Quietly m effects) where - type RequiredEffects term value (Quietly m effects) = RequiredEffects term value (m effects) + type Effects term value (Quietly m effects) = Effects term value (m effects) analyzeTerm eval term = resumeException @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield (Unspecialized _) -> unit >>= yield) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 292cb728e..ada1f73f8 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -29,7 +29,7 @@ instance ( Corecursive term , Reducer (ConfigurationFor term value) (trace (ConfigurationFor term value)) ) => MonadAnalysis term value (Tracing trace m effects) where - type RequiredEffects term value (Tracing trace m effects) = Writer (trace (ConfigurationFor term value)) ': RequiredEffects term value (m effects) + type Effects term value (Tracing trace m effects) = Writer (trace (ConfigurationFor term value)) ': Effects term value (m effects) analyzeTerm recur term = do config <- getConfiguration (embedSubterm term) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 216d8297e..edbb58b27 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -29,8 +29,8 @@ import Prologue -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. class MonadEvaluator term value m => MonadAnalysis term value m where - -- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'RequiredEffects' in their own list. - type family RequiredEffects term value m :: [* -> *] + -- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list. + type family Effects term value m :: [* -> *] -- | Analyze a term using the semantics of the current analysis. analyzeTerm :: (Base term (Subterm term (outer value)) -> m value) @@ -54,10 +54,10 @@ liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . r -- | Run an analysis, performing its effects and returning the result alongside any state. -- --- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'RequiredEffects'). +-- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects'). runAnalysis :: ( Effectful m + , Effects term value (m effects) ~ effects , RunEffects effects a - , RequiredEffects term value (m effects) ~ effects , MonadAnalysis term value (m effects) ) => m effects a diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 0d5111fe6..cad0e4c6c 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -70,7 +70,7 @@ evaluateTypeScriptFiles = evaluateFiles typescriptParser evaluateFile :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ RequiredEffects term Value (Evaluating term Value effects) + , effects ~ Effects term Value (Evaluating term Value effects) , MonadAddressable Precise Value (Evaluating term Value effects) , MonadValue Value (Evaluating term Value effects) , Recursive term @@ -81,7 +81,7 @@ evaluateFile :: forall term effects evaluateFile parser path = runAnalysis @(Evaluating term Value) . evaluateModule <$> parseFile parser Nothing path evaluateWith :: forall value term effects - . ( effects ~ RequiredEffects term value (Evaluating term value effects) + . ( effects ~ Effects term value (Evaluating term value effects) , Evaluatable (Base term) , FreeVariables term , MonadAddressable (LocationFor value) value (Evaluating term value effects) @@ -104,7 +104,7 @@ evaluateWith prelude m = runAnalysis @(Evaluating term value) $ do evaluateWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ RequiredEffects term Value (Evaluating term Value effects) + , effects ~ Effects term Value (Evaluating term Value effects) , MonadAddressable Precise Value (Evaluating term Value effects) , MonadValue Value (Evaluating term Value effects) , Recursive term @@ -124,7 +124,7 @@ evaluateWithPrelude parser path = do evaluateFiles :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ RequiredEffects term Value (Evaluating term Value effects) + , effects ~ Effects term Value (Evaluating term Value effects) , MonadAddressable Precise Value (Evaluating term Value effects) , MonadValue Value (Evaluating term Value effects) , Recursive term @@ -136,7 +136,7 @@ evaluateFiles parser paths = runAnalysis @(Evaluating term Value) . evaluateModu -- | Evaluate terms and an entry point to a value with a given prelude. evaluatesWith :: forall value term effects - . ( effects ~ RequiredEffects term value (Evaluating term value effects) + . ( effects ~ Effects term value (Evaluating term value effects) , Evaluatable (Base term) , FreeVariables term , MonadAddressable (LocationFor value) value (Evaluating term value effects) @@ -155,7 +155,7 @@ evaluatesWith prelude modules m = runAnalysis @(Evaluating term value) $ do evaluateFilesWithPrelude :: forall term effects . ( Evaluatable (Base term) , FreeVariables term - , effects ~ RequiredEffects term Value (Evaluating term Value effects) + , effects ~ Effects term Value (Evaluating term Value effects) , MonadAddressable Precise Value (Evaluating term Value effects) , MonadValue Value (Evaluating term Value effects) , Recursive term From a10d71b15285c362fab8e6ffcc292fa889dba389 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 18:27:47 -0400 Subject: [PATCH 36/38] Sort a context. --- src/Control/Abstract/Analysis.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index edbb58b27..9a7e23551 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -57,8 +57,8 @@ liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . r -- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects'). runAnalysis :: ( Effectful m , Effects term value (m effects) ~ effects - , RunEffects effects a , MonadAnalysis term value (m effects) + , RunEffects effects a ) => m effects a -> Final effects a From 749e366189790d7c121ddf3f8c8cd19566f0ded4 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 18:28:30 -0400 Subject: [PATCH 37/38] Sort another context. --- src/Analysis/Abstract/Caching.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index cdbe6822b..b1df018cd 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -70,10 +70,10 @@ instance ( Effectful m -- | This instance coinductively iterates the analysis of a term until the results converge. instance ( Corecursive term , Effectful m + , Members (CachingEffects term value '[]) effects , MonadAnalysis term value (m effects) , MonadFresh (m effects) , MonadNonDet (m effects) - , Members (CachingEffects term value '[]) effects , Ord (CellFor value) , Ord (LocationFor value) , Ord term From 8da7ec2374b3e6ba6901bd63cf3fc2f97c0324e9 Mon Sep 17 00:00:00 2001 From: Rob Rix <rob.rix@me.com> Date: Thu, 29 Mar 2018 19:39:59 -0400 Subject: [PATCH 38/38] Correct a documentation comment. --- src/Analysis/Abstract/Quiet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 422f9b0fc..f9bb5ee49 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -11,7 +11,7 @@ import Prologue -- -- Use it by composing it onto an analysis: -- --- > runAnalysis @(Quietly Evaluating term value) (…) +-- > runAnalysis @(Quietly (Evaluating term value)) (…) -- -- Note that exceptions thrown by other analyses may not be caught if 'Quietly' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery. newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a)