From c9a74da233c6b54cf59fc1d1745c9f4f5dc368da Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:13:58 -0500 Subject: [PATCH 001/292] Re-enable the tracing analysis. --- semantic.cabal | 2 +- src/Analysis/Abstract/Tracing.hs | 130 +++++++++++++++++++------------ 2 files changed, 80 insertions(+), 52 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index 7cf2314e3..ad7de3705 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -19,7 +19,7 @@ library -- , Analysis.Abstract.Collecting , Analysis.Abstract.Dead , Analysis.Abstract.Evaluating - -- , Analysis.Abstract.Tracing + , Analysis.Abstract.Tracing , Analysis.ConstructorName , Analysis.CyclomaticComplexity , Analysis.Decorator diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index fe2b09861..332dcff69 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,73 +1,101 @@ -{-# LANGUAGE AllowAmbiguousTypes, DataKinds, ScopedTypeVariables, TypeApplications, TypeFamilies #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, UndecidableInstances #-} module Analysis.Abstract.Tracing where -import Prologue +import Control.Abstract.Addressable +import Control.Abstract.Analysis +import Control.Abstract.Evaluator +import Control.Abstract.Value import Control.Effect -import Control.Monad.Effect hiding (run) -import Control.Monad.Effect.Addressable -import Control.Monad.Effect.Env import Control.Monad.Effect.Fail import Control.Monad.Effect.Reader import Control.Monad.Effect.State -import Control.Monad.Effect.Trace import Control.Monad.Effect.Writer import Data.Abstract.Address import Data.Abstract.Configuration -import Data.Abstract.Environment -import Data.Abstract.Eval -import Data.Abstract.Store +import Data.Abstract.Evaluatable +import Data.Abstract.Linker import Data.Abstract.Value +import Prologue -- | The effects necessary for tracing analyses. -type Tracing g t v - = '[ Writer (g (Configuration (LocationFor v) t v)) -- For 'MonadTrace'. +type TracingEffects trace term value + = '[ Writer (trace (Configuration (LocationFor value) term value)) -- For 'MonadTrace'. , Fail -- For 'MonadFail'. - , State (Store (LocationFor v) v) -- For 'MonadStore'. - , Reader (Environment (LocationFor v) v) -- For 'MonadEnv'. + , State (StoreFor value) -- For 'MonadStore'. + , Reader (EnvironmentFor value) -- For 'MonadEnv'. + , State (EnvironmentFor value) -- For 'MonadEnv'. + , Reader (Linker term) + , State (Linker value) ] -- | Linear trace analysis. -evalTrace :: forall v term - . ( Ord v, Ord term, Ord (Cell (LocationFor v) v) - , Functor (Base term) - , Recursive term - , Addressable (LocationFor v) (Eff (Tracing [] term v)) - , MonadGC v (Eff (Tracing [] term v)) - , Semigroup (Cell (LocationFor v) v) - , Eval term v (Eff (Tracing [] term v)) (Base term) - ) - => term -> Final (Tracing [] term v) v -evalTrace = run @(Tracing [] term v) . fix (evTell @[] (\ recur yield -> eval recur yield . project)) pure +evaluateTrace :: forall v term + . ( Ord v, Ord term, Ord (Cell (LocationFor v) v) + , Corecursive term + , Evaluatable (Base term) + , FreeVariables term + , Recursive term + , MonadAddressable (LocationFor v) v (TracingAnalysis [] term v) + , MonadValue term v (TracingAnalysis [] term v) + , Semigroup (Cell (LocationFor v) v) + ) + => term + -> Final (TracingEffects [] term v) v +evaluateTrace = run @(TracingEffects [] term v) . runEvaluator . runTracingAnalysis . evaluateTerm -- | Reachable configuration analysis. -evalReach :: forall v term - . ( Ord v, Ord term, Ord (LocationFor v), Ord (Cell (LocationFor v) v) - , Functor (Base term) - , Recursive term - , Addressable (LocationFor v) (Eff (Tracing Set term v)) - , MonadGC v (Eff (Tracing Set term v)) - , Semigroup (Cell (LocationFor v) v) - , Eval term v (Eff (Tracing Set term v)) (Base term) - ) - => term -> Final (Tracing Set term v) v -evalReach = run @(Tracing Set term v) . fix (evTell @Set (\ recur yield -> eval recur yield . project)) pure +evaluateReach :: forall v term + . ( Ord v, Ord term, Ord (LocationFor v), Ord (Cell (LocationFor v) v) + , Corecursive term + , Evaluatable (Base term) + , FreeVariables term + , Recursive term + , MonadAddressable (LocationFor v) v (TracingAnalysis Set term v) + , MonadValue term v (TracingAnalysis Set term v) + , Semigroup (Cell (LocationFor v) v) + ) + => term + -> Final (TracingEffects Set term v) v +evaluateReach = run @(TracingEffects Set term v) . runEvaluator . runTracingAnalysis . evaluateTerm -- | Small-step evaluation which records every visited configuration. -evTell :: forall g t m v - . ( Monoid (g (Configuration (LocationFor v) t v)) - , Pointed g - , MonadTrace t v g m - , MonadEnv v m - , MonadStore v m - , MonadGC v m +-- evTell :: forall g t m v +-- . ( Monoid (g (Configuration (LocationFor v) t v)) +-- , Pointed g +-- , MonadEvaluator t v m +-- ) +-- => (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v) +-- -> ((v -> m v) -> t -> m v) +-- -> (v -> m v) -> t -> m v +-- evTell ev0 ev' yield e = do +-- env <- askEnv +-- store <- getStore +-- roots <- askRoots +-- tell (point (Configuration e roots env store) :: g (Configuration (LocationFor v) t v)) +-- ev0 ev' yield e + +newtype TracingAnalysis trace term value a = TracingAnalysis { runTracingAnalysis :: Evaluator (TracingEffects trace term value) term value a } + deriving (Applicative, Functor, Monad, MonadFail) + +deriving instance MonadEvaluator term value (TracingAnalysis trace term value) + +instance ( Corecursive term + , Evaluatable (Base term) + , FreeVariables term + , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value) + , MonadValue term value (TracingAnalysis trace term value) + , Pointed trace + , Recursive term + , Semigroup (Cell (LocationFor value) value) ) - => (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v) - -> ((v -> m v) -> t -> m v) - -> (v -> m v) -> t -> m v -evTell ev0 ev' yield e = do - env <- askEnv - store <- getStore - roots <- askRoots - trace (point (Configuration e roots env store) :: g (Configuration (LocationFor v) t v)) - ev0 ev' yield e + => MonadAnalysis term value (TracingAnalysis trace term value) where + analyzeTerm term = do + env <- askLocalEnv + store <- getStore + roots <- pure mempty + trace (point (Configuration (embed (subterm <$> term)) roots env store)) + eval term + +trace :: trace (Configuration (LocationFor value) term value) -> TracingAnalysis trace term value () +trace w = TracingAnalysis (Evaluator (tell w)) From ee911a0990cd5527de29e87177da6cd8f7f6b9ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:14:52 -0500 Subject: [PATCH 002/292] :fire: MonadTrace. --- semantic.cabal | 1 - src/Control/Monad/Effect/Trace.hs | 17 ----------------- 2 files changed, 18 deletions(-) delete mode 100644 src/Control/Monad/Effect/Trace.hs diff --git a/semantic.cabal b/semantic.cabal index ad7de3705..aa81fad57 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -41,7 +41,6 @@ library , Control.Monad.Effect.Fresh -- , Control.Monad.Effect.GC , Control.Monad.Effect.NonDet - -- , Control.Monad.Effect.Trace -- Datatypes for abstract interpretation , Data.Abstract.Address , Data.Abstract.Cache diff --git a/src/Control/Monad/Effect/Trace.hs b/src/Control/Monad/Effect/Trace.hs deleted file mode 100644 index 822d4ce04..000000000 --- a/src/Control/Monad/Effect/Trace.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} -module Control.Monad.Effect.Trace where - -import Control.Monad.Effect -import Control.Monad.Effect.Writer -import Data.Abstract.Configuration -import Data.Abstract.Value - --- | 'Monad's offering a writable trace of configurations. --- --- @t@ is the type of terms, @v@ the type of values, @g@ the type of the collection represented by the log (e.g. '[]' for regular traces, or @Set@ for the trace of reachable states). -class Monad m => MonadTrace t v g m where - -- | Log the given collection of configurations. - trace :: g (Configuration (LocationFor v) t v) -> m () - -instance (Writer (g (Configuration (LocationFor v) t v)) :< fs) => MonadTrace t v g (Eff fs) where - trace = tell From 4e9f13a035755c39f854210820fbd19d92b28e46 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:18:00 -0500 Subject: [PATCH 003/292] Use the embedSubterm helper. --- 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 332dcff69..acfc0cfe4 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -94,7 +94,7 @@ instance ( Corecursive term env <- askLocalEnv store <- getStore roots <- pure mempty - trace (point (Configuration (embed (subterm <$> term)) roots env store)) + trace (point (Configuration (embedSubterm term) roots env store)) eval term trace :: trace (Configuration (LocationFor value) term value) -> TracingAnalysis trace term value () From 6650e4de4ee2f692ef15fe3dd117fb4cb216fa94 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:21:46 -0500 Subject: [PATCH 004/292] Define getConfiguration as a method on MonadEvaluator. --- src/Analysis/Abstract/Caching.hs | 4 ---- src/Control/Abstract/Evaluator.hs | 5 +++++ 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 09a880415..a3836bad3 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -133,10 +133,6 @@ converge f = loop else loop x' --- | Get the current 'Configuration' with a passed-in term. -getConfiguration :: Ord (LocationFor v) => t -> CachingAnalysis t v (Configuration (LocationFor v) t v) -getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore - -- | Nondeterministically write each of a collection of stores & return their associated results. scatter :: (Alternative m, Foldable t, MonadEvaluator term v m) => t (a, Store (LocationFor v) v) -> m a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 8c056bfd4..6cc38715a 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -8,6 +8,7 @@ import Control.Monad.Effect.Fresh import Control.Monad.Effect.NonDet import Control.Monad.Effect.Reader import Control.Monad.Effect.State +import Data.Abstract.Configuration import Data.Abstract.Linker import Data.Abstract.Value import Prelude hiding (fail) @@ -44,6 +45,10 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where -- | Run an action with a locally-modified table of unevaluated modules. localModuleTable :: (Linker term -> Linker term) -> m a -> m a + -- | Get the current 'Configuration' with a passed-in term. + getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value) + getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore + instance Members '[ Fail , Reader (EnvironmentFor value) , State (EnvironmentFor value) From f6cd19ddb9f5455de22cf9a3a9f8dfe32e491e42 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:24:14 -0500 Subject: [PATCH 005/292] Add askRoots to the MonadEvaluator interface with a default definition. --- src/Control/Abstract/Evaluator.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 6cc38715a..b6e59982d 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, FunctionalDependencies, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, UndecidableInstances #-} +{-# LANGUAGE DataKinds, DefaultSignatures, FunctionalDependencies, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, UndecidableInstances #-} module Control.Abstract.Evaluator where import Control.Applicative @@ -10,6 +10,7 @@ import Control.Monad.Effect.Reader import Control.Monad.Effect.State import Data.Abstract.Configuration import Data.Abstract.Linker +import Data.Abstract.Live import Data.Abstract.Value import Prelude hiding (fail) @@ -45,6 +46,10 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where -- | Run an action with a locally-modified table of unevaluated modules. localModuleTable :: (Linker term -> Linker term) -> m a -> m a + -- | Retrieve the current root set. + askRoots :: Ord (LocationFor value) => m (Live (LocationFor value) value) + askRoots = pure mempty + -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value) getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore From 8be2e148495e67e3ba37ffeb30e219a0460caf2f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:25:22 -0500 Subject: [PATCH 006/292] Define getConfiguration in terms of askRoots. --- src/Control/Abstract/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index b6e59982d..1d2f3192a 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -52,7 +52,7 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value) - getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore + getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore instance Members '[ Fail , Reader (EnvironmentFor value) From 68b7ffc612f0ef5ea0f5e4e8ed0145455111926d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:26:45 -0500 Subject: [PATCH 007/292] Define analyzeTerm using getConfiguration. --- src/Analysis/Abstract/Tracing.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index acfc0cfe4..2c17198f3 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -90,12 +90,7 @@ instance ( Corecursive term , Semigroup (Cell (LocationFor value) value) ) => MonadAnalysis term value (TracingAnalysis trace term value) where - analyzeTerm term = do - env <- askLocalEnv - store <- getStore - roots <- pure mempty - trace (point (Configuration (embedSubterm term) roots env store)) - eval term + analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . point >> eval term trace :: trace (Configuration (LocationFor value) term value) -> TracingAnalysis trace term value () trace w = TracingAnalysis (Evaluator (tell w)) From 95510010bae84b9a0c9757cd164dededc978fccb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:27:06 -0500 Subject: [PATCH 008/292] :fire: the commented-out evTell. --- src/Analysis/Abstract/Tracing.hs | 16 ---------------- 1 file changed, 16 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 2c17198f3..887f9a9d4 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -59,22 +59,6 @@ evaluateReach :: forall v term evaluateReach = run @(TracingEffects Set term v) . runEvaluator . runTracingAnalysis . evaluateTerm --- | Small-step evaluation which records every visited configuration. --- evTell :: forall g t m v --- . ( Monoid (g (Configuration (LocationFor v) t v)) --- , Pointed g --- , MonadEvaluator t v m --- ) --- => (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v) --- -> ((v -> m v) -> t -> m v) --- -> (v -> m v) -> t -> m v --- evTell ev0 ev' yield e = do --- env <- askEnv --- store <- getStore --- roots <- askRoots --- tell (point (Configuration e roots env store) :: g (Configuration (LocationFor v) t v)) --- ev0 ev' yield e - newtype TracingAnalysis trace term value a = TracingAnalysis { runTracingAnalysis :: Evaluator (TracingEffects trace term value) term value a } deriving (Applicative, Functor, Monad, MonadFail) From 833e6af0f584e01fd400a9aebda625d1f36bec9c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:28:20 -0500 Subject: [PATCH 009/292] Rename v to value. --- src/Analysis/Abstract/Tracing.hs | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 887f9a9d4..beb04b58f 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -29,34 +29,34 @@ type TracingEffects trace term value ] -- | Linear trace analysis. -evaluateTrace :: forall v term - . ( Ord v, Ord term, Ord (Cell (LocationFor v) v) +evaluateTrace :: forall value term + . ( Ord value, Ord term, Ord (Cell (LocationFor value) value) , Corecursive term , Evaluatable (Base term) , FreeVariables term , Recursive term - , MonadAddressable (LocationFor v) v (TracingAnalysis [] term v) - , MonadValue term v (TracingAnalysis [] term v) - , Semigroup (Cell (LocationFor v) v) + , MonadAddressable (LocationFor value) value (TracingAnalysis [] term value) + , MonadValue term value (TracingAnalysis [] term value) + , Semigroup (Cell (LocationFor value) value) ) => term - -> Final (TracingEffects [] term v) v -evaluateTrace = run @(TracingEffects [] term v) . runEvaluator . runTracingAnalysis . evaluateTerm + -> Final (TracingEffects [] term value) value +evaluateTrace = run @(TracingEffects [] term value) . runEvaluator . runTracingAnalysis . evaluateTerm -- | Reachable configuration analysis. -evaluateReach :: forall v term - . ( Ord v, Ord term, Ord (LocationFor v), Ord (Cell (LocationFor v) v) +evaluateReach :: forall value term + . ( Ord value, Ord term, Ord (LocationFor value), Ord (Cell (LocationFor value) value) , Corecursive term , Evaluatable (Base term) , FreeVariables term , Recursive term - , MonadAddressable (LocationFor v) v (TracingAnalysis Set term v) - , MonadValue term v (TracingAnalysis Set term v) - , Semigroup (Cell (LocationFor v) v) + , MonadAddressable (LocationFor value) value (TracingAnalysis Set term value) + , MonadValue term value (TracingAnalysis Set term value) + , Semigroup (Cell (LocationFor value) value) ) => term - -> Final (TracingEffects Set term v) v -evaluateReach = run @(TracingEffects Set term v) . runEvaluator . runTracingAnalysis . evaluateTerm + -> Final (TracingEffects Set term value) value +evaluateReach = run @(TracingEffects Set term value) . runEvaluator . runTracingAnalysis . evaluateTerm newtype TracingAnalysis trace term value a = TracingAnalysis { runTracingAnalysis :: Evaluator (TracingEffects trace term value) term value a } From 35793044445de127a2ce809382c10a1af7832d29 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:29:32 -0500 Subject: [PATCH 010/292] Sort the contexts of evaluateTrace and evaluateReach. --- src/Analysis/Abstract/Tracing.hs | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index beb04b58f..fb8c28bc8 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -30,10 +30,12 @@ type TracingEffects trace term value -- | Linear trace analysis. evaluateTrace :: forall value term - . ( Ord value, Ord term, Ord (Cell (LocationFor value) value) - , Corecursive term + . ( Corecursive term , Evaluatable (Base term) , FreeVariables term + , Ord (Cell (LocationFor value) value) + , Ord term + , Ord value , Recursive term , MonadAddressable (LocationFor value) value (TracingAnalysis [] term value) , MonadValue term value (TracingAnalysis [] term value) @@ -45,10 +47,13 @@ evaluateTrace = run @(TracingEffects [] term value) . runEvaluator . runTracingA -- | Reachable configuration analysis. evaluateReach :: forall value term - . ( Ord value, Ord term, Ord (LocationFor value), Ord (Cell (LocationFor value) value) - , Corecursive term + . ( Corecursive term , Evaluatable (Base term) , FreeVariables term + , Ord (Cell (LocationFor value) value) + , Ord (LocationFor value) + , Ord term + , Ord value , Recursive term , MonadAddressable (LocationFor value) value (TracingAnalysis Set term value) , MonadValue term value (TracingAnalysis Set term value) From 927c3fe608280e924095f43d7e81dfeefdffa24c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:31:01 -0500 Subject: [PATCH 011/292] Generalize evaluateTrace to arbitrary trace types. --- src/Analysis/Abstract/Tracing.hs | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index fb8c28bc8..72c6614bd 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -28,22 +28,24 @@ type TracingEffects trace term value , State (Linker value) ] --- | Linear trace analysis. -evaluateTrace :: forall value term +-- | Trace analysis. +evaluateTrace :: forall trace value term . ( Corecursive term , Evaluatable (Base term) , FreeVariables term + , Monoid (trace (Configuration (LocationFor value) term value)) , Ord (Cell (LocationFor value) value) , Ord term , Ord value + , Pointed trace , Recursive term - , MonadAddressable (LocationFor value) value (TracingAnalysis [] term value) - , MonadValue term value (TracingAnalysis [] term value) + , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value) + , MonadValue term value (TracingAnalysis trace term value) , Semigroup (Cell (LocationFor value) value) ) => term - -> Final (TracingEffects [] term value) value -evaluateTrace = run @(TracingEffects [] term value) . runEvaluator . runTracingAnalysis . evaluateTerm + -> Final (TracingEffects trace term value) value +evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTracingAnalysis . evaluateTerm -- | Reachable configuration analysis. evaluateReach :: forall value term From f78d8c717f2a2ebd4d366564d6b3171fa516da3f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:31:15 -0500 Subject: [PATCH 012/292] :fire: evaluateReach. --- src/Analysis/Abstract/Tracing.hs | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 72c6614bd..21d4c2acd 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -47,24 +47,6 @@ evaluateTrace :: forall trace value term -> Final (TracingEffects trace term value) value evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTracingAnalysis . evaluateTerm --- | Reachable configuration analysis. -evaluateReach :: forall value term - . ( Corecursive term - , Evaluatable (Base term) - , FreeVariables term - , Ord (Cell (LocationFor value) value) - , Ord (LocationFor value) - , Ord term - , Ord value - , Recursive term - , MonadAddressable (LocationFor value) value (TracingAnalysis Set term value) - , MonadValue term value (TracingAnalysis Set term value) - , Semigroup (Cell (LocationFor value) value) - ) - => term - -> Final (TracingEffects Set term value) value -evaluateReach = run @(TracingEffects Set term value) . runEvaluator . runTracingAnalysis . evaluateTerm - newtype TracingAnalysis trace term value a = TracingAnalysis { runTracingAnalysis :: Evaluator (TracingEffects trace term value) term value a } deriving (Applicative, Functor, Monad, MonadFail) From 9563c4c309496fe51e65e413f618a8df00179730 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:32:30 -0500 Subject: [PATCH 013/292] :memo: how to recover the linear/reachable state analyses. --- src/Analysis/Abstract/Tracing.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 21d4c2acd..d373c3d42 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -29,6 +29,8 @@ type TracingEffects trace term value ] -- | Trace analysis. +-- +-- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. evaluateTrace :: forall trace value term . ( Corecursive term , Evaluatable (Base term) From b2f9b1f6441a5247f93f47af13aebf6f57fc4eba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 6 Mar 2018 17:38:47 -0500 Subject: [PATCH 014/292] Align the effect comments. --- src/Analysis/Abstract/Tracing.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index d373c3d42..8234d8fef 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -19,13 +19,13 @@ import Prologue -- | The effects necessary for tracing analyses. type TracingEffects trace term value - = '[ Writer (trace (Configuration (LocationFor value) term value)) -- For 'MonadTrace'. - , Fail -- For 'MonadFail'. - , State (StoreFor value) -- For 'MonadStore'. - , Reader (EnvironmentFor value) -- For 'MonadEnv'. - , State (EnvironmentFor value) -- For 'MonadEnv'. - , Reader (Linker term) - , State (Linker value) + = '[ Writer (trace (Configuration (LocationFor value) term value)) -- For 'trace'. + , Fail -- For 'MonadFail'. + , State (StoreFor value) -- For 'MonadEvaluator'. + , Reader (EnvironmentFor value) -- For 'MonadEvaluator'. + , State (EnvironmentFor value) -- For 'MonadEvaluator'. + , Reader (Linker term) -- For 'MonadEvaluator'. + , State (Linker value) -- For 'MonadEvaluator'. ] -- | Trace analysis. From fa6062fa9c031a2bc7c57f0f0cfefb3c7cc1a2d1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 09:02:51 -0500 Subject: [PATCH 015/292] List the Control.Abstract.Analysis exports explicitly. --- src/Control/Abstract/Analysis.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 540b0fdfd..75d091372 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DefaultSignatures, FunctionalDependencies #-} -module Control.Abstract.Analysis where +module Control.Abstract.Analysis +( MonadAnalysis(..) +) where import Prologue From 85cea81d5c41412ac4c7c48f2e378d0dd463d001 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 09:03:51 -0500 Subject: [PATCH 016/292] Re-export a bunch of effect-related modules. --- src/Control/Abstract/Analysis.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 75d091372..e1a3c87c7 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,8 +1,13 @@ {-# LANGUAGE DefaultSignatures, FunctionalDependencies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) +, module X ) where +import Control.Effect as X +import Control.Monad.Effect.Fail as X +import Control.Monad.Effect.Reader as X +import Control.Monad.Effect.State as X import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. From beca16b30b12201fe29064e72d8b511cfb42e30f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 09:05:53 -0500 Subject: [PATCH 017/292] :fire: a bunch of redundant imports. --- src/Analysis/Abstract/Caching.hs | 4 ---- src/Analysis/Abstract/Dead.hs | 4 ---- src/Analysis/Abstract/Evaluating.hs | 4 ---- src/Analysis/Abstract/Tracing.hs | 4 ---- src/Data/Abstract/Evaluatable.hs | 1 - 5 files changed, 17 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index a3836bad3..c1897563a 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -6,12 +6,8 @@ module Analysis.Abstract.Caching import Prologue import Data.Monoid (Alt(..)) import Control.Abstract.Evaluator -import Control.Effect -import Control.Monad.Effect.Fail import Control.Monad.Effect.Fresh import Control.Monad.Effect.NonDet -import Control.Monad.Effect.Reader -import Control.Monad.Effect.State import Data.Abstract.Address import Data.Abstract.Cache import Data.Abstract.Configuration diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 4979d93de..903a78a0c 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -3,10 +3,6 @@ module Analysis.Abstract.Dead where import Control.Abstract.Addressable import Control.Abstract.Evaluator -import Control.Effect -import Control.Monad.Effect.Fail -import Control.Monad.Effect.Reader -import Control.Monad.Effect.State import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Linker diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 238baf0f4..7ad22c523 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -3,10 +3,6 @@ module Analysis.Abstract.Evaluating where import Prologue import Control.Abstract.Evaluator -import Control.Effect -import Control.Monad.Effect.Fail -import Control.Monad.Effect.Reader -import Control.Monad.Effect.State import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Linker diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 8234d8fef..6455137f3 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -5,10 +5,6 @@ import Control.Abstract.Addressable import Control.Abstract.Analysis import Control.Abstract.Evaluator import Control.Abstract.Value -import Control.Effect -import Control.Monad.Effect.Fail -import Control.Monad.Effect.Reader -import Control.Monad.Effect.State import Control.Monad.Effect.Writer import Data.Abstract.Address import Data.Abstract.Configuration diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 8ab2a6103..21c6bd046 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -14,7 +14,6 @@ import Control.Abstract.Addressable as Addressable import Control.Abstract.Analysis as Analysis import Control.Abstract.Evaluator import Control.Abstract.Value as Value -import Control.Monad.Effect.Fail import Data.Abstract.Address import Data.Abstract.Environment import Data.Abstract.FreeVariables as FreeVariables From 62a05485739a9969d22caffa767338318c70cb38 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 09:07:37 -0500 Subject: [PATCH 018/292] Re-export Subterm/SubtermAlgebra. --- src/Control/Abstract/Analysis.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index e1a3c87c7..498673a38 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -2,6 +2,8 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , module X +, Subterm(..) +, SubtermAlgebra ) where import Control.Effect as X From 758f1032c1041ab4f10df892562be6309b8b60aa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 09:07:42 -0500 Subject: [PATCH 019/292] :fire: a redundant import. --- src/Data/Abstract/Evaluatable.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 21c6bd046..49ea5883e 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -19,7 +19,6 @@ import Data.Abstract.Environment import Data.Abstract.FreeVariables as FreeVariables import Data.Abstract.Linker import Data.Abstract.Value -import Data.Algebra import qualified Data.ByteString.Char8 as BC import Data.Functor.Classes import Data.Proxy From 89b089033614dcd3f458228b0858c0b8df5733ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 09:09:13 -0500 Subject: [PATCH 020/292] Reformat TracingAnalysis onto a new line. --- src/Analysis/Abstract/Tracing.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 6455137f3..ab069620d 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -46,7 +46,8 @@ evaluateTrace :: forall trace value term evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTracingAnalysis . evaluateTerm -newtype TracingAnalysis trace term value a = TracingAnalysis { runTracingAnalysis :: Evaluator (TracingEffects trace term value) term value a } +newtype TracingAnalysis trace term value a + = TracingAnalysis { runTracingAnalysis :: Evaluator (TracingEffects trace term value) term value a } deriving (Applicative, Functor, Monad, MonadFail) deriving instance MonadEvaluator term value (TracingAnalysis trace term value) From 352fc2ff0778a5b864fd6efc3b56282d838c3d64 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 09:14:38 -0500 Subject: [PATCH 021/292] :fire: redundant constraints on evaluateTerm. --- src/Control/Abstract/Analysis.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 498673a38..38b51c338 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -22,6 +22,6 @@ class Monad m => MonadAnalysis term value m | m -> term, m -> value where -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. - evaluateTerm :: MonadAnalysis term value m => term -> m value - default evaluateTerm :: (MonadAnalysis term value m, Recursive term) => term -> m value + evaluateTerm :: term -> m value + default evaluateTerm :: Recursive term => term -> m value evaluateTerm = foldSubterms analyzeTerm From 1072ab151b49f99d9e37a518bb5cb55da9650ec5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:16:59 -0500 Subject: [PATCH 022/292] Define a Bifunctor instance for Subterm. --- src/Data/Algebra.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Algebra.hs b/src/Data/Algebra.hs index 28c0ee134..8344b6810 100644 --- a/src/Data/Algebra.hs +++ b/src/Data/Algebra.hs @@ -14,6 +14,7 @@ module Data.Algebra , openFToOpenR ) where +import Data.Bifunctor import Data.Functor.Foldable ( Base , Corecursive(embed) , Recursive(project) @@ -47,6 +48,9 @@ type OpenRAlgebra f t a = forall b . (b -> (t, a)) -> f b -> a data Subterm t a = Subterm { subterm :: !t, subtermValue :: !a } deriving (Eq, Ord, Show) +instance Bifunctor Subterm where + bimap f g (Subterm a b) = Subterm (f a) (g b) + -- | Like an R-algebra, but using 'Subterm' to label the fields instead of an anonymous pair. type SubtermAlgebra f t a = f (Subterm t a) -> a From bd608f713c193e95a29381f7b9821b76f42dff44 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:17:24 -0500 Subject: [PATCH 023/292] Derive Foldable, Functor, & Traversable instances for Subterm. --- src/Data/Algebra.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Algebra.hs b/src/Data/Algebra.hs index 8344b6810..b2cba81c5 100644 --- a/src/Data/Algebra.hs +++ b/src/Data/Algebra.hs @@ -46,7 +46,7 @@ type OpenRAlgebra f t a = forall b . (b -> (t, a)) -> f b -> a -- | A subterm and its computed value, used in 'SubtermAlgebra'. data Subterm t a = Subterm { subterm :: !t, subtermValue :: !a } - deriving (Eq, Ord, Show) + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) instance Bifunctor Subterm where bimap f g (Subterm a b) = Subterm (f a) (g b) From 26b34baf5e184caeb73b899ed65870a161500846 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:18:01 -0500 Subject: [PATCH 024/292] Define a Bifoldable instance for Subterm. --- src/Data/Algebra.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Algebra.hs b/src/Data/Algebra.hs index b2cba81c5..a3ef8a66a 100644 --- a/src/Data/Algebra.hs +++ b/src/Data/Algebra.hs @@ -14,6 +14,7 @@ module Data.Algebra , openFToOpenR ) where +import Data.Bifoldable import Data.Bifunctor import Data.Functor.Foldable ( Base , Corecursive(embed) @@ -48,6 +49,9 @@ type OpenRAlgebra f t a = forall b . (b -> (t, a)) -> f b -> a data Subterm t a = Subterm { subterm :: !t, subtermValue :: !a } deriving (Eq, Foldable, Functor, Ord, Show, Traversable) +instance Bifoldable Subterm where + bifoldMap f g (Subterm a b) = f a `mappend` g b + instance Bifunctor Subterm where bimap f g (Subterm a b) = Subterm (f a) (g b) From a3e500ca14e32486c4155f62b5d7cdb1f6b9a886 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:18:37 -0500 Subject: [PATCH 025/292] Define a Bitraversable instance for Subterm. --- src/Data/Algebra.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Algebra.hs b/src/Data/Algebra.hs index a3ef8a66a..55cda91c6 100644 --- a/src/Data/Algebra.hs +++ b/src/Data/Algebra.hs @@ -16,6 +16,7 @@ module Data.Algebra import Data.Bifoldable import Data.Bifunctor +import Data.Bitraversable import Data.Functor.Foldable ( Base , Corecursive(embed) , Recursive(project) @@ -55,6 +56,9 @@ instance Bifoldable Subterm where instance Bifunctor Subterm where bimap f g (Subterm a b) = Subterm (f a) (g b) +instance Bitraversable Subterm where + bitraverse f g (Subterm a b) = Subterm <$> f a <*> g b + -- | Like an R-algebra, but using 'Subterm' to label the fields instead of an anonymous pair. type SubtermAlgebra f t a = f (Subterm t a) -> a From 762ab7f31d260c21c5c6cfd9dcac8d52266dfe57 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:20:50 -0500 Subject: [PATCH 026/292] Define a Tracer effect synonym. --- src/Analysis/Abstract/Tracing.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index ab069620d..22aaca416 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -13,6 +13,8 @@ import Data.Abstract.Linker import Data.Abstract.Value import Prologue +type Tracer trace term value = Writer (trace (Configuration (LocationFor value) term value)) + -- | The effects necessary for tracing analyses. type TracingEffects trace term value = '[ Writer (trace (Configuration (LocationFor value) term value)) -- For 'trace'. From 83228ce5269d8ddf9b7bb3cbabb9170df546d400 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:21:02 -0500 Subject: [PATCH 027/292] Use the Tracer effect synonym in TracingEffects. --- src/Analysis/Abstract/Tracing.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 22aaca416..15c05d566 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -17,13 +17,13 @@ type Tracer trace term value = Writer (trace (Configuration (LocationFor value) -- | The effects necessary for tracing analyses. type TracingEffects trace term value - = '[ Writer (trace (Configuration (LocationFor value) term value)) -- For 'trace'. - , Fail -- For 'MonadFail'. - , State (StoreFor value) -- For 'MonadEvaluator'. - , Reader (EnvironmentFor value) -- For 'MonadEvaluator'. - , State (EnvironmentFor value) -- For 'MonadEvaluator'. - , Reader (Linker term) -- For 'MonadEvaluator'. - , State (Linker value) -- For 'MonadEvaluator'. + = '[ Tracer trace term value -- For 'trace'. + , Fail -- For 'MonadFail'. + , State (StoreFor value) -- For 'MonadEvaluator'. + , Reader (EnvironmentFor value) -- For 'MonadEvaluator'. + , State (EnvironmentFor value) -- For 'MonadEvaluator'. + , Reader (Linker term) -- For 'MonadEvaluator'. + , State (Linker value) -- For 'MonadEvaluator'. ] -- | Trace analysis. From 0cc7ece3802fd0ef9042824dd2b70ff194a438a0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:21:40 -0500 Subject: [PATCH 028/292] :memo: Tracer. --- src/Analysis/Abstract/Tracing.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 15c05d566..719e7c239 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -13,6 +13,7 @@ import Data.Abstract.Linker import Data.Abstract.Value import Prologue +-- | An effect to trace visited 'Configuration's. type Tracer trace term value = Writer (trace (Configuration (LocationFor value) term value)) -- | The effects necessary for tracing analyses. From 743c17e74cf4b0850ca622cd314739e9ba0a48dc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:24:07 -0500 Subject: [PATCH 029/292] Extract an EvaluatorEffects synonym. --- src/Control/Abstract/Evaluator.hs | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 1d2f3192a..2029f79d0 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -54,14 +54,16 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore -instance Members '[ Fail - , Reader (EnvironmentFor value) - , State (EnvironmentFor value) - , State (StoreFor value) - , Reader (Linker term) - , State (Linker value) - ] effects - => MonadEvaluator term value (Evaluator effects term value) where +type EvaluatorEffects term value + = '[ Fail + , Reader (EnvironmentFor value) + , State (EnvironmentFor value) + , State (StoreFor value) + , Reader (Linker term) + , State (Linker value) + ] + +instance Members (EvaluatorEffects term value) effects => MonadEvaluator term value (Evaluator effects term value) where getGlobalEnv = Evaluator get modifyGlobalEnv f = Evaluator (modify f) From ad234eb56bbf78865b3243a928f20ea6d245e5c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:27:31 -0500 Subject: [PATCH 030/292] Define TracingEffects in terms of EvaluatorEffects. --- src/Analysis/Abstract/Tracing.hs | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 719e7c239..8e3d6b584 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Addressable @@ -9,7 +9,6 @@ import Control.Monad.Effect.Writer import Data.Abstract.Address import Data.Abstract.Configuration import Data.Abstract.Evaluatable -import Data.Abstract.Linker import Data.Abstract.Value import Prologue @@ -17,15 +16,7 @@ import Prologue type Tracer trace term value = Writer (trace (Configuration (LocationFor value) term value)) -- | The effects necessary for tracing analyses. -type TracingEffects trace term value - = '[ Tracer trace term value -- For 'trace'. - , Fail -- For 'MonadFail'. - , State (StoreFor value) -- For 'MonadEvaluator'. - , Reader (EnvironmentFor value) -- For 'MonadEvaluator'. - , State (EnvironmentFor value) -- For 'MonadEvaluator'. - , Reader (Linker term) -- For 'MonadEvaluator'. - , State (Linker value) -- For 'MonadEvaluator'. - ] +type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffects term value -- | Trace analysis. -- From f534844342318fd10bf62b02403374234a962c38 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:28:23 -0500 Subject: [PATCH 031/292] Define DeadCodeEffects in terms of EvaluatorEffects. --- src/Analysis/Abstract/Dead.hs | 14 ++------------ 1 file changed, 2 insertions(+), 12 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 903a78a0c..2fdf094bd 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,26 +1,16 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Dead where import Control.Abstract.Addressable import Control.Abstract.Evaluator import Data.Abstract.Address import Data.Abstract.Evaluatable -import Data.Abstract.Linker -import Data.Abstract.Store import Data.Abstract.Value import Data.Set (delete) import Prologue -- | The effects necessary for dead code analysis. -type DeadCodeEffects t v - = '[ State (Dead t) -- The set of dead terms - , Fail -- Failure with an error message - , State (Store (LocationFor v) v) -- The heap - , State (EnvironmentFor v) -- Global (imperative) environment - , Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure) - , Reader (Linker t) -- Cache of unevaluated modules - , State (Linker v) -- Cache of evaluated modules - ] +type DeadCodeEffects term value = State (Dead term) ': EvaluatorEffects term value -- | Run a dead code analysis of the given program. From a2f3c0c6df84a9ec192f61cbe966495f0267d275 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:33:54 -0500 Subject: [PATCH 032/292] Define CachingEffects in terms of EvaluatorEffects. --- src/Analysis/Abstract/Caching.hs | 24 ++++++++---------------- 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index c1897563a..e69894b10 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Caching ( evaluateCache ) where @@ -11,28 +11,20 @@ import Control.Monad.Effect.NonDet import Data.Abstract.Address import Data.Abstract.Cache import Data.Abstract.Configuration -import Data.Abstract.Environment import Data.Abstract.Evaluatable -import Data.Abstract.Linker import Data.Abstract.Live import Data.Abstract.Store import Data.Abstract.Value import qualified Data.Set as Set -- | The effects necessary for caching analyses. -type CachingEffects t v - = '[ Fresh -- For 'MonadFresh'. - , Reader (Live (LocationFor v) v) -- For 'MonadGC'. - , Reader (Environment (LocationFor v) v) -- For 'MonadEnv'. - , State (Environment (LocationFor v) v) -- For 'MonadEvaluator'. - , Fail -- For 'MonadFail'. - , NonDetEff -- For 'Alternative' & 'MonadNonDet'. - , State (Store (LocationFor v) v) -- For 'MonadStore'. - , Reader (Cache (LocationFor v) t v) -- For 'MonadCacheIn'. - , State (Cache (LocationFor v) t v) -- For 'MonadCacheOut'. - , Reader (Linker t) -- Cache of unevaluated modules - , State (Linker v) -- Cache of evaluated modules - ] +type CachingEffects term value + = Fresh + ': NonDetEff + ': Reader (Live (LocationFor value) value) + ': Reader (Cache (LocationFor value) term value) + ': State (Cache (LocationFor value) term value) + ': EvaluatorEffects term value newtype CachingAnalysis term value a = CachingAnalysis { runCachingAnalysis :: Evaluator (CachingEffects term value) term value a } deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFresh, MonadNonDet) From 54033f592659266623d98aed66c54cdf96af25e6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:35:25 -0500 Subject: [PATCH 033/292] Copy the comments for the evaluator effects. --- src/Control/Abstract/Evaluator.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 2029f79d0..026e42416 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -55,12 +55,12 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore type EvaluatorEffects term value - = '[ Fail - , Reader (EnvironmentFor value) - , State (EnvironmentFor value) - , State (StoreFor value) - , Reader (Linker term) - , State (Linker value) + = '[ Fail -- Failure with an error message + , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) + , State (EnvironmentFor value) -- Global (imperative) environment + , State (StoreFor value) -- The heap + , Reader (Linker term) -- Cache of unevaluated modules + , State (Linker value) -- Cache of evaluated modules ] instance Members (EvaluatorEffects term value) effects => MonadEvaluator term value (Evaluator effects term value) where From 158c9251fb436b7ce3f1f5b2d92b8aec3e4f691f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:36:18 -0500 Subject: [PATCH 034/292] :fire: EvaluationEffects. --- src/Analysis/Abstract/Evaluating.hs | 22 +++++----------------- 1 file changed, 5 insertions(+), 17 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 7ad22c523..b085411e8 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -6,24 +6,12 @@ import Control.Abstract.Evaluator import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Linker -import Data.Abstract.Store import Data.Abstract.Value import Data.Blob import Prelude hiding (fail) import qualified Data.Map as Map import System.FilePath.Posix --- | The effects necessary for concrete interpretation. -type EvaluationEffects t v - = '[ Fail -- Failure with an error message - , State (Store (LocationFor v) v) -- The heap - , State (EnvironmentFor v) -- Global (imperative) environment - , Reader (EnvironmentFor v) -- Local environment (e.g. binding over a closure) - , Reader (Linker t) -- Cache of unevaluated modules - , State (Linker v) -- Cache of evaluated modules - ] - - -- | Evaluate a term to a value. evaluate :: forall v term . ( Evaluatable (Base term) @@ -35,8 +23,8 @@ evaluate :: forall v term , Semigroup (Cell (LocationFor v) v) ) => term - -> Final (EvaluationEffects term v) v -evaluate = run @(EvaluationEffects term v) . runEvaluator . runEvaluation . evaluateTerm + -> Final (EvaluatorEffects term v) v +evaluate = run @(EvaluatorEffects term v) . runEvaluator . runEvaluation . evaluateTerm -- | Evaluate terms and an entry point to a value. evaluates :: forall v term @@ -50,8 +38,8 @@ evaluates :: forall v term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint - -> Final (EvaluationEffects term v) v -evaluates pairs (_, t) = run @(EvaluationEffects term v) (runEvaluator (runEvaluation (withModules pairs (evaluateTerm t)))) + -> Final (EvaluatorEffects term v) v +evaluates pairs (_, t) = run @(EvaluatorEffects term v) (runEvaluator (runEvaluation (withModules pairs (evaluateTerm t)))) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis term value m, MonadEvaluator term value m) => [(Blob, term)] -> m a -> m a @@ -59,7 +47,7 @@ withModules pairs = localModuleTable (const moduleTable) where moduleTable = Linker (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis performing concrete evaluation of @term@s to @value@s. -newtype Evaluation term value a = Evaluation { runEvaluation :: Evaluator (EvaluationEffects term value) term value a } +newtype Evaluation term value a = Evaluation { runEvaluation :: Evaluator (EvaluatorEffects term value) term value a } deriving (Applicative, Functor, Monad, MonadFail) deriving instance MonadEvaluator term value (Evaluation term value) From 7520910147ee047cf84f200f121b31265de14c2d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:39:24 -0500 Subject: [PATCH 035/292] :memo: the CachingEffects. --- src/Analysis/Abstract/Caching.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index e69894b10..7f7113d39 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -19,11 +19,11 @@ import qualified Data.Set as Set -- | The effects necessary for caching analyses. type CachingEffects term value - = Fresh - ': NonDetEff - ': Reader (Live (LocationFor value) value) - ': Reader (Cache (LocationFor value) term value) - ': State (Cache (LocationFor value) term value) + = Fresh -- For 'MonadFresh'. TODO: Extract typing constraints into a separate analysis. + ': NonDetEff -- For 'Alternative' & 'MonadNonDet'. + ': Reader (Live (LocationFor value) value) -- For 'MonadGC'. TODO: Extract GC stuff into a separate analysis. + ': Reader (Cache (LocationFor value) term value) -- For the in-cache. + ': State (Cache (LocationFor value) term value) -- For the out-cache ': EvaluatorEffects term value newtype CachingAnalysis term value a = CachingAnalysis { runCachingAnalysis :: Evaluator (CachingEffects term value) term value a } From 29866143b79e147971d00cdf415bcc2a31618244 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:39:48 -0500 Subject: [PATCH 036/292] :fire: the root set effect. --- src/Analysis/Abstract/Caching.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 7f7113d39..89895ed99 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -12,7 +12,6 @@ import Data.Abstract.Address import Data.Abstract.Cache import Data.Abstract.Configuration import Data.Abstract.Evaluatable -import Data.Abstract.Live import Data.Abstract.Store import Data.Abstract.Value import qualified Data.Set as Set @@ -21,7 +20,6 @@ import qualified Data.Set as Set type CachingEffects term value = Fresh -- For 'MonadFresh'. TODO: Extract typing constraints into a separate analysis. ': NonDetEff -- For 'Alternative' & 'MonadNonDet'. - ': Reader (Live (LocationFor value) value) -- For 'MonadGC'. TODO: Extract GC stuff into a separate analysis. ': Reader (Cache (LocationFor value) term value) -- For the in-cache. ': State (Cache (LocationFor value) term value) -- For the out-cache ': EvaluatorEffects term value From 41103a52fe036fae52b58e196da329e9bf066d1c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:43:05 -0500 Subject: [PATCH 037/292] Rearrange the parameters to Evaluator. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Evaluator.hs | 12 ++++++------ 5 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 89895ed99..c7c66a228 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -24,7 +24,7 @@ type CachingEffects term value ': State (Cache (LocationFor value) term value) -- For the out-cache ': EvaluatorEffects term value -newtype CachingAnalysis term value a = CachingAnalysis { runCachingAnalysis :: Evaluator (CachingEffects term value) term value a } +newtype CachingAnalysis term value a = CachingAnalysis { runCachingAnalysis :: Evaluator term value (CachingEffects term value) a } deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFresh, MonadNonDet) deriving instance MonadEvaluator term value (CachingAnalysis term value) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 2fdf094bd..69253c117 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -36,7 +36,7 @@ evaluateDead term = run @(DeadCodeEffects term value) . runEvaluator . runDeadCo -- | A newtype wrapping 'Evaluator' which performs a dead code analysis on evaluation. -newtype DeadCodeAnalysis term value a = DeadCodeAnalysis { runDeadCodeAnalysis :: Evaluator (DeadCodeEffects term value) term value a } +newtype DeadCodeAnalysis term value a = DeadCodeAnalysis { runDeadCodeAnalysis :: Evaluator term value (DeadCodeEffects term value) a } deriving (Applicative, Functor, Monad, MonadFail) deriving instance MonadEvaluator term value (DeadCodeAnalysis term value) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b085411e8..1514cf504 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -47,7 +47,7 @@ withModules pairs = localModuleTable (const moduleTable) where moduleTable = Linker (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis performing concrete evaluation of @term@s to @value@s. -newtype Evaluation term value a = Evaluation { runEvaluation :: Evaluator (EvaluatorEffects term value) term value a } +newtype Evaluation term value a = Evaluation { runEvaluation :: Evaluator term value (EvaluatorEffects term value) a } deriving (Applicative, Functor, Monad, MonadFail) deriving instance MonadEvaluator term value (Evaluation term value) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 8e3d6b584..76b1380f4 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -41,7 +41,7 @@ evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTraci newtype TracingAnalysis trace term value a - = TracingAnalysis { runTracingAnalysis :: Evaluator (TracingEffects trace term value) term value a } + = TracingAnalysis { runTracingAnalysis :: Evaluator term value (TracingEffects trace term value) a } deriving (Applicative, Functor, Monad, MonadFail) deriving instance MonadEvaluator term value (TracingAnalysis trace term value) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 026e42416..4ae882f78 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -63,7 +63,7 @@ type EvaluatorEffects term value , State (Linker value) -- Cache of evaluated modules ] -instance Members (EvaluatorEffects term value) effects => MonadEvaluator term value (Evaluator effects term value) where +instance Members (EvaluatorEffects term value) effects => MonadEvaluator term value (Evaluator term value effects) where getGlobalEnv = Evaluator get modifyGlobalEnv f = Evaluator (modify f) @@ -83,10 +83,10 @@ putStore :: MonadEvaluator t value m => StoreFor value -> m () putStore = modifyStore . const -- | An evaluator of @term@s to @value@s, producing incremental results of type @a@ using a list of @effects@. -newtype Evaluator effects term value a = Evaluator { runEvaluator :: Eff effects a } +newtype Evaluator term value effects a = Evaluator { runEvaluator :: Eff effects a } deriving (Applicative, Functor, Monad) -deriving instance Member Fail effects => MonadFail (Evaluator effects term value) -deriving instance Member NonDetEff effects => Alternative (Evaluator effects term value) -deriving instance Member NonDetEff effects => MonadNonDet (Evaluator effects term value) -deriving instance Member Fresh effects => MonadFresh (Evaluator effects term value) +deriving instance Member Fail effects => MonadFail (Evaluator term value effects) +deriving instance Member NonDetEff effects => Alternative (Evaluator term value effects) +deriving instance Member NonDetEff effects => MonadNonDet (Evaluator term value effects) +deriving instance Member Fresh effects => MonadFresh (Evaluator term value effects) From 3780ffa628ab28900a4cc7e8a7e2e00a4cb11784 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:52:40 -0500 Subject: [PATCH 038/292] Disable TypeFamilies. --- 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 76b1380f4..c411571e7 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Addressable From 86fb1a870647c0a19a879e583c5d5e0bf2d58a78 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 10:53:19 -0500 Subject: [PATCH 039/292] Parameterize TracingAnalysis by the list of effects. --- src/Analysis/Abstract/Tracing.hs | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index c411571e7..51c6317e4 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Addressable @@ -31,32 +31,34 @@ evaluateTrace :: forall trace value term , Ord value , Pointed trace , Recursive term - , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value) - , MonadValue term value (TracingAnalysis trace term value) + , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value (TracingEffects trace term value)) + , MonadValue term value (TracingAnalysis trace term value (TracingEffects trace term value)) , Semigroup (Cell (LocationFor value) value) ) => term -> Final (TracingEffects trace term value) value -evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTracingAnalysis . evaluateTerm +evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTracingAnalysis @trace . evaluateTerm -newtype TracingAnalysis trace term value a - = TracingAnalysis { runTracingAnalysis :: Evaluator term value (TracingEffects trace term value) a } - deriving (Applicative, Functor, Monad, MonadFail) +newtype TracingAnalysis (trace :: * -> *) term value effects a + = TracingAnalysis { runTracingAnalysis :: Evaluator term value effects a } + deriving (Applicative, Functor, Monad) -deriving instance MonadEvaluator term value (TracingAnalysis trace term value) +deriving instance Member Fail effects => MonadFail (TracingAnalysis trace term value effects) +deriving instance Members (EvaluatorEffects term value) effects => MonadEvaluator term value (TracingAnalysis trace term value effects) instance ( Corecursive term , Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value) - , MonadValue term value (TracingAnalysis trace term value) + , Member (Tracer trace term value) effects + , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value effects) + , MonadValue term value (TracingAnalysis trace term value effects) , Pointed trace , Recursive term , Semigroup (Cell (LocationFor value) value) ) - => MonadAnalysis term value (TracingAnalysis trace term value) where + => MonadAnalysis term value (TracingAnalysis trace term value effects) where analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . point >> eval term -trace :: trace (Configuration (LocationFor value) term value) -> TracingAnalysis trace term value () +trace :: Member (Tracer trace term value) effects => trace (Configuration (LocationFor value) term value) -> TracingAnalysis trace term value effects () trace w = TracingAnalysis (Evaluator (tell w)) From 0087c5a1d155d3b9f8046e5acc865a2f1f9faa15 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:04:53 -0500 Subject: [PATCH 040/292] Define a typeclass for lifting effects into some wrapping context. --- src/Control/Effect.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 54d685cc9..692a4c22f 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -63,3 +63,7 @@ instance Ord a => RunEffect NonDetEff a where runEffect = relay (pure . point) (\ m k -> case m of MZero -> pure mempty MPlus -> mappend <$> k True <*> k False) + + +class LiftEffect f where + lift :: Eff effects a -> f effects a From 669f652062bec20ad3c8d2c38fcd9bf21b2c4096 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:05:11 -0500 Subject: [PATCH 041/292] Define a LiftEffect instance for Eff. --- src/Control/Effect.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 692a4c22f..ac5096747 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -67,3 +67,6 @@ instance Ord a => RunEffect NonDetEff a where class LiftEffect f where lift :: Eff effects a -> f effects a + +instance LiftEffect Eff where + lift = id From b05d9ac5d34372e0ff0a7ecd1455ac74a752c296 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:16:26 -0500 Subject: [PATCH 042/292] Derive a LiftEffect instance for Evaluator. --- src/Control/Abstract/Evaluator.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 4ae882f78..d28a63ff3 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -2,6 +2,7 @@ module Control.Abstract.Evaluator where import Control.Applicative +import Control.Effect import Control.Monad.Effect import Control.Monad.Effect.Fail import Control.Monad.Effect.Fresh @@ -84,7 +85,7 @@ putStore = modifyStore . const -- | An evaluator of @term@s to @value@s, producing incremental results of type @a@ using a list of @effects@. newtype Evaluator term value effects a = Evaluator { runEvaluator :: Eff effects a } - deriving (Applicative, Functor, Monad) + deriving (Applicative, Functor, LiftEffect, Monad) deriving instance Member Fail effects => MonadFail (Evaluator term value effects) deriving instance Member NonDetEff effects => Alternative (Evaluator term value effects) From 0d296bd6b18c5612f4fa3eee7f16bafd7d828b3d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:17:38 -0500 Subject: [PATCH 043/292] Derive a LiftEffect instance for the tracing analysis. --- 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 51c6317e4..582fb90ba 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -42,7 +42,7 @@ evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTraci newtype TracingAnalysis (trace :: * -> *) term value effects a = TracingAnalysis { runTracingAnalysis :: Evaluator term value effects a } - deriving (Applicative, Functor, Monad) + deriving (Applicative, Functor, LiftEffect, Monad) deriving instance Member Fail effects => MonadFail (TracingAnalysis trace term value effects) deriving instance Members (EvaluatorEffects term value) effects => MonadEvaluator term value (TracingAnalysis trace term value effects) From fae0fcd7da46eb4fdb3e10a4b67bd1c7f3a94fa9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:18:09 -0500 Subject: [PATCH 044/292] Define trace using LiftEffect. --- 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 582fb90ba..0a04323e2 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -61,4 +61,4 @@ instance ( Corecursive term analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . point >> eval term trace :: Member (Tracer trace term value) effects => trace (Configuration (LocationFor value) term value) -> TracingAnalysis trace term value effects () -trace w = TracingAnalysis (Evaluator (tell w)) +trace w = lift (tell w) From 28a5aca6c3bb6944a4115a9f07dd2629309fc7f9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:20:26 -0500 Subject: [PATCH 045/292] Reformat the signature for trace. --- src/Analysis/Abstract/Tracing.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 0a04323e2..4f37df841 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -60,5 +60,7 @@ instance ( Corecursive term => MonadAnalysis term value (TracingAnalysis trace term value effects) where analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . point >> eval term -trace :: Member (Tracer trace term value) effects => trace (Configuration (LocationFor value) term value) -> TracingAnalysis trace term value effects () +trace :: Member (Tracer trace term value) effects + => trace (Configuration (LocationFor value) term value) + -> TracingAnalysis trace term value effects () trace w = lift (tell w) From e11af850933d135b2883ccb6f9d4d2a5d2b467d4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:21:41 -0500 Subject: [PATCH 046/292] Define a Trace synonym. --- src/Analysis/Abstract/Tracing.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 4f37df841..871716dd1 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -12,8 +12,10 @@ import Data.Abstract.Evaluatable import Data.Abstract.Value import Prologue +type Trace trace term value = trace (Configuration (LocationFor value) term value) + -- | An effect to trace visited 'Configuration's. -type Tracer trace term value = Writer (trace (Configuration (LocationFor value) term value)) +type Tracer trace term value = Writer (Trace trace term value) -- | The effects necessary for tracing analyses. type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffects term value @@ -25,7 +27,7 @@ evaluateTrace :: forall trace value term . ( Corecursive term , Evaluatable (Base term) , FreeVariables term - , Monoid (trace (Configuration (LocationFor value) term value)) + , Monoid (Trace trace term value) , Ord (Cell (LocationFor value) value) , Ord term , Ord value @@ -61,6 +63,6 @@ instance ( Corecursive term analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . point >> eval term trace :: Member (Tracer trace term value) effects - => trace (Configuration (LocationFor value) term value) + => Trace trace term value -> TracingAnalysis trace term value effects () trace w = lift (tell w) From adfbc011a09b97b77a75290ed6e45c3ee94b2484 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:22:07 -0500 Subject: [PATCH 047/292] :memo: Trace. --- src/Analysis/Abstract/Tracing.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 871716dd1..234b3f9af 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -12,6 +12,7 @@ import Data.Abstract.Evaluatable import Data.Abstract.Value import Prologue +-- | Traces of program configurations in some 'Monoid'al type @trace@. type Trace trace term value = trace (Configuration (LocationFor value) term value) -- | An effect to trace visited 'Configuration's. From a2c395d54bc17486646a4e1fb3295926d371a446 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:27:17 -0500 Subject: [PATCH 048/292] Tracing uses a Reducer. --- semantic.cabal | 1 + src/Analysis/Abstract/Tracing.hs | 27 +++++++++++---------------- 2 files changed, 12 insertions(+), 16 deletions(-) diff --git a/semantic.cabal b/semantic.cabal index aa81fad57..908e24147 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -161,6 +161,7 @@ library , parsers , pointed , recursion-schemes + , reducers , semigroups , split , stm-chans diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 234b3f9af..ec1773d17 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Addressable @@ -10,16 +10,11 @@ import Data.Abstract.Address import Data.Abstract.Configuration import Data.Abstract.Evaluatable import Data.Abstract.Value +import Data.Semigroup.Reducer as Reducer import Prologue --- | Traces of program configurations in some 'Monoid'al type @trace@. -type Trace trace term value = trace (Configuration (LocationFor value) term value) - --- | An effect to trace visited 'Configuration's. -type Tracer trace term value = Writer (Trace trace term value) - -- | The effects necessary for tracing analyses. -type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffects term value +type TracingEffects trace term value = Writer trace ': EvaluatorEffects term value -- | Trace analysis. -- @@ -28,12 +23,12 @@ evaluateTrace :: forall trace value term . ( Corecursive term , Evaluatable (Base term) , FreeVariables term - , Monoid (Trace trace term value) + , Monoid trace , Ord (Cell (LocationFor value) value) , Ord term , Ord value - , Pointed trace , Recursive term + , Reducer (Configuration (LocationFor value) term value) trace , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value (TracingEffects trace term value)) , MonadValue term value (TracingAnalysis trace term value (TracingEffects trace term value)) , Semigroup (Cell (LocationFor value) value) @@ -43,7 +38,7 @@ evaluateTrace :: forall trace value term evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTracingAnalysis @trace . evaluateTerm -newtype TracingAnalysis (trace :: * -> *) term value effects a +newtype TracingAnalysis trace term value effects a = TracingAnalysis { runTracingAnalysis :: Evaluator term value effects a } deriving (Applicative, Functor, LiftEffect, Monad) @@ -53,17 +48,17 @@ deriving instance Members (EvaluatorEffects term value) effects => MonadEvaluato instance ( Corecursive term , Evaluatable (Base term) , FreeVariables term - , Member (Tracer trace term value) effects + , Member (Writer trace) effects , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value effects) , MonadValue term value (TracingAnalysis trace term value effects) - , Pointed trace , Recursive term + , Reducer (Configuration (LocationFor value) term value) trace , Semigroup (Cell (LocationFor value) value) ) => MonadAnalysis term value (TracingAnalysis trace term value effects) where - analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . point >> eval term + analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> eval term -trace :: Member (Tracer trace term value) effects - => Trace trace term value +trace :: Member (Writer trace) effects + => trace -> TracingAnalysis trace term value effects () trace w = lift (tell w) From 2467e5f41c5651afb08e6e87afd8fe610a66cdfa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:32:44 -0500 Subject: [PATCH 049/292] Define a ConfigurationFor synonym. --- src/Data/Abstract/Configuration.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index 9fe437d80..842d89897 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -6,6 +6,9 @@ import Data.Abstract.Address import Data.Abstract.Environment import Data.Abstract.Live import Data.Abstract.Store +import Data.Abstract.Value + +type ConfigurationFor term value = Configuration (LocationFor value) term value -- | A single point in a program’s execution. data Configuration l t v From 1c00a35d3ce6caa15a0fb526e3472c2b9602a40f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:33:12 -0500 Subject: [PATCH 050/292] Use ConfigurationFor to tidy up Tracing. --- src/Analysis/Abstract/Tracing.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index ec1773d17..06de52816 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -28,7 +28,7 @@ evaluateTrace :: forall trace value term , Ord term , Ord value , Recursive term - , Reducer (Configuration (LocationFor value) term value) trace + , Reducer (ConfigurationFor term value) trace , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value (TracingEffects trace term value)) , MonadValue term value (TracingAnalysis trace term value (TracingEffects trace term value)) , Semigroup (Cell (LocationFor value) value) @@ -52,7 +52,7 @@ instance ( Corecursive term , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value effects) , MonadValue term value (TracingAnalysis trace term value effects) , Recursive term - , Reducer (Configuration (LocationFor value) term value) trace + , Reducer (ConfigurationFor term value) trace , Semigroup (Cell (LocationFor value) value) ) => MonadAnalysis term value (TracingAnalysis trace term value effects) where From 6c0a818269b097f710f5443f2bd8e0604e73ff2f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:33:56 -0500 Subject: [PATCH 051/292] Define a CellFor synonym. --- src/Data/Abstract/Value.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 9f798baf2..c323df350 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -81,6 +81,8 @@ type EnvironmentFor v = Environment (LocationFor v) v -- | The store for an abstract value type. type StoreFor v = Store (LocationFor v) v +type CellFor value = Cell (LocationFor value) value + -- | The location type (the body of 'Address'es) which should be used for an abstract value type. type family LocationFor value :: * where LocationFor (Value location term) = location From e1885469c1d289b889cc3a32683622711056f1fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:34:11 -0500 Subject: [PATCH 052/292] :memo: CellFor. --- src/Data/Abstract/Value.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index c323df350..97cb622e0 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -81,6 +81,7 @@ type EnvironmentFor v = Environment (LocationFor v) v -- | The store for an abstract value type. type StoreFor v = Store (LocationFor v) v +-- | The cell for an abstract value type. type CellFor value = Cell (LocationFor value) value -- | The location type (the body of 'Address'es) which should be used for an abstract value type. From 7e439f877218624e75150494888e36ed0a910b1d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:34:39 -0500 Subject: [PATCH 053/292] :memo: ConfigurationFor. --- src/Data/Abstract/Configuration.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Data/Abstract/Configuration.hs b/src/Data/Abstract/Configuration.hs index 842d89897..1506a5b97 100644 --- a/src/Data/Abstract/Configuration.hs +++ b/src/Data/Abstract/Configuration.hs @@ -8,6 +8,7 @@ import Data.Abstract.Live import Data.Abstract.Store import Data.Abstract.Value +-- | The configuration for term and abstract value types. type ConfigurationFor term value = Configuration (LocationFor value) term value -- | A single point in a program’s execution. From 3fc768fac713db9aad2a0f8ab81bc26bc045a916 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:38:36 -0500 Subject: [PATCH 054/292] Use CellFor everywhere we can. --- src/Analysis/Abstract/Caching.hs | 12 ++++++------ src/Analysis/Abstract/Dead.hs | 5 ++--- src/Analysis/Abstract/Evaluating.hs | 9 ++++----- src/Analysis/Abstract/Tracing.hs | 7 +++---- src/Control/Abstract/Addressable.hs | 6 +++--- src/Data/Abstract/Evaluatable.hs | 3 +-- 6 files changed, 19 insertions(+), 23 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index c7c66a228..bb8e7e325 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -56,14 +56,14 @@ modifyCache f = fmap f getCache >>= putCache instance ( Corecursive t , Ord t , Ord v - , Ord (Cell (LocationFor v) v) + , Ord (CellFor v) , Evaluatable (Base t) , Foldable (Cell (LocationFor v)) , FreeVariables t , MonadAddressable (LocationFor v) v (CachingAnalysis t v) , MonadValue t v (CachingAnalysis t v) , Recursive t - , Semigroup (Cell (LocationFor v) v) + , Semigroup (CellFor v) ) => MonadAnalysis t v (CachingAnalysis t v) where analyzeTerm e = do @@ -88,7 +88,7 @@ evaluateCache :: forall v term . ( Ord v , Ord term , Ord (LocationFor v) - , Ord (Cell (LocationFor v) v) + , Ord (CellFor v) , Corecursive term , Evaluatable (Base term) , FreeVariables term @@ -97,7 +97,7 @@ evaluateCache :: forall v term , Recursive term , MonadAddressable (LocationFor v) v (CachingAnalysis term v) , MonadValue term v (CachingAnalysis term v) - , Semigroup (Cell (LocationFor v) v) + , Semigroup (CellFor v) , ValueRoots (LocationFor v) v ) => term @@ -128,7 +128,7 @@ memoizeEval :: forall v term . ( Ord v , Ord term , Ord (LocationFor v) - , Ord (Cell (LocationFor v) v) + , Ord (CellFor v) , Corecursive term , Evaluatable (Base term) , FreeVariables term @@ -137,7 +137,7 @@ memoizeEval :: forall v term , Recursive term , MonadAddressable (LocationFor v) v (CachingAnalysis term v) , MonadValue term v (CachingAnalysis term v) - , Semigroup (Cell (LocationFor v) v) + , Semigroup (CellFor v) ) => SubtermAlgebra (Base term) term (CachingAnalysis term v v) memoizeEval e = do diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 69253c117..6b5c2f176 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -3,7 +3,6 @@ module Analysis.Abstract.Dead where import Control.Abstract.Addressable import Control.Abstract.Evaluator -import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Value import Data.Set (delete) @@ -24,7 +23,7 @@ evaluateDead :: forall term value , Ord (LocationFor value) , Ord term , Recursive term - , Semigroup (Cell (LocationFor value) value) + , Semigroup (CellFor value) ) => term -> Final (DeadCodeEffects term value) value @@ -62,7 +61,7 @@ instance ( Corecursive t , MonadValue t v (DeadCodeAnalysis t v) , Ord t , Recursive t - , Semigroup (Cell (LocationFor v) v) + , Semigroup (CellFor v) ) => MonadAnalysis t v (DeadCodeAnalysis t v) where analyzeTerm term = do diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 1514cf504..f81f25f12 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,15 +1,14 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, MultiParamTypeClasses, UndecidableInstances #-} module Analysis.Abstract.Evaluating where -import Prologue import Control.Abstract.Evaluator -import Data.Abstract.Address import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value import Data.Blob import Prelude hiding (fail) import qualified Data.Map as Map +import Prologue import System.FilePath.Posix -- | Evaluate a term to a value. @@ -20,7 +19,7 @@ evaluate :: forall v term , MonadValue term v (Evaluation term v) , Ord (LocationFor v) , Recursive term - , Semigroup (Cell (LocationFor v) v) + , Semigroup (CellFor v) ) => term -> Final (EvaluatorEffects term v) v @@ -34,7 +33,7 @@ evaluates :: forall v term , MonadValue term v (Evaluation term v) , Ord (LocationFor v) , Recursive term - , Semigroup (Cell (LocationFor v) v) + , Semigroup (CellFor v) ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint @@ -57,7 +56,7 @@ instance ( Evaluatable (Base t) , MonadAddressable (LocationFor v) v (Evaluation t v) , MonadValue t v (Evaluation t v) , Recursive t - , Semigroup (Cell (LocationFor v) v) + , Semigroup (CellFor v) ) => MonadAnalysis t v (Evaluation t v) where analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 06de52816..a13fa9bec 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -6,7 +6,6 @@ import Control.Abstract.Analysis import Control.Abstract.Evaluator import Control.Abstract.Value import Control.Monad.Effect.Writer -import Data.Abstract.Address import Data.Abstract.Configuration import Data.Abstract.Evaluatable import Data.Abstract.Value @@ -24,14 +23,14 @@ evaluateTrace :: forall trace value term , Evaluatable (Base term) , FreeVariables term , Monoid trace - , Ord (Cell (LocationFor value) value) + , Ord (CellFor value) , Ord term , Ord value , Recursive term , Reducer (ConfigurationFor term value) trace , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value (TracingEffects trace term value)) , MonadValue term value (TracingAnalysis trace term value (TracingEffects trace term value)) - , Semigroup (Cell (LocationFor value) value) + , Semigroup (CellFor value) ) => term -> Final (TracingEffects trace term value) value @@ -53,7 +52,7 @@ instance ( Corecursive term , MonadValue term value (TracingAnalysis trace term value effects) , Recursive term , Reducer (ConfigurationFor term value) trace - , Semigroup (Cell (LocationFor value) value) + , Semigroup (CellFor value) ) => MonadAnalysis term value (TracingAnalysis trace term value effects) where analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> eval term diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index a4eb4b832..12b9ccf91 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -29,7 +29,7 @@ class (Monad m, Ord l, Pointed (Cell l), l ~ LocationFor a) => MonadAddressable lookupOrAlloc :: ( FreeVariables t , MonadAddressable (LocationFor a) a m , MonadEvaluator t a m - , Semigroup (Cell (LocationFor a) a) + , Semigroup (CellFor a) ) => t -> a @@ -39,7 +39,7 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in lookupOrAlloc' name where -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. - lookupOrAlloc' :: ( Semigroup (Cell (LocationFor a) a) + lookupOrAlloc' :: ( Semigroup (CellFor a) , MonadAddressable (LocationFor a) a m , MonadEvaluator t a m ) @@ -56,7 +56,7 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in assign :: ( Ord (LocationFor a) , MonadEvaluator t a m , Pointed (Cell (LocationFor a)) - , Semigroup (Cell (LocationFor a) a) + , Semigroup (CellFor a) ) => Address (LocationFor a) a -> a diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 49ea5883e..563ba209a 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -14,7 +14,6 @@ import Control.Abstract.Addressable as Addressable import Control.Abstract.Analysis as Analysis import Control.Abstract.Evaluator import Control.Abstract.Value as Value -import Data.Abstract.Address import Data.Abstract.Environment import Data.Abstract.FreeVariables as FreeVariables import Data.Abstract.Linker @@ -36,7 +35,7 @@ class Evaluatable constr where , MonadEvaluator term value m , MonadValue term value m , Ord (LocationFor value) - , Semigroup (Cell (LocationFor value) value) + , Semigroup (CellFor value) ) => SubtermAlgebra constr term (m value) default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) From 2deae91af1f2ee154ff04db856ffa018f86466de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:40:02 -0500 Subject: [PATCH 055/292] Define a CacheFor synonym. --- src/Analysis/Abstract/Caching.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index bb8e7e325..a1eaec60f 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -24,6 +24,9 @@ type CachingEffects term value ': State (Cache (LocationFor value) term value) -- For the out-cache ': EvaluatorEffects term value +-- | The cache for term and abstract value types. +type CacheFor term value = Cache (LocationFor value) term value + newtype CachingAnalysis term value a = CachingAnalysis { runCachingAnalysis :: Evaluator term value (CachingEffects term value) a } deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFresh, MonadNonDet) From 03a0717ca95b5c9696b08427c0fea3b0598ea9d1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:42:14 -0500 Subject: [PATCH 056/292] Use CacheFor everywhere we can. --- src/Analysis/Abstract/Caching.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index a1eaec60f..6b09208d0 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -18,10 +18,10 @@ import qualified Data.Set as Set -- | The effects necessary for caching analyses. type CachingEffects term value - = Fresh -- For 'MonadFresh'. TODO: Extract typing constraints into a separate analysis. - ': NonDetEff -- For 'Alternative' & 'MonadNonDet'. - ': Reader (Cache (LocationFor value) term value) -- For the in-cache. - ': State (Cache (LocationFor value) term value) -- For the out-cache + = Fresh -- For 'MonadFresh'. TODO: Extract typing constraints into a separate analysis. + ': NonDetEff -- For 'Alternative' & 'MonadNonDet'. + ': Reader (CacheFor term value) -- For the in-cache. + ': State (CacheFor term value) -- For the out-cache ': EvaluatorEffects term value -- | The cache for term and abstract value types. @@ -34,25 +34,25 @@ deriving instance MonadEvaluator term value (CachingAnalysis term value) -- TODO: reabstract these later on -askCache :: CachingAnalysis t v (Cache (LocationFor v) t v) +askCache :: CachingAnalysis t v (CacheFor t v) askCache = CachingAnalysis (Evaluator ask) -localCache :: (Cache (LocationFor v) t v -> Cache (LocationFor v) t v) -> CachingAnalysis t v a -> CachingAnalysis t v a +localCache :: (CacheFor t v -> CacheFor t v) -> CachingAnalysis t v a -> CachingAnalysis t v a localCache f (CachingAnalysis (Evaluator a)) = CachingAnalysis (Evaluator (local f a)) -asksCache :: (Cache (LocationFor v) t v -> a) -> CachingAnalysis t v a +asksCache :: (CacheFor t v -> a) -> CachingAnalysis t v a asksCache f = f <$> askCache -getsCache :: (Cache (LocationFor v) t v -> a) -> CachingAnalysis t v a +getsCache :: (CacheFor t v -> a) -> CachingAnalysis t v a getsCache f = f <$> getCache -getCache :: CachingAnalysis t v (Cache (LocationFor v) t v) +getCache :: CachingAnalysis t v (CacheFor t v) getCache = CachingAnalysis (Evaluator get) -putCache :: Cache (LocationFor v) t v -> CachingAnalysis t v () +putCache :: CacheFor t v -> CachingAnalysis t v () putCache v = CachingAnalysis (Evaluator (put v)) -modifyCache :: (Cache (LocationFor v) t v -> Cache (LocationFor v) t v) -> CachingAnalysis t v () +modifyCache :: (CacheFor t v -> CacheFor t v) -> CachingAnalysis t v () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. @@ -73,7 +73,7 @@ instance ( Corecursive t c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge (\ prevCache -> do - putCache (mempty :: Cache (LocationFor v) t v) + putCache (mempty :: CacheFor t v) putStore (configurationStore c) -- We need to reset fresh generation so that this invocation converges. reset 0 From b7c0afb02eba7d86f8c896b54eb2d21f371b03d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:42:24 -0500 Subject: [PATCH 057/292] :fire: the old commented-out evCache. --- src/Analysis/Abstract/Caching.hs | 18 ------------------ 1 file changed, 18 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 6b09208d0..980ec711e 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -155,21 +155,3 @@ memoizeEval e = do store' <- getStore modifyCache (cacheInsert c (v, store')) pure v - -{- - - --- | Evaluation of a single iteration of an analysis, given a 'MonadCacheIn' instance as an oracle for results and a 'MonadCacheOut' instance to record computed results in. -evCache :: forall t v m - . ( Ord (LocationFor v) - , Ord t - , Ord v - , Ord (Cell (LocationFor v) v) - , MonadCaching t v m - ) - => (((v -> m v) -> t -> m v) -> (v -> m v) -> t -> m v) - -> ((v -> m v) -> t -> m v) - -> (v -> m v) -> t -> m v - - --} From b2b29974d682d48626202db474cb25ea901ecf0e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:42:54 -0500 Subject: [PATCH 058/292] Correct the :memo: for memoizeEval. --- 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 980ec711e..46555f440 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -126,7 +126,7 @@ converge f = loop scatter :: (Alternative m, Foldable t, MonadEvaluator term v m) => t (a, Store (LocationFor v) v) -> m a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) --- | Evaluation of a single iteration of an analysis, given a 'MonadCacheIn' instance as an oracle for results and a 'MonadCacheOut' instance to record computed results in. +-- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. memoizeEval :: forall v term . ( Ord v , Ord term From b0815eeb367f43b40e8df48cfc25dbba25f25d1b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:49:11 -0500 Subject: [PATCH 059/292] Define a Reducer instance for Latest. --- src/Data/Abstract/Address.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index 4d0257941..f6beb07be 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeFamilyDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeFamilies, TypeFamilyDependencies #-} module Data.Abstract.Address where -import Prologue import Data.Abstract.FreeVariables +import Data.Semigroup.Reducer +import Prologue -- | An abstract address with a location of @l@ pointing to a variable of type @a@. newtype Address l a = Address { unAddress :: l } @@ -38,6 +39,9 @@ instance Semigroup (Latest a) where instance Pointed Latest where point = Latest +instance Reducer a (Latest a) where + unit = Latest + instance Eq1 Latest where liftEq = genericLiftEq instance Ord1 Latest where liftCompare = genericLiftCompare instance Show1 Latest where liftShowsPrec = genericLiftShowsPrec From 15f8962700492a9a4cf26cfe3fac1a2e92025de0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:49:52 -0500 Subject: [PATCH 060/292] Specialize snoc & cons. --- src/Data/Abstract/Address.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index f6beb07be..ccd4dfd29 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -41,6 +41,8 @@ instance Pointed Latest where instance Reducer a (Latest a) where unit = Latest + cons _ = id + snoc _ = unit instance Eq1 Latest where liftEq = genericLiftEq instance Ord1 Latest where liftCompare = genericLiftCompare From 81e5fa061a0fd98465f2567b94487e891b817498 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:50:15 -0500 Subject: [PATCH 061/292] Use a pointful definition for <>. --- src/Data/Abstract/Address.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index ccd4dfd29..0dff7820a 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -34,7 +34,7 @@ newtype Latest a = Latest { unLatest :: a } deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable) instance Semigroup (Latest a) where - (<>) = flip const + _ <> a = a instance Pointed Latest where point = Latest From 57521b10f17606ea032a6974a09dc4d15d410919 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 11:51:53 -0500 Subject: [PATCH 062/292] Stores use a Reducer to insert values. --- src/Control/Abstract/Addressable.hs | 9 ++++----- src/Data/Abstract/Store.hs | 7 ++++--- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 12b9ccf91..eeaf77536 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -11,12 +11,12 @@ import Data.Abstract.FreeVariables import Data.Abstract.Store import Data.Abstract.Value import Data.Foldable (asum, toList) -import Data.Pointed import Data.Semigroup +import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad m, Ord l, Pointed (Cell l), l ~ LocationFor a) => MonadAddressable l a m | m -> a where +class (Monad m, Ord l, l ~ LocationFor a, Reducer a (Cell l a)) => MonadAddressable l a m | m -> a where deref :: Address l a -> m a @@ -55,8 +55,7 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor a) , MonadEvaluator t a m - , Pointed (Cell (LocationFor a)) - , Semigroup (CellFor a) + , Reducer a (CellFor a) ) => Address (LocationFor a) a -> a @@ -78,7 +77,7 @@ instance (Monad m, MonadEvaluator t v m, LocationFor v ~ Precise) => MonadAddres -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, LocationFor v ~ Monovariant, Monad m, MonadEvaluator t v m) => MonadAddressable Monovariant v m where +instance (Alternative m, Ord v, LocationFor v ~ Monovariant, Monad m, MonadEvaluator t v m) => MonadAddressable Monovariant v m where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Data/Abstract/Store.hs b/src/Data/Abstract/Store.hs index 2a8c8ccd4..df62a34bb 100644 --- a/src/Data/Abstract/Store.hs +++ b/src/Data/Abstract/Store.hs @@ -1,10 +1,11 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-} module Data.Abstract.Store where -import Prologue import Data.Abstract.Address import Data.Abstract.Live import qualified Data.Map as Map +import Data.Semigroup.Reducer +import Prologue -- | A map of addresses onto cells holding their values. newtype Store l a = Store { unStore :: Map.Map l (Cell l a) } @@ -29,8 +30,8 @@ storeLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Store l a -> Mayb storeLookupAll address = fmap toList . storeLookup address -- | Append a value onto the cell for a given address, inserting a new cell if none existed. -storeInsert :: (Ord l, Semigroup (Cell l a), Pointed (Cell l)) => Address l a -> a -> Store l a -> Store l a -storeInsert (Address address) value = Store . Map.insertWith (<>) address (point value) . unStore +storeInsert :: (Ord l, Reducer a (Cell l a)) => Address l a -> a -> Store l a -> Store l a +storeInsert (Address address) value = Store . Map.insertWith (<>) address (unit value) . unStore -- | The number of addresses extant in a 'Store'. storeSize :: Store l a -> Int From 48e1ae7003a6a0669ecc1b25dbafa0db74cb3460 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:00:04 -0500 Subject: [PATCH 063/292] Flip the semigroup operator in storeInsert. --- src/Data/Abstract/Store.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Store.hs b/src/Data/Abstract/Store.hs index df62a34bb..86a9267bb 100644 --- a/src/Data/Abstract/Store.hs +++ b/src/Data/Abstract/Store.hs @@ -31,7 +31,9 @@ storeLookupAll address = fmap toList . storeLookup address -- | Append a value onto the cell for a given address, inserting a new cell if none existed. storeInsert :: (Ord l, Reducer a (Cell l a)) => Address l a -> a -> Store l a -> Store l a -storeInsert (Address address) value = Store . Map.insertWith (<>) address (unit value) . unStore +storeInsert (Address address) value + -- Per the docs, 'Map.insertWith' applies its function operand to the new value first, followed by the old value. For 'Latest' this will result in us always keeping the oldest value instead of the latest one, which is exactly opposite to the desired semantics. + = Store . Map.insertWith (flip (<>)) address (unit value) . unStore -- | The number of addresses extant in a 'Store'. storeSize :: Store l a -> Int From 08472f6139753e0e769c2ff2d222696287c3b2e9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:00:13 -0500 Subject: [PATCH 064/292] :fire: the Pointed instance for Latest. --- src/Data/Abstract/Address.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index 0dff7820a..e071e27c8 100644 --- a/src/Data/Abstract/Address.hs +++ b/src/Data/Abstract/Address.hs @@ -36,9 +36,6 @@ newtype Latest a = Latest { unLatest :: a } instance Semigroup (Latest a) where _ <> a = a -instance Pointed Latest where - point = Latest - instance Reducer a (Latest a) where unit = Latest cons _ = id From 0f8f30231692bc53a7e8d3f9694e331f1318419c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:04:44 -0500 Subject: [PATCH 065/292] Define gather using a Reducer. --- src/Analysis/Abstract/Caching.hs | 3 +-- src/Control/Monad/Effect/NonDet.hs | 12 ++++++------ 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 46555f440..2c744a8b4 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -14,7 +14,6 @@ import Data.Abstract.Configuration import Data.Abstract.Evaluatable import Data.Abstract.Store import Data.Abstract.Value -import qualified Data.Set as Set -- | The effects necessary for caching analyses. type CachingEffects term value @@ -81,7 +80,7 @@ instance ( Corecursive t -- to corral all the nondeterminism that happens in this @eval@ invocation, so -- that it doesn't "leak" to the calling context and diverge -- (otherwise this would never complete). - _ <- localCache (const prevCache) (gather Set.singleton (memoizeEval e)) + _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis t v ()) getCache) mempty maybe empty scatter (cacheLookup c cache) diff --git a/src/Control/Monad/Effect/NonDet.hs b/src/Control/Monad/Effect/NonDet.hs index 265ef879a..4b4d8afc2 100644 --- a/src/Control/Monad/Effect/NonDet.hs +++ b/src/Control/Monad/Effect/NonDet.hs @@ -4,20 +4,20 @@ module Control.Monad.Effect.NonDet , NonDetEff ) where -import Prologue import Control.Monad.Effect.Internal import Control.Monad.Effect.NonDetEff +import Data.Semigroup.Reducer +import Prologue -- | 'Monad's offering local isolation of nondeterminism effects. class (Alternative m, Monad m) => MonadNonDet m where -- | Run a computation, gathering any nondeterministically produced results into a single 'Monoid'al value. - gather :: Monoid b - => (a -> b) -- ^ A function constructing a 'Monoid'al value from a single computed result. This might typically be @point@ (for @Pointed@ functors), 'pure' (for 'Applicative's), or some similar singleton constructor. - -> m a -- ^ The computation to run locally-nondeterministically. - -> m b -- ^ A _deterministic_ computation producing the 'Monoid'al accumulation of the _locally-nondeterministic_ result values. + gather :: (Monoid b, Reducer a b) + => m a -- ^ The computation to run locally-nondeterministically. + -> m b -- ^ A _deterministic_ computation producing the 'Monoid'al accumulation of the _locally-nondeterministic_ result values. -- | Effect stacks containing 'NonDetEff' offer a 'MonadNonDet' instance which implements 'gather' by interpreting the requests for nondeterminism locally, without removing 'NonDetEff' from the stack—i.e. the _capacity_ for nondeterminism is still present in the effect stack, but any local nondeterminism has been applied. instance (NonDetEff :< fs) => MonadNonDet (Eff fs) where - gather f = interpose (pure . f) (\ m k -> case m of + gather = interpose (pure . unit) (\ m k -> case m of MZero -> pure mempty MPlus -> mappend <$> k True <*> k False) From 64b0e7f27357e8617544c1edef1c0d32f9e253da Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:06:39 -0500 Subject: [PATCH 066/292] =?UTF-8?q?Clarify=20why=20we=E2=80=99re=20'gather?= =?UTF-8?q?'ing=20into=20().?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Caching.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 2c744a8b4..d861855b5 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -78,8 +78,9 @@ instance ( Corecursive t reset 0 -- This is subtle: though the calling context supports nondeterminism, we want -- to corral all the nondeterminism that happens in this @eval@ invocation, so - -- that it doesn't "leak" to the calling context and diverge - -- (otherwise this would never complete). + -- that it doesn't "leak" to the calling context and diverge (otherwise this + -- would never complete). We don’t need to use the values, so we 'gather' the + -- nondeterministic values into @()@. _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis t v ()) getCache) mempty maybe empty scatter (cacheLookup c cache) From c08b46be0499d1baa21abff1d6d5eb2671275e3c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:07:29 -0500 Subject: [PATCH 067/292] Derive a Reducer instance for Dead. --- src/Analysis/Abstract/Dead.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 6b5c2f176..e069de1f6 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -5,6 +5,7 @@ import Control.Abstract.Addressable import Control.Abstract.Evaluator import Data.Abstract.Evaluatable import Data.Abstract.Value +import Data.Semigroup.Reducer import Data.Set (delete) import Prologue @@ -45,6 +46,8 @@ deriving instance MonadEvaluator term value (DeadCodeAnalysis term value) newtype Dead a = Dead { unDead :: Set a } deriving (Eq, Foldable, Semigroup, Monoid, Ord, Pointed, Show) +deriving instance Ord a => Reducer a (Dead a) + -- | Update the current 'Dead' set. killAll :: Dead t -> DeadCodeAnalysis t v () killAll = DeadCodeAnalysis . Evaluator . put From ceb42a0839e21935b4fc0f6c2cf04b15693bf26d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:09:51 -0500 Subject: [PATCH 068/292] Define subterms using the Reducer instance. --- src/Analysis/Abstract/Dead.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index e069de1f6..ae12315e2 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -5,7 +5,7 @@ import Control.Abstract.Addressable import Control.Abstract.Evaluator import Data.Abstract.Evaluatable import Data.Abstract.Value -import Data.Semigroup.Reducer +import Data.Semigroup.Reducer as Reducer import Data.Set (delete) import Prologue @@ -32,7 +32,7 @@ evaluateDead term = run @(DeadCodeEffects term value) . runEvaluator . runDeadCo killAll (subterms term) evaluateTerm term where subterms :: (Ord a, Recursive a, Foldable (Base a)) => a -> Dead a - subterms term = para (foldMap (uncurry ((<>) . point))) term <> point term + subterms term = term `cons` para (foldMap (uncurry cons)) term -- | A newtype wrapping 'Evaluator' which performs a dead code analysis on evaluation. From 54cf11614114898df09b5a45cf4b1c045d031a90 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:11:09 -0500 Subject: [PATCH 069/292] :fire: the Pointed instance for Dead. --- src/Analysis/Abstract/Dead.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index ae12315e2..c1fde105b 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -44,7 +44,7 @@ deriving instance MonadEvaluator term value (DeadCodeAnalysis term value) -- | A set of “dead” (unreachable) terms. newtype Dead a = Dead { unDead :: Set a } - deriving (Eq, Foldable, Semigroup, Monoid, Ord, Pointed, Show) + deriving (Eq, Foldable, Semigroup, Monoid, Ord, Show) deriving instance Ord a => Reducer a (Dead a) From df05cd25e348b6f45a8507caf46ed37e4928a6ce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:13:22 -0500 Subject: [PATCH 070/292] Define cacheInsert using the Reducer instance. --- src/Data/Abstract/Cache.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index b636d3056..c9177557b 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -1,11 +1,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-} module Data.Abstract.Cache where -import Prologue import Data.Abstract.Address import Data.Abstract.Configuration import Data.Abstract.Store import Data.Map as Map +import Data.Semigroup.Reducer +import Prologue -- | A map of 'Configuration's to 'Set's of resulting values & 'Store's. newtype Cache l t v = Cache { unCache :: Map.Map (Configuration l t v) (Set (v, Store l v)) } @@ -26,7 +27,7 @@ cacheSet key value = Cache . Map.insert key value . unCache -- | Insert the resulting value & 'Store' for a given 'Configuration', appending onto any previous entry. cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v -cacheInsert key value = Cache . Map.insertWith (<>) key (point value) . unCache +cacheInsert key value = Cache . Map.insertWith (<>) key (unit value) . unCache instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Cache l t) where From 5b1187018f6598e6faf1234806b214b1c3574df7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:18:23 -0500 Subject: [PATCH 071/292] Define the RunEffect instance for NonDetEff in terms of Reducer. --- src/Control/Effect.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index ac5096747..162dce702 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-} module Control.Effect where -import Prologue import qualified Control.Monad.Effect as Effect import Control.Monad.Effect.Fail import Control.Monad.Effect.Internal hiding (run) @@ -9,6 +8,8 @@ import Control.Monad.Effect.NonDetEff import Control.Monad.Effect.Reader import Control.Monad.Effect.State import Control.Monad.Effect.Writer +import Data.Semigroup.Reducer +import Prologue -- | Run a computation in 'Eff' to completion, interpreting each effect with some sensible defaults, and return the 'Final' result. run :: RunEffects fs a => Eff fs a -> Final fs a @@ -60,7 +61,7 @@ instance Monoid w => RunEffect (Writer w) a where -- | 'NonDetEff' effects are interpreted into a nondeterministic set of result values. instance Ord a => RunEffect NonDetEff a where type Result NonDetEff a = Set a - runEffect = relay (pure . point) (\ m k -> case m of + runEffect = relay (pure . unit) (\ m k -> case m of MZero -> pure mempty MPlus -> mappend <$> k True <*> k False) From e6c9778ec9b097895a699994f6427fdc2a599523 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:18:53 -0500 Subject: [PATCH 072/292] Use Set.singleton instead of point to produce the free variables for Identifier. --- src/Data/Syntax.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index e3275b7d5..4c53e86c8 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -10,6 +10,7 @@ import Data.ByteString.Char8 (unpack) import qualified Data.Error as Error import Data.Range import Data.Record +import qualified Data.Set as Set import Data.Span import Data.Term import Diffing.Algorithm hiding (Empty) @@ -113,7 +114,7 @@ instance Evaluatable Identifier where maybe (fail ("free variable: " <> unpack name)) deref (envLookup name env) instance FreeVariables1 Identifier where - liftFreeVariables _ (Identifier x) = point x + liftFreeVariables _ (Identifier x) = Set.singleton x newtype Program a = Program [a] deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) From e5b662f1ba3ac4baad8999ff2b6aaecdae9c7aa2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:19:04 -0500 Subject: [PATCH 073/292] :fire: the re-export of Pointed. --- src/Prologue.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Prologue.hs b/src/Prologue.hs index bb11324ec..c818baecb 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -51,7 +51,6 @@ import Data.Functor.Classes.Generic as X import Data.Functor.Foldable as X (Base, Recursive(..), Corecursive(..)) import Data.Mergeable as X (Mergeable) import Data.Monoid as X (Monoid(..), First(..), Last(..)) -import Data.Pointed as X import Data.Proxy as X (Proxy(..)) import Data.Semigroup as X (Semigroup(..)) import Data.Traversable as X From c121a0665e5e1ff99eadcd5a4230ec660c0f4cc9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:19:27 -0500 Subject: [PATCH 074/292] :fire: the dependency on pointed. --- semantic.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/semantic.cabal b/semantic.cabal index 908e24147..0e967beed 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -159,7 +159,6 @@ library , optparse-applicative , parallel , parsers - , pointed , recursion-schemes , reducers , semigroups From 257a068b3c634733c3458f1c9e263ad864271755 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:22:52 -0500 Subject: [PATCH 075/292] Stub in a Monoidal map module. --- semantic.cabal | 1 + src/Data/Map/Monoidal.hs | 2 ++ 2 files changed, 3 insertions(+) create mode 100644 src/Data/Map/Monoidal.hs diff --git a/semantic.cabal b/semantic.cabal index 0e967beed..0d0e958cb 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -64,6 +64,7 @@ library , Data.Functor.Classes.Generic , Data.JSON.Fields , Data.Language + , Data.Map.Monoidal , Data.Mergeable , Data.Output , Data.Patch diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs new file mode 100644 index 000000000..a2446665f --- /dev/null +++ b/src/Data/Map/Monoidal.hs @@ -0,0 +1,2 @@ +-- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type. +module Data.Map.Monoidal where From f0f7a6599a9daee8d4ffca5443f34b069e93a948 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:23:31 -0500 Subject: [PATCH 076/292] Define a Monoidal Map type. --- src/Data/Map/Monoidal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index a2446665f..c66f5d4b9 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -1,2 +1,6 @@ -- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type. module Data.Map.Monoidal where + +import qualified Data.Map as Map + +newtype Map key value = Map { unMap :: Map.Map key value } From 24d37d7f8f05c2a827e1f5a0b966de671958a8ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:23:59 -0500 Subject: [PATCH 077/292] Derive Eq, Ord, & Show instances for Map. --- src/Data/Map/Monoidal.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index c66f5d4b9..d9acfcc3f 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type. module Data.Map.Monoidal where import qualified Data.Map as Map newtype Map key value = Map { unMap :: Map.Map key value } + deriving (Eq, Ord, Show) From 303e55b40343f779145c5f7e0981c133cd829e2e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:25:39 -0500 Subject: [PATCH 078/292] Define a Semigroup instance for Map. --- src/Data/Map/Monoidal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index d9acfcc3f..18e21c40c 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -3,6 +3,10 @@ module Data.Map.Monoidal where import qualified Data.Map as Map +import Prologue hiding (Map) newtype Map key value = Map { unMap :: Map.Map key value } deriving (Eq, Ord, Show) + +instance (Ord key, Semigroup value) => Semigroup (Map key value) where + Map a <> Map b = Map (Map.unionWith (<>) a b) From f199e7fa73981277374f3f44d09811982cc6e8a3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:26:32 -0500 Subject: [PATCH 079/292] Define a Monoid instance for Map. --- src/Data/Map/Monoidal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 18e21c40c..36996c464 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -10,3 +10,7 @@ newtype Map key value = Map { unMap :: Map.Map key value } instance (Ord key, Semigroup value) => Semigroup (Map key value) where Map a <> Map b = Map (Map.unionWith (<>) a b) + +instance (Ord key, Semigroup value) => Monoid (Map key value) where + mempty = Map Map.empty + mappend = (<>) From 9c7c6ed6523dad45bc839163403b4e6e2f6eab38 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:30:34 -0500 Subject: [PATCH 080/292] Define a Reducer instance for Map. --- src/Data/Map/Monoidal.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 36996c464..b14db67b6 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} -- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type. module Data.Map.Monoidal where import qualified Data.Map as Map +import Data.Semigroup.Reducer import Prologue hiding (Map) newtype Map key value = Map { unMap :: Map.Map key value } @@ -14,3 +15,8 @@ instance (Ord key, Semigroup value) => Semigroup (Map key value) where instance (Ord key, Semigroup value) => Monoid (Map key value) where mempty = Map Map.empty mappend = (<>) + +instance (Ord key, Reducer a value) => Reducer (key, a) (Map key value) where + unit (key, a) = Map (Map.singleton key (unit a)) + cons (key, a) (Map m) = Map (Map.insertWith (<>) key (unit a) m) + snoc (Map m) (key, a) = Map (Map.insertWith (flip (<>)) key (unit a) m) From f77812bb1ef7a6083399df5870df4270f3fda035 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:34:57 -0500 Subject: [PATCH 081/292] Derive Foldable, Functor, & Traversable instances for Map. --- src/Data/Map/Monoidal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index b14db67b6..2f99906a7 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -7,7 +7,7 @@ import Data.Semigroup.Reducer import Prologue hiding (Map) newtype Map key value = Map { unMap :: Map.Map key value } - deriving (Eq, Ord, Show) + deriving (Eq, Foldable, Functor, Ord, Show, Traversable) instance (Ord key, Semigroup value) => Semigroup (Map key value) where Map a <> Map b = Map (Map.unionWith (<>) a b) From 104d9f77bf60fb6b875653a5a3502b416724831c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:35:49 -0500 Subject: [PATCH 082/292] Derive Eq1, Ord1, & Show1 instances for Map. --- src/Data/Map/Monoidal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 2f99906a7..fd1a9da21 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -7,7 +7,7 @@ import Data.Semigroup.Reducer import Prologue hiding (Map) newtype Map key value = Map { unMap :: Map.Map key value } - deriving (Eq, Foldable, Functor, Ord, Show, Traversable) + deriving (Eq, Eq1, Foldable, Functor, Ord, Ord1, Show, Show1, Traversable) instance (Ord key, Semigroup value) => Semigroup (Map key value) where Map a <> Map b = Map (Map.unionWith (<>) a b) From 6981a2a6ce0de68f1c530d34f1cad78ac084fd18 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:36:06 -0500 Subject: [PATCH 083/292] Derive Eq2, Ord2, & Show2 instances for Map. --- src/Data/Map/Monoidal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index fd1a9da21..c192f8483 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -7,7 +7,7 @@ import Data.Semigroup.Reducer import Prologue hiding (Map) newtype Map key value = Map { unMap :: Map.Map key value } - deriving (Eq, Eq1, Foldable, Functor, Ord, Ord1, Show, Show1, Traversable) + deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, Traversable) instance (Ord key, Semigroup value) => Semigroup (Map key value) where Map a <> Map b = Map (Map.unionWith (<>) a b) From adce2707e23098f0ff727e34db926347f8bc0c74 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:40:36 -0500 Subject: [PATCH 084/292] Explicitly list the exports from Map. --- src/Data/Map/Monoidal.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index c192f8483..36d8136f2 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -1,12 +1,14 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-} -- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type. -module Data.Map.Monoidal where +module Data.Map.Monoidal +( Map +) where import qualified Data.Map as Map import Data.Semigroup.Reducer import Prologue hiding (Map) -newtype Map key value = Map { unMap :: Map.Map key value } +newtype Map key value = Map (Map.Map key value) deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, Traversable) instance (Ord key, Semigroup value) => Semigroup (Map key value) where From 00942f7073973a730683fbbb1f4c5ac49172309d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:40:57 -0500 Subject: [PATCH 085/292] Re-export the Reducer interface. --- src/Data/Map/Monoidal.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 36d8136f2..32032aa1f 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -2,10 +2,11 @@ -- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type. module Data.Map.Monoidal ( Map +, module Reducer ) where import qualified Data.Map as Map -import Data.Semigroup.Reducer +import Data.Semigroup.Reducer as Reducer import Prologue hiding (Map) newtype Map key value = Map (Map.Map key value) From 2aeab94001367a155a75a98c710e69b3f2b055b8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:44:05 -0500 Subject: [PATCH 086/292] Define a lookup function for Map. --- src/Data/Map/Monoidal.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 32032aa1f..538a93343 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -2,16 +2,23 @@ -- | This module defines a 'Map' type whose 'Monoid' and 'Reducer' instances merge values using the 'Semigroup' instance for the underlying type. module Data.Map.Monoidal ( Map +, lookup , module Reducer ) where import qualified Data.Map as Map import Data.Semigroup.Reducer as Reducer +import Prelude hiding (lookup) import Prologue hiding (Map) -newtype Map key value = Map (Map.Map key value) +newtype Map key value = Map { unMap :: Map.Map key value } deriving (Eq, Eq1, Eq2, Foldable, Functor, Ord, Ord1, Ord2, Show, Show1, Show2, Traversable) + +lookup :: Ord key => key -> Map key value -> Maybe value +lookup key = Map.lookup key . unMap + + instance (Ord key, Semigroup value) => Semigroup (Map key value) where Map a <> Map b = Map (Map.unionWith (<>) a b) From b940eb6e86669baf6b93822921c2002d63a7ba4b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:46:08 -0500 Subject: [PATCH 087/292] Define an insert function for Map. --- src/Data/Map/Monoidal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index 538a93343..f3222aef4 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -3,6 +3,7 @@ module Data.Map.Monoidal ( Map , lookup +, insert , module Reducer ) where @@ -18,6 +19,9 @@ newtype Map key value = Map { unMap :: Map.Map key value } lookup :: Ord key => key -> Map key value -> Maybe value lookup key = Map.lookup key . unMap +insert :: Ord key => key -> value -> Map key value -> Map key value +insert key value = Map . Map.insert key value . unMap + instance (Ord key, Semigroup value) => Semigroup (Map key value) where Map a <> Map b = Map (Map.unionWith (<>) a b) From a8fdeddd6f6894d4aa6f8728b8b4405ba08e9ded Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:46:55 -0500 Subject: [PATCH 088/292] Define Cache using a Monoidal Map. --- src/Data/Abstract/Cache.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index c9177557b..6dbbda10c 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -4,8 +4,7 @@ module Data.Abstract.Cache where import Data.Abstract.Address import Data.Abstract.Configuration import Data.Abstract.Store -import Data.Map as Map -import Data.Semigroup.Reducer +import Data.Map.Monoidal as Map import Prologue -- | A map of 'Configuration's to 'Set's of resulting values & 'Store's. @@ -27,7 +26,7 @@ cacheSet key value = Cache . Map.insert key value . unCache -- | Insert the resulting value & 'Store' for a given 'Configuration', appending onto any previous entry. cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v -cacheInsert key value = Cache . Map.insertWith (<>) key (unit value) . unCache +cacheInsert key value = Cache . flip snoc (key, value) . unCache instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Cache l t) where From 52b4609027478507833835547383e9fa629994c6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:49:06 -0500 Subject: [PATCH 089/292] Derive a Reducer instance for Cache. --- src/Data/Abstract/Cache.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 6dbbda10c..7f4e3aadd 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} module Data.Abstract.Cache where import Data.Abstract.Address @@ -15,6 +15,7 @@ deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Cache l t v) deriving instance (Show l, Show t, Show v, Show (Cell l v)) => Show (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Semigroup (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Monoid (Cache l t v) +deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Reducer (Configuration l t v, (v, Store l v)) (Cache l t v) -- | Look up the resulting value & 'Store' for a given 'Configuration'. cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Store l v)) From 4c1133e5931c9a1d390ea2fed714730baed5cfa8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:50:27 -0500 Subject: [PATCH 090/292] Simplify cacheInsert. --- src/Data/Abstract/Cache.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index 7f4e3aadd..c60cf3c0d 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -27,7 +27,7 @@ cacheSet key value = Cache . Map.insert key value . unCache -- | Insert the resulting value & 'Store' for a given 'Configuration', appending onto any previous entry. cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v -cacheInsert key value = Cache . flip snoc (key, value) . unCache +cacheInsert key value = cons (key, value) instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Cache l t) where From eee6c84553edab418bf50a879bb394afb706883c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 12:50:38 -0500 Subject: [PATCH 091/292] Simplify cacheInsert further! --- src/Data/Abstract/Cache.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index c60cf3c0d..fc7671148 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -27,7 +27,7 @@ cacheSet key value = Cache . Map.insert key value . unCache -- | Insert the resulting value & 'Store' for a given 'Configuration', appending onto any previous entry. cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v -cacheInsert key value = cons (key, value) +cacheInsert = curry cons instance (Eq l, Eq t, Eq1 (Cell l)) => Eq1 (Cache l t) where From 6588787368e3638e3cdb53a263d94aac8898cb5e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 13:24:27 -0500 Subject: [PATCH 092/292] Define a size function for Map. --- src/Data/Map/Monoidal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index f3222aef4..ac135bd82 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -3,6 +3,7 @@ module Data.Map.Monoidal ( Map , lookup +, size , insert , module Reducer ) where @@ -19,6 +20,9 @@ newtype Map key value = Map { unMap :: Map.Map key value } lookup :: Ord key => key -> Map key value -> Maybe value lookup key = Map.lookup key . unMap +size :: Map key value -> Int +size = Map.size . unMap + insert :: Ord key => key -> value -> Map key value -> Map key value insert key value = Map . Map.insert key value . unMap From 09650a1330b69a92dbca3b429c70d9275b3eeb72 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 13:25:30 -0500 Subject: [PATCH 093/292] Define a filterWithKey function for Map. --- src/Data/Map/Monoidal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/Map/Monoidal.hs b/src/Data/Map/Monoidal.hs index ac135bd82..d3de1f021 100644 --- a/src/Data/Map/Monoidal.hs +++ b/src/Data/Map/Monoidal.hs @@ -5,6 +5,7 @@ module Data.Map.Monoidal , lookup , size , insert +, filterWithKey , module Reducer ) where @@ -26,6 +27,9 @@ size = Map.size . unMap insert :: Ord key => key -> value -> Map key value -> Map key value insert key value = Map . Map.insert key value . unMap +filterWithKey :: (key -> value -> Bool) -> Map key value -> Map key value +filterWithKey f = Map . Map.filterWithKey f . unMap + instance (Ord key, Semigroup value) => Semigroup (Map key value) where Map a <> Map b = Map (Map.unionWith (<>) a b) From fb19c9df32f92a456ba5939d60461da199769561 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 13:28:29 -0500 Subject: [PATCH 094/292] Define Store over a Monoidal Map. --- src/Data/Abstract/Store.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Data/Abstract/Store.hs b/src/Data/Abstract/Store.hs index 86a9267bb..4dbb6270c 100644 --- a/src/Data/Abstract/Store.hs +++ b/src/Data/Abstract/Store.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, UndecidableInstances #-} module Data.Abstract.Store where import Data.Abstract.Address import Data.Abstract.Live -import qualified Data.Map as Map +import qualified Data.Map.Monoidal as Map import Data.Semigroup.Reducer import Prologue -- | A map of addresses onto cells holding their values. newtype Store l a = Store { unStore :: Map.Map l (Cell l a) } - deriving (Generic1, Monoid, Semigroup) + deriving (Generic1) deriving instance (Eq l, Eq (Cell l a)) => Eq (Store l a) deriving instance (Ord l, Ord (Cell l a)) => Ord (Store l a) @@ -20,6 +20,9 @@ instance (Show l, Show1 (Cell l)) => Show1 (Store l) where liftShowsPrec = gener deriving instance Foldable (Cell l) => Foldable (Store l) deriving instance Functor (Cell l) => Functor (Store l) deriving instance Traversable (Cell l) => Traversable (Store l) +deriving instance (Ord l, Semigroup (Cell l a)) => Semigroup (Store l a) +deriving instance (Ord l, Semigroup (Cell l a)) => Monoid (Store l a) +deriving instance (Ord l, Reducer a (Cell l a)) => Reducer (l, a) (Store l a) -- | Look up the cell of values for an 'Address' in a 'Store', if any. storeLookup :: Ord l => Address l a -> Store l a -> Maybe (Cell l a) @@ -31,9 +34,7 @@ storeLookupAll address = fmap toList . storeLookup address -- | Append a value onto the cell for a given address, inserting a new cell if none existed. storeInsert :: (Ord l, Reducer a (Cell l a)) => Address l a -> a -> Store l a -> Store l a -storeInsert (Address address) value - -- Per the docs, 'Map.insertWith' applies its function operand to the new value first, followed by the old value. For 'Latest' this will result in us always keeping the oldest value instead of the latest one, which is exactly opposite to the desired semantics. - = Store . Map.insertWith (flip (<>)) address (unit value) . unStore +storeInsert (Address address) value = flip snoc (address, value) -- | The number of addresses extant in a 'Store'. storeSize :: Store l a -> Int From 94dfeb34ad63b63fe3203ebc9196f511b2623bff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 13:46:51 -0500 Subject: [PATCH 095/292] Abstract TracingAnalysis over the underlying evaluator. --- src/Analysis/Abstract/Tracing.hs | 30 ++++++++++++++++-------------- 1 file changed, 16 insertions(+), 14 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index a13fa9bec..ff69fd305 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Addressable @@ -28,8 +28,9 @@ evaluateTrace :: forall trace value term , Ord value , Recursive term , Reducer (ConfigurationFor term value) trace - , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value (TracingEffects trace term value)) - , MonadValue term value (TracingAnalysis trace term value (TracingEffects trace term value)) + , MonadAddressable (LocationFor value) value (TracingAnalysis trace Evaluator term value (TracingEffects trace term value)) + , MonadAnalysis term value (Evaluator term value (TracingEffects trace term value)) + , MonadValue term value (TracingAnalysis trace Evaluator term value (TracingEffects trace term value)) , Semigroup (CellFor value) ) => term @@ -37,27 +38,28 @@ evaluateTrace :: forall trace value term evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTracingAnalysis @trace . evaluateTerm -newtype TracingAnalysis trace term value effects a - = TracingAnalysis { runTracingAnalysis :: Evaluator term value effects a } - deriving (Applicative, Functor, LiftEffect, Monad) +newtype TracingAnalysis trace underlying term value (effects :: [* -> *]) a + = TracingAnalysis { runTracingAnalysis :: underlying term value effects a } + deriving (Applicative, Functor, LiftEffect, Monad, MonadFail) -deriving instance Member Fail effects => MonadFail (TracingAnalysis trace term value effects) -deriving instance Members (EvaluatorEffects term value) effects => MonadEvaluator term value (TracingAnalysis trace term value effects) +deriving instance MonadEvaluator term value (underlying term value effects) => MonadEvaluator term value (TracingAnalysis trace underlying term value effects) instance ( Corecursive term , Evaluatable (Base term) , FreeVariables term + , LiftEffect (underlying term value) , Member (Writer trace) effects - , MonadAddressable (LocationFor value) value (TracingAnalysis trace term value effects) - , MonadValue term value (TracingAnalysis trace term value effects) + , MonadAddressable (LocationFor value) value (TracingAnalysis trace underlying term value effects) + , MonadAnalysis term value (underlying term value effects) + , MonadValue term value (TracingAnalysis trace underlying term value effects) , Recursive term , Reducer (ConfigurationFor term value) trace , Semigroup (CellFor value) ) - => MonadAnalysis term value (TracingAnalysis trace term value effects) where - analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> eval term + => MonadAnalysis term value (TracingAnalysis trace underlying term value effects) where + analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> analyzeTerm term -trace :: Member (Writer trace) effects +trace :: (LiftEffect (underlying term value), Member (Writer trace) effects) => trace - -> TracingAnalysis trace term value effects () + -> TracingAnalysis trace underlying term value effects () trace w = lift (tell w) From 16d03caf3d7ee443c73a2496ccc8d2b81f4dad72 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 13:59:47 -0500 Subject: [PATCH 096/292] Rename the term/value type parameters. --- src/Analysis/Abstract/Evaluating.hs | 42 ++++++++++++++--------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index f81f25f12..f75189e21 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -12,33 +12,33 @@ import Prologue import System.FilePath.Posix -- | Evaluate a term to a value. -evaluate :: forall v term +evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor v) v (Evaluation term v) - , MonadValue term v (Evaluation term v) - , Ord (LocationFor v) + , MonadAddressable (LocationFor value) value (Evaluation term value) + , MonadValue term value (Evaluation term value) + , Ord (LocationFor value) , Recursive term - , Semigroup (CellFor v) + , Semigroup (CellFor value) ) => term - -> Final (EvaluatorEffects term v) v -evaluate = run @(EvaluatorEffects term v) . runEvaluator . runEvaluation . evaluateTerm + -> Final (EvaluatorEffects term value) value +evaluate = run @(EvaluatorEffects term value) . runEvaluator . runEvaluation . evaluateTerm -- | Evaluate terms and an entry point to a value. -evaluates :: forall v term +evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor v) v (Evaluation term v) - , MonadValue term v (Evaluation term v) - , Ord (LocationFor v) + , MonadAddressable (LocationFor value) value (Evaluation term value) + , MonadValue term value (Evaluation term value) + , Ord (LocationFor value) , Recursive term - , Semigroup (CellFor v) + , Semigroup (CellFor value) ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint - -> Final (EvaluatorEffects term v) v -evaluates pairs (_, t) = run @(EvaluatorEffects term v) (runEvaluator (runEvaluation (withModules pairs (evaluateTerm t)))) + -> Final (EvaluatorEffects term value) value +evaluates pairs (_, t) = run @(EvaluatorEffects term value) (runEvaluator (runEvaluation (withModules pairs (evaluateTerm t)))) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis term value m, MonadEvaluator term value m) => [(Blob, term)] -> m a -> m a @@ -51,12 +51,12 @@ newtype Evaluation term value a = Evaluation { runEvaluation :: Evaluator term v deriving instance MonadEvaluator term value (Evaluation term value) -instance ( Evaluatable (Base t) - , FreeVariables t - , MonadAddressable (LocationFor v) v (Evaluation t v) - , MonadValue t v (Evaluation t v) - , Recursive t - , Semigroup (CellFor v) +instance ( Evaluatable (Base term) + , FreeVariables term + , MonadAddressable (LocationFor value) value (Evaluation term value) + , MonadValue term value (Evaluation term value) + , Recursive term + , Semigroup (CellFor value) ) - => MonadAnalysis t v (Evaluation t v) where + => MonadAnalysis term value (Evaluation term value) where analyzeTerm = eval From b0de8c583063eb1a4f424dcd89c936513666f0f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 15:05:08 -0500 Subject: [PATCH 097/292] Represent term/value types with type families. --- src/Analysis/Abstract/Caching.hs | 23 +++++++++-------- src/Analysis/Abstract/Dead.hs | 17 +++++++------ src/Analysis/Abstract/Evaluating.hs | 21 +++++++++------- src/Analysis/Abstract/Tracing.hs | 31 ++++++++++++++--------- src/Control/Abstract/Addressable.hs | 27 +++++++++++--------- src/Control/Abstract/Analysis.hs | 15 +++++++---- src/Control/Abstract/Evaluator.hs | 39 ++++++++++++++--------------- src/Control/Abstract/Value.hs | 20 ++++++++------- src/Data/Abstract/Evaluatable.hs | 32 ++++++++++++----------- 9 files changed, 126 insertions(+), 99 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index d861855b5..f03769e04 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Caching ( evaluateCache ) where @@ -29,7 +29,7 @@ type CacheFor term value = Cache (LocationFor value) term value newtype CachingAnalysis term value a = CachingAnalysis { runCachingAnalysis :: Evaluator term value (CachingEffects term value) a } deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadEvaluator term value (CachingAnalysis term value) +deriving instance Ord (LocationFor value) => MonadEvaluator (CachingAnalysis term value) -- TODO: reabstract these later on @@ -62,12 +62,12 @@ instance ( Corecursive t , Evaluatable (Base t) , Foldable (Cell (LocationFor v)) , FreeVariables t - , MonadAddressable (LocationFor v) v (CachingAnalysis t v) - , MonadValue t v (CachingAnalysis t v) + , MonadAddressable (LocationFor v) (CachingAnalysis t v) + , MonadValue v (CachingAnalysis t v) , Recursive t , Semigroup (CellFor v) ) - => MonadAnalysis t v (CachingAnalysis t v) where + => MonadAnalysis (CachingAnalysis t v) where analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -85,6 +85,9 @@ instance ( Corecursive t getCache) mempty maybe empty scatter (cacheLookup c cache) +type instance AnalysisTerm (CachingAnalysis term value) = term +type instance AnalysisValue (CachingAnalysis term value) = value + -- | Coinductively-cached evaluation. evaluateCache :: forall v term @@ -98,8 +101,8 @@ evaluateCache :: forall v term , Foldable (Cell (LocationFor v)) , Functor (Base term) , Recursive term - , MonadAddressable (LocationFor v) v (CachingAnalysis term v) - , MonadValue term v (CachingAnalysis term v) + , MonadAddressable (LocationFor v) (CachingAnalysis term v) + , MonadValue v (CachingAnalysis term v) , Semigroup (CellFor v) , ValueRoots (LocationFor v) v ) @@ -123,7 +126,7 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative m, Foldable t, MonadEvaluator term v m) => t (a, Store (LocationFor v) v) -> m a +scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (LocationFor (AnalysisValue m)) (AnalysisValue m)) -> m a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. @@ -138,8 +141,8 @@ memoizeEval :: forall v term , Foldable (Cell (LocationFor v)) , Functor (Base term) , Recursive term - , MonadAddressable (LocationFor v) v (CachingAnalysis term v) - , MonadValue term v (CachingAnalysis term v) + , MonadAddressable (LocationFor v) (CachingAnalysis term v) + , MonadValue v (CachingAnalysis term v) , Semigroup (CellFor v) ) => SubtermAlgebra (Base term) term (CachingAnalysis term v v) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index c1fde105b..31603d5e6 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Dead where import Control.Abstract.Addressable @@ -19,8 +19,8 @@ evaluateDead :: forall term value , Evaluatable (Base term) , Foldable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) value (DeadCodeAnalysis term value) - , MonadValue term value (DeadCodeAnalysis term value) + , MonadAddressable (LocationFor value) (DeadCodeAnalysis term value) + , MonadValue value (DeadCodeAnalysis term value) , Ord (LocationFor value) , Ord term , Recursive term @@ -39,7 +39,7 @@ evaluateDead term = run @(DeadCodeEffects term value) . runEvaluator . runDeadCo newtype DeadCodeAnalysis term value a = DeadCodeAnalysis { runDeadCodeAnalysis :: Evaluator term value (DeadCodeEffects term value) a } deriving (Applicative, Functor, Monad, MonadFail) -deriving instance MonadEvaluator term value (DeadCodeAnalysis term value) +deriving instance Ord (LocationFor value) => MonadEvaluator (DeadCodeAnalysis term value) -- | A set of “dead” (unreachable) terms. @@ -60,13 +60,16 @@ revive t = DeadCodeAnalysis (Evaluator (modify (Dead . delete t . unDead))) instance ( Corecursive t , Evaluatable (Base t) , FreeVariables t - , MonadAddressable (LocationFor v) v (DeadCodeAnalysis t v) - , MonadValue t v (DeadCodeAnalysis t v) + , MonadAddressable (LocationFor v) (DeadCodeAnalysis t v) + , MonadValue v (DeadCodeAnalysis t v) , Ord t , Recursive t , Semigroup (CellFor v) ) - => MonadAnalysis t v (DeadCodeAnalysis t v) where + => MonadAnalysis (DeadCodeAnalysis t v) where analyzeTerm term = do revive (embedSubterm term) eval term + +type instance AnalysisTerm (DeadCodeAnalysis term value) = term +type instance AnalysisValue (DeadCodeAnalysis term value) = value diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index f75189e21..e07cb3fc5 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -15,8 +15,8 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) value (Evaluation term value) - , MonadValue term value (Evaluation term value) + , MonadAddressable (LocationFor value) (Evaluation term value) + , MonadValue value (Evaluation term value) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) @@ -29,8 +29,8 @@ evaluate = run @(EvaluatorEffects term value) . runEvaluator . runEvaluation . e evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) value (Evaluation term value) - , MonadValue term value (Evaluation term value) + , MonadAddressable (LocationFor value) (Evaluation term value) + , MonadValue value (Evaluation term value) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) @@ -41,7 +41,7 @@ evaluates :: forall value term evaluates pairs (_, t) = run @(EvaluatorEffects term value) (runEvaluator (runEvaluation (withModules pairs (evaluateTerm t)))) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. -withModules :: (MonadAnalysis term value m, MonadEvaluator term value m) => [(Blob, term)] -> m a -> m a +withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, AnalysisTerm m)] -> m a -> m a withModules pairs = localModuleTable (const moduleTable) where moduleTable = Linker (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) @@ -49,14 +49,17 @@ withModules pairs = localModuleTable (const moduleTable) newtype Evaluation term value a = Evaluation { runEvaluation :: Evaluator term value (EvaluatorEffects term value) a } deriving (Applicative, Functor, Monad, MonadFail) -deriving instance MonadEvaluator term value (Evaluation term value) +deriving instance Ord (LocationFor value) => MonadEvaluator (Evaluation term value) instance ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) value (Evaluation term value) - , MonadValue term value (Evaluation term value) + , MonadAddressable (LocationFor value) (Evaluation term value) + , MonadValue value (Evaluation term value) , Recursive term , Semigroup (CellFor value) ) - => MonadAnalysis term value (Evaluation term value) where + => MonadAnalysis (Evaluation term value) where analyzeTerm = eval + +type instance AnalysisTerm (Evaluation term value) = term +type instance AnalysisValue (Evaluation term value) = value diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index ff69fd305..e9b8e3665 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Addressable @@ -26,11 +26,13 @@ evaluateTrace :: forall trace value term , Ord (CellFor value) , Ord term , Ord value + , AnalysisTerm (Evaluator term value (TracingEffects trace term value)) ~ term + , AnalysisValue (Evaluator term value (TracingEffects trace term value)) ~ value , Recursive term , Reducer (ConfigurationFor term value) trace - , MonadAddressable (LocationFor value) value (TracingAnalysis trace Evaluator term value (TracingEffects trace term value)) - , MonadAnalysis term value (Evaluator term value (TracingEffects trace term value)) - , MonadValue term value (TracingAnalysis trace Evaluator term value (TracingEffects trace term value)) + , MonadAddressable (LocationFor value) (TracingAnalysis trace (Evaluator term value) term value (TracingEffects trace term value)) + , MonadAnalysis (Evaluator term value (TracingEffects trace term value)) + , MonadValue value (TracingAnalysis trace (Evaluator term value) term value (TracingEffects trace term value)) , Semigroup (CellFor value) ) => term @@ -39,27 +41,32 @@ evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTraci newtype TracingAnalysis trace underlying term value (effects :: [* -> *]) a - = TracingAnalysis { runTracingAnalysis :: underlying term value effects a } + = TracingAnalysis { runTracingAnalysis :: underlying effects a } deriving (Applicative, Functor, LiftEffect, Monad, MonadFail) -deriving instance MonadEvaluator term value (underlying term value effects) => MonadEvaluator term value (TracingAnalysis trace underlying term value effects) +deriving instance (AnalysisTerm (underlying effects) ~ term, AnalysisValue (underlying effects) ~ value, MonadEvaluator (underlying effects)) => MonadEvaluator (TracingAnalysis trace underlying term value effects) instance ( Corecursive term , Evaluatable (Base term) , FreeVariables term - , LiftEffect (underlying term value) + , LiftEffect underlying , Member (Writer trace) effects - , MonadAddressable (LocationFor value) value (TracingAnalysis trace underlying term value effects) - , MonadAnalysis term value (underlying term value effects) - , MonadValue term value (TracingAnalysis trace underlying term value effects) + , MonadAddressable (LocationFor value) (TracingAnalysis trace underlying term value effects) + , MonadAnalysis (underlying effects) + , AnalysisTerm (underlying effects) ~ term + , AnalysisValue (underlying effects) ~ value + , MonadValue value (TracingAnalysis trace underlying term value effects) , Recursive term , Reducer (ConfigurationFor term value) trace , Semigroup (CellFor value) ) - => MonadAnalysis term value (TracingAnalysis trace underlying term value effects) where + => MonadAnalysis (TracingAnalysis trace underlying term value effects) where analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> analyzeTerm term -trace :: (LiftEffect (underlying term value), Member (Writer trace) effects) +type instance AnalysisTerm (TracingAnalysis trace underlying term value effects) = term +type instance AnalysisValue (TracingAnalysis trace underlying term value effects) = value + +trace :: (LiftEffect underlying, Member (Writer trace) effects) => trace -> TracingAnalysis trace underlying term value effects () trace w = lift (tell w) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index eeaf77536..318dfd7b3 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -1,10 +1,10 @@ {-# LANGUAGE FunctionalDependencies, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Addressable where +import Control.Abstract.Analysis import Control.Abstract.Evaluator import Control.Applicative import Control.Monad ((<=<)) -import Control.Monad.Effect.Fail import Data.Abstract.Address import Data.Abstract.Environment import Data.Abstract.FreeVariables @@ -16,19 +16,20 @@ import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad m, Ord l, l ~ LocationFor a, Reducer a (Cell l a)) => MonadAddressable l a m | m -> a where - deref :: Address l a - -> m a +class (Monad m, Ord l, l ~ LocationFor (AnalysisValue m), Reducer (AnalysisValue m) (Cell l (AnalysisValue m))) => MonadAddressable l m where + deref :: Address l (AnalysisValue m) + -> m (AnalysisValue m) alloc :: Name - -> m (Address l a) + -> m (Address l (AnalysisValue m)) -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- -- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. lookupOrAlloc :: ( FreeVariables t - , MonadAddressable (LocationFor a) a m - , MonadEvaluator t a m + , MonadAddressable (LocationFor a) m + , MonadEvaluator m + , a ~ AnalysisValue m , Semigroup (CellFor a) ) => t @@ -40,8 +41,9 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in where -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. lookupOrAlloc' :: ( Semigroup (CellFor a) - , MonadAddressable (LocationFor a) a m - , MonadEvaluator t a m + , MonadAddressable (LocationFor a) m + , a ~ AnalysisValue m + , MonadEvaluator m ) => Name -> a @@ -54,7 +56,8 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor a) - , MonadEvaluator t a m + , MonadEvaluator m + , a ~ AnalysisValue m , Reducer a (CellFor a) ) => Address (LocationFor a) a @@ -66,7 +69,7 @@ assign address = modifyStore . storeInsert address -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Monad m, MonadEvaluator t v m, LocationFor v ~ Precise) => MonadAddressable Precise v m where +instance (Monad m, MonadEvaluator m, LocationFor (AnalysisValue m) ~ Precise) => MonadAddressable Precise m where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -77,7 +80,7 @@ instance (Monad m, MonadEvaluator t v m, LocationFor v ~ Precise) => MonadAddres -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, Ord v, LocationFor v ~ Monovariant, Monad m, MonadEvaluator t v m) => MonadAddressable Monovariant v m where +instance (Alternative m, Ord (AnalysisValue m), LocationFor (AnalysisValue m) ~ Monovariant, Monad m, MonadEvaluator m) => MonadAddressable Monovariant m where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 38b51c338..4e97b91f1 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE DefaultSignatures, FunctionalDependencies #-} +{-# LANGUAGE DefaultSignatures, KindSignatures, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) +, AnalysisTerm +, AnalysisValue , module X , Subterm(..) , SubtermAlgebra @@ -12,16 +14,19 @@ import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X import Prologue +type family AnalysisTerm (m :: * -> *) +type family AnalysisValue (m :: * -> *) + -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class Monad m => MonadAnalysis term value m | m -> term, m -> value where +class Monad m => MonadAnalysis m where -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. - analyzeTerm :: SubtermAlgebra (Base term) term (m value) + analyzeTerm :: SubtermAlgebra (Base (AnalysisTerm m)) (AnalysisTerm m) (m (AnalysisValue m)) -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. - evaluateTerm :: term -> m value - default evaluateTerm :: Recursive term => term -> m value + evaluateTerm :: AnalysisTerm m -> m (AnalysisValue m) + default evaluateTerm :: Recursive (AnalysisTerm m) => AnalysisTerm m -> m (AnalysisValue m) evaluateTerm = foldSubterms analyzeTerm diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index d28a63ff3..6e23892a2 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,14 +1,11 @@ -{-# LANGUAGE DataKinds, DefaultSignatures, FunctionalDependencies, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, UndecidableInstances #-} +{-# LANGUAGE DataKinds, DefaultSignatures, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator where +import Control.Abstract.Analysis import Control.Applicative -import Control.Effect import Control.Monad.Effect -import Control.Monad.Effect.Fail import Control.Monad.Effect.Fresh import Control.Monad.Effect.NonDet -import Control.Monad.Effect.Reader -import Control.Monad.Effect.State import Data.Abstract.Configuration import Data.Abstract.Linker import Data.Abstract.Live @@ -21,38 +18,38 @@ import Prelude hiding (fail) -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where +class (MonadFail m, Ord (LocationFor (AnalysisValue m))) => MonadEvaluator m where -- | Retrieve the global environment. - getGlobalEnv :: m (EnvironmentFor value) + getGlobalEnv :: m (EnvironmentFor (AnalysisValue m)) -- | Update the global environment. - modifyGlobalEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m () + modifyGlobalEnv :: (EnvironmentFor (AnalysisValue m) -> EnvironmentFor (AnalysisValue m)) -> m () -- | Retrieve the local environment. - askLocalEnv :: m (EnvironmentFor value) + askLocalEnv :: m (EnvironmentFor (AnalysisValue m)) -- | Run an action with a locally-modified environment. - localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a + localEnv :: (EnvironmentFor (AnalysisValue m) -> EnvironmentFor (AnalysisValue m)) -> m a -> m a -- | Retrieve the heap. - getStore :: m (StoreFor value) + getStore :: m (StoreFor (AnalysisValue m)) -- | Update the heap. - modifyStore :: (StoreFor value -> StoreFor value) -> m () + modifyStore :: (StoreFor (AnalysisValue m) -> StoreFor (AnalysisValue m)) -> m () -- | Retrieve the table of evaluated modules. - getModuleTable :: m (Linker value) + getModuleTable :: m (Linker (AnalysisValue m)) -- | Update the table of evaluated modules. - modifyModuleTable :: (Linker value -> Linker value) -> m () + modifyModuleTable :: (Linker (AnalysisValue m) -> Linker (AnalysisValue m)) -> m () -- | Retrieve the table of unevaluated modules. - askModuleTable :: m (Linker term) + askModuleTable :: m (Linker (AnalysisTerm m)) -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (Linker term -> Linker term) -> m a -> m a + localModuleTable :: (Linker (AnalysisTerm m) -> Linker (AnalysisTerm m)) -> m a -> m a -- | Retrieve the current root set. - askRoots :: Ord (LocationFor value) => m (Live (LocationFor value) value) + askRoots :: m (Live (LocationFor (AnalysisValue m)) (AnalysisValue m)) askRoots = pure mempty -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value) + getConfiguration :: term -> m (Configuration (LocationFor (AnalysisValue m)) term (AnalysisValue m)) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore type EvaluatorEffects term value @@ -64,7 +61,9 @@ type EvaluatorEffects term value , State (Linker value) -- Cache of evaluated modules ] -instance Members (EvaluatorEffects term value) effects => MonadEvaluator term value (Evaluator term value effects) where +type instance AnalysisTerm (Evaluator term value effects) = term +type instance AnalysisValue (Evaluator term value effects) = value +instance (Ord (LocationFor value), Members (EvaluatorEffects term value) effects) => MonadEvaluator (Evaluator term value effects) where getGlobalEnv = Evaluator get modifyGlobalEnv f = Evaluator (modify f) @@ -80,7 +79,7 @@ instance Members (EvaluatorEffects term value) effects => MonadEvaluator term va askModuleTable = Evaluator ask localModuleTable f a = Evaluator (local f (runEvaluator a)) -putStore :: MonadEvaluator t value m => StoreFor value -> m () +putStore :: MonadEvaluator m => StoreFor (AnalysisValue m) -> m () putStore = modifyStore . const -- | An evaluator of @term@s to @value@s, producing incremental results of type @a@ using a list of @effects@. diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 8120eb47c..8762c8927 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Value where import Control.Abstract.Addressable @@ -16,7 +16,7 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadEvaluator t v m) => MonadValue t v m where +class (MonadEvaluator m, v ~ AnalysisValue m) => MonadValue v m where -- | Construct an abstract unit value. unit :: m v @@ -33,19 +33,21 @@ class (MonadEvaluator t v m) => MonadValue t v m where ifthenelse :: v -> m v -> m v -> m v -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: [Name] -> Subterm t (m v) -> m v + abstract :: [Name] -> Subterm (AnalysisTerm m) (m v) -> m v -- | Evaluate an application (like a function call). - apply :: v -> [Subterm t (m v)] -> m v + apply :: v -> [Subterm (AnalysisTerm m) (m v)] -> m v -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables t - , MonadAddressable location (Value location t) m - , MonadAnalysis t (Value location t) m - , MonadEvaluator t (Value location t) m + , MonadAddressable location m + , MonadAnalysis m + , AnalysisTerm m ~ t + , AnalysisValue m ~ Value location t + , MonadEvaluator m , Recursive t , Semigroup (Cell location (Value location t)) ) - => MonadValue t (Value location t) m where + => MonadValue (Value location t) m where unit = pure $ inj Value.Unit integer = pure . inj . Integer @@ -68,7 +70,7 @@ instance ( FreeVariables t localEnv (mappend bindings) (evaluateTerm body) -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative m, MonadEvaluator t Type m, MonadFresh m) => MonadValue t Type m where +instance (Alternative m, MonadEvaluator m, MonadFresh m, AnalysisValue m ~ Type) => MonadValue Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 563ba209a..cbdf3bea2 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DefaultSignatures, FunctionalDependencies, UndecidableInstances #-} +{-# LANGUAGE DefaultSignatures, FunctionalDependencies, TypeFamilies, UndecidableInstances #-} module Data.Abstract.Evaluatable ( Evaluatable(..) , module Addressable @@ -30,10 +30,12 @@ import Prologue -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class Evaluatable constr where eval :: ( FreeVariables term - , MonadAddressable (LocationFor value) value m - , MonadAnalysis term value m - , MonadEvaluator term value m - , MonadValue term value m + , MonadAddressable (LocationFor value) m + , MonadAnalysis m + , AnalysisTerm m ~ term + , AnalysisValue m ~ value + , MonadEvaluator m + , MonadValue value m , Ord (LocationFor value) , Semigroup (CellFor value) ) @@ -75,24 +77,24 @@ instance Evaluatable [] where -- | Require/import another term/file and return an Effect. -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. -require :: ( FreeVariables term - , MonadAnalysis term v m - , MonadEvaluator term v m +require :: ( FreeVariables (AnalysisTerm m) + , MonadAnalysis m + , MonadEvaluator m ) - => term - -> m v + => AnalysisTerm m + -> m (AnalysisValue m) require term = getModuleTable >>= maybe (load term) pure . linkerLookup name where name = moduleName term -- | Load another term/file and return an Effect. -- -- Always loads/evaluates. -load :: ( FreeVariables term - , MonadAnalysis term v m - , MonadEvaluator term v m +load :: ( FreeVariables (AnalysisTerm m) + , MonadAnalysis m + , MonadEvaluator m ) - => term - -> m v + => AnalysisTerm m + -> m (AnalysisValue m) load term = askModuleTable >>= maybe notFound evalAndCache . linkerLookup name where name = moduleName term notFound = fail ("cannot find " <> show name) From ded1c3e5e883ff63d530e4d01774f5cc5e0aa299 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 15:11:44 -0500 Subject: [PATCH 098/292] Parameterize the Evaluation analysis by the effect set. --- src/Analysis/Abstract/Evaluating.hs | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index e07cb3fc5..a22125680 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -15,8 +15,8 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluation term value) - , MonadValue value (Evaluation term value) + , MonadAddressable (LocationFor value) (Evaluation term value (EvaluatorEffects term value)) + , MonadValue value (Evaluation term value (EvaluatorEffects term value)) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) @@ -29,8 +29,8 @@ evaluate = run @(EvaluatorEffects term value) . runEvaluator . runEvaluation . e evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluation term value) - , MonadValue value (Evaluation term value) + , MonadAddressable (LocationFor value) (Evaluation term value (EvaluatorEffects term value)) + , MonadValue value (Evaluation term value (EvaluatorEffects term value)) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) @@ -46,20 +46,21 @@ withModules pairs = localModuleTable (const moduleTable) where moduleTable = Linker (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis performing concrete evaluation of @term@s to @value@s. -newtype Evaluation term value a = Evaluation { runEvaluation :: Evaluator term value (EvaluatorEffects term value) a } - deriving (Applicative, Functor, Monad, MonadFail) +newtype Evaluation term value effects a = Evaluation { runEvaluation :: Evaluator term value effects a } + deriving (Applicative, Functor, LiftEffect, Monad) -deriving instance Ord (LocationFor value) => MonadEvaluator (Evaluation term value) +deriving instance Member Fail effects => MonadFail (Evaluation term value effects) +deriving instance (Member Fail effects, MonadEvaluator (Evaluator term value effects), Ord (LocationFor value)) => MonadEvaluator (Evaluation term value effects) instance ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluation term value) - , MonadValue value (Evaluation term value) + , MonadAddressable (LocationFor value) (Evaluation term value effects) + , MonadValue value (Evaluation term value effects) , Recursive term , Semigroup (CellFor value) ) - => MonadAnalysis (Evaluation term value) where + => MonadAnalysis (Evaluation term value effects) where analyzeTerm = eval -type instance AnalysisTerm (Evaluation term value) = term -type instance AnalysisValue (Evaluation term value) = value +type instance AnalysisTerm (Evaluation term value effects) = term +type instance AnalysisValue (Evaluation term value effects) = value From 5846ab7315c07a47f58d3aaa2a33bab5b44a159e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 15:23:30 -0500 Subject: [PATCH 099/292] trace is of kind * -> *. --- src/Analysis/Abstract/Tracing.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index e9b8e3665..b12713830 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where +import Analysis.Abstract.Evaluating import Control.Abstract.Addressable import Control.Abstract.Analysis import Control.Abstract.Evaluator @@ -13,7 +14,8 @@ import Data.Semigroup.Reducer as Reducer import Prologue -- | The effects necessary for tracing analyses. -type TracingEffects trace term value = Writer trace ': EvaluatorEffects term value +type Trace trace term value = trace (ConfigurationFor term value) +type TracingEffects trace term value = Writer (Trace trace term value) ': EvaluatorEffects term value -- | Trace analysis. -- @@ -22,25 +24,23 @@ evaluateTrace :: forall trace value term . ( Corecursive term , Evaluatable (Base term) , FreeVariables term - , Monoid trace + , Monoid (Trace trace term value) , Ord (CellFor value) , Ord term , Ord value - , AnalysisTerm (Evaluator term value (TracingEffects trace term value)) ~ term - , AnalysisValue (Evaluator term value (TracingEffects trace term value)) ~ value , Recursive term - , Reducer (ConfigurationFor term value) trace - , MonadAddressable (LocationFor value) (TracingAnalysis trace (Evaluator term value) term value (TracingEffects trace term value)) - , MonadAnalysis (Evaluator term value (TracingEffects trace term value)) - , MonadValue value (TracingAnalysis trace (Evaluator term value) term value (TracingEffects trace term value)) + , Reducer (ConfigurationFor term value) (Trace trace term value) + , MonadAddressable (LocationFor value) (TracingAnalysis trace (Evaluation term value) term value (TracingEffects trace term value)) + , MonadAnalysis (Evaluation term value (TracingEffects trace term value)) + , MonadValue value (TracingAnalysis trace (Evaluation term value) term value (TracingEffects trace term value)) , Semigroup (CellFor value) ) => term -> Final (TracingEffects trace term value) value -evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runTracingAnalysis @trace . evaluateTerm +evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runEvaluation . runTracingAnalysis @trace . evaluateTerm -newtype TracingAnalysis trace underlying term value (effects :: [* -> *]) a +newtype TracingAnalysis (trace :: * -> *) underlying term value (effects :: [* -> *]) a = TracingAnalysis { runTracingAnalysis :: underlying effects a } deriving (Applicative, Functor, LiftEffect, Monad, MonadFail) @@ -50,23 +50,23 @@ instance ( Corecursive term , Evaluatable (Base term) , FreeVariables term , LiftEffect underlying - , Member (Writer trace) effects + , Member (Writer (Trace trace term value)) effects , MonadAddressable (LocationFor value) (TracingAnalysis trace underlying term value effects) , MonadAnalysis (underlying effects) , AnalysisTerm (underlying effects) ~ term , AnalysisValue (underlying effects) ~ value , MonadValue value (TracingAnalysis trace underlying term value effects) , Recursive term - , Reducer (ConfigurationFor term value) trace + , Reducer (ConfigurationFor term value) (Trace trace term value) , Semigroup (CellFor value) ) => MonadAnalysis (TracingAnalysis trace underlying term value effects) where - analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> analyzeTerm term + analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> TracingAnalysis (analyzeTerm (second runTracingAnalysis <$> term)) type instance AnalysisTerm (TracingAnalysis trace underlying term value effects) = term type instance AnalysisValue (TracingAnalysis trace underlying term value effects) = value -trace :: (LiftEffect underlying, Member (Writer trace) effects) - => trace +trace :: (LiftEffect underlying, Member (Writer (Trace trace term value)) effects) + => Trace trace term value -> TracingAnalysis trace underlying term value effects () trace w = lift (tell w) From 147c373c297db26a8a8c9f43f7feddff4afa00a5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 15:23:36 -0500 Subject: [PATCH 100/292] Define a helper for tracing Python files. --- src/Semantic/Util.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 1e7c249fa..72c6c8524 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -5,6 +5,7 @@ module Semantic.Util where import Prologue import Analysis.Abstract.Caching import Analysis.Abstract.Evaluating +import Analysis.Abstract.Tracing import Analysis.Declaration import Control.Monad.IO.Class import Data.Abstract.Address @@ -46,6 +47,8 @@ evaluateRubyFiles paths = do typecheckPythonFile path = evaluateCache @Type <$> (file path >>= runTask . parse pythonParser) +tracePythonFile path = evaluateTrace @[] @PythonValue <$> (file path >>= runTask . parse pythonParser) + evaluatePythonFile path = evaluate @PythonValue <$> (file path >>= runTask . parse pythonParser) From af5f1de520b9037e82684256b6b368d6d92c5fee Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 15:24:29 -0500 Subject: [PATCH 101/292] Redefine the Tracer convenience. --- src/Analysis/Abstract/Tracing.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index b12713830..349546a9f 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -13,9 +13,10 @@ import Data.Abstract.Value import Data.Semigroup.Reducer as Reducer import Prologue --- | The effects necessary for tracing analyses. type Trace trace term value = trace (ConfigurationFor term value) -type TracingEffects trace term value = Writer (Trace trace term value) ': EvaluatorEffects term value +type Tracer trace term value = Writer (Trace trace term value) +-- | The effects necessary for tracing analyses. +type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffects term value -- | Trace analysis. -- @@ -50,7 +51,7 @@ instance ( Corecursive term , Evaluatable (Base term) , FreeVariables term , LiftEffect underlying - , Member (Writer (Trace trace term value)) effects + , Member (Tracer trace term value) effects , MonadAddressable (LocationFor value) (TracingAnalysis trace underlying term value effects) , MonadAnalysis (underlying effects) , AnalysisTerm (underlying effects) ~ term @@ -66,7 +67,7 @@ instance ( Corecursive term type instance AnalysisTerm (TracingAnalysis trace underlying term value effects) = term type instance AnalysisValue (TracingAnalysis trace underlying term value effects) = value -trace :: (LiftEffect underlying, Member (Writer (Trace trace term value)) effects) +trace :: (LiftEffect underlying, Member (Tracer trace term value) effects) => Trace trace term value -> TracingAnalysis trace underlying term value effects () trace w = lift (tell w) From 1f7d9672ea854c37c9b260c08e0c3d467fd8ced4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 17:32:05 -0500 Subject: [PATCH 102/292] Remove the term/value parameters from TracingAnalysis. --- src/Analysis/Abstract/Tracing.hs | 42 ++++++++++++++++---------------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 349546a9f..77ffc97f3 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -31,9 +31,9 @@ evaluateTrace :: forall trace value term , Ord value , Recursive term , Reducer (ConfigurationFor term value) (Trace trace term value) - , MonadAddressable (LocationFor value) (TracingAnalysis trace (Evaluation term value) term value (TracingEffects trace term value)) + , MonadAddressable (LocationFor value) (TracingAnalysis trace (Evaluation term value) (TracingEffects trace term value)) , MonadAnalysis (Evaluation term value (TracingEffects trace term value)) - , MonadValue value (TracingAnalysis trace (Evaluation term value) term value (TracingEffects trace term value)) + , MonadValue value (TracingAnalysis trace (Evaluation term value) (TracingEffects trace term value)) , Semigroup (CellFor value) ) => term @@ -41,33 +41,33 @@ evaluateTrace :: forall trace value term evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runEvaluation . runTracingAnalysis @trace . evaluateTerm -newtype TracingAnalysis (trace :: * -> *) underlying term value (effects :: [* -> *]) a +newtype TracingAnalysis (trace :: * -> *) underlying (effects :: [* -> *]) a = TracingAnalysis { runTracingAnalysis :: underlying effects a } deriving (Applicative, Functor, LiftEffect, Monad, MonadFail) -deriving instance (AnalysisTerm (underlying effects) ~ term, AnalysisValue (underlying effects) ~ value, MonadEvaluator (underlying effects)) => MonadEvaluator (TracingAnalysis trace underlying term value effects) +deriving instance (AnalysisTerm (underlying effects) ~ term, AnalysisValue (underlying effects) ~ value, MonadEvaluator (underlying effects)) => MonadEvaluator (TracingAnalysis trace underlying effects) -instance ( Corecursive term - , Evaluatable (Base term) - , FreeVariables term +instance ( Corecursive (AnalysisTerm (underlying effects)) + , Evaluatable (Base (AnalysisTerm (underlying effects))) + , FreeVariables (AnalysisTerm (underlying effects)) , LiftEffect underlying - , Member (Tracer trace term value) effects - , MonadAddressable (LocationFor value) (TracingAnalysis trace underlying term value effects) + , Member (Tracer trace (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) effects + , MonadAddressable (LocationFor (AnalysisValue (underlying effects))) (TracingAnalysis trace underlying effects) , MonadAnalysis (underlying effects) - , AnalysisTerm (underlying effects) ~ term - , AnalysisValue (underlying effects) ~ value - , MonadValue value (TracingAnalysis trace underlying term value effects) - , Recursive term - , Reducer (ConfigurationFor term value) (Trace trace term value) - , Semigroup (CellFor value) + , MonadValue (AnalysisValue (underlying effects)) (TracingAnalysis trace underlying effects) + , Recursive (AnalysisTerm (underlying effects)) + , Reducer (ConfigurationFor (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) (Trace trace (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) + , Semigroup (CellFor (AnalysisValue (underlying effects))) ) - => MonadAnalysis (TracingAnalysis trace underlying term value effects) where + => MonadAnalysis (TracingAnalysis trace underlying effects) where analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> TracingAnalysis (analyzeTerm (second runTracingAnalysis <$> term)) -type instance AnalysisTerm (TracingAnalysis trace underlying term value effects) = term -type instance AnalysisValue (TracingAnalysis trace underlying term value effects) = value +type instance AnalysisTerm (TracingAnalysis trace underlying effects) = AnalysisTerm (underlying effects) +type instance AnalysisValue (TracingAnalysis trace underlying effects) = AnalysisValue (underlying effects) -trace :: (LiftEffect underlying, Member (Tracer trace term value) effects) - => Trace trace term value - -> TracingAnalysis trace underlying term value effects () +trace :: ( LiftEffect underlying + , Member (Tracer trace (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) effects + ) + => Trace trace (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects)) + -> TracingAnalysis trace underlying effects () trace w = lift (tell w) From 45fccdc7dcb79c4d342f90ff82e523681b09abc3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 17:34:17 -0500 Subject: [PATCH 103/292] Add a lower method to LiftEffect. --- src/Control/Effect.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 162dce702..69947f48a 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -68,6 +68,8 @@ instance Ord a => RunEffect NonDetEff a where class LiftEffect f where lift :: Eff effects a -> f effects a + lower :: f effects a -> Eff effects a instance LiftEffect Eff where lift = id + lower = id From 2dc698b3e8479eae69f50d334501171322dc64ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 17:35:40 -0500 Subject: [PATCH 104/292] Define a convenience for applying Trace to the underlying monad. --- src/Analysis/Abstract/Tracing.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 77ffc97f3..5c4b64bb3 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,6 +14,7 @@ import Data.Semigroup.Reducer as Reducer import Prologue type Trace trace term value = trace (ConfigurationFor term value) +type TraceFor trace m = Trace trace (AnalysisTerm m) (AnalysisValue m) type Tracer trace term value = Writer (Trace trace term value) -- | The effects necessary for tracing analyses. type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffects term value @@ -56,7 +57,7 @@ instance ( Corecursive (AnalysisTerm (underlying effects)) , MonadAnalysis (underlying effects) , MonadValue (AnalysisValue (underlying effects)) (TracingAnalysis trace underlying effects) , Recursive (AnalysisTerm (underlying effects)) - , Reducer (ConfigurationFor (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) (Trace trace (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) + , Reducer (ConfigurationFor (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) (TraceFor trace (underlying effects)) , Semigroup (CellFor (AnalysisValue (underlying effects))) ) => MonadAnalysis (TracingAnalysis trace underlying effects) where @@ -68,6 +69,6 @@ type instance AnalysisValue (TracingAnalysis trace underlying effects) = Analysi trace :: ( LiftEffect underlying , Member (Tracer trace (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) effects ) - => Trace trace (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects)) + => TraceFor trace (underlying effects) -> TracingAnalysis trace underlying effects () trace w = lift (tell w) From f121205fa4ad01f5d8080a756d51e47e0fa799e2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 17:37:30 -0500 Subject: [PATCH 105/292] Define a convenience for applying Tracer to the underlying monad. --- src/Analysis/Abstract/Tracing.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 5c4b64bb3..3bad05680 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -16,6 +16,7 @@ import Prologue type Trace trace term value = trace (ConfigurationFor term value) type TraceFor trace m = Trace trace (AnalysisTerm m) (AnalysisValue m) type Tracer trace term value = Writer (Trace trace term value) +type TracerFor trace m = Writer (TraceFor trace m) -- | The effects necessary for tracing analyses. type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffects term value @@ -52,7 +53,7 @@ instance ( Corecursive (AnalysisTerm (underlying effects)) , Evaluatable (Base (AnalysisTerm (underlying effects))) , FreeVariables (AnalysisTerm (underlying effects)) , LiftEffect underlying - , Member (Tracer trace (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) effects + , Member (TracerFor trace (underlying effects)) effects , MonadAddressable (LocationFor (AnalysisValue (underlying effects))) (TracingAnalysis trace underlying effects) , MonadAnalysis (underlying effects) , MonadValue (AnalysisValue (underlying effects)) (TracingAnalysis trace underlying effects) @@ -67,7 +68,7 @@ type instance AnalysisTerm (TracingAnalysis trace underlying effects) = Analysi type instance AnalysisValue (TracingAnalysis trace underlying effects) = AnalysisValue (underlying effects) trace :: ( LiftEffect underlying - , Member (Tracer trace (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) effects + , Member (TracerFor trace (underlying effects)) effects ) => TraceFor trace (underlying effects) -> TracingAnalysis trace underlying effects () From c7dbc9842ce4031239d373504a88b890e7584077 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 17:46:02 -0500 Subject: [PATCH 106/292] Provide the effect list via a type family. --- src/Control/Effect.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 69947f48a..27bc4870e 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -67,9 +67,11 @@ instance Ord a => RunEffect NonDetEff a where class LiftEffect f where - lift :: Eff effects a -> f effects a - lower :: f effects a -> Eff effects a + type Effects f :: [* -> *] + lift :: Eff (Effects f) a -> f a + lower :: f a -> Eff (Effects f) a -instance LiftEffect Eff where +instance LiftEffect (Eff effects) where + type Effects (Eff effects) = effects lift = id lower = id From 2490cc1d43a283aa95e5fdaca8132b6069e63f89 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 17:47:42 -0500 Subject: [PATCH 107/292] Parameterize TracingAnalysis by the underlying monad. --- src/Analysis/Abstract/Tracing.hs | 48 ++++++++++++++++---------------- 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 3bad05680..62975dd9e 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -33,43 +33,43 @@ evaluateTrace :: forall trace value term , Ord value , Recursive term , Reducer (ConfigurationFor term value) (Trace trace term value) - , MonadAddressable (LocationFor value) (TracingAnalysis trace (Evaluation term value) (TracingEffects trace term value)) + , MonadAddressable (LocationFor value) (TracingAnalysis trace (Evaluation term value (TracingEffects trace term value))) , MonadAnalysis (Evaluation term value (TracingEffects trace term value)) - , MonadValue value (TracingAnalysis trace (Evaluation term value) (TracingEffects trace term value)) + , MonadValue value (TracingAnalysis trace (Evaluation term value (TracingEffects trace term value))) , Semigroup (CellFor value) ) => term -> Final (TracingEffects trace term value) value -evaluateTrace = run @(TracingEffects trace term value) . runEvaluator . runEvaluation . runTracingAnalysis @trace . evaluateTerm +evaluateTrace = run . lower @(Evaluation term value (TracingEffects trace term value)) . evaluateTerm -newtype TracingAnalysis (trace :: * -> *) underlying (effects :: [* -> *]) a - = TracingAnalysis { runTracingAnalysis :: underlying effects a } +newtype TracingAnalysis (trace :: * -> *) m a + = TracingAnalysis { runTracingAnalysis :: m a } deriving (Applicative, Functor, LiftEffect, Monad, MonadFail) -deriving instance (AnalysisTerm (underlying effects) ~ term, AnalysisValue (underlying effects) ~ value, MonadEvaluator (underlying effects)) => MonadEvaluator (TracingAnalysis trace underlying effects) +deriving instance MonadEvaluator m => MonadEvaluator (TracingAnalysis trace m) -instance ( Corecursive (AnalysisTerm (underlying effects)) - , Evaluatable (Base (AnalysisTerm (underlying effects))) - , FreeVariables (AnalysisTerm (underlying effects)) - , LiftEffect underlying - , Member (TracerFor trace (underlying effects)) effects - , MonadAddressable (LocationFor (AnalysisValue (underlying effects))) (TracingAnalysis trace underlying effects) - , MonadAnalysis (underlying effects) - , MonadValue (AnalysisValue (underlying effects)) (TracingAnalysis trace underlying effects) - , Recursive (AnalysisTerm (underlying effects)) - , Reducer (ConfigurationFor (AnalysisTerm (underlying effects)) (AnalysisValue (underlying effects))) (TraceFor trace (underlying effects)) - , Semigroup (CellFor (AnalysisValue (underlying effects))) +instance ( Corecursive (AnalysisTerm m) + , Evaluatable (Base (AnalysisTerm m)) + , FreeVariables (AnalysisTerm m) + , LiftEffect m + , Member (TracerFor trace m) (Effects m) + , MonadAddressable (LocationFor (AnalysisValue m)) (TracingAnalysis trace m) + , MonadAnalysis m + , MonadValue (AnalysisValue m) (TracingAnalysis trace m) + , Recursive (AnalysisTerm m) + , Reducer (ConfigurationFor (AnalysisTerm m) (AnalysisValue m)) (TraceFor trace m) + , Semigroup (CellFor (AnalysisValue m)) ) - => MonadAnalysis (TracingAnalysis trace underlying effects) where + => MonadAnalysis (TracingAnalysis trace m) where analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> TracingAnalysis (analyzeTerm (second runTracingAnalysis <$> term)) -type instance AnalysisTerm (TracingAnalysis trace underlying effects) = AnalysisTerm (underlying effects) -type instance AnalysisValue (TracingAnalysis trace underlying effects) = AnalysisValue (underlying effects) +type instance AnalysisTerm (TracingAnalysis trace m) = AnalysisTerm m +type instance AnalysisValue (TracingAnalysis trace m) = AnalysisValue m -trace :: ( LiftEffect underlying - , Member (TracerFor trace (underlying effects)) effects +trace :: ( LiftEffect m + , Member (TracerFor trace m) (Effects m) ) - => TraceFor trace (underlying effects) - -> TracingAnalysis trace underlying effects () + => TraceFor trace m + -> TracingAnalysis trace m () trace w = lift (tell w) From 86fafc5abdf499995d015e2ae3e4bacf61fed2f7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 17:48:20 -0500 Subject: [PATCH 108/292] Rename AnalysisTerm/Value to Term/ValueFor. --- src/Analysis/Abstract/Caching.hs | 6 +++--- src/Analysis/Abstract/Dead.hs | 4 ++-- src/Analysis/Abstract/Evaluating.hs | 6 +++--- src/Analysis/Abstract/Tracing.hs | 22 ++++++++++---------- src/Control/Abstract/Addressable.hs | 18 ++++++++-------- src/Control/Abstract/Analysis.hs | 14 ++++++------- src/Control/Abstract/Evaluator.hs | 32 ++++++++++++++--------------- src/Control/Abstract/Value.hs | 12 +++++------ src/Data/Abstract/Evaluatable.hs | 16 +++++++-------- 9 files changed, 65 insertions(+), 65 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index f03769e04..3e5ace2a2 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -85,8 +85,8 @@ instance ( Corecursive t getCache) mempty maybe empty scatter (cacheLookup c cache) -type instance AnalysisTerm (CachingAnalysis term value) = term -type instance AnalysisValue (CachingAnalysis term value) = value +type instance TermFor (CachingAnalysis term value) = term +type instance ValueFor (CachingAnalysis term value) = value -- | Coinductively-cached evaluation. @@ -126,7 +126,7 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (LocationFor (AnalysisValue m)) (AnalysisValue m)) -> m a +scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 31603d5e6..f2d9f2c12 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -71,5 +71,5 @@ instance ( Corecursive t revive (embedSubterm term) eval term -type instance AnalysisTerm (DeadCodeAnalysis term value) = term -type instance AnalysisValue (DeadCodeAnalysis term value) = value +type instance TermFor (DeadCodeAnalysis term value) = term +type instance ValueFor (DeadCodeAnalysis term value) = value diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index a22125680..1d5ed6fe9 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -41,7 +41,7 @@ evaluates :: forall value term evaluates pairs (_, t) = run @(EvaluatorEffects term value) (runEvaluator (runEvaluation (withModules pairs (evaluateTerm t)))) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. -withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, AnalysisTerm m)] -> m a -> m a +withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a withModules pairs = localModuleTable (const moduleTable) where moduleTable = Linker (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) @@ -62,5 +62,5 @@ instance ( Evaluatable (Base term) => MonadAnalysis (Evaluation term value effects) where analyzeTerm = eval -type instance AnalysisTerm (Evaluation term value effects) = term -type instance AnalysisValue (Evaluation term value effects) = value +type instance TermFor (Evaluation term value effects) = term +type instance ValueFor (Evaluation term value effects) = value diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 62975dd9e..14b252acc 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Data.Semigroup.Reducer as Reducer import Prologue type Trace trace term value = trace (ConfigurationFor term value) -type TraceFor trace m = Trace trace (AnalysisTerm m) (AnalysisValue m) +type TraceFor trace m = Trace trace (TermFor m) (ValueFor m) type Tracer trace term value = Writer (Trace trace term value) type TracerFor trace m = Writer (TraceFor trace m) -- | The effects necessary for tracing analyses. @@ -49,23 +49,23 @@ newtype TracingAnalysis (trace :: * -> *) m a deriving instance MonadEvaluator m => MonadEvaluator (TracingAnalysis trace m) -instance ( Corecursive (AnalysisTerm m) - , Evaluatable (Base (AnalysisTerm m)) - , FreeVariables (AnalysisTerm m) +instance ( Corecursive (TermFor m) + , Evaluatable (Base (TermFor m)) + , FreeVariables (TermFor m) , LiftEffect m , Member (TracerFor trace m) (Effects m) - , MonadAddressable (LocationFor (AnalysisValue m)) (TracingAnalysis trace m) + , MonadAddressable (LocationFor (ValueFor m)) (TracingAnalysis trace m) , MonadAnalysis m - , MonadValue (AnalysisValue m) (TracingAnalysis trace m) - , Recursive (AnalysisTerm m) - , Reducer (ConfigurationFor (AnalysisTerm m) (AnalysisValue m)) (TraceFor trace m) - , Semigroup (CellFor (AnalysisValue m)) + , MonadValue (ValueFor m) (TracingAnalysis trace m) + , Recursive (TermFor m) + , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) + , Semigroup (CellFor (ValueFor m)) ) => MonadAnalysis (TracingAnalysis trace m) where analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> TracingAnalysis (analyzeTerm (second runTracingAnalysis <$> term)) -type instance AnalysisTerm (TracingAnalysis trace m) = AnalysisTerm m -type instance AnalysisValue (TracingAnalysis trace m) = AnalysisValue m +type instance TermFor (TracingAnalysis trace m) = TermFor m +type instance ValueFor (TracingAnalysis trace m) = ValueFor m trace :: ( LiftEffect m , Member (TracerFor trace m) (Effects m) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 318dfd7b3..2c24183ae 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -16,12 +16,12 @@ import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad m, Ord l, l ~ LocationFor (AnalysisValue m), Reducer (AnalysisValue m) (Cell l (AnalysisValue m))) => MonadAddressable l m where - deref :: Address l (AnalysisValue m) - -> m (AnalysisValue m) +class (Monad m, Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l m where + deref :: Address l (ValueFor m) + -> m (ValueFor m) alloc :: Name - -> m (Address l (AnalysisValue m)) + -> m (Address l (ValueFor m)) -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- @@ -29,7 +29,7 @@ class (Monad m, Ord l, l ~ LocationFor (AnalysisValue m), Reducer (AnalysisValue lookupOrAlloc :: ( FreeVariables t , MonadAddressable (LocationFor a) m , MonadEvaluator m - , a ~ AnalysisValue m + , a ~ ValueFor m , Semigroup (CellFor a) ) => t @@ -42,7 +42,7 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. lookupOrAlloc' :: ( Semigroup (CellFor a) , MonadAddressable (LocationFor a) m - , a ~ AnalysisValue m + , a ~ ValueFor m , MonadEvaluator m ) => Name @@ -57,7 +57,7 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor a) , MonadEvaluator m - , a ~ AnalysisValue m + , a ~ ValueFor m , Reducer a (CellFor a) ) => Address (LocationFor a) a @@ -69,7 +69,7 @@ assign address = modifyStore . storeInsert address -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Monad m, MonadEvaluator m, LocationFor (AnalysisValue m) ~ Precise) => MonadAddressable Precise m where +instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise m where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -80,7 +80,7 @@ instance (Monad m, MonadEvaluator m, LocationFor (AnalysisValue m) ~ Precise) => -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, Ord (AnalysisValue m), LocationFor (AnalysisValue m) ~ Monovariant, Monad m, MonadEvaluator m) => MonadAddressable Monovariant m where +instance (Alternative m, Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad m, MonadEvaluator m) => MonadAddressable Monovariant m where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 4e97b91f1..e09ca7b55 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DefaultSignatures, KindSignatures, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) -, AnalysisTerm -, AnalysisValue +, TermFor +, ValueFor , module X , Subterm(..) , SubtermAlgebra @@ -14,19 +14,19 @@ import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X import Prologue -type family AnalysisTerm (m :: * -> *) -type family AnalysisValue (m :: * -> *) +type family TermFor (m :: * -> *) +type family ValueFor (m :: * -> *) -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. class Monad m => MonadAnalysis m where -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. - analyzeTerm :: SubtermAlgebra (Base (AnalysisTerm m)) (AnalysisTerm m) (m (AnalysisValue m)) + analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. - evaluateTerm :: AnalysisTerm m -> m (AnalysisValue m) - default evaluateTerm :: Recursive (AnalysisTerm m) => AnalysisTerm m -> m (AnalysisValue m) + evaluateTerm :: TermFor m -> m (ValueFor m) + default evaluateTerm :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 6e23892a2..64550854d 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -18,38 +18,38 @@ import Prelude hiding (fail) -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class (MonadFail m, Ord (LocationFor (AnalysisValue m))) => MonadEvaluator m where +class (MonadFail m, Ord (LocationFor (ValueFor m))) => MonadEvaluator m where -- | Retrieve the global environment. - getGlobalEnv :: m (EnvironmentFor (AnalysisValue m)) + getGlobalEnv :: m (EnvironmentFor (ValueFor m)) -- | Update the global environment. - modifyGlobalEnv :: (EnvironmentFor (AnalysisValue m) -> EnvironmentFor (AnalysisValue m)) -> m () + modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m () -- | Retrieve the local environment. - askLocalEnv :: m (EnvironmentFor (AnalysisValue m)) + askLocalEnv :: m (EnvironmentFor (ValueFor m)) -- | Run an action with a locally-modified environment. - localEnv :: (EnvironmentFor (AnalysisValue m) -> EnvironmentFor (AnalysisValue m)) -> m a -> m a + localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m a -> m a -- | Retrieve the heap. - getStore :: m (StoreFor (AnalysisValue m)) + getStore :: m (StoreFor (ValueFor m)) -- | Update the heap. - modifyStore :: (StoreFor (AnalysisValue m) -> StoreFor (AnalysisValue m)) -> m () + modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m () -- | Retrieve the table of evaluated modules. - getModuleTable :: m (Linker (AnalysisValue m)) + getModuleTable :: m (Linker (ValueFor m)) -- | Update the table of evaluated modules. - modifyModuleTable :: (Linker (AnalysisValue m) -> Linker (AnalysisValue m)) -> m () + modifyModuleTable :: (Linker (ValueFor m) -> Linker (ValueFor m)) -> m () -- | Retrieve the table of unevaluated modules. - askModuleTable :: m (Linker (AnalysisTerm m)) + askModuleTable :: m (Linker (TermFor m)) -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (Linker (AnalysisTerm m) -> Linker (AnalysisTerm m)) -> m a -> m a + localModuleTable :: (Linker (TermFor m) -> Linker (TermFor m)) -> m a -> m a -- | Retrieve the current root set. - askRoots :: m (Live (LocationFor (AnalysisValue m)) (AnalysisValue m)) + askRoots :: m (Live (LocationFor (ValueFor m)) (ValueFor m)) askRoots = pure mempty -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: term -> m (Configuration (LocationFor (AnalysisValue m)) term (AnalysisValue m)) + getConfiguration :: term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore type EvaluatorEffects term value @@ -61,8 +61,8 @@ type EvaluatorEffects term value , State (Linker value) -- Cache of evaluated modules ] -type instance AnalysisTerm (Evaluator term value effects) = term -type instance AnalysisValue (Evaluator term value effects) = value +type instance TermFor (Evaluator term value effects) = term +type instance ValueFor (Evaluator term value effects) = value instance (Ord (LocationFor value), Members (EvaluatorEffects term value) effects) => MonadEvaluator (Evaluator term value effects) where getGlobalEnv = Evaluator get modifyGlobalEnv f = Evaluator (modify f) @@ -79,7 +79,7 @@ instance (Ord (LocationFor value), Members (EvaluatorEffects term value) effects askModuleTable = Evaluator ask localModuleTable f a = Evaluator (local f (runEvaluator a)) -putStore :: MonadEvaluator m => StoreFor (AnalysisValue m) -> m () +putStore :: MonadEvaluator m => StoreFor (ValueFor m) -> m () putStore = modifyStore . const -- | An evaluator of @term@s to @value@s, producing incremental results of type @a@ using a list of @effects@. diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 8762c8927..55b1cfb4e 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -16,7 +16,7 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadEvaluator m, v ~ AnalysisValue m) => MonadValue v m where +class (MonadEvaluator m, v ~ ValueFor m) => MonadValue v m where -- | Construct an abstract unit value. unit :: m v @@ -33,16 +33,16 @@ class (MonadEvaluator m, v ~ AnalysisValue m) => MonadValue v m where ifthenelse :: v -> m v -> m v -> m v -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: [Name] -> Subterm (AnalysisTerm m) (m v) -> m v + abstract :: [Name] -> Subterm (TermFor m) (m v) -> m v -- | Evaluate an application (like a function call). - apply :: v -> [Subterm (AnalysisTerm m) (m v)] -> m v + apply :: v -> [Subterm (TermFor m) (m v)] -> m v -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables t , MonadAddressable location m , MonadAnalysis m - , AnalysisTerm m ~ t - , AnalysisValue m ~ Value location t + , TermFor m ~ t + , ValueFor m ~ Value location t , MonadEvaluator m , Recursive t , Semigroup (Cell location (Value location t)) @@ -70,7 +70,7 @@ instance ( FreeVariables t localEnv (mappend bindings) (evaluateTerm body) -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative m, MonadEvaluator m, MonadFresh m, AnalysisValue m ~ Type) => MonadValue Type m where +instance (Alternative m, MonadEvaluator m, MonadFresh m, ValueFor m ~ Type) => MonadValue Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index cbdf3bea2..414be8945 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -32,8 +32,8 @@ class Evaluatable constr where eval :: ( FreeVariables term , MonadAddressable (LocationFor value) m , MonadAnalysis m - , AnalysisTerm m ~ term - , AnalysisValue m ~ value + , TermFor m ~ term + , ValueFor m ~ value , MonadEvaluator m , MonadValue value m , Ord (LocationFor value) @@ -77,24 +77,24 @@ instance Evaluatable [] where -- | Require/import another term/file and return an Effect. -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. -require :: ( FreeVariables (AnalysisTerm m) +require :: ( FreeVariables (TermFor m) , MonadAnalysis m , MonadEvaluator m ) - => AnalysisTerm m - -> m (AnalysisValue m) + => TermFor m + -> m (ValueFor m) require term = getModuleTable >>= maybe (load term) pure . linkerLookup name where name = moduleName term -- | Load another term/file and return an Effect. -- -- Always loads/evaluates. -load :: ( FreeVariables (AnalysisTerm m) +load :: ( FreeVariables (TermFor m) , MonadAnalysis m , MonadEvaluator m ) - => AnalysisTerm m - -> m (AnalysisValue m) + => TermFor m + -> m (ValueFor m) load term = askModuleTable >>= maybe notFound evalAndCache . linkerLookup name where name = moduleName term notFound = fail ("cannot find " <> show name) From 8b43136fc8a9377bcfa3e9538c7640f68a2c57d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:01:37 -0500 Subject: [PATCH 109/292] Derive the MonadEvaluator instance directly. --- src/Analysis/Abstract/Tracing.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 14b252acc..9dd23aa7b 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -45,9 +45,7 @@ evaluateTrace = run . lower @(Evaluation term value (TracingEffects trace term v newtype TracingAnalysis (trace :: * -> *) m a = TracingAnalysis { runTracingAnalysis :: m a } - deriving (Applicative, Functor, LiftEffect, Monad, MonadFail) - -deriving instance MonadEvaluator m => MonadEvaluator (TracingAnalysis trace m) + deriving (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) instance ( Corecursive (TermFor m) , Evaluatable (Base (TermFor m)) From 3ec8d65126eb08fcba357b17eb95b832abd1af39 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:01:44 -0500 Subject: [PATCH 110/292] :fire: a redundant constraint. --- src/Analysis/Abstract/Tracing.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 9dd23aa7b..4965911e0 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -48,7 +48,6 @@ newtype TracingAnalysis (trace :: * -> *) m a deriving (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) instance ( Corecursive (TermFor m) - , Evaluatable (Base (TermFor m)) , FreeVariables (TermFor m) , LiftEffect m , Member (TracerFor trace m) (Effects m) From 19ae302c40940f0aa08103f28d80aaedf886434d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:05:53 -0500 Subject: [PATCH 111/292] Define the tracePythonFile helper w/o evaluateTrace. --- src/Semantic/Util.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 72c6c8524..a0a3d7045 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -7,6 +7,7 @@ import Analysis.Abstract.Caching import Analysis.Abstract.Evaluating import Analysis.Abstract.Tracing import Analysis.Declaration +import Control.Abstract.Analysis import Control.Monad.IO.Class import Data.Abstract.Address import Data.Abstract.Type @@ -47,7 +48,7 @@ evaluateRubyFiles paths = do typecheckPythonFile path = evaluateCache @Type <$> (file path >>= runTask . parse pythonParser) -tracePythonFile path = evaluateTrace @[] @PythonValue <$> (file path >>= runTask . parse pythonParser) +tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluation Python.Term PythonValue (TracingEffects [] Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) evaluatePythonFile path = evaluate @PythonValue <$> (file path >>= runTask . parse pythonParser) From 7d2cfbe9181defbb4614b76c44f3b2f93d45df3e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:06:15 -0500 Subject: [PATCH 112/292] :fire: evaluateTrace. --- src/Analysis/Abstract/Tracing.hs | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 4965911e0..7057d353a 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where -import Analysis.Abstract.Evaluating import Control.Abstract.Addressable import Control.Abstract.Analysis import Control.Abstract.Evaluator @@ -23,26 +22,6 @@ type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffec -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -evaluateTrace :: forall trace value term - . ( Corecursive term - , Evaluatable (Base term) - , FreeVariables term - , Monoid (Trace trace term value) - , Ord (CellFor value) - , Ord term - , Ord value - , Recursive term - , Reducer (ConfigurationFor term value) (Trace trace term value) - , MonadAddressable (LocationFor value) (TracingAnalysis trace (Evaluation term value (TracingEffects trace term value))) - , MonadAnalysis (Evaluation term value (TracingEffects trace term value)) - , MonadValue value (TracingAnalysis trace (Evaluation term value (TracingEffects trace term value))) - , Semigroup (CellFor value) - ) - => term - -> Final (TracingEffects trace term value) value -evaluateTrace = run . lower @(Evaluation term value (TracingEffects trace term value)) . evaluateTerm - - newtype TracingAnalysis (trace :: * -> *) m a = TracingAnalysis { runTracingAnalysis :: m a } deriving (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) From ccb66340fdaac8ef79469b827721e7a2fe366639 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:10:25 -0500 Subject: [PATCH 113/292] Simplify the constraints on the MonadAnalysis instance. --- src/Analysis/Abstract/Tracing.hs | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 7057d353a..f7d9c6d86 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,14 +1,10 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where -import Control.Abstract.Addressable import Control.Abstract.Analysis import Control.Abstract.Evaluator -import Control.Abstract.Value import Control.Monad.Effect.Writer import Data.Abstract.Configuration -import Data.Abstract.Evaluatable -import Data.Abstract.Value import Data.Semigroup.Reducer as Reducer import Prologue @@ -27,15 +23,12 @@ newtype TracingAnalysis (trace :: * -> *) m a deriving (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) instance ( Corecursive (TermFor m) - , FreeVariables (TermFor m) , LiftEffect m , Member (TracerFor trace m) (Effects m) - , MonadAddressable (LocationFor (ValueFor m)) (TracingAnalysis trace m) , MonadAnalysis m - , MonadValue (ValueFor m) (TracingAnalysis trace m) + , MonadEvaluator m , Recursive (TermFor m) , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) - , Semigroup (CellFor (ValueFor m)) ) => MonadAnalysis (TracingAnalysis trace m) where analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> TracingAnalysis (analyzeTerm (second runTracingAnalysis <$> term)) From 176142b47168eb4a51809241e0f917f720e9abb8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:14:40 -0500 Subject: [PATCH 114/292] Pull subterms out to the top level. --- src/Analysis/Abstract/Dead.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index f2d9f2c12..664729c8d 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -31,8 +31,6 @@ evaluateDead :: forall term value evaluateDead term = run @(DeadCodeEffects term value) . runEvaluator . runDeadCodeAnalysis $ do killAll (subterms term) evaluateTerm term - where subterms :: (Ord a, Recursive a, Foldable (Base a)) => a -> Dead a - subterms term = term `cons` para (foldMap (uncurry cons)) term -- | A newtype wrapping 'Evaluator' which performs a dead code analysis on evaluation. @@ -56,6 +54,9 @@ killAll = DeadCodeAnalysis . Evaluator . put revive :: Ord t => t -> DeadCodeAnalysis t v () revive t = DeadCodeAnalysis (Evaluator (modify (Dead . delete t . unDead))) +-- | Compute the set of all subterms recursively. +subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term +subterms term = term `cons` para (foldMap (uncurry cons)) term instance ( Corecursive t , Evaluatable (Base t) From d6b04d985868d54b932e3cb88548481e813c19b7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:14:45 -0500 Subject: [PATCH 115/292] Rename a bunch of type parameters. --- src/Analysis/Abstract/Dead.hs | 27 ++++++++++++++------------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 664729c8d..6868c213a 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -41,33 +41,34 @@ deriving instance Ord (LocationFor value) => MonadEvaluator (DeadCodeAnalysis te -- | A set of “dead” (unreachable) terms. -newtype Dead a = Dead { unDead :: Set a } +newtype Dead term = Dead { unDead :: Set term } deriving (Eq, Foldable, Semigroup, Monoid, Ord, Show) -deriving instance Ord a => Reducer a (Dead a) +deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: Dead t -> DeadCodeAnalysis t v () +killAll :: Dead term -> DeadCodeAnalysis term value () killAll = DeadCodeAnalysis . Evaluator . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: Ord t => t -> DeadCodeAnalysis t v () +revive :: Ord term => term -> DeadCodeAnalysis term value () revive t = DeadCodeAnalysis (Evaluator (modify (Dead . delete t . unDead))) -- | Compute the set of all subterms recursively. subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term subterms term = term `cons` para (foldMap (uncurry cons)) term -instance ( Corecursive t - , Evaluatable (Base t) - , FreeVariables t - , MonadAddressable (LocationFor v) (DeadCodeAnalysis t v) - , MonadValue v (DeadCodeAnalysis t v) - , Ord t - , Recursive t - , Semigroup (CellFor v) + +instance ( Corecursive term + , Evaluatable (Base term) + , FreeVariables term + , MonadAddressable (LocationFor value) (DeadCodeAnalysis term value) + , MonadValue value (DeadCodeAnalysis term value) + , Ord term + , Recursive term + , Semigroup (CellFor value) ) - => MonadAnalysis (DeadCodeAnalysis t v) where + => MonadAnalysis (DeadCodeAnalysis term value) where analyzeTerm term = do revive (embedSubterm term) eval term From 704f09083f5756071ef96397b8b28d6d0ab23c3d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:31:18 -0500 Subject: [PATCH 116/292] Abstract the dead code analysis over the underlying analysis. --- src/Analysis/Abstract/Dead.hs | 54 ++++++++++++++++++----------------- 1 file changed, 28 insertions(+), 26 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 6868c213a..eef868fe2 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Dead where +import Analysis.Abstract.Evaluating import Control.Abstract.Addressable import Control.Abstract.Evaluator import Data.Abstract.Evaluatable @@ -14,13 +15,15 @@ type DeadCodeEffects term value = State (Dead term) ': EvaluatorEffects term val -- | Run a dead code analysis of the given program. -evaluateDead :: forall term value - . ( Corecursive term +evaluateDead :: forall term value effects m + . ( m ~ Evaluation term value effects + , effects ~ DeadCodeEffects term value + , Corecursive term , Evaluatable (Base term) , Foldable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (DeadCodeAnalysis term value) - , MonadValue value (DeadCodeAnalysis term value) + , MonadAddressable (LocationFor value) m + , MonadValue value m , Ord (LocationFor value) , Ord term , Recursive term @@ -28,16 +31,14 @@ evaluateDead :: forall term value ) => term -> Final (DeadCodeEffects term value) value -evaluateDead term = run @(DeadCodeEffects term value) . runEvaluator . runDeadCodeAnalysis $ do +evaluateDead term = run @(DeadCodeEffects term value) . lower @(DeadCodeAnalysis m) $ do killAll (subterms term) evaluateTerm term --- | A newtype wrapping 'Evaluator' which performs a dead code analysis on evaluation. -newtype DeadCodeAnalysis term value a = DeadCodeAnalysis { runDeadCodeAnalysis :: Evaluator term value (DeadCodeEffects term value) a } - deriving (Applicative, Functor, Monad, MonadFail) - -deriving instance Ord (LocationFor value) => MonadEvaluator (DeadCodeAnalysis term value) +-- | An analysis tracking dead (unreachable) code. +newtype DeadCodeAnalysis m a = DeadCodeAnalysis { runDeadCodeAnalysis :: m a } + deriving (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) -- | A set of “dead” (unreachable) terms. @@ -47,31 +48,32 @@ newtype Dead term = Dead { unDead :: Set term } deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: Dead term -> DeadCodeAnalysis term value () -killAll = DeadCodeAnalysis . Evaluator . put +killAll :: (LiftEffect m, Member (State (Dead (TermFor m))) (Effects m)) => Dead (TermFor m) -> DeadCodeAnalysis m () +killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: Ord term => term -> DeadCodeAnalysis term value () -revive t = DeadCodeAnalysis (Evaluator (modify (Dead . delete t . unDead))) +revive :: (LiftEffect m, Member (State (Dead (TermFor m))) (Effects m)) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m () +revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term subterms term = term `cons` para (foldMap (uncurry cons)) term -instance ( Corecursive term - , Evaluatable (Base term) - , FreeVariables term - , MonadAddressable (LocationFor value) (DeadCodeAnalysis term value) - , MonadValue value (DeadCodeAnalysis term value) - , Ord term - , Recursive term - , Semigroup (CellFor value) +instance ( Corecursive (TermFor m) + , Evaluatable (Base (TermFor m)) + , LiftEffect m + , Member (State (Dead (TermFor m))) (Effects m) + , MonadAnalysis m + , MonadEvaluator m + , Ord (TermFor m) + , Recursive (TermFor m) + , Semigroup (CellFor (ValueFor m)) ) - => MonadAnalysis (DeadCodeAnalysis term value) where + => MonadAnalysis (DeadCodeAnalysis m) where analyzeTerm term = do revive (embedSubterm term) - eval term + DeadCodeAnalysis (analyzeTerm (second runDeadCodeAnalysis <$> term)) -type instance TermFor (DeadCodeAnalysis term value) = term -type instance ValueFor (DeadCodeAnalysis term value) = value +type instance TermFor (DeadCodeAnalysis m) = TermFor m +type instance ValueFor (DeadCodeAnalysis m) = ValueFor m From 6ed41a911c674137c3c82bc67c7b18cb3a22a650 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:35:56 -0500 Subject: [PATCH 117/292] Move the Ord constraint on the location into the class methods requiring it. --- src/Analysis/Abstract/Tracing.hs | 2 ++ src/Control/Abstract/Evaluator.hs | 8 ++++---- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index f7d9c6d86..cd75144af 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -6,6 +6,7 @@ import Control.Abstract.Evaluator import Control.Monad.Effect.Writer import Data.Abstract.Configuration import Data.Semigroup.Reducer as Reducer +import Data.Abstract.Value import Prologue type Trace trace term value = trace (ConfigurationFor term value) @@ -27,6 +28,7 @@ instance ( Corecursive (TermFor m) , Member (TracerFor trace m) (Effects m) , MonadAnalysis m , MonadEvaluator m + , Ord (LocationFor (ValueFor m)) , Recursive (TermFor m) , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) ) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 64550854d..bf1632e64 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, DefaultSignatures, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE ConstrainedClassMethods, DataKinds, DefaultSignatures, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator where import Control.Abstract.Analysis @@ -18,7 +18,7 @@ import Prelude hiding (fail) -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class (MonadFail m, Ord (LocationFor (ValueFor m))) => MonadEvaluator m where +class MonadFail m => MonadEvaluator m where -- | Retrieve the global environment. getGlobalEnv :: m (EnvironmentFor (ValueFor m)) -- | Update the global environment. @@ -45,11 +45,11 @@ class (MonadFail m, Ord (LocationFor (ValueFor m))) => MonadEvaluator m where localModuleTable :: (Linker (TermFor m) -> Linker (TermFor m)) -> m a -> m a -- | Retrieve the current root set. - askRoots :: m (Live (LocationFor (ValueFor m)) (ValueFor m)) + askRoots :: Ord (LocationFor (ValueFor m)) => m (Live (LocationFor (ValueFor m)) (ValueFor m)) askRoots = pure mempty -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) + getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore type EvaluatorEffects term value From 6b9ae3eb73c6982e26cf6573f2a9551df07c5b62 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:36:16 -0500 Subject: [PATCH 118/292] :fire: some redundant constraints. --- src/Analysis/Abstract/Dead.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index eef868fe2..807c64f3e 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -61,14 +61,12 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term instance ( Corecursive (TermFor m) - , Evaluatable (Base (TermFor m)) , LiftEffect m , Member (State (Dead (TermFor m))) (Effects m) , MonadAnalysis m , MonadEvaluator m , Ord (TermFor m) , Recursive (TermFor m) - , Semigroup (CellFor (ValueFor m)) ) => MonadAnalysis (DeadCodeAnalysis m) where analyzeTerm term = do From b9a6d1bda5cfe266e44ad42346dc9fa781dd0e8c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:39:41 -0500 Subject: [PATCH 119/292] Give a tacit definition of trace. --- 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 cd75144af..1b462b23e 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -43,4 +43,4 @@ trace :: ( LiftEffect m ) => TraceFor trace m -> TracingAnalysis trace m () -trace w = lift (tell w) +trace = lift . tell From d0a464318e195db5b1bf4ee20a86433ee15e3eaf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:40:05 -0500 Subject: [PATCH 120/292] Format analyzeTerm over several lines. --- src/Analysis/Abstract/Tracing.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 1b462b23e..0571f8ef3 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -33,7 +33,10 @@ instance ( Corecursive (TermFor m) , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) ) => MonadAnalysis (TracingAnalysis trace m) where - analyzeTerm term = getConfiguration (embedSubterm term) >>= trace . Reducer.unit >> TracingAnalysis (analyzeTerm (second runTracingAnalysis <$> term)) + analyzeTerm term = do + config <- getConfiguration (embedSubterm term) + trace (Reducer.unit config) + TracingAnalysis (analyzeTerm (second runTracingAnalysis <$> term)) type instance TermFor (TracingAnalysis trace m) = TermFor m type instance ValueFor (TracingAnalysis trace m) = ValueFor m From d49d2860dd653309a3609f1be405485c4bc4952d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:53:31 -0500 Subject: [PATCH 121/292] Define a Newtype1 typeclass. --- src/Control/Abstract/Analysis.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index e09ca7b55..49a2d726f 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -30,3 +30,10 @@ class Monad m => MonadAnalysis m where evaluateTerm :: TermFor m -> m (ValueFor m) default evaluateTerm :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm + + +class Newtype1 n where + type O1 n :: * -> * + + pack1 :: O1 n a -> n a + unpack1 :: n a -> O1 n a From 9c49bb2f0c72b96093538ee032395413d09eef72 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:56:35 -0500 Subject: [PATCH 122/292] Define a generic Newtype1 analogue. --- src/Control/Abstract/Analysis.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 49a2d726f..91dcabfc0 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -37,3 +37,9 @@ class Newtype1 n where pack1 :: O1 n a -> n a unpack1 :: n a -> O1 n a + +class GNewtype1 n where + type GO1 n :: * -> * + + gpack1 :: GO1 n a -> n a + gunpack1 :: n a -> GO1 n a From e30a4d3f25bc3bb276167b25f2679b58eebfb4ed Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 18:56:50 -0500 Subject: [PATCH 123/292] Define default implementations of pack1 and unpack1 for Generic1 types. --- src/Control/Abstract/Analysis.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 91dcabfc0..12f9bac75 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -36,7 +36,12 @@ class Newtype1 n where type O1 n :: * -> * pack1 :: O1 n a -> n a + default pack1 :: (Generic1 n, GNewtype1 (Rep1 n), O1 n ~ GO1 (Rep1 n)) => O1 n a -> n a + pack1 = to1 . gpack1 + unpack1 :: n a -> O1 n a + default unpack1 :: (Generic1 n, GNewtype1 (Rep1 n), O1 n ~ GO1 (Rep1 n)) => n a -> O1 n a + unpack1 = gunpack1 . from1 class GNewtype1 n where type GO1 n :: * -> * From f3ace5ca2af541e62e7f394b1e58980048be17eb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 19:00:41 -0500 Subject: [PATCH 124/292] Give an instance of GNewtype1. --- src/Control/Abstract/Analysis.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 12f9bac75..bb0a228b7 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -12,6 +12,7 @@ import Control.Effect as X import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X +import Data.Coerce import Prologue type family TermFor (m :: * -> *) @@ -48,3 +49,8 @@ class GNewtype1 n where gpack1 :: GO1 n a -> n a gunpack1 :: n a -> GO1 n a + +instance GNewtype1 (D1 d (C1 c (S1 s (Rec1 a)))) where + type GO1 (D1 d (C1 c (S1 s (Rec1 a)))) = a + gpack1 = coerce + gunpack1 = coerce From f4fcdfecf1fbd20c585be1d4af66a270faccce2f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 19:02:16 -0500 Subject: [PATCH 125/292] Stub in a module for Newtype1. --- semantic.cabal | 1 + src/Control/Newtype1.hs | 1 + 2 files changed, 2 insertions(+) create mode 100644 src/Control/Newtype1.hs diff --git a/semantic.cabal b/semantic.cabal index 0d0e958cb..443f23835 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -36,6 +36,7 @@ library , Control.Abstract.Value -- Control flow , Control.Effect + , Control.Newtype1 -- Effects used for program analysis , Control.Monad.Effect.Cache , Control.Monad.Effect.Fresh diff --git a/src/Control/Newtype1.hs b/src/Control/Newtype1.hs new file mode 100644 index 000000000..443ba24fe --- /dev/null +++ b/src/Control/Newtype1.hs @@ -0,0 +1 @@ +module Control.Newtype1 where From 11360000cbce25c53ebb532bf0bc35154fb97301 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 19:03:46 -0500 Subject: [PATCH 126/292] Move Newtype1 into its own module. --- src/Control/Abstract/Analysis.hs | 24 +----------------------- src/Control/Newtype1.hs | 30 +++++++++++++++++++++++++++++- 2 files changed, 30 insertions(+), 24 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index bb0a228b7..f2618042b 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -9,10 +9,10 @@ module Control.Abstract.Analysis ) where import Control.Effect as X +import Control.Newtype1 as X import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X -import Data.Coerce import Prologue type family TermFor (m :: * -> *) @@ -32,25 +32,3 @@ class Monad m => MonadAnalysis m where default evaluateTerm :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm - -class Newtype1 n where - type O1 n :: * -> * - - pack1 :: O1 n a -> n a - default pack1 :: (Generic1 n, GNewtype1 (Rep1 n), O1 n ~ GO1 (Rep1 n)) => O1 n a -> n a - pack1 = to1 . gpack1 - - unpack1 :: n a -> O1 n a - default unpack1 :: (Generic1 n, GNewtype1 (Rep1 n), O1 n ~ GO1 (Rep1 n)) => n a -> O1 n a - unpack1 = gunpack1 . from1 - -class GNewtype1 n where - type GO1 n :: * -> * - - gpack1 :: GO1 n a -> n a - gunpack1 :: n a -> GO1 n a - -instance GNewtype1 (D1 d (C1 c (S1 s (Rec1 a)))) where - type GO1 (D1 d (C1 c (S1 s (Rec1 a)))) = a - gpack1 = coerce - gunpack1 = coerce diff --git a/src/Control/Newtype1.hs b/src/Control/Newtype1.hs index 443ba24fe..97fa29297 100644 --- a/src/Control/Newtype1.hs +++ b/src/Control/Newtype1.hs @@ -1 +1,29 @@ -module Control.Newtype1 where +{-# LANGUAGE DefaultSignatures, TypeFamilies #-} +module Control.Newtype1 +( Newtype1(..) +) where + +import Data.Coerce (coerce) +import Prologue + +class Newtype1 n where + type O1 n :: * -> * + + pack1 :: O1 n a -> n a + default pack1 :: (Generic1 n, GNewtype1 (Rep1 n), O1 n ~ GO1 (Rep1 n)) => O1 n a -> n a + pack1 = to1 . gpack1 + + unpack1 :: n a -> O1 n a + default unpack1 :: (Generic1 n, GNewtype1 (Rep1 n), O1 n ~ GO1 (Rep1 n)) => n a -> O1 n a + unpack1 = gunpack1 . from1 + +class GNewtype1 n where + type GO1 n :: * -> * + + gpack1 :: GO1 n a -> n a + gunpack1 :: n a -> GO1 n a + +instance GNewtype1 (D1 d (C1 c (S1 s (Rec1 a)))) where + type GO1 (D1 d (C1 c (S1 s (Rec1 a)))) = a + gpack1 = coerce + gunpack1 = coerce From 7215f499a06e576c7980e60d7083e116181d12ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 19:04:02 -0500 Subject: [PATCH 127/292] Define a function delegating term analysis to an underlying MonadAnalysis instance. --- src/Control/Abstract/Analysis.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index f2618042b..e9dc3e14a 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -32,3 +32,5 @@ class Monad m => MonadAnalysis m where default evaluateTerm :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm +delegateAnalyzeTerm :: (Functor (Base (TermFor m)), Newtype1 m, MonadAnalysis (O1 m), TermFor m ~ TermFor (O1 m), ValueFor m ~ ValueFor (O1 m)) => SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) +delegateAnalyzeTerm term = pack1 (analyzeTerm (second unpack1 <$> term)) From 1b004925c4298d64ee4538c39731f420c42dca5b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 19:04:15 -0500 Subject: [PATCH 128/292] Derive Generic1 & Newtype1 instances for TracingAnalysis. --- 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 0571f8ef3..4856597c9 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -21,7 +21,7 @@ type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffec -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m a = TracingAnalysis { runTracingAnalysis :: m a } - deriving (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, Generic1, LiftEffect, Monad, MonadEvaluator, MonadFail, Newtype1) instance ( Corecursive (TermFor m) , LiftEffect m From 1de12b1119b9365a00ed48096176b9e863f610fe Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 19:08:32 -0500 Subject: [PATCH 129/292] Reformat the signature for delegateAnalyzeTerm. --- src/Control/Abstract/Analysis.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index e9dc3e14a..b2a77a381 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DefaultSignatures, KindSignatures, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) +, delegateAnalyzeTerm , TermFor , ValueFor , module X @@ -32,5 +33,11 @@ class Monad m => MonadAnalysis m where default evaluateTerm :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm -delegateAnalyzeTerm :: (Functor (Base (TermFor m)), Newtype1 m, MonadAnalysis (O1 m), TermFor m ~ TermFor (O1 m), ValueFor m ~ ValueFor (O1 m)) => SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) +delegateAnalyzeTerm :: ( TermFor m ~ TermFor (O1 m) + , ValueFor m ~ ValueFor (O1 m) + , Functor (Base (TermFor m)) + , MonadAnalysis (O1 m) + , Newtype1 m + ) + => SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) delegateAnalyzeTerm term = pack1 (analyzeTerm (second unpack1 <$> term)) From 35d82b248724aa869476492622ece84a542df659 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 19:15:43 -0500 Subject: [PATCH 130/292] Give a default definition for O1. --- src/Control/Newtype1.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Control/Newtype1.hs b/src/Control/Newtype1.hs index 97fa29297..a5b9bb225 100644 --- a/src/Control/Newtype1.hs +++ b/src/Control/Newtype1.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DefaultSignatures, TypeFamilies #-} +{-# LANGUAGE DefaultSignatures, TypeFamilies, UndecidableInstances #-} module Control.Newtype1 ( Newtype1(..) ) where @@ -8,6 +8,7 @@ import Prologue class Newtype1 n where type O1 n :: * -> * + type O1 n = GO1 (Rep1 n) pack1 :: O1 n a -> n a default pack1 :: (Generic1 n, GNewtype1 (Rep1 n), O1 n ~ GO1 (Rep1 n)) => O1 n a -> n a From 4945fdf575c1d717c565c091eb676185f611d790 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 20:41:57 -0500 Subject: [PATCH 131/292] Sort imports. --- 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 4856597c9..42882e94f 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -5,8 +5,8 @@ import Control.Abstract.Analysis import Control.Abstract.Evaluator import Control.Monad.Effect.Writer import Data.Abstract.Configuration -import Data.Semigroup.Reducer as Reducer import Data.Abstract.Value +import Data.Semigroup.Reducer as Reducer import Prologue type Trace trace term value = trace (ConfigurationFor term value) From 4226d0f2592478187eb3af777148bb409605326e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 20:49:00 -0500 Subject: [PATCH 132/292] Use -XDerivingStrategies to correct the instances. --- src/Analysis/Abstract/Tracing.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 42882e94f..d0ac881d4 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Analysis @@ -21,7 +21,9 @@ type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffec -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m a = TracingAnalysis { runTracingAnalysis :: m a } - deriving (Applicative, Functor, Generic1, LiftEffect, Monad, MonadEvaluator, MonadFail, Newtype1) + deriving newtype (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) + deriving stock (Generic1) + deriving anyclass (Newtype1) instance ( Corecursive (TermFor m) , LiftEffect m From 7e6ff8674d8f181dee46cd4fb846be0546ffd547 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 20:49:16 -0500 Subject: [PATCH 133/292] Use delegateAnalysis. --- 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 d0ac881d4..c02bbd769 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -38,7 +38,7 @@ instance ( Corecursive (TermFor m) analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) - TracingAnalysis (analyzeTerm (second runTracingAnalysis <$> term)) + delegateAnalyzeTerm term type instance TermFor (TracingAnalysis trace m) = TermFor m type instance ValueFor (TracingAnalysis trace m) = ValueFor m From 8ac41065ec2c410e389068b89f9acf72b4b6582b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:02:21 -0500 Subject: [PATCH 134/292] Define delegateAnalyzeTerm using Coercible. --- src/Control/Abstract/Analysis.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index b2a77a381..edadc7ec6 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -14,6 +14,7 @@ import Control.Newtype1 as X import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X +import Data.Coerce import Prologue type family TermFor (m :: * -> *) @@ -33,11 +34,15 @@ class Monad m => MonadAnalysis m where default evaluateTerm :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm -delegateAnalyzeTerm :: ( TermFor m ~ TermFor (O1 m) - , ValueFor m ~ ValueFor (O1 m) - , Functor (Base (TermFor m)) - , MonadAnalysis (O1 m) - , Newtype1 m +delegateAnalyzeTerm :: ( TermFor (t m) ~ TermFor m + , ValueFor (t m) ~ ValueFor m + , Functor (Base (TermFor (t m))) + , MonadAnalysis m + , Coercible (t m (ValueFor m)) (m (ValueFor m)) + , Coercible (m (ValueFor m)) (t m (ValueFor m)) ) - => SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) + => SubtermAlgebra (Base (TermFor (t m))) (TermFor (t m)) (t m (ValueFor m)) delegateAnalyzeTerm term = pack1 (analyzeTerm (second unpack1 <$> term)) + where pack1 = coerce + unpack1 :: Coercible (t m (ValueFor m)) (m (ValueFor m)) => t m (ValueFor m) -> m (ValueFor m) + unpack1 = coerce From 7fb874e5eb268adebacbf6dd4fb570768edb76b3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:02:34 -0500 Subject: [PATCH 135/292] Revert "Use -XDerivingStrategies to correct the instances." This reverts commit af43e435dc87bddf02fd9ccc99e2d08a3990fab3. --- src/Analysis/Abstract/Tracing.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index c02bbd769..b6b2f378c 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, DeriveAnyClass, DerivingStrategies, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Analysis @@ -21,9 +21,7 @@ type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffec -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m a = TracingAnalysis { runTracingAnalysis :: m a } - deriving newtype (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) - deriving stock (Generic1) - deriving anyclass (Newtype1) + deriving (Applicative, Functor, Generic1, LiftEffect, Monad, MonadEvaluator, MonadFail, Newtype1) instance ( Corecursive (TermFor m) , LiftEffect m From ad195fa0ccc0e8ec0b7b95b7937aaf35bd657bf5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:03:15 -0500 Subject: [PATCH 136/292] :fire: the instance of Newtype1. --- 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 b6b2f378c..742537e50 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -21,7 +21,7 @@ type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffec -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m a = TracingAnalysis { runTracingAnalysis :: m a } - deriving (Applicative, Functor, Generic1, LiftEffect, Monad, MonadEvaluator, MonadFail, Newtype1) + deriving (Applicative, Functor, Generic1, LiftEffect, Monad, MonadEvaluator, MonadFail) instance ( Corecursive (TermFor m) , LiftEffect m From 1c117beacdbec24967fbc9b8f8731e4c6b84c0fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:03:22 -0500 Subject: [PATCH 137/292] :fire: the re-export of Newtype1. --- src/Control/Abstract/Analysis.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index edadc7ec6..3c2d5a54f 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -10,7 +10,6 @@ module Control.Abstract.Analysis ) where import Control.Effect as X -import Control.Newtype1 as X import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X From 089b08edb3243aba6aaf23a56567564623598982 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:03:46 -0500 Subject: [PATCH 138/292] :fire: Control.Newtype1. --- semantic.cabal | 1 - src/Control/Newtype1.hs | 30 ------------------------------ 2 files changed, 31 deletions(-) delete mode 100644 src/Control/Newtype1.hs diff --git a/semantic.cabal b/semantic.cabal index 443f23835..0d0e958cb 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -36,7 +36,6 @@ library , Control.Abstract.Value -- Control flow , Control.Effect - , Control.Newtype1 -- Effects used for program analysis , Control.Monad.Effect.Cache , Control.Monad.Effect.Fresh diff --git a/src/Control/Newtype1.hs b/src/Control/Newtype1.hs deleted file mode 100644 index a5b9bb225..000000000 --- a/src/Control/Newtype1.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE DefaultSignatures, TypeFamilies, UndecidableInstances #-} -module Control.Newtype1 -( Newtype1(..) -) where - -import Data.Coerce (coerce) -import Prologue - -class Newtype1 n where - type O1 n :: * -> * - type O1 n = GO1 (Rep1 n) - - pack1 :: O1 n a -> n a - default pack1 :: (Generic1 n, GNewtype1 (Rep1 n), O1 n ~ GO1 (Rep1 n)) => O1 n a -> n a - pack1 = to1 . gpack1 - - unpack1 :: n a -> O1 n a - default unpack1 :: (Generic1 n, GNewtype1 (Rep1 n), O1 n ~ GO1 (Rep1 n)) => n a -> O1 n a - unpack1 = gunpack1 . from1 - -class GNewtype1 n where - type GO1 n :: * -> * - - gpack1 :: GO1 n a -> n a - gunpack1 :: n a -> GO1 n a - -instance GNewtype1 (D1 d (C1 c (S1 s (Rec1 a)))) where - type GO1 (D1 d (C1 c (S1 s (Rec1 a)))) = a - gpack1 = coerce - gunpack1 = coerce From e71fac7493287ad2fd8fc704138597d41bafb8fa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:04:17 -0500 Subject: [PATCH 139/292] :fire: the (wrong, bad) Generic1 instance. --- 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 742537e50..f0a9f58b3 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -21,7 +21,7 @@ type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffec -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m a = TracingAnalysis { runTracingAnalysis :: m a } - deriving (Applicative, Functor, Generic1, LiftEffect, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) instance ( Corecursive (TermFor m) , LiftEffect m From c35b1f4f0c4413be8e2f1b5915967225b31b12e1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:09:26 -0500 Subject: [PATCH 140/292] :fire: a bunch of redundant language extensions. --- 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 f0a9f58b3..fad6fa984 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Analysis From b0f03a021ff8330ba50c8dbc11d741a81b3d2757 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:09:28 -0500 Subject: [PATCH 141/292] Spacing. --- src/Analysis/Abstract/Tracing.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index fad6fa984..f9685fe5d 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -13,6 +13,7 @@ type Trace trace term value = trace (ConfigurationFor term value) type TraceFor trace m = Trace trace (TermFor m) (ValueFor m) type Tracer trace term value = Writer (Trace trace term value) type TracerFor trace m = Writer (TraceFor trace m) + -- | The effects necessary for tracing analyses. type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffects term value From 7fbafef56c7e86317858e42ba2892b50a80a19d9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:12:20 -0500 Subject: [PATCH 142/292] Move TermFor and ValueFor into Control.Abstract.Evaluator. --- src/Control/Abstract/Analysis.hs | 4 +--- src/Control/Abstract/Evaluator.hs | 8 +++++++- 2 files changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 3c2d5a54f..d8d1f7f69 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -9,6 +9,7 @@ module Control.Abstract.Analysis , SubtermAlgebra ) where +import Control.Abstract.Evaluator import Control.Effect as X import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Reader as X @@ -16,9 +17,6 @@ import Control.Monad.Effect.State as X import Data.Coerce import Prologue -type family TermFor (m :: * -> *) -type family ValueFor (m :: * -> *) - -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index bf1632e64..508fabaf3 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,17 +1,23 @@ {-# LANGUAGE ConstrainedClassMethods, DataKinds, DefaultSignatures, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator where -import Control.Abstract.Analysis import Control.Applicative +import Control.Effect import Control.Monad.Effect +import Control.Monad.Effect.Fail import Control.Monad.Effect.Fresh import Control.Monad.Effect.NonDet +import Control.Monad.Effect.Reader +import Control.Monad.Effect.State import Data.Abstract.Configuration import Data.Abstract.Linker import Data.Abstract.Live import Data.Abstract.Value import Prelude hiding (fail) +type family TermFor (m :: * -> *) +type family ValueFor (m :: * -> *) + -- | A 'Monad' providing the basic essentials for evaluation. -- -- These presently include: From 7e5deee2c326831528bdab8a9ce3c0783461e608 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:14:09 -0500 Subject: [PATCH 143/292] Define TermFor & ValueFor as associated type families. --- src/Analysis/Abstract/Caching.hs | 3 --- src/Analysis/Abstract/Dead.hs | 3 --- src/Analysis/Abstract/Evaluating.hs | 3 --- src/Analysis/Abstract/Tracing.hs | 3 --- src/Control/Abstract/Evaluator.hs | 11 ++++++----- 5 files changed, 6 insertions(+), 17 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 3e5ace2a2..c9d2d9084 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -85,9 +85,6 @@ instance ( Corecursive t getCache) mempty maybe empty scatter (cacheLookup c cache) -type instance TermFor (CachingAnalysis term value) = term -type instance ValueFor (CachingAnalysis term value) = value - -- | Coinductively-cached evaluation. evaluateCache :: forall v term diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 807c64f3e..747feef04 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -72,6 +72,3 @@ instance ( Corecursive (TermFor m) analyzeTerm term = do revive (embedSubterm term) DeadCodeAnalysis (analyzeTerm (second runDeadCodeAnalysis <$> term)) - -type instance TermFor (DeadCodeAnalysis m) = TermFor m -type instance ValueFor (DeadCodeAnalysis m) = ValueFor m diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 1d5ed6fe9..5c8b49a93 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -61,6 +61,3 @@ instance ( Evaluatable (Base term) ) => MonadAnalysis (Evaluation term value effects) where analyzeTerm = eval - -type instance TermFor (Evaluation term value effects) = term -type instance ValueFor (Evaluation term value effects) = value diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index f9685fe5d..b9dedf3fa 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -39,9 +39,6 @@ instance ( Corecursive (TermFor m) trace (Reducer.unit config) delegateAnalyzeTerm term -type instance TermFor (TracingAnalysis trace m) = TermFor m -type instance ValueFor (TracingAnalysis trace m) = ValueFor m - trace :: ( LiftEffect m , Member (TracerFor trace m) (Effects m) ) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 508fabaf3..990b0371a 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -15,9 +15,6 @@ import Data.Abstract.Live import Data.Abstract.Value import Prelude hiding (fail) -type family TermFor (m :: * -> *) -type family ValueFor (m :: * -> *) - -- | A 'Monad' providing the basic essentials for evaluation. -- -- These presently include: @@ -25,6 +22,9 @@ type family ValueFor (m :: * -> *) -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import class MonadFail m => MonadEvaluator m where + type TermFor m :: * + type ValueFor m :: * + -- | Retrieve the global environment. getGlobalEnv :: m (EnvironmentFor (ValueFor m)) -- | Update the global environment. @@ -67,9 +67,10 @@ type EvaluatorEffects term value , State (Linker value) -- Cache of evaluated modules ] -type instance TermFor (Evaluator term value effects) = term -type instance ValueFor (Evaluator term value effects) = value instance (Ord (LocationFor value), Members (EvaluatorEffects term value) effects) => MonadEvaluator (Evaluator term value effects) where + type TermFor (Evaluator term value effects) = term + type ValueFor (Evaluator term value effects) = value + getGlobalEnv = Evaluator get modifyGlobalEnv f = Evaluator (modify f) From fe7c2e66f86ce4a481e9c23e09fea2208079c47c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:14:55 -0500 Subject: [PATCH 144/292] :fire: redundant kind signatures. --- src/Control/Abstract/Evaluator.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 990b0371a..28a0e8341 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -22,8 +22,8 @@ import Prelude hiding (fail) -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import class MonadFail m => MonadEvaluator m where - type TermFor m :: * - type ValueFor m :: * + type TermFor m + type ValueFor m -- | Retrieve the global environment. getGlobalEnv :: m (EnvironmentFor (ValueFor m)) From c3de4459aa777e1e6389991951b714710b6d8e1c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:15:15 -0500 Subject: [PATCH 145/292] :fire: a redundant extension. --- src/Control/Abstract/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 28a0e8341..70495c903 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, DataKinds, DefaultSignatures, GeneralizedNewtypeDeriving, RankNTypes, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE ConstrainedClassMethods, DataKinds, DefaultSignatures, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator where import Control.Applicative From 8551034a1b625f5b9383b2789e6764690e2e7931 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:16:21 -0500 Subject: [PATCH 146/292] Re-export Evaluator from Analysis. --- src/Analysis/Abstract/Tracing.hs | 1 - src/Control/Abstract/Addressable.hs | 1 - src/Control/Abstract/Analysis.hs | 4 +--- src/Control/Abstract/Value.hs | 1 - src/Data/Abstract/Evaluatable.hs | 1 - 5 files changed, 1 insertion(+), 7 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index b9dedf3fa..cead4cbe4 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -2,7 +2,6 @@ module Analysis.Abstract.Tracing where import Control.Abstract.Analysis -import Control.Abstract.Evaluator import Control.Monad.Effect.Writer import Data.Abstract.Configuration import Data.Abstract.Value diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 2c24183ae..91d2c247e 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -2,7 +2,6 @@ module Control.Abstract.Addressable where import Control.Abstract.Analysis -import Control.Abstract.Evaluator import Control.Applicative import Control.Monad ((<=<)) import Data.Abstract.Address diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index d8d1f7f69..d91245b1a 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -2,14 +2,12 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , delegateAnalyzeTerm -, TermFor -, ValueFor , module X , Subterm(..) , SubtermAlgebra ) where -import Control.Abstract.Evaluator +import Control.Abstract.Evaluator as X import Control.Effect as X import Control.Monad.Effect.Fail as X import Control.Monad.Effect.Reader as X diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 55b1cfb4e..26cfd544b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -3,7 +3,6 @@ module Control.Abstract.Value where import Control.Abstract.Addressable import Control.Abstract.Analysis -import Control.Abstract.Evaluator import Control.Monad.Effect.Fresh import Data.Abstract.Address import Data.Abstract.Environment diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 414be8945..e4b7e4965 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -12,7 +12,6 @@ module Data.Abstract.Evaluatable import Control.Abstract.Addressable as Addressable import Control.Abstract.Analysis as Analysis -import Control.Abstract.Evaluator import Control.Abstract.Value as Value import Data.Abstract.Environment import Data.Abstract.FreeVariables as FreeVariables From 271f3fb78653bf3eadd3913e86e95fd5bd67063e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:19:05 -0500 Subject: [PATCH 147/292] MonadAnalysis implies MonadEvaluator. --- src/Analysis/Abstract/Evaluating.hs | 1 + src/Control/Abstract/Analysis.hs | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 5c8b49a93..ce3c3fc26 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -54,6 +54,7 @@ deriving instance (Member Fail effects, MonadEvaluator (Evaluator term value eff instance ( Evaluatable (Base term) , FreeVariables term + , Members (EvaluatorEffects term value) effects , MonadAddressable (LocationFor value) (Evaluation term value effects) , MonadValue value (Evaluation term value effects) , Recursive term diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index d91245b1a..b5c5cb9ee 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -18,7 +18,7 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class Monad m => MonadAnalysis m where +class MonadEvaluator m => MonadAnalysis m where -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) From 5749c50302c24116aec873028975f48c319b26db Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:20:16 -0500 Subject: [PATCH 148/292] Delegate the analysis of terms to the underlying analysis. --- src/Analysis/Abstract/Dead.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 747feef04..edc903636 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -71,4 +71,4 @@ instance ( Corecursive (TermFor m) => MonadAnalysis (DeadCodeAnalysis m) where analyzeTerm term = do revive (embedSubterm term) - DeadCodeAnalysis (analyzeTerm (second runDeadCodeAnalysis <$> term)) + delegateAnalyzeTerm term From 9a3e0fe6076be58eadf1da1e0eb558631cf9c567 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:26:44 -0500 Subject: [PATCH 149/292] Rename a bunch of type parameters. --- src/Analysis/Abstract/Caching.hs | 84 ++++++++++++++++---------------- 1 file changed, 42 insertions(+), 42 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index c9d2d9084..58b7e5ab1 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -33,46 +33,46 @@ deriving instance Ord (LocationFor value) => MonadEvaluator (CachingAnalysis ter -- TODO: reabstract these later on -askCache :: CachingAnalysis t v (CacheFor t v) +askCache :: CachingAnalysis term value (CacheFor term value) askCache = CachingAnalysis (Evaluator ask) -localCache :: (CacheFor t v -> CacheFor t v) -> CachingAnalysis t v a -> CachingAnalysis t v a +localCache :: (CacheFor term value -> CacheFor term value) -> CachingAnalysis term value a -> CachingAnalysis term value a localCache f (CachingAnalysis (Evaluator a)) = CachingAnalysis (Evaluator (local f a)) -asksCache :: (CacheFor t v -> a) -> CachingAnalysis t v a +asksCache :: (CacheFor term value -> a) -> CachingAnalysis term value a asksCache f = f <$> askCache -getsCache :: (CacheFor t v -> a) -> CachingAnalysis t v a +getsCache :: (CacheFor term value -> a) -> CachingAnalysis term value a getsCache f = f <$> getCache -getCache :: CachingAnalysis t v (CacheFor t v) +getCache :: CachingAnalysis term value (CacheFor term value) getCache = CachingAnalysis (Evaluator get) -putCache :: CacheFor t v -> CachingAnalysis t v () -putCache v = CachingAnalysis (Evaluator (put v)) +putCache :: CacheFor term value -> CachingAnalysis term value () +putCache cache = CachingAnalysis (Evaluator (put cache)) -modifyCache :: (CacheFor t v -> CacheFor t v) -> CachingAnalysis t v () +modifyCache :: (CacheFor term value -> CacheFor term value) -> CachingAnalysis term value () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. -instance ( Corecursive t - , Ord t - , Ord v - , Ord (CellFor v) - , Evaluatable (Base t) - , Foldable (Cell (LocationFor v)) - , FreeVariables t - , MonadAddressable (LocationFor v) (CachingAnalysis t v) - , MonadValue v (CachingAnalysis t v) - , Recursive t - , Semigroup (CellFor v) +instance ( Corecursive term + , Ord term + , Ord value + , Ord (CellFor value) + , Evaluatable (Base term) + , Foldable (Cell (LocationFor value)) + , FreeVariables term + , MonadAddressable (LocationFor value) (CachingAnalysis term value) + , MonadValue value (CachingAnalysis term value) + , Recursive term + , Semigroup (CellFor value) ) - => MonadAnalysis (CachingAnalysis t v) where + => MonadAnalysis (CachingAnalysis term value) where analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge (\ prevCache -> do - putCache (mempty :: CacheFor t v) + putCache (mempty :: CacheFor term value) putStore (configurationStore c) -- We need to reset fresh generation so that this invocation converges. reset 0 @@ -81,31 +81,31 @@ instance ( Corecursive t -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis t v ()) + _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis term value ()) getCache) mempty maybe empty scatter (cacheLookup c cache) -- | Coinductively-cached evaluation. -evaluateCache :: forall v term - . ( Ord v +evaluateCache :: forall value term + . ( Ord value , Ord term - , Ord (LocationFor v) - , Ord (CellFor v) + , Ord (LocationFor value) + , Ord (CellFor value) , Corecursive term , Evaluatable (Base term) , FreeVariables term - , Foldable (Cell (LocationFor v)) + , Foldable (Cell (LocationFor value)) , Functor (Base term) , Recursive term - , MonadAddressable (LocationFor v) (CachingAnalysis term v) - , MonadValue v (CachingAnalysis term v) - , Semigroup (CellFor v) - , ValueRoots (LocationFor v) v + , MonadAddressable (LocationFor value) (CachingAnalysis term value) + , MonadValue value (CachingAnalysis term value) + , Semigroup (CellFor value) + , ValueRoots (LocationFor value) value ) => term - -> Final (CachingEffects term v) v -evaluateCache = run @(CachingEffects term v) . runEvaluator . runCachingAnalysis . evaluateTerm + -> Final (CachingEffects term value) value +evaluateCache = run @(CachingEffects term value) . runEvaluator . runCachingAnalysis . evaluateTerm -- | Iterate a monadic action starting from some initial seed until the results converge. -- @@ -127,22 +127,22 @@ scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (Locatio scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: forall v term - . ( Ord v +memoizeEval :: forall value term + . ( Ord value , Ord term - , Ord (LocationFor v) - , Ord (CellFor v) + , Ord (LocationFor value) + , Ord (CellFor value) , Corecursive term , Evaluatable (Base term) , FreeVariables term - , Foldable (Cell (LocationFor v)) + , Foldable (Cell (LocationFor value)) , Functor (Base term) , Recursive term - , MonadAddressable (LocationFor v) (CachingAnalysis term v) - , MonadValue v (CachingAnalysis term v) - , Semigroup (CellFor v) + , MonadAddressable (LocationFor value) (CachingAnalysis term value) + , MonadValue value (CachingAnalysis term value) + , Semigroup (CellFor value) ) - => SubtermAlgebra (Base term) term (CachingAnalysis term v v) + => SubtermAlgebra (Base term) term (CachingAnalysis term value value) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) From 66ea2f0c3e061eda4ae59ed4d143f74364e8ee1e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:26:59 -0500 Subject: [PATCH 150/292] :fire: a type annotation. --- 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 58b7e5ab1..d14aa22bd 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -72,7 +72,7 @@ instance ( Corecursive term c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge (\ prevCache -> do - putCache (mempty :: CacheFor term value) + putCache mempty putStore (configurationStore c) -- We need to reset fresh generation so that this invocation converges. reset 0 From 45a0559400766a0085933ba75c41dd32aaf2adeb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:50:28 -0500 Subject: [PATCH 151/292] Derive MonadFresh, Alternative, & MonadNonDet instances for Evaluation. --- src/Analysis/Abstract/Evaluating.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index ce3c3fc26..19a283e62 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -2,6 +2,8 @@ module Analysis.Abstract.Evaluating where import Control.Abstract.Evaluator +import Control.Monad.Effect.Fresh +import Control.Monad.Effect.NonDet import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value @@ -50,6 +52,9 @@ newtype Evaluation term value effects a = Evaluation { runEvaluation :: Evaluato deriving (Applicative, Functor, LiftEffect, Monad) deriving instance Member Fail effects => MonadFail (Evaluation term value effects) +deriving instance Member Fresh effects => MonadFresh (Evaluation term value effects) +deriving instance Member NonDetEff effects => Alternative (Evaluation term value effects) +deriving instance Member NonDetEff effects => MonadNonDet (Evaluation term value effects) deriving instance (Member Fail effects, MonadEvaluator (Evaluator term value effects), Ord (LocationFor value)) => MonadEvaluator (Evaluation term value effects) instance ( Evaluatable (Base term) From bce888995a281f3212f419901fffd25bdd8cd894 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 7 Mar 2018 21:50:44 -0500 Subject: [PATCH 152/292] Abstract CachingAnalysis over the underlying analysis. --- src/Analysis/Abstract/Caching.hs | 145 ++++++++++++++----------------- src/Semantic/Util.hs | 3 +- 2 files changed, 68 insertions(+), 80 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index d14aa22bd..bd80537e7 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,11 +1,9 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Caching - ( evaluateCache ) + -- ( evaluateCache ) where -import Prologue -import Data.Monoid (Alt(..)) -import Control.Abstract.Evaluator +import Control.Abstract.Analysis import Control.Monad.Effect.Fresh import Control.Monad.Effect.NonDet import Data.Abstract.Address @@ -14,60 +12,73 @@ import Data.Abstract.Configuration import Data.Abstract.Evaluatable import Data.Abstract.Store import Data.Abstract.Value +import Data.Monoid (Alt(..)) +import Prologue -- | The effects necessary for caching analyses. -type CachingEffects term value - = Fresh -- For 'MonadFresh'. TODO: Extract typing constraints into a separate analysis. - ': NonDetEff -- For 'Alternative' & 'MonadNonDet'. - ': Reader (CacheFor term value) -- For the in-cache. - ': State (CacheFor term value) -- For the out-cache - ': EvaluatorEffects term value +type CachingEffectsFor m + = '[ Fresh -- For 'MonadFresh'. TODO: Extract typing constraints into a separate analysis. + , NonDetEff -- For 'Alternative' & 'MonadNonDet'. + , Reader (CacheFor m) -- For the in-cache. + , State (CacheFor m) -- For the out-cache + ] + +type CachingEffects term value effects + = Fresh + ': NonDetEff + ': Reader (Cache (LocationFor value) term value) + ': State (Cache (LocationFor value) term value) + ': effects -- | The cache for term and abstract value types. -type CacheFor term value = Cache (LocationFor value) term value +type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) -newtype CachingAnalysis term value a = CachingAnalysis { runCachingAnalysis :: Evaluator term value (CachingEffects term value) a } - deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFresh, MonadNonDet) - -deriving instance Ord (LocationFor value) => MonadEvaluator (CachingAnalysis term value) +newtype CachingAnalysis m a = CachingAnalysis { runCachingAnalysis :: m a } + deriving (Alternative, Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) -- TODO: reabstract these later on -askCache :: CachingAnalysis term value (CacheFor term value) -askCache = CachingAnalysis (Evaluator ask) +type InCacheEffectFor m = Reader (CacheFor m) +type OutCacheEffectFor m = State (CacheFor m) -localCache :: (CacheFor term value -> CacheFor term value) -> CachingAnalysis term value a -> CachingAnalysis term value a -localCache f (CachingAnalysis (Evaluator a)) = CachingAnalysis (Evaluator (local f a)) +askCache :: (LiftEffect m, Member (InCacheEffectFor m) (Effects m)) => CachingAnalysis m (CacheFor m) +askCache = lift ask -asksCache :: (CacheFor term value -> a) -> CachingAnalysis term value a +localCache :: (LiftEffect m, Member (InCacheEffectFor m) (Effects m)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m a -> CachingAnalysis m a +localCache f a = lift (local f (lower a)) + +asksCache :: (Functor m, LiftEffect m, Member (InCacheEffectFor m) (Effects m)) => (CacheFor m -> a) -> CachingAnalysis m a asksCache f = f <$> askCache -getsCache :: (CacheFor term value -> a) -> CachingAnalysis term value a +getsCache :: (Functor m, LiftEffect m, Member (OutCacheEffectFor m) (Effects m)) => (CacheFor m -> a) -> CachingAnalysis m a getsCache f = f <$> getCache -getCache :: CachingAnalysis term value (CacheFor term value) -getCache = CachingAnalysis (Evaluator get) +getCache :: (LiftEffect m, Member (OutCacheEffectFor m) (Effects m)) => CachingAnalysis m (CacheFor m) +getCache = lift get -putCache :: CacheFor term value -> CachingAnalysis term value () -putCache cache = CachingAnalysis (Evaluator (put cache)) +putCache :: (LiftEffect m, Member (OutCacheEffectFor m) (Effects m)) => CacheFor m -> CachingAnalysis m () +putCache = lift . put -modifyCache :: (CacheFor term value -> CacheFor term value) -> CachingAnalysis term value () +modifyCache :: (LiftEffect m, Member (OutCacheEffectFor m) (Effects m), Monad m) => (CacheFor m -> CacheFor m) -> CachingAnalysis m () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. -instance ( Corecursive term - , Ord term - , Ord value - , Ord (CellFor value) - , Evaluatable (Base term) - , Foldable (Cell (LocationFor value)) - , FreeVariables term - , MonadAddressable (LocationFor value) (CachingAnalysis term value) - , MonadValue value (CachingAnalysis term value) - , Recursive term - , Semigroup (CellFor value) +instance ( Corecursive (TermFor m) + , Ord (TermFor m) + , Ord (ValueFor m) + , Ord (CellFor (ValueFor m)) + , Ord (LocationFor (ValueFor m)) + , LiftEffect m + , MonadFresh m + , MonadNonDet m + , Members (CachingEffectsFor m) (Effects m) + , Evaluatable (Base (TermFor m)) + , Foldable (Cell (LocationFor (ValueFor m))) + , FreeVariables (TermFor m) + , MonadAnalysis m + , Recursive (TermFor m) ) - => MonadAnalysis (CachingAnalysis term value) where + => MonadAnalysis (CachingAnalysis m) where analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -81,32 +92,10 @@ instance ( Corecursive term -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis term value ()) + _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis m ()) getCache) mempty maybe empty scatter (cacheLookup c cache) - --- | Coinductively-cached evaluation. -evaluateCache :: forall value term - . ( Ord value - , Ord term - , Ord (LocationFor value) - , Ord (CellFor value) - , Corecursive term - , Evaluatable (Base term) - , FreeVariables term - , Foldable (Cell (LocationFor value)) - , Functor (Base term) - , Recursive term - , MonadAddressable (LocationFor value) (CachingAnalysis term value) - , MonadValue value (CachingAnalysis term value) - , Semigroup (CellFor value) - , ValueRoots (LocationFor value) value - ) - => term - -> Final (CachingEffects term value) value -evaluateCache = run @(CachingEffects term value) . runEvaluator . runCachingAnalysis . evaluateTerm - -- | Iterate a monadic action starting from some initial seed until the results converge. -- -- This applies the Kleene fixed-point theorem to finitize a monotone action. cf https://en.wikipedia.org/wiki/Kleene_fixed-point_theorem @@ -127,22 +116,22 @@ scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (Locatio scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: forall value term - . ( Ord value - , Ord term - , Ord (LocationFor value) - , Ord (CellFor value) - , Corecursive term - , Evaluatable (Base term) - , FreeVariables term - , Foldable (Cell (LocationFor value)) - , Functor (Base term) - , Recursive term - , MonadAddressable (LocationFor value) (CachingAnalysis term value) - , MonadValue value (CachingAnalysis term value) - , Semigroup (CellFor value) - ) - => SubtermAlgebra (Base term) term (CachingAnalysis term value value) +memoizeEval :: ( Ord (ValueFor m) + , Ord (TermFor m) + , Ord (LocationFor (ValueFor m)) + , Ord (CellFor (ValueFor m)) + , Alternative m + , Corecursive (TermFor m) + , FreeVariables (TermFor m) + , Foldable (Cell (LocationFor (ValueFor m))) + , Functor (Base (TermFor m)) + , LiftEffect m + , Members (CachingEffectsFor m) (Effects m) + , Recursive (TermFor m) + , MonadAnalysis m + -- , Semigroup (CellFor (ValueFor m)) + ) + => SubtermAlgebra (Base (TermFor m)) (TermFor m) (CachingAnalysis m (ValueFor m)) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) @@ -151,7 +140,7 @@ memoizeEval e = do Nothing -> do pairs <- asksCache (fromMaybe mempty . cacheLookup c) modifyCache (cacheSet c pairs) - v <- eval e + v <- delegateAnalyzeTerm e store' <- getStore modifyCache (cacheInsert c (v, store')) pure v diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index a0a3d7045..a6ee4baf2 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -45,8 +45,7 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue (zip bs ts) (b, t) -- Python -typecheckPythonFile path = evaluateCache @Type <$> - (file path >>= runTask . parse pythonParser) +typecheckPythonFile path = run . lower @(CachingAnalysis (Evaluation Python.Term Type (CachingEffects Python.Term Type (EvaluatorEffects Python.Term Type)))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluation Python.Term PythonValue (TracingEffects [] Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) From 02347f701467bd23123a7dbae29e73d23859ceaf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 10:00:31 -0500 Subject: [PATCH 153/292] Rename Evaluation to Evaluating. --- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 30 ++++++++++++++--------------- src/Semantic/Util.hs | 4 ++-- 3 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index edc903636..c4a83afbe 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -16,7 +16,7 @@ type DeadCodeEffects term value = State (Dead term) ': EvaluatorEffects term val -- | Run a dead code analysis of the given program. evaluateDead :: forall term value effects m - . ( m ~ Evaluation term value effects + . ( m ~ Evaluating term value effects , effects ~ DeadCodeEffects term value , Corecursive term , Evaluatable (Base term) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 19a283e62..baed94d6c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -17,22 +17,22 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluation term value (EvaluatorEffects term value)) - , MonadValue value (Evaluation term value (EvaluatorEffects term value)) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatorEffects term value)) + , MonadValue value (Evaluating term value (EvaluatorEffects term value)) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) ) => term -> Final (EvaluatorEffects term value) value -evaluate = run @(EvaluatorEffects term value) . runEvaluator . runEvaluation . evaluateTerm +evaluate = run @(EvaluatorEffects term value) . runEvaluator . runEvaluating . evaluateTerm -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluation term value (EvaluatorEffects term value)) - , MonadValue value (Evaluation term value (EvaluatorEffects term value)) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatorEffects term value)) + , MonadValue value (Evaluating term value (EvaluatorEffects term value)) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) @@ -40,7 +40,7 @@ evaluates :: forall value term => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatorEffects term value) value -evaluates pairs (_, t) = run @(EvaluatorEffects term value) (runEvaluator (runEvaluation (withModules pairs (evaluateTerm t)))) +evaluates pairs (_, t) = run @(EvaluatorEffects term value) (runEvaluator (runEvaluating (withModules pairs (evaluateTerm t)))) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a @@ -48,22 +48,22 @@ withModules pairs = localModuleTable (const moduleTable) where moduleTable = Linker (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis performing concrete evaluation of @term@s to @value@s. -newtype Evaluation term value effects a = Evaluation { runEvaluation :: Evaluator term value effects a } +newtype Evaluating term value effects a = Evaluating { runEvaluating :: Evaluator term value effects a } deriving (Applicative, Functor, LiftEffect, Monad) -deriving instance Member Fail effects => MonadFail (Evaluation term value effects) -deriving instance Member Fresh effects => MonadFresh (Evaluation term value effects) -deriving instance Member NonDetEff effects => Alternative (Evaluation term value effects) -deriving instance Member NonDetEff effects => MonadNonDet (Evaluation term value effects) -deriving instance (Member Fail effects, MonadEvaluator (Evaluator term value effects), Ord (LocationFor value)) => MonadEvaluator (Evaluation 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 NonDetEff effects => Alternative (Evaluating term value effects) +deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) +deriving instance (Member Fail effects, MonadEvaluator (Evaluator term value effects), Ord (LocationFor value)) => MonadEvaluator (Evaluating term value effects) instance ( Evaluatable (Base term) , FreeVariables term , Members (EvaluatorEffects term value) effects - , MonadAddressable (LocationFor value) (Evaluation term value effects) - , MonadValue value (Evaluation term value effects) + , MonadAddressable (LocationFor value) (Evaluating term value effects) + , MonadValue value (Evaluating term value effects) , Recursive term , Semigroup (CellFor value) ) - => MonadAnalysis (Evaluation term value effects) where + => MonadAnalysis (Evaluating term value effects) where analyzeTerm = eval diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index a6ee4baf2..ce89c082a 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -45,9 +45,9 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue (zip bs ts) (b, t) -- Python -typecheckPythonFile path = run . lower @(CachingAnalysis (Evaluation Python.Term Type (CachingEffects Python.Term Type (EvaluatorEffects Python.Term Type)))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) +typecheckPythonFile path = run . lower @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatorEffects Python.Term Type)))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) -tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluation Python.Term PythonValue (TracingEffects [] Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) +tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluating Python.Term PythonValue (TracingEffects [] Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) evaluatePythonFile path = evaluate @PythonValue <$> (file path >>= runTask . parse pythonParser) From 114c8a58ac4b113487da7d9b5536db5b4e0969be Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 10:01:10 -0500 Subject: [PATCH 154/292] Rename LiftEffect to Effectful. --- src/Analysis/Abstract/Caching.hs | 20 ++++++++++---------- src/Analysis/Abstract/Dead.hs | 8 ++++---- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 6 +++--- src/Control/Abstract/Evaluator.hs | 2 +- src/Control/Effect.hs | 4 ++-- 6 files changed, 21 insertions(+), 21 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index bd80537e7..443668c53 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -34,32 +34,32 @@ type CachingEffects term value effects type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) newtype CachingAnalysis m a = CachingAnalysis { runCachingAnalysis :: m a } - deriving (Alternative, Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) -- TODO: reabstract these later on type InCacheEffectFor m = Reader (CacheFor m) type OutCacheEffectFor m = State (CacheFor m) -askCache :: (LiftEffect m, Member (InCacheEffectFor m) (Effects m)) => CachingAnalysis m (CacheFor m) +askCache :: (Effectful m, Member (InCacheEffectFor m) (Effects m)) => CachingAnalysis m (CacheFor m) askCache = lift ask -localCache :: (LiftEffect m, Member (InCacheEffectFor m) (Effects m)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m a -> CachingAnalysis m a +localCache :: (Effectful m, Member (InCacheEffectFor m) (Effects m)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m a -> CachingAnalysis m a localCache f a = lift (local f (lower a)) -asksCache :: (Functor m, LiftEffect m, Member (InCacheEffectFor m) (Effects m)) => (CacheFor m -> a) -> CachingAnalysis m a +asksCache :: (Functor m, Effectful m, Member (InCacheEffectFor m) (Effects m)) => (CacheFor m -> a) -> CachingAnalysis m a asksCache f = f <$> askCache -getsCache :: (Functor m, LiftEffect m, Member (OutCacheEffectFor m) (Effects m)) => (CacheFor m -> a) -> CachingAnalysis m a +getsCache :: (Functor m, Effectful m, Member (OutCacheEffectFor m) (Effects m)) => (CacheFor m -> a) -> CachingAnalysis m a getsCache f = f <$> getCache -getCache :: (LiftEffect m, Member (OutCacheEffectFor m) (Effects m)) => CachingAnalysis m (CacheFor m) +getCache :: (Effectful m, Member (OutCacheEffectFor m) (Effects m)) => CachingAnalysis m (CacheFor m) getCache = lift get -putCache :: (LiftEffect m, Member (OutCacheEffectFor m) (Effects m)) => CacheFor m -> CachingAnalysis m () +putCache :: (Effectful m, Member (OutCacheEffectFor m) (Effects m)) => CacheFor m -> CachingAnalysis m () putCache = lift . put -modifyCache :: (LiftEffect m, Member (OutCacheEffectFor m) (Effects m), Monad m) => (CacheFor m -> CacheFor m) -> CachingAnalysis m () +modifyCache :: (Effectful m, Member (OutCacheEffectFor m) (Effects m), Monad m) => (CacheFor m -> CacheFor m) -> CachingAnalysis m () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. @@ -68,7 +68,7 @@ instance ( Corecursive (TermFor m) , Ord (ValueFor m) , Ord (CellFor (ValueFor m)) , Ord (LocationFor (ValueFor m)) - , LiftEffect m + , Effectful m , MonadFresh m , MonadNonDet m , Members (CachingEffectsFor m) (Effects m) @@ -125,7 +125,7 @@ memoizeEval :: ( Ord (ValueFor m) , FreeVariables (TermFor m) , Foldable (Cell (LocationFor (ValueFor m))) , Functor (Base (TermFor m)) - , LiftEffect m + , Effectful m , Members (CachingEffectsFor m) (Effects m) , Recursive (TermFor m) , MonadAnalysis m diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index c4a83afbe..b64a81ed8 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -38,7 +38,7 @@ evaluateDead term = run @(DeadCodeEffects term value) . lower @(DeadCodeAnalysis -- | An analysis tracking dead (unreachable) code. newtype DeadCodeAnalysis m a = DeadCodeAnalysis { runDeadCodeAnalysis :: m a } - deriving (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) -- | A set of “dead” (unreachable) terms. @@ -48,11 +48,11 @@ newtype Dead term = Dead { unDead :: Set term } deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: (LiftEffect m, Member (State (Dead (TermFor m))) (Effects m)) => Dead (TermFor m) -> DeadCodeAnalysis m () +killAll :: (Effectful m, Member (State (Dead (TermFor m))) (Effects m)) => Dead (TermFor m) -> DeadCodeAnalysis m () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (LiftEffect m, Member (State (Dead (TermFor m))) (Effects m)) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m () +revive :: (Effectful m, Member (State (Dead (TermFor m))) (Effects m)) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -61,7 +61,7 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term instance ( Corecursive (TermFor m) - , LiftEffect m + , Effectful m , Member (State (Dead (TermFor m))) (Effects m) , MonadAnalysis m , MonadEvaluator m diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index baed94d6c..8564bb5cf 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -49,7 +49,7 @@ withModules pairs = localModuleTable (const moduleTable) -- | An analysis performing concrete evaluation of @term@s to @value@s. newtype Evaluating term value effects a = Evaluating { runEvaluating :: Evaluator term value effects a } - deriving (Applicative, Functor, LiftEffect, Monad) + 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) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index cead4cbe4..def360edb 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -21,10 +21,10 @@ type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffec -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m a = TracingAnalysis { runTracingAnalysis :: m a } - deriving (Applicative, Functor, LiftEffect, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) instance ( Corecursive (TermFor m) - , LiftEffect m + , Effectful m , Member (TracerFor trace m) (Effects m) , MonadAnalysis m , MonadEvaluator m @@ -38,7 +38,7 @@ instance ( Corecursive (TermFor m) trace (Reducer.unit config) delegateAnalyzeTerm term -trace :: ( LiftEffect m +trace :: ( Effectful m , Member (TracerFor trace m) (Effects m) ) => TraceFor trace m diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 70495c903..87f684268 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -91,7 +91,7 @@ putStore = modifyStore . const -- | An evaluator of @term@s to @value@s, producing incremental results of type @a@ using a list of @effects@. newtype Evaluator term value effects a = Evaluator { runEvaluator :: Eff effects a } - deriving (Applicative, Functor, LiftEffect, Monad) + deriving (Applicative, Functor, Effectful, Monad) deriving instance Member Fail effects => MonadFail (Evaluator term value effects) deriving instance Member NonDetEff effects => Alternative (Evaluator term value effects) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 27bc4870e..3944f3275 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -66,12 +66,12 @@ instance Ord a => RunEffect NonDetEff a where MPlus -> mappend <$> k True <*> k False) -class LiftEffect f where +class Effectful f where type Effects f :: [* -> *] lift :: Eff (Effects f) a -> f a lower :: f a -> Eff (Effects f) a -instance LiftEffect (Eff effects) where +instance Effectful (Eff effects) where type Effects (Eff effects) = effects lift = id lower = id From 902f2698476ab2ad2518d9dcace3f2c40ecf5416 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 10:48:39 -0500 Subject: [PATCH 155/292] evaluateDead returns an analysis. --- src/Analysis/Abstract/Dead.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index b64a81ed8..6d5e0f2da 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -15,23 +15,26 @@ type DeadCodeEffects term value = State (Dead term) ': EvaluatorEffects term val -- | Run a dead code analysis of the given program. -evaluateDead :: forall term value effects m - . ( m ~ Evaluating term value effects - , effects ~ DeadCodeEffects term value +evaluateDead :: forall m term value effects + . ( term ~ TermFor m + , value ~ ValueFor m + , effects ~ Effects m , Corecursive term + , Member (State (Dead term)) effects + , Effectful m , Evaluatable (Base term) , Foldable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) m - , MonadValue value m + , MonadAnalysis m , Ord (LocationFor value) , Ord term , Recursive term + , RunEffects effects value , Semigroup (CellFor value) ) => term - -> Final (DeadCodeEffects term value) value -evaluateDead term = run @(DeadCodeEffects term value) . lower @(DeadCodeAnalysis m) $ do + -> DeadCodeAnalysis m value +evaluateDead term = do killAll (subterms term) evaluateTerm term From 9fa05c9b61437726a3e8d84463ff8c9e39247be3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 10:50:55 -0500 Subject: [PATCH 156/292] Define a convenience for evaluating Python with dead code and tracing analyses. --- src/Semantic/Util.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ce89c082a..e328d434f 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -4,6 +4,7 @@ module Semantic.Util where import Prologue import Analysis.Abstract.Caching +import Analysis.Abstract.Dead import Analysis.Abstract.Evaluating import Analysis.Abstract.Tracing import Analysis.Declaration @@ -49,6 +50,10 @@ typecheckPythonFile path = run . lower @(CachingAnalysis (Evaluating Python.Term tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluating Python.Term PythonValue (TracingEffects [] Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) +type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (State (Dead (Python.Term)) ': TracingEffects [] Python.Term PythonValue)) + +evaluateDeadTracePythonFile path = run . lower @(DeadCodeAnalysis PythonTracer) . evaluateDead <$> (file path >>= runTask . parse pythonParser) + evaluatePythonFile path = evaluate @PythonValue <$> (file path >>= runTask . parse pythonParser) From 34387b02e0ac80056f3bb88355cfab596c3273ff Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 10:52:55 -0500 Subject: [PATCH 157/292] Add an evaluateModule method to MonadAnalysis. --- src/Control/Abstract/Analysis.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index b5c5cb9ee..ecf7fefc5 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -29,6 +29,10 @@ class MonadEvaluator m => MonadAnalysis m where default evaluateTerm :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm + evaluateModule :: TermFor m -> m (ValueFor m) + default evaluateModule :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) + evaluateModule = evaluateTerm + delegateAnalyzeTerm :: ( TermFor (t m) ~ TermFor m , ValueFor (t m) ~ ValueFor m , Functor (Base (TermFor (t m))) From 01f7fd455d01bfce69921470b2b3f2e4f9623ef9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 10:53:02 -0500 Subject: [PATCH 158/292] Correct the docs for evaluateTerm. --- 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 ecf7fefc5..fc88ebbff 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -24,7 +24,7 @@ class MonadEvaluator m => MonadAnalysis m where -- | Evaluate a term to a value using the semantics of the current analysis. -- - -- This should always be called instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. + -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. evaluateTerm :: TermFor m -> m (ValueFor m) default evaluateTerm :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm From ca6b18e74337930afcc9a283265a83d05111941f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 10:53:19 -0500 Subject: [PATCH 159/292] :fire: redundant imports. --- src/Analysis/Abstract/Dead.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 6d5e0f2da..867fdceb7 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,8 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Dead where -import Analysis.Abstract.Evaluating -import Control.Abstract.Addressable import Control.Abstract.Evaluator import Data.Abstract.Evaluatable import Data.Abstract.Value From f1b4770ff17ff35f86ad8b263903caba6cfb8d1e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:04:31 -0500 Subject: [PATCH 160/292] Define a helper to lift an evaluator into an underlying type. --- src/Control/Abstract/Analysis.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index fc88ebbff..c121cf4ee 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -2,6 +2,7 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , delegateAnalyzeTerm +, liftEvaluate , module X , Subterm(..) , SubtermAlgebra @@ -45,3 +46,13 @@ delegateAnalyzeTerm term = pack1 (analyzeTerm (second unpack1 <$> term)) where pack1 = coerce unpack1 :: Coercible (t m (ValueFor m)) (m (ValueFor m)) => t m (ValueFor m) -> m (ValueFor m) unpack1 = coerce + +liftEvaluate :: ( term ~ TermFor m + , term ~ TermFor (t m) + , value ~ ValueFor m + , value ~ ValueFor (t m) + , Coercible (m value) (t m value) + ) + => (term -> m value) + -> (term -> t m value) +liftEvaluate evaluate = coerce . evaluate From 72ddeeedf6055ea2a6f414441661ebe2f230f52f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:06:10 -0500 Subject: [PATCH 161/292] Rename delegateAnalyzeTerm to liftAnalyze. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Analysis.hs | 20 ++++++++++---------- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 443668c53..25c975284 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -140,7 +140,7 @@ memoizeEval e = do Nothing -> do pairs <- asksCache (fromMaybe mempty . cacheLookup c) modifyCache (cacheSet c pairs) - v <- delegateAnalyzeTerm e + v <- liftAnalyze e store' <- getStore modifyCache (cacheInsert c (v, store')) pure v diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 867fdceb7..dfed999d6 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -72,4 +72,4 @@ instance ( Corecursive (TermFor m) => MonadAnalysis (DeadCodeAnalysis m) where analyzeTerm term = do revive (embedSubterm term) - delegateAnalyzeTerm term + liftAnalyze term diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index def360edb..eeb07f2dc 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -36,7 +36,7 @@ instance ( Corecursive (TermFor m) analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) - delegateAnalyzeTerm term + liftAnalyze term trace :: ( Effectful m , Member (TracerFor trace m) (Effects m) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index c121cf4ee..0a4455296 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DefaultSignatures, KindSignatures, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) -, delegateAnalyzeTerm +, liftAnalyze , liftEvaluate , module X , Subterm(..) @@ -34,15 +34,15 @@ class MonadEvaluator m => MonadAnalysis m where default evaluateModule :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateModule = evaluateTerm -delegateAnalyzeTerm :: ( TermFor (t m) ~ TermFor m - , ValueFor (t m) ~ ValueFor m - , Functor (Base (TermFor (t m))) - , MonadAnalysis m - , Coercible (t m (ValueFor m)) (m (ValueFor m)) - , Coercible (m (ValueFor m)) (t m (ValueFor m)) - ) - => SubtermAlgebra (Base (TermFor (t m))) (TermFor (t m)) (t m (ValueFor m)) -delegateAnalyzeTerm term = pack1 (analyzeTerm (second unpack1 <$> term)) +liftAnalyze :: ( TermFor (t m) ~ TermFor m + , ValueFor (t m) ~ ValueFor m + , Functor (Base (TermFor (t m))) + , MonadAnalysis m + , Coercible (t m (ValueFor m)) (m (ValueFor m)) + , Coercible (m (ValueFor m)) (t m (ValueFor m)) + ) + => SubtermAlgebra (Base (TermFor (t m))) (TermFor (t m)) (t m (ValueFor m)) +liftAnalyze term = pack1 (analyzeTerm (second unpack1 <$> term)) where pack1 = coerce unpack1 :: Coercible (t m (ValueFor m)) (m (ValueFor m)) => t m (ValueFor m) -> m (ValueFor m) unpack1 = coerce From 7982b8ddf4fd70aeedbb05ade1dfa8ed41da422f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:08:05 -0500 Subject: [PATCH 162/292] Use equality constraints to name the term/value type parameters. --- src/Control/Abstract/Analysis.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 0a4455296..9f70692a1 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -34,17 +34,19 @@ class MonadEvaluator m => MonadAnalysis m where default evaluateModule :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateModule = evaluateTerm -liftAnalyze :: ( TermFor (t m) ~ TermFor m - , ValueFor (t m) ~ ValueFor m - , Functor (Base (TermFor (t m))) +liftAnalyze :: ( term ~ TermFor m + , term ~ TermFor (t m) + , value ~ ValueFor m + , value ~ ValueFor (t m) + , Functor (Base term) , MonadAnalysis m - , Coercible (t m (ValueFor m)) (m (ValueFor m)) - , Coercible (m (ValueFor m)) (t m (ValueFor m)) + , Coercible (t m value) (m value) + , Coercible (m value) (t m value) ) - => SubtermAlgebra (Base (TermFor (t m))) (TermFor (t m)) (t m (ValueFor m)) + => SubtermAlgebra (Base term) term (t m value) liftAnalyze term = pack1 (analyzeTerm (second unpack1 <$> term)) where pack1 = coerce - unpack1 :: Coercible (t m (ValueFor m)) (m (ValueFor m)) => t m (ValueFor m) -> m (ValueFor m) + unpack1 :: Coercible (t m value) (m value) => t m value -> m value unpack1 = coerce liftEvaluate :: ( term ~ TermFor m From ff6f99fbf5510a2620a91527a460a81c81e12823 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:08:32 -0500 Subject: [PATCH 163/292] Sort the context. --- src/Control/Abstract/Analysis.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 9f70692a1..f36eaa09e 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -38,10 +38,10 @@ liftAnalyze :: ( term ~ TermFor m , term ~ TermFor (t m) , value ~ ValueFor m , value ~ ValueFor (t m) + , Coercible (m value) (t m value) + , Coercible (t m value) (m value) , Functor (Base term) , MonadAnalysis m - , Coercible (t m value) (m value) - , Coercible (m value) (t m value) ) => SubtermAlgebra (Base term) term (t m value) liftAnalyze term = pack1 (analyzeTerm (second unpack1 <$> term)) From 4f085d6707e6cdcf2b8ba11ffee777f8634ecd65 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:10:08 -0500 Subject: [PATCH 164/292] liftAnalyze takes the algebra to lift. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Analysis.hs | 6 +++--- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 25c975284..6b0c9e7d3 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -140,7 +140,7 @@ memoizeEval e = do Nothing -> do pairs <- asksCache (fromMaybe mempty . cacheLookup c) modifyCache (cacheSet c pairs) - v <- liftAnalyze e + v <- liftAnalyze analyzeTerm e store' <- getStore modifyCache (cacheInsert c (v, store')) pure v diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index dfed999d6..1b4db2f25 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -72,4 +72,4 @@ instance ( Corecursive (TermFor m) => MonadAnalysis (DeadCodeAnalysis m) where analyzeTerm term = do revive (embedSubterm term) - liftAnalyze term + liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index eeb07f2dc..a6211270b 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -36,7 +36,7 @@ instance ( Corecursive (TermFor m) analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) - liftAnalyze term + liftAnalyze analyzeTerm term trace :: ( Effectful m , Member (TracerFor trace m) (Effects m) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index f36eaa09e..b8ec7c0f6 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -41,10 +41,10 @@ liftAnalyze :: ( term ~ TermFor m , Coercible (m value) (t m value) , Coercible (t m value) (m value) , Functor (Base term) - , MonadAnalysis m ) - => SubtermAlgebra (Base term) term (t m value) -liftAnalyze term = pack1 (analyzeTerm (second unpack1 <$> term)) + => SubtermAlgebra (Base term) term (m value) + -> SubtermAlgebra (Base term) term (t m value) +liftAnalyze analyze term = pack1 (analyze (second unpack1 <$> term)) where pack1 = coerce unpack1 :: Coercible (t m value) (m value) => t m value -> m value unpack1 = coerce From e275b4ba4c1ecf27afe23e2f58367565e657ef7a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:10:59 -0500 Subject: [PATCH 165/292] Define evaluateModule for DeadCodeAnalysis. --- src/Analysis/Abstract/Dead.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 1b4db2f25..5fc093e9f 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -63,6 +63,7 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term instance ( Corecursive (TermFor m) , Effectful m + , Foldable (Base (TermFor m)) , Member (State (Dead (TermFor m))) (Effects m) , MonadAnalysis m , MonadEvaluator m @@ -73,3 +74,7 @@ instance ( Corecursive (TermFor m) analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term + + evaluateModule term = do + killAll (subterms term) + liftEvaluate evaluateModule term From 85fc0ba56457e997f304cfe786e8146d6446a682 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:14:00 -0500 Subject: [PATCH 166/292] Add Recursive (TermFor m) as a superclass of MonadAnalysis. --- src/Control/Abstract/Analysis.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index b8ec7c0f6..c88df4cfe 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DefaultSignatures, KindSignatures, TypeFamilies #-} +{-# LANGUAGE KindSignatures, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , liftAnalyze @@ -19,7 +19,7 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class MonadEvaluator m => MonadAnalysis m where +class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) @@ -27,11 +27,9 @@ class MonadEvaluator m => MonadAnalysis m where -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. evaluateTerm :: TermFor m -> m (ValueFor m) - default evaluateTerm :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm evaluateModule :: TermFor m -> m (ValueFor m) - default evaluateModule :: Recursive (TermFor m) => TermFor m -> m (ValueFor m) evaluateModule = evaluateTerm liftAnalyze :: ( term ~ TermFor m From d7ec06267b6109306138fe99ccfebd0232afb061 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:14:12 -0500 Subject: [PATCH 167/292] =?UTF-8?q?Don=E2=80=99t=20allow=20specialization?= =?UTF-8?q?=20of=20evaluateTerm.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Analysis.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index c88df4cfe..726f5ed77 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,6 +1,7 @@ {-# LANGUAGE KindSignatures, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) +, evaluateTerm , liftAnalyze , liftEvaluate , module X @@ -23,15 +24,15 @@ class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) - -- | Evaluate a term to a value using the semantics of the current analysis. - -- - -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. - evaluateTerm :: TermFor m -> m (ValueFor m) - evaluateTerm = foldSubterms analyzeTerm - evaluateModule :: TermFor m -> m (ValueFor m) evaluateModule = evaluateTerm +-- | Evaluate a term to a value using the semantics of the current analysis. +-- +-- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. +evaluateTerm :: MonadAnalysis m => TermFor m -> m (ValueFor m) +evaluateTerm = foldSubterms analyzeTerm + liftAnalyze :: ( term ~ TermFor m , term ~ TermFor (t m) , value ~ ValueFor m From f38cb76dc43d6af66ce2b7f822113b71ce328a82 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:14:44 -0500 Subject: [PATCH 168/292] :fire: a redundant language extension. --- 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 726f5ed77..b4d6da220 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE KindSignatures, TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm From 47b585b58fe71b66f674dcf4395f27baf9544191 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:15:02 -0500 Subject: [PATCH 169/292] load calls evaluateModule instead of evaluateTerm. --- 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 e4b7e4965..99ce870cb 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -98,7 +98,7 @@ load term = askModuleTable >>= maybe notFound evalAndCache . linkerLookup name where name = moduleName term notFound = fail ("cannot find " <> show name) evalAndCache e = do - v <- evaluateTerm e + v <- evaluateModule e modifyModuleTable (linkerInsert name v) pure v From fa93a23368df198556b5ef39164c9c056f13b6c4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:20:09 -0500 Subject: [PATCH 170/292] evaluate/evaluates use evaluateModule. --- src/Analysis/Abstract/Evaluating.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 8564bb5cf..2a06be36c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -25,7 +25,7 @@ evaluate :: forall value term ) => term -> Final (EvaluatorEffects term value) value -evaluate = run @(EvaluatorEffects term value) . runEvaluator . runEvaluating . evaluateTerm +evaluate = run @(EvaluatorEffects term value) . runEvaluator . runEvaluating . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term @@ -40,7 +40,7 @@ evaluates :: forall value term => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatorEffects term value) value -evaluates pairs (_, t) = run @(EvaluatorEffects term value) (runEvaluator (runEvaluating (withModules pairs (evaluateTerm t)))) +evaluates pairs (_, t) = run @(EvaluatorEffects term value) (runEvaluator (runEvaluating (withModules pairs (evaluateModule t)))) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a From 3f358a4cceeebab6027323cf47ec46c1ce5ce479 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:25:18 -0500 Subject: [PATCH 171/292] Rename EvaluatorEffects to EvaluatingEffects. --- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 18 +++++++++--------- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Evaluator.hs | 4 ++-- src/Semantic/Util.hs | 2 +- 5 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 5fc093e9f..f7acb064b 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -9,7 +9,7 @@ import Data.Set (delete) import Prologue -- | The effects necessary for dead code analysis. -type DeadCodeEffects term value = State (Dead term) ': EvaluatorEffects term value +type DeadCodeEffects term value = State (Dead term) ': EvaluatingEffects term value -- | Run a dead code analysis of the given program. diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 2a06be36c..24c698d68 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -17,30 +17,30 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatorEffects term value)) - , MonadValue value (Evaluating term value (EvaluatorEffects term value)) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value)) + , MonadValue value (Evaluating term value (EvaluatingEffects term value)) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) ) => term - -> Final (EvaluatorEffects term value) value -evaluate = run @(EvaluatorEffects term value) . runEvaluator . runEvaluating . evaluateModule + -> Final (EvaluatingEffects term value) value +evaluate = run @(EvaluatingEffects term value) . runEvaluator . runEvaluating . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatorEffects term value)) - , MonadValue value (Evaluating term value (EvaluatorEffects term value)) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value)) + , MonadValue value (Evaluating term value (EvaluatingEffects term value)) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint - -> Final (EvaluatorEffects term value) value -evaluates pairs (_, t) = run @(EvaluatorEffects term value) (runEvaluator (runEvaluating (withModules pairs (evaluateModule t)))) + -> Final (EvaluatingEffects term value) value +evaluates pairs (_, t) = run @(EvaluatingEffects term value) (runEvaluator (runEvaluating (withModules pairs (evaluateModule t)))) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a @@ -59,7 +59,7 @@ deriving instance (Member Fail effects, MonadEvaluator (Evaluator term value eff instance ( Evaluatable (Base term) , FreeVariables term - , Members (EvaluatorEffects term value) effects + , Members (EvaluatingEffects term value) effects , MonadAddressable (LocationFor value) (Evaluating term value effects) , MonadValue value (Evaluating term value effects) , Recursive term diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index a6211270b..7252d3ea7 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ type Tracer trace term value = Writer (Trace trace term value) type TracerFor trace m = Writer (TraceFor trace m) -- | The effects necessary for tracing analyses. -type TracingEffects trace term value = Tracer trace term value ': EvaluatorEffects term value +type TracingEffects trace term value = Tracer trace term value ': EvaluatingEffects term value -- | Trace analysis. -- diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 87f684268..9c1792fb0 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -58,7 +58,7 @@ class MonadFail m => MonadEvaluator m where getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore -type EvaluatorEffects term value +type EvaluatingEffects term value = '[ Fail -- Failure with an error message , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) , State (EnvironmentFor value) -- Global (imperative) environment @@ -67,7 +67,7 @@ type EvaluatorEffects term value , State (Linker value) -- Cache of evaluated modules ] -instance (Ord (LocationFor value), Members (EvaluatorEffects term value) effects) => MonadEvaluator (Evaluator term value effects) where +instance (Ord (LocationFor value), Members (EvaluatingEffects term value) effects) => MonadEvaluator (Evaluator term value effects) where type TermFor (Evaluator term value effects) = term type ValueFor (Evaluator term value effects) = value diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index e328d434f..55f8f1cd7 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,7 +46,7 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue (zip bs ts) (b, t) -- Python -typecheckPythonFile path = run . lower @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatorEffects Python.Term Type)))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) +typecheckPythonFile path = run . lower @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluating Python.Term PythonValue (TracingEffects [] Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) From 563b43b52750eba7f621abb7583dedf7da812d92 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:31:59 -0500 Subject: [PATCH 172/292] Move Evaluator into the Evaluating module. --- src/Analysis/Abstract/Dead.hs | 5 ++- src/Analysis/Abstract/Evaluating.hs | 43 +++++++++++++++++++++++- src/Analysis/Abstract/Tracing.hs | 3 -- src/Control/Abstract/Evaluator.hs | 51 ++--------------------------- src/Semantic/Util.hs | 4 +-- 5 files changed, 49 insertions(+), 57 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index f7acb064b..a3219bb0a 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -9,8 +9,7 @@ import Data.Set (delete) import Prologue -- | The effects necessary for dead code analysis. -type DeadCodeEffects term value = State (Dead term) ': EvaluatingEffects term value - +type DeadCode term = State (Dead term) -- | Run a dead code analysis of the given program. evaluateDead :: forall m term value effects @@ -18,7 +17,7 @@ evaluateDead :: forall m term value effects , value ~ ValueFor m , effects ~ Effects m , Corecursive term - , Member (State (Dead term)) effects + , Member (DeadCode term) effects , Effectful m , Evaluatable (Base term) , Foldable (Base term) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 24c698d68..450c4e9b0 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -2,14 +2,18 @@ module Analysis.Abstract.Evaluating where import Control.Abstract.Evaluator +import Control.Monad.Effect hiding (run) +import Control.Monad.Effect.Fail import Control.Monad.Effect.Fresh import Control.Monad.Effect.NonDet +import Control.Monad.Effect.Reader +import Control.Monad.Effect.State import Data.Abstract.Evaluatable import Data.Abstract.Linker import Data.Abstract.Value import Data.Blob -import Prelude hiding (fail) import qualified Data.Map as Map +import Prelude hiding (fail) import Prologue import System.FilePath.Posix @@ -67,3 +71,40 @@ instance ( Evaluatable (Base term) ) => MonadAnalysis (Evaluating term value effects) where analyzeTerm = eval + +type EvaluatingEffects term value + = '[ Fail -- Failure with an error message + , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) + , State (EnvironmentFor value) -- Global (imperative) environment + , State (StoreFor value) -- The heap + , Reader (Linker term) -- Cache of unevaluated modules + , State (Linker value) -- Cache of evaluated modules + ] + +instance (Ord (LocationFor value), Members (EvaluatingEffects term value) effects) => MonadEvaluator (Evaluator term value effects) where + type TermFor (Evaluator term value effects) = term + type ValueFor (Evaluator term value effects) = value + + getGlobalEnv = Evaluator get + modifyGlobalEnv f = Evaluator (modify f) + + askLocalEnv = Evaluator ask + localEnv f a = Evaluator (local f (runEvaluator a)) + + getStore = Evaluator get + modifyStore f = Evaluator (modify f) + + getModuleTable = Evaluator get + modifyModuleTable f = Evaluator (modify f) + + askModuleTable = Evaluator ask + localModuleTable f a = Evaluator (local f (runEvaluator a)) + +-- | An evaluator of @term@s to @value@s, producing incremental results of type @a@ using a list of @effects@. +newtype Evaluator term value effects a = Evaluator { runEvaluator :: Eff effects a } + deriving (Applicative, Functor, Effectful, Monad) + +deriving instance Member Fail effects => MonadFail (Evaluator term value effects) +deriving instance Member NonDetEff effects => Alternative (Evaluator term value effects) +deriving instance Member NonDetEff effects => MonadNonDet (Evaluator term value effects) +deriving instance Member Fresh effects => MonadFresh (Evaluator term value effects) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 7252d3ea7..e604ca998 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -13,9 +13,6 @@ type TraceFor trace m = Trace trace (TermFor m) (ValueFor m) type Tracer trace term value = Writer (Trace trace term value) type TracerFor trace m = Writer (TraceFor trace m) --- | The effects necessary for tracing analyses. -type TracingEffects trace term value = Tracer trace term value ': EvaluatingEffects term value - -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 9c1792fb0..d81968df6 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,19 +1,12 @@ {-# LANGUAGE ConstrainedClassMethods, DataKinds, DefaultSignatures, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator where -import Control.Applicative -import Control.Effect -import Control.Monad.Effect -import Control.Monad.Effect.Fail -import Control.Monad.Effect.Fresh -import Control.Monad.Effect.NonDet -import Control.Monad.Effect.Reader -import Control.Monad.Effect.State import Data.Abstract.Configuration import Data.Abstract.Linker import Data.Abstract.Live import Data.Abstract.Value import Prelude hiding (fail) +import Prologue -- | A 'Monad' providing the basic essentials for evaluation. -- @@ -39,6 +32,8 @@ class MonadFail m => MonadEvaluator m where getStore :: m (StoreFor (ValueFor m)) -- | Update the heap. modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m () + putStore :: StoreFor (ValueFor m) -> m () + putStore = modifyStore . const -- | Retrieve the table of evaluated modules. getModuleTable :: m (Linker (ValueFor m)) @@ -57,43 +52,3 @@ class MonadFail m => MonadEvaluator m where -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore - -type EvaluatingEffects term value - = '[ Fail -- Failure with an error message - , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) - , State (EnvironmentFor value) -- Global (imperative) environment - , State (StoreFor value) -- The heap - , Reader (Linker term) -- Cache of unevaluated modules - , State (Linker value) -- Cache of evaluated modules - ] - -instance (Ord (LocationFor value), Members (EvaluatingEffects term value) effects) => MonadEvaluator (Evaluator term value effects) where - type TermFor (Evaluator term value effects) = term - type ValueFor (Evaluator term value effects) = value - - getGlobalEnv = Evaluator get - modifyGlobalEnv f = Evaluator (modify f) - - askLocalEnv = Evaluator ask - localEnv f a = Evaluator (local f (runEvaluator a)) - - getStore = Evaluator get - modifyStore f = Evaluator (modify f) - - getModuleTable = Evaluator get - modifyModuleTable f = Evaluator (modify f) - - askModuleTable = Evaluator ask - localModuleTable f a = Evaluator (local f (runEvaluator a)) - -putStore :: MonadEvaluator m => StoreFor (ValueFor m) -> m () -putStore = modifyStore . const - --- | An evaluator of @term@s to @value@s, producing incremental results of type @a@ using a list of @effects@. -newtype Evaluator term value effects a = Evaluator { runEvaluator :: Eff effects a } - deriving (Applicative, Functor, Effectful, Monad) - -deriving instance Member Fail effects => MonadFail (Evaluator term value effects) -deriving instance Member NonDetEff effects => Alternative (Evaluator term value effects) -deriving instance Member NonDetEff effects => MonadNonDet (Evaluator term value effects) -deriving instance Member Fresh effects => MonadFresh (Evaluator term value effects) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 55f8f1cd7..81ae79441 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -48,9 +48,9 @@ evaluateRubyFiles paths = do -- Python typecheckPythonFile path = run . lower @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) -tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluating Python.Term PythonValue (TracingEffects [] Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) +tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) -type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (State (Dead (Python.Term)) ': TracingEffects [] Python.Term PythonValue)) +type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue)) evaluateDeadTracePythonFile path = run . lower @(DeadCodeAnalysis PythonTracer) . evaluateDead <$> (file path >>= runTask . parse pythonParser) From dbe31824b93dcb98501ab0e571884a1179867375 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:35:37 -0500 Subject: [PATCH 173/292] :fire: Evaluator. --- src/Analysis/Abstract/Evaluating.hs | 74 +++++++++++++---------------- 1 file changed, 32 insertions(+), 42 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 450c4e9b0..02982ef07 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -29,7 +29,7 @@ evaluate :: forall value term ) => term -> Final (EvaluatingEffects term value) value -evaluate = run @(EvaluatingEffects term value) . runEvaluator . runEvaluating . evaluateModule +evaluate = run @(EvaluatingEffects term value) . runEvaluating . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term @@ -44,22 +44,49 @@ evaluates :: forall value term => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value) value -evaluates pairs (_, t) = run @(EvaluatingEffects term value) (runEvaluator (runEvaluating (withModules pairs (evaluateModule t)))) +evaluates pairs (_, t) = run @(EvaluatingEffects term value) (runEvaluating (withModules pairs (evaluateModule t))) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a withModules pairs = localModuleTable (const moduleTable) where moduleTable = Linker (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) --- | An analysis performing concrete evaluation of @term@s to @value@s. -newtype Evaluating term value effects a = Evaluating { runEvaluating :: Evaluator term value effects a } +-- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. +newtype Evaluating term value effects a = Evaluating { runEvaluating :: 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 NonDetEff effects => Alternative (Evaluating term value effects) deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) -deriving instance (Member Fail effects, MonadEvaluator (Evaluator term value effects), Ord (LocationFor value)) => MonadEvaluator (Evaluating term value effects) + +type EvaluatingEffects term value + = '[ Fail -- Failure with an error message + , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) + , State (EnvironmentFor value) -- Global (imperative) environment + , State (StoreFor value) -- The heap + , Reader (Linker term) -- Cache of unevaluated modules + , State (Linker value) -- Cache of evaluated modules + ] + +instance (Ord (LocationFor value), Members (EvaluatingEffects term value) effects) => MonadEvaluator (Evaluating term value effects) where + type TermFor (Evaluating term value effects) = term + type ValueFor (Evaluating term value effects) = value + + getGlobalEnv = lift get + modifyGlobalEnv f = lift (modify f) + + askLocalEnv = lift ask + localEnv f a = lift (local f (lower a)) + + getStore = lift get + modifyStore f = lift (modify f) + + getModuleTable = lift get + modifyModuleTable f = lift (modify f) + + askModuleTable = lift ask + localModuleTable f a = lift (local f (lower a)) instance ( Evaluatable (Base term) , FreeVariables term @@ -71,40 +98,3 @@ instance ( Evaluatable (Base term) ) => MonadAnalysis (Evaluating term value effects) where analyzeTerm = eval - -type EvaluatingEffects term value - = '[ Fail -- Failure with an error message - , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) - , State (EnvironmentFor value) -- Global (imperative) environment - , State (StoreFor value) -- The heap - , Reader (Linker term) -- Cache of unevaluated modules - , State (Linker value) -- Cache of evaluated modules - ] - -instance (Ord (LocationFor value), Members (EvaluatingEffects term value) effects) => MonadEvaluator (Evaluator term value effects) where - type TermFor (Evaluator term value effects) = term - type ValueFor (Evaluator term value effects) = value - - getGlobalEnv = Evaluator get - modifyGlobalEnv f = Evaluator (modify f) - - askLocalEnv = Evaluator ask - localEnv f a = Evaluator (local f (runEvaluator a)) - - getStore = Evaluator get - modifyStore f = Evaluator (modify f) - - getModuleTable = Evaluator get - modifyModuleTable f = Evaluator (modify f) - - askModuleTable = Evaluator ask - localModuleTable f a = Evaluator (local f (runEvaluator a)) - --- | An evaluator of @term@s to @value@s, producing incremental results of type @a@ using a list of @effects@. -newtype Evaluator term value effects a = Evaluator { runEvaluator :: Eff effects a } - deriving (Applicative, Functor, Effectful, Monad) - -deriving instance Member Fail effects => MonadFail (Evaluator term value effects) -deriving instance Member NonDetEff effects => Alternative (Evaluator term value effects) -deriving instance Member NonDetEff effects => MonadNonDet (Evaluator term value effects) -deriving instance Member Fresh effects => MonadFresh (Evaluator term value effects) From a53ed1f39c3b214838fe6402c7deacf51e3cfd0d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:36:18 -0500 Subject: [PATCH 174/292] Define evaluateDead with evaluateModule. --- src/Analysis/Abstract/Dead.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index a3219bb0a..90cde5e70 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -31,9 +31,7 @@ evaluateDead :: forall m term value effects ) => term -> DeadCodeAnalysis m value -evaluateDead term = do - killAll (subterms term) - evaluateTerm term +evaluateDead = evaluateModule -- | An analysis tracking dead (unreachable) code. From e20fcac374a958f9075a83dd3a275dad6a886f41 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:36:53 -0500 Subject: [PATCH 175/292] :fire: evaluateDead. --- src/Analysis/Abstract/Dead.hs | 23 ----------------------- src/Semantic/Util.hs | 2 +- 2 files changed, 1 insertion(+), 24 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 90cde5e70..131f51801 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -3,7 +3,6 @@ module Analysis.Abstract.Dead where import Control.Abstract.Evaluator import Data.Abstract.Evaluatable -import Data.Abstract.Value import Data.Semigroup.Reducer as Reducer import Data.Set (delete) import Prologue @@ -11,28 +10,6 @@ import Prologue -- | The effects necessary for dead code analysis. type DeadCode term = State (Dead term) --- | Run a dead code analysis of the given program. -evaluateDead :: forall m term value effects - . ( term ~ TermFor m - , value ~ ValueFor m - , effects ~ Effects m - , Corecursive term - , Member (DeadCode term) effects - , Effectful m - , Evaluatable (Base term) - , Foldable (Base term) - , FreeVariables term - , MonadAnalysis m - , Ord (LocationFor value) - , Ord term - , Recursive term - , RunEffects effects value - , Semigroup (CellFor value) - ) - => term - -> DeadCodeAnalysis m value -evaluateDead = evaluateModule - -- | An analysis tracking dead (unreachable) code. newtype DeadCodeAnalysis m a = DeadCodeAnalysis { runDeadCodeAnalysis :: m a } diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 81ae79441..cb41b2fe0 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -52,7 +52,7 @@ tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluating Python.Term type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue)) -evaluateDeadTracePythonFile path = run . lower @(DeadCodeAnalysis PythonTracer) . evaluateDead <$> (file path >>= runTask . parse pythonParser) +evaluateDeadTracePythonFile path = run . lower @(DeadCodeAnalysis PythonTracer) . evaluateModule <$> (file path >>= runTask . parse pythonParser) evaluatePythonFile path = evaluate @PythonValue <$> (file path >>= runTask . parse pythonParser) From 09d7a59693f2e15923b9c88394044556e5f77094 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:37:47 -0500 Subject: [PATCH 176/292] Rename the Effects parameter. --- src/Control/Effect.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 3944f3275..ba60b460f 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -66,10 +66,10 @@ instance Ord a => RunEffect NonDetEff a where MPlus -> mappend <$> k True <*> k False) -class Effectful f where - type Effects f :: [* -> *] - lift :: Eff (Effects f) a -> f a - lower :: f a -> Eff (Effects f) a +class Effectful m where + type Effects m :: [* -> *] + lift :: Eff (Effects m) a -> m a + lower :: m a -> Eff (Effects m) a instance Effectful (Eff effects) where type Effects (Eff effects) = effects From 899c62f2fc38b5c2626e34bff6c7fb38e0d2b092 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:40:02 -0500 Subject: [PATCH 177/292] run takes an 'Effectful' computation instead of 'Eff' directly. --- src/Analysis/Abstract/Evaluating.hs | 4 ++-- src/Control/Effect.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 02982ef07..a5264b615 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -29,7 +29,7 @@ evaluate :: forall value term ) => term -> Final (EvaluatingEffects term value) value -evaluate = run @(EvaluatingEffects term value) . runEvaluating . evaluateModule +evaluate = run @(Evaluating term value (EvaluatingEffects term value)) . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term @@ -44,7 +44,7 @@ evaluates :: forall value term => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value) value -evaluates pairs (_, t) = run @(EvaluatingEffects term value) (runEvaluating (withModules pairs (evaluateModule t))) +evaluates pairs (_, t) = run @(Evaluating term value (EvaluatingEffects term value)) (withModules pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index ba60b460f..d1c042e66 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -11,9 +11,9 @@ import Control.Monad.Effect.Writer import Data.Semigroup.Reducer import Prologue --- | Run a computation in 'Eff' to completion, interpreting each effect with some sensible defaults, and return the 'Final' result. -run :: RunEffects fs a => Eff fs a -> Final fs a -run = Effect.run . runEffects +-- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result. +run :: (Effectful m, RunEffects (Effects m) a) => m a -> Final (Effects m) a +run = Effect.run . runEffects . lower -- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults. class RunEffects fs a where From d5c74a9ecffe8ac749f6c758737182342f5b87ce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 11:41:43 -0500 Subject: [PATCH 178/292] Rename Effects to EffectsFor. --- src/Analysis/Abstract/Caching.hs | 18 +++++++++--------- src/Analysis/Abstract/Dead.hs | 6 +++--- src/Analysis/Abstract/Tracing.hs | 4 ++-- src/Control/Effect.hs | 10 +++++----- 4 files changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 6b0c9e7d3..461183aca 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -41,25 +41,25 @@ newtype CachingAnalysis m a = CachingAnalysis { runCachingAnalysis :: m a } type InCacheEffectFor m = Reader (CacheFor m) type OutCacheEffectFor m = State (CacheFor m) -askCache :: (Effectful m, Member (InCacheEffectFor m) (Effects m)) => CachingAnalysis m (CacheFor m) +askCache :: (Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => CachingAnalysis m (CacheFor m) askCache = lift ask -localCache :: (Effectful m, Member (InCacheEffectFor m) (Effects m)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m a -> CachingAnalysis m a +localCache :: (Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m a -> CachingAnalysis m a localCache f a = lift (local f (lower a)) -asksCache :: (Functor m, Effectful m, Member (InCacheEffectFor m) (Effects m)) => (CacheFor m -> a) -> CachingAnalysis m a +asksCache :: (Functor m, Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> a) -> CachingAnalysis m a asksCache f = f <$> askCache -getsCache :: (Functor m, Effectful m, Member (OutCacheEffectFor m) (Effects m)) => (CacheFor m -> a) -> CachingAnalysis m a +getsCache :: (Functor m, Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> a) -> CachingAnalysis m a getsCache f = f <$> getCache -getCache :: (Effectful m, Member (OutCacheEffectFor m) (Effects m)) => CachingAnalysis m (CacheFor m) +getCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => CachingAnalysis m (CacheFor m) getCache = lift get -putCache :: (Effectful m, Member (OutCacheEffectFor m) (Effects m)) => CacheFor m -> CachingAnalysis m () +putCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => CacheFor m -> CachingAnalysis m () putCache = lift . put -modifyCache :: (Effectful m, Member (OutCacheEffectFor m) (Effects m), Monad m) => (CacheFor m -> CacheFor m) -> CachingAnalysis m () +modifyCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m), Monad m) => (CacheFor m -> CacheFor m) -> CachingAnalysis m () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. @@ -71,7 +71,7 @@ instance ( Corecursive (TermFor m) , Effectful m , MonadFresh m , MonadNonDet m - , Members (CachingEffectsFor m) (Effects m) + , Members (CachingEffectsFor m) (EffectsFor m) , Evaluatable (Base (TermFor m)) , Foldable (Cell (LocationFor (ValueFor m))) , FreeVariables (TermFor m) @@ -126,7 +126,7 @@ memoizeEval :: ( Ord (ValueFor m) , Foldable (Cell (LocationFor (ValueFor m))) , Functor (Base (TermFor m)) , Effectful m - , Members (CachingEffectsFor m) (Effects m) + , Members (CachingEffectsFor m) (EffectsFor m) , Recursive (TermFor m) , MonadAnalysis m -- , Semigroup (CellFor (ValueFor m)) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 131f51801..5b4fe7371 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -23,11 +23,11 @@ newtype Dead term = Dead { unDead :: Set term } deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: (Effectful m, Member (State (Dead (TermFor m))) (Effects m)) => Dead (TermFor m) -> DeadCodeAnalysis m () +killAll :: (Effectful m, Member (State (Dead (TermFor m))) (EffectsFor m)) => Dead (TermFor m) -> DeadCodeAnalysis m () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful m, Member (State (Dead (TermFor m))) (Effects m)) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m () +revive :: (Effectful m, Member (State (Dead (TermFor m))) (EffectsFor m)) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -38,7 +38,7 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term instance ( Corecursive (TermFor m) , Effectful m , Foldable (Base (TermFor m)) - , Member (State (Dead (TermFor m))) (Effects m) + , Member (State (Dead (TermFor m))) (EffectsFor m) , MonadAnalysis m , MonadEvaluator m , Ord (TermFor m) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index e604ca998..30735dca1 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -22,7 +22,7 @@ newtype TracingAnalysis (trace :: * -> *) m a instance ( Corecursive (TermFor m) , Effectful m - , Member (TracerFor trace m) (Effects m) + , Member (TracerFor trace m) (EffectsFor m) , MonadAnalysis m , MonadEvaluator m , Ord (LocationFor (ValueFor m)) @@ -36,7 +36,7 @@ instance ( Corecursive (TermFor m) liftAnalyze analyzeTerm term trace :: ( Effectful m - , Member (TracerFor trace m) (Effects m) + , Member (TracerFor trace m) (EffectsFor m) ) => TraceFor trace m -> TracingAnalysis trace m () diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index d1c042e66..2833f0418 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -12,7 +12,7 @@ import Data.Semigroup.Reducer import Prologue -- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result. -run :: (Effectful m, RunEffects (Effects m) a) => m a -> Final (Effects m) a +run :: (Effectful m, RunEffects (EffectsFor m) a) => m a -> Final (EffectsFor m) a run = Effect.run . runEffects . lower -- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults. @@ -67,11 +67,11 @@ instance Ord a => RunEffect NonDetEff a where class Effectful m where - type Effects m :: [* -> *] - lift :: Eff (Effects m) a -> m a - lower :: m a -> Eff (Effects m) a + type EffectsFor m :: [* -> *] + lift :: Eff (EffectsFor m) a -> m a + lower :: m a -> Eff (EffectsFor m) a instance Effectful (Eff effects) where - type Effects (Eff effects) = effects + type EffectsFor (Eff effects) = effects lift = id lower = id From 5c65b042c3f251c6f779150b7f7a25e7b351a964 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 12:42:03 -0500 Subject: [PATCH 179/292] Use the simplified RunEffects interface. --- src/Semantic/Util.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index cb41b2fe0..3f9615345 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,13 +46,13 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue (zip bs ts) (b, t) -- Python -typecheckPythonFile path = run . lower @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) +typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) -tracePythonFile path = run . lower @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) +tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue)) -evaluateDeadTracePythonFile path = run . lower @(DeadCodeAnalysis PythonTracer) . evaluateModule <$> (file path >>= runTask . parse pythonParser) +evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule <$> (file path >>= runTask . parse pythonParser) evaluatePythonFile path = evaluate @PythonValue <$> (file path >>= runTask . parse pythonParser) From f301cb09436f9a8592dc0c7c32e962dcf39af1c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 12:46:26 -0500 Subject: [PATCH 180/292] Typecheck and trace using evaluateModule. --- src/Semantic/Util.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 3f9615345..d9ad263f9 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,9 +46,9 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue (zip bs ts) (b, t) -- Python -typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) +typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateModule <$> (file path >>= runTask . parse pythonParser) -tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue))) . evaluateTerm <$> (file path >>= runTask . parse pythonParser) +tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue))) . evaluateModule <$> (file path >>= runTask . parse pythonParser) type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue)) From b7536a939a143cc2612664208c974fe1b349af50 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 12:46:46 -0500 Subject: [PATCH 181/292] Extract a helper to parse Python files. --- src/Semantic/Util.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index d9ad263f9..a3bc9e2b5 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -62,6 +62,8 @@ evaluatePythonFiles paths = do (t:ts) <- runTask $ traverse (parse pythonParser) blobs pure $ evaluates @PythonValue (zip bs ts) (b, t) +parsePythonFile path = runTask (file path >>= fmap . (,) <*> parse pythonParser) + -- Diff helpers diffWithParser :: (HasField fields Data.Span.Span, From 0bbbe11b77e69e55a36e37cd6fa05a19cba86759 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 12:47:11 -0500 Subject: [PATCH 182/292] Use parsePythonFile to evaluate. --- src/Semantic/Util.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index a3bc9e2b5..25436b209 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -54,13 +54,11 @@ type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (Dead evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule <$> (file path >>= runTask . parse pythonParser) -evaluatePythonFile path = evaluate @PythonValue <$> - (file path >>= runTask . parse pythonParser) +evaluatePythonFile path = evaluate @PythonValue . snd <$> parsePythonFile path evaluatePythonFiles paths = do - blobs@(b:bs) <- traverse file paths - (t:ts) <- runTask $ traverse (parse pythonParser) blobs - pure $ evaluates @PythonValue (zip bs ts) (b, t) + pair:pairs <- traverse parsePythonFile paths + pure $ evaluates @PythonValue pairs pair parsePythonFile path = runTask (file path >>= fmap . (,) <*> parse pythonParser) From 5887ba194fad3c7c4319737164c60045f3b565d3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 12:50:00 -0500 Subject: [PATCH 183/292] Generalize the parser helper over the parser. --- src/Semantic/Util.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 25436b209..b6a06fd97 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -54,13 +54,13 @@ type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (Dead evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule <$> (file path >>= runTask . parse pythonParser) -evaluatePythonFile path = evaluate @PythonValue . snd <$> parsePythonFile path +evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path evaluatePythonFiles paths = do - pair:pairs <- traverse parsePythonFile paths + pair:pairs <- traverse (parseFile pythonParser) paths pure $ evaluates @PythonValue pairs pair -parsePythonFile path = runTask (file path >>= fmap . (,) <*> parse pythonParser) +parseFile parser path = runTask (file path >>= fmap . (,) <*> parse parser) -- Diff helpers From e912723b92c0b739c1a11b5364221e88fb886354 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 12:50:56 -0500 Subject: [PATCH 184/292] Evaluate Ruby files using the helper. --- src/Semantic/Util.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index b6a06fd97..e89dd6b29 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -37,13 +37,11 @@ file :: MonadIO m => FilePath -> m Blob file path = fromJust <$> IO.readFile path (languageForFilePath path) -- Ruby -evaluateRubyFile path = Prelude.fst . evaluate @RubyValue <$> - (file path >>= runTask . parse rubyParser) +evaluateRubyFile path = Prelude.fst . evaluate @RubyValue . snd <$> parseFile rubyParser path evaluateRubyFiles paths = do - blobs@(b:bs) <- traverse file paths - (t:ts) <- runTask $ traverse (parse rubyParser) blobs - pure $ evaluates @RubyValue (zip bs ts) (b, t) + first:rest <- traverse (parseFile rubyParser) paths + pure $ evaluates @RubyValue rest first -- Python typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateModule <$> (file path >>= runTask . parse pythonParser) @@ -57,8 +55,8 @@ evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evalua evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path evaluatePythonFiles paths = do - pair:pairs <- traverse (parseFile pythonParser) paths - pure $ evaluates @PythonValue pairs pair + first:rest <- traverse (parseFile pythonParser) paths + pure $ evaluates @PythonValue rest first parseFile parser path = runTask (file path >>= fmap . (,) <*> parse parser) From 78be762a0c1034d978dc56e7c0c9a584d2024e05 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 12:51:44 -0500 Subject: [PATCH 185/292] Use the parser helper for the rest of the evaluators. --- src/Semantic/Util.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index e89dd6b29..31b254cb2 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -44,13 +44,13 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python -typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateModule <$> (file path >>= runTask . parse pythonParser) +typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue))) . evaluateModule <$> (file path >>= runTask . parse pythonParser) +tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue))) . evaluateModule . snd <$> parseFile pythonParser path type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue)) -evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule <$> (file path >>= runTask . parse pythonParser) +evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From a862ef9fefe9c6743f263ca8ec9dc111198b5be2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:15:55 -0500 Subject: [PATCH 186/292] Evaluating adds its own effects. --- src/Analysis/Abstract/Evaluating.hs | 45 ++++++++++++++--------------- src/Semantic/Util.hs | 6 ++-- 2 files changed, 25 insertions(+), 26 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 6e226679f..084f910bb 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,30 +21,30 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value)) - , MonadValue value (Evaluating term value (EvaluatingEffects term value)) + , MonadAddressable (LocationFor value) (Evaluating term value '[]) + , MonadValue value (Evaluating term value '[]) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) ) => term - -> Final (EvaluatingEffects term value) value -evaluate = run @(Evaluating term value (EvaluatingEffects term value)) . evaluateModule + -> Final (EvaluatingEffects term value '[]) value +evaluate = run @(Evaluating term value '[]) . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value)) - , MonadValue value (Evaluating term value (EvaluatingEffects term value)) + , MonadAddressable (LocationFor value) (Evaluating term value '[]) + , MonadValue value (Evaluating term value '[]) , Ord (LocationFor value) , Recursive term , Semigroup (CellFor value) ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint - -> Final (EvaluatingEffects term value) value -evaluates pairs (_, t) = run @(Evaluating term value (EvaluatingEffects term value)) (withModules pairs (evaluateModule t)) + -> Final (EvaluatingEffects term value '[]) value +evaluates pairs (_, t) = run @(Evaluating term value '[]) (withModules pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a @@ -52,24 +52,24 @@ withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff effects a } +newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff (EvaluatingEffects term value 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 NonDetEff effects => Alternative (Evaluating term value effects) -deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) +deriving instance Member Fail (EvaluatingEffects term value effects) => MonadFail (Evaluating term value effects) +deriving instance Member Fresh (EvaluatingEffects term value effects) => MonadFresh (Evaluating term value effects) +deriving instance Member NonDetEff (EvaluatingEffects term value effects) => Alternative (Evaluating term value effects) +deriving instance Member NonDetEff (EvaluatingEffects term value effects) => MonadNonDet (Evaluating term value effects) -type EvaluatingEffects term value - = '[ Fail -- Failure with an error message - , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) - , State (EnvironmentFor value) -- Global (imperative) environment - , State (StoreFor value) -- The heap - , Reader (ModuleTable term) -- Cache of unevaluated modules - , State (ModuleTable value) -- Cache of evaluated modules - ] +type EvaluatingEffects term value effects + = Fail -- Failure with an error message + ': Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) + ': State (EnvironmentFor value) -- Global (imperative) environment + ': State (StoreFor value) -- The heap + ': Reader (ModuleTable term) -- Cache of unevaluated modules + ': State (ModuleTable value) -- Cache of evaluated modules + ': effects -instance (Ord (LocationFor value), Members (EvaluatingEffects term value) effects) => MonadEvaluator (Evaluating term value effects) where +instance Ord (LocationFor value) => MonadEvaluator (Evaluating term value effects) where type TermFor (Evaluating term value effects) = term type ValueFor (Evaluating term value effects) = value @@ -90,7 +90,6 @@ instance (Ord (LocationFor value), Members (EvaluatingEffects term value) effect instance ( Evaluatable (Base term) , FreeVariables term - , Members (EvaluatingEffects term value) effects , MonadAddressable (LocationFor value) (Evaluating term value effects) , MonadValue value (Evaluating term value effects) , Recursive term diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 31b254cb2..1cc5ba5fa 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -44,11 +44,11 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python -typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type)))) . evaluateModule . snd <$> parseFile pythonParser path +typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type '[]))) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue))) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue '[Tracer [] Python.Term PythonValue])) . evaluateModule . snd <$> parseFile pythonParser path -type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue)) +type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue '[DeadCode Python.Term, Tracer [] Python.Term PythonValue]) evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule . snd <$> parseFile pythonParser path From 38a21bc9de6b988c55947967274e3a4ec970cc40 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:22:40 -0500 Subject: [PATCH 187/292] Sort language extensions & imports. --- src/Semantic/Util.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 1cc5ba5fa..39766bc0c 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,8 +1,7 @@ -- MonoLocalBinds is to silence a warning about a simplifiable constraint. -{-# LANGUAGE DataKinds, MonoLocalBinds, TypeOperators, TypeApplications #-} +{-# LANGUAGE DataKinds, MonoLocalBinds, TypeApplications, TypeOperators #-} module Semantic.Util where -import Prologue import Analysis.Abstract.Caching import Analysis.Abstract.Dead import Analysis.Abstract.Evaluating @@ -23,12 +22,13 @@ import Data.Term import Diffing.Algorithm import Diffing.Interpreter import Parsing.Parser +import Prologue import Semantic import Semantic.IO as IO import Semantic.Task -import qualified Language.Ruby.Assignment as Ruby import qualified Language.Python.Assignment as Python +import qualified Language.Ruby.Assignment as Ruby type RubyValue = Value Precise (Term (Union Ruby.Syntax) (Record Location)) type PythonValue = Value Precise (Term (Union Python.Syntax) (Record Location)) From a919fe8fb653846f9d587fe82509f2c1912a9171 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:23:48 -0500 Subject: [PATCH 188/292] Align some instances. --- src/Analysis/Abstract/Evaluating.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 084f910bb..40c3fe37a 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -55,8 +55,8 @@ withModules pairs = localModuleTable (const moduleTable) newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff (EvaluatingEffects term value effects) a } deriving (Applicative, Functor, Effectful, Monad) -deriving instance Member Fail (EvaluatingEffects term value effects) => MonadFail (Evaluating term value effects) -deriving instance Member Fresh (EvaluatingEffects term value effects) => MonadFresh (Evaluating term value effects) +deriving instance Member Fail (EvaluatingEffects term value effects) => MonadFail (Evaluating term value effects) +deriving instance Member Fresh (EvaluatingEffects term value effects) => MonadFresh (Evaluating term value effects) deriving instance Member NonDetEff (EvaluatingEffects term value effects) => Alternative (Evaluating term value effects) deriving instance Member NonDetEff (EvaluatingEffects term value effects) => MonadNonDet (Evaluating term value effects) From d12a1dafc25f83d54cd6c7e5a0cc3b0dd175d0ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:24:03 -0500 Subject: [PATCH 189/292] Align the associated types. --- src/Analysis/Abstract/Evaluating.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 40c3fe37a..5436d7dc2 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -70,7 +70,7 @@ type EvaluatingEffects term value effects ': effects instance Ord (LocationFor value) => MonadEvaluator (Evaluating term value effects) where - type TermFor (Evaluating term value effects) = term + type TermFor (Evaluating term value effects) = term type ValueFor (Evaluating term value effects) = value getGlobalEnv = lift get From ec350c78ff3ef956053a7c1a9f4ece72b1f07c52 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:27:16 -0500 Subject: [PATCH 190/292] Align some more types. --- src/Control/Abstract/Analysis.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index b4d6da220..c736bfe58 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -37,11 +37,11 @@ liftAnalyze :: ( term ~ TermFor m , term ~ TermFor (t m) , value ~ ValueFor m , value ~ ValueFor (t m) - , Coercible (m value) (t m value) - , Coercible (t m value) (m value) + , Coercible ( m value) (t m value) + , Coercible (t m value) ( m value) , Functor (Base term) ) - => SubtermAlgebra (Base term) term (m value) + => SubtermAlgebra (Base term) term ( m value) -> SubtermAlgebra (Base term) term (t m value) liftAnalyze analyze term = pack1 (analyze (second unpack1 <$> term)) where pack1 = coerce From bf7b397275a28b62802b2d95467e6afb72b37972 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:31:36 -0500 Subject: [PATCH 191/292] :fire: redundant language extensions. --- src/Control/Abstract/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 745565a52..102299315 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, DataKinds, DefaultSignatures, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE ConstrainedClassMethods, TypeFamilies #-} module Control.Abstract.Evaluator where import Data.Abstract.Configuration From abe6415536a7fc2dfcc7d0cc71fdaeb61668c8d7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:34:33 -0500 Subject: [PATCH 192/292] :fire: a redundant type signature. --- src/Control/Abstract/Analysis.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index c736bfe58..03e3c83bd 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -45,7 +45,6 @@ liftAnalyze :: ( term ~ TermFor m -> SubtermAlgebra (Base term) term (t m value) liftAnalyze analyze term = pack1 (analyze (second unpack1 <$> term)) where pack1 = coerce - unpack1 :: Coercible (t m value) (m value) => t m value -> m value unpack1 = coerce liftEvaluate :: ( term ~ TermFor m From eb3fbcc4db52ec81178320da73162b2daad17f36 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:35:01 -0500 Subject: [PATCH 193/292] Just say coerce. --- src/Control/Abstract/Analysis.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 03e3c83bd..3bba4917c 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -43,9 +43,7 @@ liftAnalyze :: ( term ~ TermFor m ) => SubtermAlgebra (Base term) term ( m value) -> SubtermAlgebra (Base term) term (t m value) -liftAnalyze analyze term = pack1 (analyze (second unpack1 <$> term)) - where pack1 = coerce - unpack1 = coerce +liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) liftEvaluate :: ( term ~ TermFor m , term ~ TermFor (t m) From 1eacebfab89787c82fa7063002182f9eb18ded54 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:36:49 -0500 Subject: [PATCH 194/292] Align the associated type families. --- src/Control/Abstract/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 102299315..77341d341 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -15,7 +15,7 @@ import Prologue -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import class MonadFail m => MonadEvaluator m where - type TermFor m + type TermFor m type ValueFor m -- | Retrieve the global environment. From 4468dee9be68063b757a78360f477580643f7645 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:47:18 -0500 Subject: [PATCH 195/292] :fire: redundant constraints. --- src/Data/Abstract/Evaluatable.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 153e47f90..023afd8d3 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -33,7 +33,6 @@ class Evaluatable constr where , MonadAnalysis m , TermFor m ~ term , ValueFor m ~ value - , MonadEvaluator m , MonadValue value m , Ord (LocationFor value) , Semigroup (CellFor value) @@ -78,7 +77,6 @@ instance Evaluatable [] where -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. require :: ( FreeVariables (TermFor m) , MonadAnalysis m - , MonadEvaluator m ) => TermFor m -> m (ValueFor m) @@ -90,7 +88,6 @@ require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup nam -- Always loads/evaluates. load :: ( FreeVariables (TermFor m) , MonadAnalysis m - , MonadEvaluator m ) => TermFor m -> m (ValueFor m) From bda709146749ace912b12f7f8935130c1be77ec3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:47:39 -0500 Subject: [PATCH 196/292] Sort some constraints. --- src/Data/Abstract/Evaluatable.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 023afd8d3..ced0536de 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -28,11 +28,11 @@ import Prologue -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class Evaluatable constr where - eval :: ( FreeVariables term + eval :: ( term ~ TermFor m + , value ~ ValueFor m + , FreeVariables term , MonadAddressable (LocationFor value) m , MonadAnalysis m - , TermFor m ~ term - , ValueFor m ~ value , MonadValue value m , Ord (LocationFor value) , Semigroup (CellFor value) From 9f49a4921e14de1cb89af1ad5b04fcea78a7be85 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:48:17 -0500 Subject: [PATCH 197/292] :fire: redundant constraints on eval. --- src/Data/Abstract/Evaluatable.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index ced0536de..b3c9c495d 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -34,8 +34,6 @@ class Evaluatable constr where , MonadAddressable (LocationFor value) m , MonadAnalysis m , MonadValue value m - , Ord (LocationFor value) - , Semigroup (CellFor value) ) => SubtermAlgebra constr term (m value) default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) From a848426b03a772959e50140fb6538d6707624568 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 13:49:18 -0500 Subject: [PATCH 198/292] :fire: a bunch more redundant constraints. --- src/Analysis/Abstract/Evaluating.hs | 7 +------ 1 file changed, 1 insertion(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 5436d7dc2..d4a294bc2 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,9 +23,7 @@ evaluate :: forall value term , FreeVariables term , MonadAddressable (LocationFor value) (Evaluating term value '[]) , MonadValue value (Evaluating term value '[]) - , Ord (LocationFor value) , Recursive term - , Semigroup (CellFor value) ) => term -> Final (EvaluatingEffects term value '[]) value @@ -37,9 +35,7 @@ evaluates :: forall value term , FreeVariables term , MonadAddressable (LocationFor value) (Evaluating term value '[]) , MonadValue value (Evaluating term value '[]) - , Ord (LocationFor value) , Recursive term - , Semigroup (CellFor value) ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint @@ -69,7 +65,7 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance Ord (LocationFor value) => MonadEvaluator (Evaluating term value effects) where +instance MonadEvaluator (Evaluating term value effects) where type TermFor (Evaluating term value effects) = term type ValueFor (Evaluating term value effects) = value @@ -93,7 +89,6 @@ instance ( Evaluatable (Base term) , MonadAddressable (LocationFor value) (Evaluating term value effects) , MonadValue value (Evaluating term value effects) , Recursive term - , Semigroup (CellFor value) ) => MonadAnalysis (Evaluating term value effects) where analyzeTerm = eval From 29dee3a213f74e4804c79558bbb223766168c105 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 14:13:53 -0500 Subject: [PATCH 199/292] Abstract the various types over the effect list. --- src/Analysis/Abstract/Caching.hs | 74 ++++++++++++++--------------- src/Analysis/Abstract/Dead.hs | 22 ++++----- src/Analysis/Abstract/Evaluating.hs | 30 +++++++----- src/Analysis/Abstract/Tracing.hs | 26 +++++----- src/Control/Abstract/Analysis.hs | 32 ++++++------- src/Control/Effect.hs | 10 ++-- src/Semantic/Util.hs | 9 ++-- 7 files changed, 103 insertions(+), 100 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 461183aca..1591b31c5 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -33,7 +33,7 @@ type CachingEffects term value effects -- | The cache for term and abstract value types. type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) -newtype CachingAnalysis m a = CachingAnalysis { runCachingAnalysis :: m a } +newtype CachingAnalysis m (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) -- TODO: reabstract these later on @@ -41,44 +41,44 @@ newtype CachingAnalysis m a = CachingAnalysis { runCachingAnalysis :: m a } type InCacheEffectFor m = Reader (CacheFor m) type OutCacheEffectFor m = State (CacheFor m) -askCache :: (Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => CachingAnalysis m (CacheFor m) +askCache :: (Effectful m, Member (InCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) askCache = lift ask -localCache :: (Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m a -> CachingAnalysis m a +localCache :: (Effectful m, Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects a -> CachingAnalysis m effects a localCache f a = lift (local f (lower a)) -asksCache :: (Functor m, Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> a) -> CachingAnalysis m a +asksCache :: (Functor (m effects), Effectful m, Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a asksCache f = f <$> askCache -getsCache :: (Functor m, Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> a) -> CachingAnalysis m a +getsCache :: (Functor (m effects), Effectful m, Member (OutCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a getsCache f = f <$> getCache -getCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => CachingAnalysis m (CacheFor m) +getCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) getCache = lift get -putCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => CacheFor m -> CachingAnalysis m () +putCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects) => CacheFor (m effects) -> CachingAnalysis m effects () putCache = lift . put -modifyCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m), Monad m) => (CacheFor m -> CacheFor m) -> CachingAnalysis m () +modifyCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects, Monad (m effects)) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. -instance ( Corecursive (TermFor m) - , Ord (TermFor m) - , Ord (ValueFor m) - , Ord (CellFor (ValueFor m)) - , Ord (LocationFor (ValueFor m)) +instance ( Corecursive (TermFor (m effects)) + , Ord (TermFor (m effects)) + , Ord (ValueFor (m effects)) + , Ord (CellFor (ValueFor (m effects))) + , Ord (LocationFor (ValueFor (m effects))) , Effectful m - , MonadFresh m - , MonadNonDet m - , Members (CachingEffectsFor m) (EffectsFor m) - , Evaluatable (Base (TermFor m)) - , Foldable (Cell (LocationFor (ValueFor m))) - , FreeVariables (TermFor m) - , MonadAnalysis m - , Recursive (TermFor m) + , MonadFresh (m effects) + , MonadNonDet (m effects) + , Members (CachingEffectsFor (m effects)) effects + , Evaluatable (Base (TermFor (m effects))) + , Foldable (Cell (LocationFor (ValueFor (m effects)))) + , FreeVariables (TermFor (m effects)) + , MonadAnalysis (m effects) + , Recursive (TermFor (m effects)) ) - => MonadAnalysis (CachingAnalysis m) where + => MonadAnalysis (CachingAnalysis m effects) where analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -92,7 +92,7 @@ instance ( Corecursive (TermFor m) -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis m ()) + _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis m effects ()) getCache) mempty maybe empty scatter (cacheLookup c cache) @@ -116,22 +116,22 @@ scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (Locatio scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: ( Ord (ValueFor m) - , Ord (TermFor m) - , Ord (LocationFor (ValueFor m)) - , Ord (CellFor (ValueFor m)) - , Alternative m - , Corecursive (TermFor m) - , FreeVariables (TermFor m) - , Foldable (Cell (LocationFor (ValueFor m))) - , Functor (Base (TermFor m)) +memoizeEval :: ( Ord (ValueFor (m effects)) + , Ord (TermFor (m effects)) + , Ord (LocationFor (ValueFor (m effects))) + , Ord (CellFor (ValueFor (m effects))) + , Alternative (m effects) + , Corecursive (TermFor (m effects)) + , FreeVariables (TermFor (m effects)) + , Foldable (Cell (LocationFor (ValueFor (m effects)))) + , Functor (Base (TermFor (m effects))) , Effectful m - , Members (CachingEffectsFor m) (EffectsFor m) - , Recursive (TermFor m) - , MonadAnalysis m - -- , Semigroup (CellFor (ValueFor m)) + , Members (CachingEffectsFor (m effects)) effects + , Recursive (TermFor (m effects)) + , MonadAnalysis (m effects) + -- , Semigroup (CellFor (ValueFor (m effects))) ) - => SubtermAlgebra (Base (TermFor m)) (TermFor m) (CachingAnalysis m (ValueFor m)) + => SubtermAlgebra (Base (TermFor (m effects))) (TermFor (m effects)) (CachingAnalysis m effects (ValueFor (m effects))) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 5b4fe7371..71db4e775 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -12,7 +12,7 @@ type DeadCode term = State (Dead term) -- | An analysis tracking dead (unreachable) code. -newtype DeadCodeAnalysis m a = DeadCodeAnalysis { runDeadCodeAnalysis :: m a } +newtype DeadCodeAnalysis m (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m effects a } deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) @@ -23,11 +23,11 @@ newtype Dead term = Dead { unDead :: Set term } deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: (Effectful m, Member (State (Dead (TermFor m))) (EffectsFor m)) => Dead (TermFor m) -> DeadCodeAnalysis m () +killAll :: (Effectful m, Member (State (Dead (TermFor (m effects)))) effects) => Dead (TermFor (m effects)) -> DeadCodeAnalysis m effects () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful m, Member (State (Dead (TermFor m))) (EffectsFor m)) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m () +revive :: (Effectful m, Member (State (Dead (TermFor (m effects)))) effects) => Ord (TermFor (m effects)) => (TermFor (m effects)) -> DeadCodeAnalysis m effects () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -35,16 +35,16 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter subterms term = term `cons` para (foldMap (uncurry cons)) term -instance ( Corecursive (TermFor m) +instance ( Corecursive (TermFor (m effects)) , Effectful m - , Foldable (Base (TermFor m)) - , Member (State (Dead (TermFor m))) (EffectsFor m) - , MonadAnalysis m - , MonadEvaluator m - , Ord (TermFor m) - , Recursive (TermFor m) + , Foldable (Base (TermFor (m effects))) + , Member (State (Dead (TermFor (m effects)))) effects + , MonadAnalysis (m effects) + , MonadEvaluator (m effects) + , Ord (TermFor (m effects)) + , Recursive (TermFor (m effects)) ) - => MonadAnalysis (DeadCodeAnalysis m) where + => MonadAnalysis (DeadCodeAnalysis m effects) where analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index d4a294bc2..4d29ee286 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,26 +21,26 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value '[]) - , MonadValue value (Evaluating term value '[]) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) + , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) , Recursive term ) => term -> Final (EvaluatingEffects term value '[]) value -evaluate = run @(Evaluating term value '[]) . evaluateModule +evaluate = run @(Evaluating term value) @(EvaluatingEffects term value '[]) . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value '[]) - , MonadValue value (Evaluating term value '[]) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) + , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value '[]) value -evaluates pairs (_, t) = run @(Evaluating term value '[]) (withModules pairs (evaluateModule t)) +evaluates pairs (_, t) = run @(Evaluating term value) @(EvaluatingEffects term value '[]) (withModules pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a @@ -48,13 +48,16 @@ withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff (EvaluatingEffects term value effects) a } - deriving (Applicative, Functor, Effectful, Monad) +newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff effects a } + deriving (Applicative, Effectful, Functor, Monad) -deriving instance Member Fail (EvaluatingEffects term value effects) => MonadFail (Evaluating term value effects) -deriving instance Member Fresh (EvaluatingEffects term value effects) => MonadFresh (Evaluating term value effects) -deriving instance Member NonDetEff (EvaluatingEffects term value effects) => Alternative (Evaluating term value effects) -deriving instance Member NonDetEff (EvaluatingEffects term value 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 NonDetEff effects => Alternative (Evaluating term value effects) +deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) + +-- instance Effectful (Evaluating term value) where +-- lift = _ type EvaluatingEffects term value effects = Fail -- Failure with an error message @@ -65,7 +68,7 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance MonadEvaluator (Evaluating term value effects) where +instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (Evaluating term value effects) where type TermFor (Evaluating term value effects) = term type ValueFor (Evaluating term value effects) = value @@ -86,6 +89,7 @@ instance MonadEvaluator (Evaluating term value effects) where instance ( Evaluatable (Base term) , FreeVariables term + , Members (EvaluatingEffects term value '[]) effects , MonadAddressable (LocationFor value) (Evaluating term value effects) , MonadValue value (Evaluating term value effects) , Recursive term diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 30735dca1..2359f0170 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -16,28 +16,28 @@ type TracerFor trace m = Writer (TraceFor trace m) -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -newtype TracingAnalysis (trace :: * -> *) m a - = TracingAnalysis { runTracingAnalysis :: m a } +newtype TracingAnalysis (trace :: * -> *) m (effects :: [* -> *]) a + = TracingAnalysis { runTracingAnalysis :: m effects a } deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) -instance ( Corecursive (TermFor m) +instance ( Corecursive (TermFor (m effects)) , Effectful m - , Member (TracerFor trace m) (EffectsFor m) - , MonadAnalysis m - , MonadEvaluator m - , Ord (LocationFor (ValueFor m)) - , Recursive (TermFor m) - , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) + , Member (TracerFor trace (m effects)) effects + , MonadAnalysis (m effects) + , MonadEvaluator (m effects) + , Ord (LocationFor (ValueFor (m effects))) + , Recursive (TermFor (m effects)) + , Reducer (ConfigurationFor (TermFor (m effects)) (ValueFor (m effects))) (TraceFor trace (m effects)) ) - => MonadAnalysis (TracingAnalysis trace m) where + => MonadAnalysis (TracingAnalysis trace m effects) where analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) liftAnalyze analyzeTerm term trace :: ( Effectful m - , Member (TracerFor trace m) (EffectsFor m) + , Member (TracerFor trace (m effects)) effects ) - => TraceFor trace m - -> TracingAnalysis trace m () + => TraceFor trace (m effects) + -> TracingAnalysis trace m effects () trace = lift . tell diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 3bba4917c..287957800 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE PolyKinds, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -33,24 +33,24 @@ class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where evaluateTerm :: MonadAnalysis m => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm -liftAnalyze :: ( term ~ TermFor m - , term ~ TermFor (t m) - , value ~ ValueFor m - , value ~ ValueFor (t m) - , Coercible ( m value) (t m value) - , Coercible (t m value) ( m value) +liftAnalyze :: ( term ~ TermFor ( m effects) + , term ~ TermFor (t m effects) + , value ~ ValueFor ( m effects) + , value ~ ValueFor (t m effects) + , Coercible ( m effects value) (t m effects value) + , Coercible (t m effects value) ( m effects value) , Functor (Base term) ) - => SubtermAlgebra (Base term) term ( m value) - -> SubtermAlgebra (Base term) term (t m value) + => SubtermAlgebra (Base term) term ( m effects value) + -> SubtermAlgebra (Base term) term (t m effects value) liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -liftEvaluate :: ( term ~ TermFor m - , term ~ TermFor (t m) - , value ~ ValueFor m - , value ~ ValueFor (t m) - , Coercible (m value) (t m value) +liftEvaluate :: ( term ~ TermFor ( m effects) + , term ~ TermFor (t m effects) + , value ~ ValueFor ( m effects) + , value ~ ValueFor (t m effects) + , Coercible (m effects value) (t m effects value) ) - => (term -> m value) - -> (term -> t m value) + => (term -> m effects value) + -> (term -> t m effects value) liftEvaluate evaluate = coerce . evaluate diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 2833f0418..79fcd4db6 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -12,7 +12,7 @@ import Data.Semigroup.Reducer import Prologue -- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result. -run :: (Effectful m, RunEffects (EffectsFor m) a) => m a -> Final (EffectsFor m) a +run :: (Effectful m, RunEffects effects a) => m effects a -> Final effects a run = Effect.run . runEffects . lower -- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults. @@ -67,11 +67,9 @@ instance Ord a => RunEffect NonDetEff a where class Effectful m where - type EffectsFor m :: [* -> *] - lift :: Eff (EffectsFor m) a -> m a - lower :: m a -> Eff (EffectsFor m) a + lift :: Eff effects a -> m effects a + lower :: m effects a -> Eff effects a -instance Effectful (Eff effects) where - type EffectsFor (Eff effects) = effects +instance Effectful Eff where lift = id lower = id diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 39766bc0c..727faf4e5 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -44,13 +44,14 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python -typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type '[]))) . evaluateModule . snd <$> parseFile pythonParser path +typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type)) @(CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[])) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue '[Tracer [] Python.Term PythonValue])) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue)) @(Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])) . evaluateModule . snd <$> parseFile pythonParser path -type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue '[DeadCode Python.Term, Tracer [] Python.Term PythonValue]) +type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue) +type PythonTracerEffects = DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue '[] -evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) @PythonTracerEffects . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From 1478187f0f4f290540adfcc50281f40da2ec6cf4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 14:37:37 -0500 Subject: [PATCH 200/292] Parameterize the typeclasses by the list of effects. --- src/Analysis/Abstract/Caching.hs | 69 +++++++++++++++-------------- src/Analysis/Abstract/Dead.hs | 23 +++++----- src/Analysis/Abstract/Evaluating.hs | 22 ++++----- src/Analysis/Abstract/Tracing.hs | 26 ++++++----- src/Control/Abstract/Addressable.hs | 26 +++++------ src/Control/Abstract/Analysis.hs | 26 +++++------ src/Control/Abstract/Evaluator.hs | 30 ++++++------- src/Control/Abstract/Value.hs | 27 ++++++----- src/Data/Abstract/Evaluatable.hs | 18 ++++---- 9 files changed, 135 insertions(+), 132 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 1591b31c5..9a1c4f608 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -34,51 +34,52 @@ type CachingEffects term value effects type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) newtype CachingAnalysis m (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m effects a } - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) +deriving instance MonadEvaluator effects m => MonadEvaluator effects (CachingAnalysis m) -- TODO: reabstract these later on type InCacheEffectFor m = Reader (CacheFor m) type OutCacheEffectFor m = State (CacheFor m) -askCache :: (Effectful m, Member (InCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) +askCache :: (Effectful m, Member (InCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m) askCache = lift ask -localCache :: (Effectful m, Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects a -> CachingAnalysis m effects a +localCache :: (Effectful m, Member (InCacheEffectFor m) effects) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects a -> CachingAnalysis m effects a localCache f a = lift (local f (lower a)) -asksCache :: (Functor (m effects), Effectful m, Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a +asksCache :: (Functor (m effects), Effectful m, Member (InCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a asksCache f = f <$> askCache -getsCache :: (Functor (m effects), Effectful m, Member (OutCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a +getsCache :: (Functor (m effects), Effectful m, Member (OutCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a getsCache f = f <$> getCache -getCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) +getCache :: (Effectful m, Member (OutCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m) getCache = lift get -putCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects) => CacheFor (m effects) -> CachingAnalysis m effects () +putCache :: (Effectful m, Member (OutCacheEffectFor m) effects) => CacheFor m -> CachingAnalysis m effects () putCache = lift . put -modifyCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects, Monad (m effects)) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects () +modifyCache :: (Effectful m, Member (OutCacheEffectFor m) effects, Monad (m effects)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. -instance ( Corecursive (TermFor (m effects)) - , Ord (TermFor (m effects)) - , Ord (ValueFor (m effects)) - , Ord (CellFor (ValueFor (m effects))) - , Ord (LocationFor (ValueFor (m effects))) +instance ( Corecursive (TermFor m) + , Ord (TermFor m) + , Ord (ValueFor m) + , Ord (CellFor (ValueFor m)) + , Ord (LocationFor (ValueFor m)) , Effectful m , MonadFresh (m effects) , MonadNonDet (m effects) - , Members (CachingEffectsFor (m effects)) effects - , Evaluatable (Base (TermFor (m effects))) - , Foldable (Cell (LocationFor (ValueFor (m effects)))) - , FreeVariables (TermFor (m effects)) - , MonadAnalysis (m effects) - , Recursive (TermFor (m effects)) + , Members (CachingEffectsFor m) effects + , Evaluatable (Base (TermFor m)) + , Foldable (Cell (LocationFor (ValueFor m))) + , FreeVariables (TermFor m) + , MonadAnalysis effects m + , Recursive (TermFor m) ) - => MonadAnalysis (CachingAnalysis m effects) where + => MonadAnalysis effects (CachingAnalysis m) where analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -112,26 +113,26 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m a +scatter :: (Alternative (m effects), Foldable t, MonadEvaluator effects m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m effects a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: ( Ord (ValueFor (m effects)) - , Ord (TermFor (m effects)) - , Ord (LocationFor (ValueFor (m effects))) - , Ord (CellFor (ValueFor (m effects))) +memoizeEval :: ( Ord (ValueFor m) + , Ord (TermFor m) + , Ord (LocationFor (ValueFor m)) + , Ord (CellFor (ValueFor m)) , Alternative (m effects) - , Corecursive (TermFor (m effects)) - , FreeVariables (TermFor (m effects)) - , Foldable (Cell (LocationFor (ValueFor (m effects)))) - , Functor (Base (TermFor (m effects))) + , Corecursive (TermFor m) + , FreeVariables (TermFor m) + , Foldable (Cell (LocationFor (ValueFor m))) + , Functor (Base (TermFor m)) , Effectful m - , Members (CachingEffectsFor (m effects)) effects - , Recursive (TermFor (m effects)) - , MonadAnalysis (m effects) - -- , Semigroup (CellFor (ValueFor (m effects))) + , Members (CachingEffectsFor m) effects + , Recursive (TermFor m) + , MonadAnalysis effects m + -- , Semigroup (CellFor (ValueFor m)) ) - => SubtermAlgebra (Base (TermFor (m effects))) (TermFor (m effects)) (CachingAnalysis m effects (ValueFor (m effects))) + => SubtermAlgebra (Base (TermFor m)) (TermFor m) (CachingAnalysis m effects (ValueFor m)) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 71db4e775..7bb0aa371 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,8 +13,9 @@ type DeadCode term = State (Dead term) -- | An analysis tracking dead (unreachable) code. newtype DeadCodeAnalysis m (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m effects a } - deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, Effectful, Monad, MonadFail) +deriving instance MonadEvaluator effects m => MonadEvaluator effects (DeadCodeAnalysis m) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } @@ -23,11 +24,11 @@ newtype Dead term = Dead { unDead :: Set term } deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: (Effectful m, Member (State (Dead (TermFor (m effects)))) effects) => Dead (TermFor (m effects)) -> DeadCodeAnalysis m effects () +killAll :: (Effectful m, Member (State (Dead (TermFor m))) effects) => Dead (TermFor m) -> DeadCodeAnalysis m effects () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful m, Member (State (Dead (TermFor (m effects)))) effects) => Ord (TermFor (m effects)) => (TermFor (m effects)) -> DeadCodeAnalysis m effects () +revive :: (Effectful m, Member (State (Dead (TermFor m))) effects) => Ord (TermFor m) => TermFor m -> DeadCodeAnalysis m effects () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -35,16 +36,16 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter subterms term = term `cons` para (foldMap (uncurry cons)) term -instance ( Corecursive (TermFor (m effects)) +instance ( Corecursive (TermFor m) , Effectful m - , Foldable (Base (TermFor (m effects))) - , Member (State (Dead (TermFor (m effects)))) effects - , MonadAnalysis (m effects) - , MonadEvaluator (m effects) - , Ord (TermFor (m effects)) - , Recursive (TermFor (m effects)) + , Foldable (Base (TermFor m)) + , Member (State (Dead (TermFor m))) effects + , MonadAnalysis effects m + , MonadEvaluator effects m + , Ord (TermFor m) + , Recursive (TermFor m) ) - => MonadAnalysis (DeadCodeAnalysis m effects) where + => MonadAnalysis effects (DeadCodeAnalysis m) where analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 4d29ee286..2f4155291 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,8 +21,8 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) - , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) + , MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value) + , MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value) , Recursive term ) => term @@ -33,8 +33,8 @@ evaluate = run @(Evaluating term value) @(EvaluatingEffects term value '[]) . ev evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) - , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) + , MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value) + , MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated @@ -43,7 +43,7 @@ evaluates :: forall value term evaluates pairs (_, t) = run @(Evaluating term value) @(EvaluatingEffects term value '[]) (withModules pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. -withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a +withModules :: (MonadAnalysis effects m, MonadEvaluator effects m) => [(Blob, TermFor m)] -> m effects a -> m effects a withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) @@ -68,9 +68,9 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (Evaluating term value effects) where - type TermFor (Evaluating term value effects) = term - type ValueFor (Evaluating term value effects) = value +instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator effects (Evaluating term value) where + type TermFor (Evaluating term value) = term + type ValueFor (Evaluating term value) = value getGlobalEnv = lift get modifyGlobalEnv f = lift (modify f) @@ -90,9 +90,9 @@ instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (E instance ( Evaluatable (Base term) , FreeVariables term , Members (EvaluatingEffects term value '[]) effects - , MonadAddressable (LocationFor value) (Evaluating term value effects) - , MonadValue value (Evaluating term value effects) + , MonadAddressable (LocationFor value) effects (Evaluating term value) + , MonadValue value effects (Evaluating term value) , Recursive term ) - => MonadAnalysis (Evaluating term value effects) where + => MonadAnalysis effects (Evaluating term value) where analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 2359f0170..ef7628bd9 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Analysis @@ -18,26 +18,28 @@ type TracerFor trace m = Writer (TraceFor trace m) -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m (effects :: [* -> *]) a = TracingAnalysis { runTracingAnalysis :: m effects a } - deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, Effectful, Monad, MonadFail) -instance ( Corecursive (TermFor (m effects)) +deriving instance MonadEvaluator effects m => MonadEvaluator effects (TracingAnalysis trace m) + +instance ( Corecursive (TermFor m) , Effectful m - , Member (TracerFor trace (m effects)) effects - , MonadAnalysis (m effects) - , MonadEvaluator (m effects) - , Ord (LocationFor (ValueFor (m effects))) - , Recursive (TermFor (m effects)) - , Reducer (ConfigurationFor (TermFor (m effects)) (ValueFor (m effects))) (TraceFor trace (m effects)) + , Member (TracerFor trace m) effects + , MonadAnalysis effects m + , MonadEvaluator effects m + , Ord (LocationFor (ValueFor m)) + , Recursive (TermFor m) + , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) ) - => MonadAnalysis (TracingAnalysis trace m effects) where + => MonadAnalysis effects (TracingAnalysis trace m) where analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) liftAnalyze analyzeTerm term trace :: ( Effectful m - , Member (TracerFor trace (m effects)) effects + , Member (TracerFor trace m) effects ) - => TraceFor trace (m effects) + => TraceFor trace m -> TracingAnalysis trace m effects () trace = lift . tell diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 91d2c247e..8fcc459f2 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -15,39 +15,39 @@ import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad m, Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l m where +class (Monad (m effects), Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l effects m where deref :: Address l (ValueFor m) - -> m (ValueFor m) + -> m effects (ValueFor m) alloc :: Name - -> m (Address l (ValueFor m)) + -> m effects (Address l (ValueFor m)) -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- -- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. lookupOrAlloc :: ( FreeVariables t - , MonadAddressable (LocationFor a) m - , MonadEvaluator m + , MonadAddressable (LocationFor a) effects m + , MonadEvaluator effects m , a ~ ValueFor m , Semigroup (CellFor a) ) => t -> a -> Environment (LocationFor a) a - -> m (Name, Address (LocationFor a) a) + -> m effects (Name, Address (LocationFor a) a) lookupOrAlloc term = let [name] = toList (freeVariables term) in lookupOrAlloc' name where -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. lookupOrAlloc' :: ( Semigroup (CellFor a) - , MonadAddressable (LocationFor a) m + , MonadAddressable (LocationFor a) effects m , a ~ ValueFor m - , MonadEvaluator m + , MonadEvaluator effects m ) => Name -> a -> Environment (LocationFor a) a - -> m (Name, Address (LocationFor a) a) + -> m effects (Name, Address (LocationFor a) a) lookupOrAlloc' name v env = do a <- maybe (alloc name) pure (envLookup name env) assign a v @@ -55,20 +55,20 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor a) - , MonadEvaluator m + , MonadEvaluator effects m , a ~ ValueFor m , Reducer a (CellFor a) ) => Address (LocationFor a) a -> a - -> m () + -> m effects () assign address = modifyStore . storeInsert address -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise m where +instance (Monad (m effects), MonadEvaluator effects m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise effects m where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -79,7 +79,7 @@ instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => Mona -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad m, MonadEvaluator m) => MonadAddressable Monovariant m where +instance (Alternative (m effects), Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad (m effects), MonadEvaluator effects m) => MonadAddressable Monovariant effects m where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 287957800..dfc4a8ab5 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PolyKinds, TypeFamilies #-} +{-# LANGUAGE KindSignatures, MultiParamTypeClasses, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -20,23 +20,23 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where +class (MonadEvaluator effects m, Recursive (TermFor m)) => MonadAnalysis effects m where -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. - analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) + analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m effects (ValueFor m)) - evaluateModule :: TermFor m -> m (ValueFor m) + evaluateModule :: TermFor m -> m effects (ValueFor m) evaluateModule = evaluateTerm -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. -evaluateTerm :: MonadAnalysis m => TermFor m -> m (ValueFor m) +evaluateTerm :: MonadAnalysis effects m => TermFor m -> m effects (ValueFor m) evaluateTerm = foldSubterms analyzeTerm -liftAnalyze :: ( term ~ TermFor ( m effects) - , term ~ TermFor (t m effects) - , value ~ ValueFor ( m effects) - , value ~ ValueFor (t m effects) +liftAnalyze :: ( term ~ TermFor ( m) + , term ~ TermFor (t m) + , value ~ ValueFor ( m) + , value ~ ValueFor (t m) , Coercible ( m effects value) (t m effects value) , Coercible (t m effects value) ( m effects value) , Functor (Base term) @@ -45,10 +45,10 @@ liftAnalyze :: ( term ~ TermFor ( m effects) -> SubtermAlgebra (Base term) term (t m effects value) liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -liftEvaluate :: ( term ~ TermFor ( m effects) - , term ~ TermFor (t m effects) - , value ~ ValueFor ( m effects) - , value ~ ValueFor (t m effects) +liftEvaluate :: ( term ~ TermFor ( m) + , term ~ TermFor (t m) + , value ~ ValueFor ( m) + , value ~ ValueFor (t m) , Coercible (m effects value) (t m effects value) ) => (term -> m effects value) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 77341d341..1dd3c6b66 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, TypeFamilies #-} +{-# LANGUAGE ConstrainedClassMethods, DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies #-} module Control.Abstract.Evaluator where import Data.Abstract.Configuration @@ -14,41 +14,41 @@ import Prologue -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class MonadFail m => MonadEvaluator m where +class MonadFail (m effects) => MonadEvaluator (effects :: [* -> *]) m where type TermFor m type ValueFor m -- | Retrieve the global environment. - getGlobalEnv :: m (EnvironmentFor (ValueFor m)) + getGlobalEnv :: m effects (EnvironmentFor (ValueFor m)) -- | Update the global environment. - modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m () + modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects () -- | Retrieve the local environment. - askLocalEnv :: m (EnvironmentFor (ValueFor m)) + askLocalEnv :: m effects (EnvironmentFor (ValueFor m)) -- | Run an action with a locally-modified environment. - localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m a -> m a + localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects a -> m effects a -- | Retrieve the heap. - getStore :: m (StoreFor (ValueFor m)) + getStore :: m effects (StoreFor (ValueFor m)) -- | Update the heap. - modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m () - putStore :: StoreFor (ValueFor m) -> m () + modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m effects () + putStore :: StoreFor (ValueFor m) -> m effects () putStore = modifyStore . const -- | Retrieve the table of evaluated modules. - getModuleTable :: m (ModuleTable (ValueFor m)) + getModuleTable :: m effects (ModuleTable (ValueFor m)) -- | Update the table of evaluated modules. - modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m () + modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m effects () -- | Retrieve the table of unevaluated modules. - askModuleTable :: m (ModuleTable (TermFor m)) + askModuleTable :: m effects (ModuleTable (TermFor m)) -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m a -> m a + localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m effects a -> m effects a -- | Retrieve the current root set. - askRoots :: Ord (LocationFor (ValueFor m)) => m (Live (LocationFor (ValueFor m)) (ValueFor m)) + askRoots :: Ord (LocationFor (ValueFor m)) => m effects (Live (LocationFor (ValueFor m)) (ValueFor m)) askRoots = pure mempty -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) + getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m effects (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 81dec141d..9ab5b32c0 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -16,41 +16,40 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadEvaluator m, v ~ ValueFor m) => MonadValue v m where +class (MonadEvaluator effects m, v ~ ValueFor m) => MonadValue v effects m where -- | Construct an abstract unit value. - unit :: m v + unit :: m effects v -- | Construct an abstract integral value. - integer :: Prelude.Integer -> m v + integer :: Prelude.Integer -> m effects v -- | Construct an abstract boolean value. - boolean :: Bool -> m v + boolean :: Bool -> m effects v -- | Construct an abstract string value. - string :: ByteString -> m v + string :: ByteString -> m effects v -- | Construct a floating-point value. - float :: Scientific -> m v + float :: Scientific -> m effects v -- | Eliminate boolean values. TODO: s/boolean/truthy - ifthenelse :: v -> m v -> m v -> m v + ifthenelse :: v -> m effects v -> m effects v -> m effects v -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: [Name] -> Subterm (TermFor m) (m v) -> m v + abstract :: [Name] -> Subterm (TermFor m) (m effects v) -> m effects v -- | Evaluate an application (like a function call). - apply :: v -> [Subterm (TermFor m) (m v)] -> m v + apply :: v -> [Subterm (TermFor m) (m effects v)] -> m effects v -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables t - , MonadAddressable location m - , MonadAnalysis m + , MonadAddressable location effects m + , MonadAnalysis effects m , TermFor m ~ t , ValueFor m ~ Value location t - , MonadEvaluator m , Recursive t , Semigroup (Cell location (Value location t)) ) - => MonadValue (Value location t) m where + => MonadValue (Value location t) effects m where unit = pure $ inj Value.Unit integer = pure . inj . Integer @@ -74,7 +73,7 @@ instance ( FreeVariables t localEnv (mappend bindings) (evaluateTerm body) -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative m, MonadEvaluator m, MonadFresh m, ValueFor m ~ Type) => MonadValue Type m where +instance (Alternative (m effects), MonadEvaluator effects m, MonadFresh (m effects), ValueFor m ~ Type) => MonadValue Type effects m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index b3c9c495d..3a926d675 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -31,12 +31,12 @@ class Evaluatable constr where eval :: ( term ~ TermFor m , value ~ ValueFor m , FreeVariables term - , MonadAddressable (LocationFor value) m - , MonadAnalysis m - , MonadValue value m + , MonadAddressable (LocationFor value) effects m + , MonadAnalysis effects m + , MonadValue value effects m ) - => SubtermAlgebra constr term (m value) - default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) + => SubtermAlgebra constr term (m effects value) + default eval :: (MonadAnalysis effects m, Show1 constr) => SubtermAlgebra constr term (m effects value) eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "" -- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'. @@ -74,10 +74,10 @@ instance Evaluatable [] where -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. require :: ( FreeVariables (TermFor m) - , MonadAnalysis m + , MonadAnalysis effects m ) => TermFor m - -> m (ValueFor m) + -> m effects (ValueFor m) require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup name where name = moduleName term @@ -85,10 +85,10 @@ require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup nam -- -- Always loads/evaluates. load :: ( FreeVariables (TermFor m) - , MonadAnalysis m + , MonadAnalysis effects m ) => TermFor m - -> m (ValueFor m) + -> m effects (ValueFor m) load term = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name where name = moduleName term notFound = fail ("cannot find " <> show name) From 9a3cba982dbb4eb3e058bfeb7514a84587de8866 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 14:42:20 -0500 Subject: [PATCH 201/292] Refactor the type synonyms a little. --- src/Semantic/Util.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 727faf4e5..5280f5a9a 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,12 +46,12 @@ evaluateRubyFiles paths = do -- Python typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type)) @(CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[])) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue)) @(Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = run @(TracingAnalysis [] PythonEvaluating) @(Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])) . evaluateModule . snd <$> parseFile pythonParser path -type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue) +type PythonEvaluating = Evaluating Python.Term PythonValue type PythonTracerEffects = DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue '[] -evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) @PythonTracerEffects . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis (TracingAnalysis [] PythonEvaluating)) @PythonTracerEffects . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From 95e6de97ee14824d70daddc720cf28e393a0ceae Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 14:42:25 -0500 Subject: [PATCH 202/292] Revert "Refactor the type synonyms a little." This reverts commit 9ea8b80a185ce32933844f4787989877dd71f0e5. --- src/Semantic/Util.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 5280f5a9a..727faf4e5 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,12 +46,12 @@ evaluateRubyFiles paths = do -- Python typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type)) @(CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[])) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = run @(TracingAnalysis [] PythonEvaluating) @(Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue)) @(Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])) . evaluateModule . snd <$> parseFile pythonParser path -type PythonEvaluating = Evaluating Python.Term PythonValue +type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue) type PythonTracerEffects = DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue '[] -evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis (TracingAnalysis [] PythonEvaluating)) @PythonTracerEffects . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) @PythonTracerEffects . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From bbab0c7f6949aa94d3da4389aecf00318ad1f216 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 14:42:30 -0500 Subject: [PATCH 203/292] Revert "Parameterize the typeclasses by the list of effects." This reverts commit d922393406bce47366f9269f63edbf93b19d13c1. --- src/Analysis/Abstract/Caching.hs | 69 ++++++++++++++--------------- src/Analysis/Abstract/Dead.hs | 23 +++++----- src/Analysis/Abstract/Evaluating.hs | 22 ++++----- src/Analysis/Abstract/Tracing.hs | 26 +++++------ src/Control/Abstract/Addressable.hs | 26 +++++------ src/Control/Abstract/Analysis.hs | 26 +++++------ src/Control/Abstract/Evaluator.hs | 30 ++++++------- src/Control/Abstract/Value.hs | 27 +++++------ src/Data/Abstract/Evaluatable.hs | 18 ++++---- 9 files changed, 132 insertions(+), 135 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 9a1c4f608..1591b31c5 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -34,52 +34,51 @@ type CachingEffects term value effects type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) newtype CachingAnalysis m (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m effects a } - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadEvaluator effects m => MonadEvaluator effects (CachingAnalysis m) -- TODO: reabstract these later on type InCacheEffectFor m = Reader (CacheFor m) type OutCacheEffectFor m = State (CacheFor m) -askCache :: (Effectful m, Member (InCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m) +askCache :: (Effectful m, Member (InCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) askCache = lift ask -localCache :: (Effectful m, Member (InCacheEffectFor m) effects) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects a -> CachingAnalysis m effects a +localCache :: (Effectful m, Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects a -> CachingAnalysis m effects a localCache f a = lift (local f (lower a)) -asksCache :: (Functor (m effects), Effectful m, Member (InCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a +asksCache :: (Functor (m effects), Effectful m, Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a asksCache f = f <$> askCache -getsCache :: (Functor (m effects), Effectful m, Member (OutCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a +getsCache :: (Functor (m effects), Effectful m, Member (OutCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a getsCache f = f <$> getCache -getCache :: (Effectful m, Member (OutCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m) +getCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) getCache = lift get -putCache :: (Effectful m, Member (OutCacheEffectFor m) effects) => CacheFor m -> CachingAnalysis m effects () +putCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects) => CacheFor (m effects) -> CachingAnalysis m effects () putCache = lift . put -modifyCache :: (Effectful m, Member (OutCacheEffectFor m) effects, Monad (m effects)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects () +modifyCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects, Monad (m effects)) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. -instance ( Corecursive (TermFor m) - , Ord (TermFor m) - , Ord (ValueFor m) - , Ord (CellFor (ValueFor m)) - , Ord (LocationFor (ValueFor m)) +instance ( Corecursive (TermFor (m effects)) + , Ord (TermFor (m effects)) + , Ord (ValueFor (m effects)) + , Ord (CellFor (ValueFor (m effects))) + , Ord (LocationFor (ValueFor (m effects))) , Effectful m , MonadFresh (m effects) , MonadNonDet (m effects) - , Members (CachingEffectsFor m) effects - , Evaluatable (Base (TermFor m)) - , Foldable (Cell (LocationFor (ValueFor m))) - , FreeVariables (TermFor m) - , MonadAnalysis effects m - , Recursive (TermFor m) + , Members (CachingEffectsFor (m effects)) effects + , Evaluatable (Base (TermFor (m effects))) + , Foldable (Cell (LocationFor (ValueFor (m effects)))) + , FreeVariables (TermFor (m effects)) + , MonadAnalysis (m effects) + , Recursive (TermFor (m effects)) ) - => MonadAnalysis effects (CachingAnalysis m) where + => MonadAnalysis (CachingAnalysis m effects) where analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -113,26 +112,26 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative (m effects), Foldable t, MonadEvaluator effects m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m effects a +scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: ( Ord (ValueFor m) - , Ord (TermFor m) - , Ord (LocationFor (ValueFor m)) - , Ord (CellFor (ValueFor m)) +memoizeEval :: ( Ord (ValueFor (m effects)) + , Ord (TermFor (m effects)) + , Ord (LocationFor (ValueFor (m effects))) + , Ord (CellFor (ValueFor (m effects))) , Alternative (m effects) - , Corecursive (TermFor m) - , FreeVariables (TermFor m) - , Foldable (Cell (LocationFor (ValueFor m))) - , Functor (Base (TermFor m)) + , Corecursive (TermFor (m effects)) + , FreeVariables (TermFor (m effects)) + , Foldable (Cell (LocationFor (ValueFor (m effects)))) + , Functor (Base (TermFor (m effects))) , Effectful m - , Members (CachingEffectsFor m) effects - , Recursive (TermFor m) - , MonadAnalysis effects m - -- , Semigroup (CellFor (ValueFor m)) + , Members (CachingEffectsFor (m effects)) effects + , Recursive (TermFor (m effects)) + , MonadAnalysis (m effects) + -- , Semigroup (CellFor (ValueFor (m effects))) ) - => SubtermAlgebra (Base (TermFor m)) (TermFor m) (CachingAnalysis m effects (ValueFor m)) + => SubtermAlgebra (Base (TermFor (m effects))) (TermFor (m effects)) (CachingAnalysis m effects (ValueFor (m effects))) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 7bb0aa371..71db4e775 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,9 +13,8 @@ type DeadCode term = State (Dead term) -- | An analysis tracking dead (unreachable) code. newtype DeadCodeAnalysis m (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m effects a } - deriving (Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) -deriving instance MonadEvaluator effects m => MonadEvaluator effects (DeadCodeAnalysis m) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } @@ -24,11 +23,11 @@ newtype Dead term = Dead { unDead :: Set term } deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: (Effectful m, Member (State (Dead (TermFor m))) effects) => Dead (TermFor m) -> DeadCodeAnalysis m effects () +killAll :: (Effectful m, Member (State (Dead (TermFor (m effects)))) effects) => Dead (TermFor (m effects)) -> DeadCodeAnalysis m effects () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful m, Member (State (Dead (TermFor m))) effects) => Ord (TermFor m) => TermFor m -> DeadCodeAnalysis m effects () +revive :: (Effectful m, Member (State (Dead (TermFor (m effects)))) effects) => Ord (TermFor (m effects)) => (TermFor (m effects)) -> DeadCodeAnalysis m effects () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -36,16 +35,16 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter subterms term = term `cons` para (foldMap (uncurry cons)) term -instance ( Corecursive (TermFor m) +instance ( Corecursive (TermFor (m effects)) , Effectful m - , Foldable (Base (TermFor m)) - , Member (State (Dead (TermFor m))) effects - , MonadAnalysis effects m - , MonadEvaluator effects m - , Ord (TermFor m) - , Recursive (TermFor m) + , Foldable (Base (TermFor (m effects))) + , Member (State (Dead (TermFor (m effects)))) effects + , MonadAnalysis (m effects) + , MonadEvaluator (m effects) + , Ord (TermFor (m effects)) + , Recursive (TermFor (m effects)) ) - => MonadAnalysis effects (DeadCodeAnalysis m) where + => MonadAnalysis (DeadCodeAnalysis m effects) where analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 2f4155291..4d29ee286 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,8 +21,8 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value) - , MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) + , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) , Recursive term ) => term @@ -33,8 +33,8 @@ evaluate = run @(Evaluating term value) @(EvaluatingEffects term value '[]) . ev evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value) - , MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) + , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated @@ -43,7 +43,7 @@ evaluates :: forall value term evaluates pairs (_, t) = run @(Evaluating term value) @(EvaluatingEffects term value '[]) (withModules pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. -withModules :: (MonadAnalysis effects m, MonadEvaluator effects m) => [(Blob, TermFor m)] -> m effects a -> m effects a +withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) @@ -68,9 +68,9 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator effects (Evaluating term value) where - type TermFor (Evaluating term value) = term - type ValueFor (Evaluating term value) = value +instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (Evaluating term value effects) where + type TermFor (Evaluating term value effects) = term + type ValueFor (Evaluating term value effects) = value getGlobalEnv = lift get modifyGlobalEnv f = lift (modify f) @@ -90,9 +90,9 @@ instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator ef instance ( Evaluatable (Base term) , FreeVariables term , Members (EvaluatingEffects term value '[]) effects - , MonadAddressable (LocationFor value) effects (Evaluating term value) - , MonadValue value effects (Evaluating term value) + , MonadAddressable (LocationFor value) (Evaluating term value effects) + , MonadValue value (Evaluating term value effects) , Recursive term ) - => MonadAnalysis effects (Evaluating term value) where + => MonadAnalysis (Evaluating term value effects) where analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index ef7628bd9..2359f0170 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Analysis @@ -18,28 +18,26 @@ type TracerFor trace m = Writer (TraceFor trace m) -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m (effects :: [* -> *]) a = TracingAnalysis { runTracingAnalysis :: m effects a } - deriving (Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) -deriving instance MonadEvaluator effects m => MonadEvaluator effects (TracingAnalysis trace m) - -instance ( Corecursive (TermFor m) +instance ( Corecursive (TermFor (m effects)) , Effectful m - , Member (TracerFor trace m) effects - , MonadAnalysis effects m - , MonadEvaluator effects m - , Ord (LocationFor (ValueFor m)) - , Recursive (TermFor m) - , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) + , Member (TracerFor trace (m effects)) effects + , MonadAnalysis (m effects) + , MonadEvaluator (m effects) + , Ord (LocationFor (ValueFor (m effects))) + , Recursive (TermFor (m effects)) + , Reducer (ConfigurationFor (TermFor (m effects)) (ValueFor (m effects))) (TraceFor trace (m effects)) ) - => MonadAnalysis effects (TracingAnalysis trace m) where + => MonadAnalysis (TracingAnalysis trace m effects) where analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) liftAnalyze analyzeTerm term trace :: ( Effectful m - , Member (TracerFor trace m) effects + , Member (TracerFor trace (m effects)) effects ) - => TraceFor trace m + => TraceFor trace (m effects) -> TracingAnalysis trace m effects () trace = lift . tell diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 8fcc459f2..91d2c247e 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -15,39 +15,39 @@ import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad (m effects), Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l effects m where +class (Monad m, Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l m where deref :: Address l (ValueFor m) - -> m effects (ValueFor m) + -> m (ValueFor m) alloc :: Name - -> m effects (Address l (ValueFor m)) + -> m (Address l (ValueFor m)) -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- -- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. lookupOrAlloc :: ( FreeVariables t - , MonadAddressable (LocationFor a) effects m - , MonadEvaluator effects m + , MonadAddressable (LocationFor a) m + , MonadEvaluator m , a ~ ValueFor m , Semigroup (CellFor a) ) => t -> a -> Environment (LocationFor a) a - -> m effects (Name, Address (LocationFor a) a) + -> m (Name, Address (LocationFor a) a) lookupOrAlloc term = let [name] = toList (freeVariables term) in lookupOrAlloc' name where -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. lookupOrAlloc' :: ( Semigroup (CellFor a) - , MonadAddressable (LocationFor a) effects m + , MonadAddressable (LocationFor a) m , a ~ ValueFor m - , MonadEvaluator effects m + , MonadEvaluator m ) => Name -> a -> Environment (LocationFor a) a - -> m effects (Name, Address (LocationFor a) a) + -> m (Name, Address (LocationFor a) a) lookupOrAlloc' name v env = do a <- maybe (alloc name) pure (envLookup name env) assign a v @@ -55,20 +55,20 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor a) - , MonadEvaluator effects m + , MonadEvaluator m , a ~ ValueFor m , Reducer a (CellFor a) ) => Address (LocationFor a) a -> a - -> m effects () + -> m () assign address = modifyStore . storeInsert address -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Monad (m effects), MonadEvaluator effects m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise effects m where +instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise m where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -79,7 +79,7 @@ instance (Monad (m effects), MonadEvaluator effects m, LocationFor (ValueFor m) -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative (m effects), Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad (m effects), MonadEvaluator effects m) => MonadAddressable Monovariant effects m where +instance (Alternative m, Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad m, MonadEvaluator m) => MonadAddressable Monovariant m where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index dfc4a8ab5..287957800 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE KindSignatures, MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE PolyKinds, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -20,23 +20,23 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class (MonadEvaluator effects m, Recursive (TermFor m)) => MonadAnalysis effects m where +class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. - analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m effects (ValueFor m)) + analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) - evaluateModule :: TermFor m -> m effects (ValueFor m) + evaluateModule :: TermFor m -> m (ValueFor m) evaluateModule = evaluateTerm -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. -evaluateTerm :: MonadAnalysis effects m => TermFor m -> m effects (ValueFor m) +evaluateTerm :: MonadAnalysis m => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm -liftAnalyze :: ( term ~ TermFor ( m) - , term ~ TermFor (t m) - , value ~ ValueFor ( m) - , value ~ ValueFor (t m) +liftAnalyze :: ( term ~ TermFor ( m effects) + , term ~ TermFor (t m effects) + , value ~ ValueFor ( m effects) + , value ~ ValueFor (t m effects) , Coercible ( m effects value) (t m effects value) , Coercible (t m effects value) ( m effects value) , Functor (Base term) @@ -45,10 +45,10 @@ liftAnalyze :: ( term ~ TermFor ( m) -> SubtermAlgebra (Base term) term (t m effects value) liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -liftEvaluate :: ( term ~ TermFor ( m) - , term ~ TermFor (t m) - , value ~ ValueFor ( m) - , value ~ ValueFor (t m) +liftEvaluate :: ( term ~ TermFor ( m effects) + , term ~ TermFor (t m effects) + , value ~ ValueFor ( m effects) + , value ~ ValueFor (t m effects) , Coercible (m effects value) (t m effects value) ) => (term -> m effects value) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 1dd3c6b66..77341d341 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE ConstrainedClassMethods, TypeFamilies #-} module Control.Abstract.Evaluator where import Data.Abstract.Configuration @@ -14,41 +14,41 @@ import Prologue -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class MonadFail (m effects) => MonadEvaluator (effects :: [* -> *]) m where +class MonadFail m => MonadEvaluator m where type TermFor m type ValueFor m -- | Retrieve the global environment. - getGlobalEnv :: m effects (EnvironmentFor (ValueFor m)) + getGlobalEnv :: m (EnvironmentFor (ValueFor m)) -- | Update the global environment. - modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects () + modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m () -- | Retrieve the local environment. - askLocalEnv :: m effects (EnvironmentFor (ValueFor m)) + askLocalEnv :: m (EnvironmentFor (ValueFor m)) -- | Run an action with a locally-modified environment. - localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects a -> m effects a + localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m a -> m a -- | Retrieve the heap. - getStore :: m effects (StoreFor (ValueFor m)) + getStore :: m (StoreFor (ValueFor m)) -- | Update the heap. - modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m effects () - putStore :: StoreFor (ValueFor m) -> m effects () + modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m () + putStore :: StoreFor (ValueFor m) -> m () putStore = modifyStore . const -- | Retrieve the table of evaluated modules. - getModuleTable :: m effects (ModuleTable (ValueFor m)) + getModuleTable :: m (ModuleTable (ValueFor m)) -- | Update the table of evaluated modules. - modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m effects () + modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m () -- | Retrieve the table of unevaluated modules. - askModuleTable :: m effects (ModuleTable (TermFor m)) + askModuleTable :: m (ModuleTable (TermFor m)) -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m effects a -> m effects a + localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m a -> m a -- | Retrieve the current root set. - askRoots :: Ord (LocationFor (ValueFor m)) => m effects (Live (LocationFor (ValueFor m)) (ValueFor m)) + askRoots :: Ord (LocationFor (ValueFor m)) => m (Live (LocationFor (ValueFor m)) (ValueFor m)) askRoots = pure mempty -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m effects (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) + getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 9ab5b32c0..81dec141d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -16,40 +16,41 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadEvaluator effects m, v ~ ValueFor m) => MonadValue v effects m where +class (MonadEvaluator m, v ~ ValueFor m) => MonadValue v m where -- | Construct an abstract unit value. - unit :: m effects v + unit :: m v -- | Construct an abstract integral value. - integer :: Prelude.Integer -> m effects v + integer :: Prelude.Integer -> m v -- | Construct an abstract boolean value. - boolean :: Bool -> m effects v + boolean :: Bool -> m v -- | Construct an abstract string value. - string :: ByteString -> m effects v + string :: ByteString -> m v -- | Construct a floating-point value. - float :: Scientific -> m effects v + float :: Scientific -> m v -- | Eliminate boolean values. TODO: s/boolean/truthy - ifthenelse :: v -> m effects v -> m effects v -> m effects v + ifthenelse :: v -> m v -> m v -> m v -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: [Name] -> Subterm (TermFor m) (m effects v) -> m effects v + abstract :: [Name] -> Subterm (TermFor m) (m v) -> m v -- | Evaluate an application (like a function call). - apply :: v -> [Subterm (TermFor m) (m effects v)] -> m effects v + apply :: v -> [Subterm (TermFor m) (m v)] -> m v -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables t - , MonadAddressable location effects m - , MonadAnalysis effects m + , MonadAddressable location m + , MonadAnalysis m , TermFor m ~ t , ValueFor m ~ Value location t + , MonadEvaluator m , Recursive t , Semigroup (Cell location (Value location t)) ) - => MonadValue (Value location t) effects m where + => MonadValue (Value location t) m where unit = pure $ inj Value.Unit integer = pure . inj . Integer @@ -73,7 +74,7 @@ instance ( FreeVariables t localEnv (mappend bindings) (evaluateTerm body) -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative (m effects), MonadEvaluator effects m, MonadFresh (m effects), ValueFor m ~ Type) => MonadValue Type effects m where +instance (Alternative m, MonadEvaluator m, MonadFresh m, ValueFor m ~ Type) => MonadValue Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 3a926d675..b3c9c495d 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -31,12 +31,12 @@ class Evaluatable constr where eval :: ( term ~ TermFor m , value ~ ValueFor m , FreeVariables term - , MonadAddressable (LocationFor value) effects m - , MonadAnalysis effects m - , MonadValue value effects m + , MonadAddressable (LocationFor value) m + , MonadAnalysis m + , MonadValue value m ) - => SubtermAlgebra constr term (m effects value) - default eval :: (MonadAnalysis effects m, Show1 constr) => SubtermAlgebra constr term (m effects value) + => SubtermAlgebra constr term (m value) + default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "" -- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'. @@ -74,10 +74,10 @@ instance Evaluatable [] where -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. require :: ( FreeVariables (TermFor m) - , MonadAnalysis effects m + , MonadAnalysis m ) => TermFor m - -> m effects (ValueFor m) + -> m (ValueFor m) require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup name where name = moduleName term @@ -85,10 +85,10 @@ require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup nam -- -- Always loads/evaluates. load :: ( FreeVariables (TermFor m) - , MonadAnalysis effects m + , MonadAnalysis m ) => TermFor m - -> m effects (ValueFor m) + -> m (ValueFor m) load term = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name where name = moduleName term notFound = fail ("cannot find " <> show name) From 6b59dee449eedef315607729f3e7751f982b3698 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 14:55:06 -0500 Subject: [PATCH 204/292] Parameterize Effectful by the effect list. --- src/Analysis/Abstract/Caching.hs | 22 ++++++++++++---------- src/Analysis/Abstract/Dead.hs | 9 +++++---- src/Analysis/Abstract/Evaluating.hs | 10 ++++------ src/Analysis/Abstract/Tracing.hs | 10 ++++++---- src/Control/Effect.hs | 12 ++++++------ src/Semantic/Util.hs | 6 +++--- 6 files changed, 36 insertions(+), 33 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 1591b31c5..4b39424e9 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -34,32 +34,34 @@ type CachingEffects term value effects type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) newtype CachingAnalysis m (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m effects a } - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) + deriving (Alternative, Applicative, Functor, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) + +deriving instance Effectful effects (m effects) => Effectful effects (CachingAnalysis m effects) -- TODO: reabstract these later on type InCacheEffectFor m = Reader (CacheFor m) type OutCacheEffectFor m = State (CacheFor m) -askCache :: (Effectful m, Member (InCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) +askCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) askCache = lift ask -localCache :: (Effectful m, Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects a -> CachingAnalysis m effects a +localCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects a -> CachingAnalysis m effects a localCache f a = lift (local f (lower a)) -asksCache :: (Functor (m effects), Effectful m, Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a +asksCache :: (Functor (m effects), Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a asksCache f = f <$> askCache -getsCache :: (Functor (m effects), Effectful m, Member (OutCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a +getsCache :: (Functor (m effects), Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a getsCache f = f <$> getCache -getCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) +getCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) getCache = lift get -putCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects) => CacheFor (m effects) -> CachingAnalysis m effects () +putCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CacheFor (m effects) -> CachingAnalysis m effects () putCache = lift . put -modifyCache :: (Effectful m, Member (OutCacheEffectFor (m effects)) effects, Monad (m effects)) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects () +modifyCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects, Monad (m effects)) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. @@ -68,7 +70,7 @@ instance ( Corecursive (TermFor (m effects)) , Ord (ValueFor (m effects)) , Ord (CellFor (ValueFor (m effects))) , Ord (LocationFor (ValueFor (m effects))) - , Effectful m + , Effectful effects (m effects) , MonadFresh (m effects) , MonadNonDet (m effects) , Members (CachingEffectsFor (m effects)) effects @@ -125,7 +127,7 @@ memoizeEval :: ( Ord (ValueFor (m effects)) , FreeVariables (TermFor (m effects)) , Foldable (Cell (LocationFor (ValueFor (m effects)))) , Functor (Base (TermFor (m effects))) - , Effectful m + , Effectful effects (m effects) , Members (CachingEffectsFor (m effects)) effects , Recursive (TermFor (m effects)) , MonadAnalysis (m effects) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 71db4e775..5a4e11f60 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,7 +13,7 @@ type DeadCode term = State (Dead term) -- | An analysis tracking dead (unreachable) code. newtype DeadCodeAnalysis m (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m effects a } - deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail) -- | A set of “dead” (unreachable) terms. @@ -21,13 +21,14 @@ newtype Dead term = Dead { unDead :: Set term } deriving (Eq, Foldable, Semigroup, Monoid, Ord, Show) deriving instance Ord term => Reducer term (Dead term) +deriving instance Effectful effects (m effects) => Effectful effects (DeadCodeAnalysis m effects) -- | Update the current 'Dead' set. -killAll :: (Effectful m, Member (State (Dead (TermFor (m effects)))) effects) => Dead (TermFor (m effects)) -> DeadCodeAnalysis m effects () +killAll :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Dead (TermFor (m effects)) -> DeadCodeAnalysis m effects () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful m, Member (State (Dead (TermFor (m effects)))) effects) => Ord (TermFor (m effects)) => (TermFor (m effects)) -> DeadCodeAnalysis m effects () +revive :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Ord (TermFor (m effects)) => (TermFor (m effects)) -> DeadCodeAnalysis m effects () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -36,7 +37,7 @@ subterms term = term `cons` para (foldMap (uncurry cons)) term instance ( Corecursive (TermFor (m effects)) - , Effectful m + , Effectful effects (m effects) , Foldable (Base (TermFor (m effects))) , Member (State (Dead (TermFor (m effects)))) effects , MonadAnalysis (m effects) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 4d29ee286..b26b6446c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -27,7 +27,7 @@ evaluate :: forall value term ) => term -> Final (EvaluatingEffects term value '[]) value -evaluate = run @(Evaluating term value) @(EvaluatingEffects term value '[]) . evaluateModule +evaluate = run . evaluateModule @(Evaluating term value (EvaluatingEffects term value '[])) -- | Evaluate terms and an entry point to a value. evaluates :: forall value term @@ -40,7 +40,7 @@ evaluates :: forall value term => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value '[]) value -evaluates pairs (_, t) = run @(Evaluating term value) @(EvaluatingEffects term value '[]) (withModules pairs (evaluateModule t)) +evaluates pairs (_, t) = run (withModules pairs (evaluateModule @(Evaluating term value (EvaluatingEffects term value '[])) t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a @@ -49,15 +49,13 @@ withModules pairs = localModuleTable (const moduleTable) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff effects a } - deriving (Applicative, Effectful, Functor, Monad) + deriving (Applicative, Functor, Monad) deriving instance Member Fail effects => MonadFail (Evaluating term value effects) deriving instance Member Fresh effects => MonadFresh (Evaluating term value effects) deriving instance Member NonDetEff effects => Alternative (Evaluating term value effects) deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) - --- instance Effectful (Evaluating term value) where --- lift = _ +deriving instance Effectful effects (Evaluating term value effects) type EvaluatingEffects term value effects = Fail -- Failure with an error message diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 2359f0170..e2e66a701 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Analysis @@ -18,10 +18,12 @@ type TracerFor trace m = Writer (TraceFor trace m) -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m (effects :: [* -> *]) a = TracingAnalysis { runTracingAnalysis :: m effects a } - deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail) + +deriving instance Effectful effects (m effects) => Effectful effects (TracingAnalysis trace m effects) instance ( Corecursive (TermFor (m effects)) - , Effectful m + , Effectful effects (m effects) , Member (TracerFor trace (m effects)) effects , MonadAnalysis (m effects) , MonadEvaluator (m effects) @@ -35,7 +37,7 @@ instance ( Corecursive (TermFor (m effects)) trace (Reducer.unit config) liftAnalyze analyzeTerm term -trace :: ( Effectful m +trace :: ( Effectful effects (m effects) , Member (TracerFor trace (m effects)) effects ) => TraceFor trace (m effects) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 79fcd4db6..0b1a5d80b 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies, TypeOperators, UndecidableInstances #-} module Control.Effect where import qualified Control.Monad.Effect as Effect @@ -12,7 +12,7 @@ import Data.Semigroup.Reducer import Prologue -- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result. -run :: (Effectful m, RunEffects effects a) => m effects a -> Final effects a +run :: (Effectful effects m, RunEffects effects a) => m a -> Final effects a run = Effect.run . runEffects . lower -- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults. @@ -66,10 +66,10 @@ instance Ord a => RunEffect NonDetEff a where MPlus -> mappend <$> k True <*> k False) -class Effectful m where - lift :: Eff effects a -> m effects a - lower :: m effects a -> Eff effects a +class Effectful effects m | m -> effects where + lift :: Eff effects a -> m a + lower :: m a -> Eff effects a -instance Effectful Eff where +instance Effectful effects (Eff effects) where lift = id lower = id diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 727faf4e5..c7d3151b4 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -44,14 +44,14 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python -typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type)) @(CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[])) . evaluateModule . snd <$> parseFile pythonParser path +typecheckPythonFile path = run . evaluateModule @(CachingAnalysis (Evaluating Python.Term Type) (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[]))) . snd <$> parseFile pythonParser path -tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue)) @(Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = run . evaluateModule @(TracingAnalysis [] (Evaluating Python.Term PythonValue) (Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[]))) . snd <$> parseFile pythonParser path type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue) type PythonTracerEffects = DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue '[] -evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) @PythonTracerEffects . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = run . evaluateModule @(DeadCodeAnalysis PythonTracer PythonTracerEffects) . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From 3aa0b2eddc4cf733f2a6d800405a1a0745cb2e07 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 15:13:27 -0500 Subject: [PATCH 205/292] Revert "Revert "Parameterize the typeclasses by the list of effects."" This reverts commit fe9c84af96b4046a0b355094b5eb60ec3cc70a45. --- src/Analysis/Abstract/Caching.hs | 68 ++++++++++++++--------------- src/Analysis/Abstract/Dead.hs | 23 +++++----- src/Analysis/Abstract/Evaluating.hs | 26 +++++------ src/Analysis/Abstract/Tracing.hs | 23 +++++----- src/Control/Abstract/Addressable.hs | 26 +++++------ src/Control/Abstract/Analysis.hs | 26 +++++------ src/Control/Abstract/Evaluator.hs | 30 ++++++------- src/Control/Abstract/Value.hs | 27 ++++++------ src/Data/Abstract/Evaluatable.hs | 18 ++++---- src/Semantic/Util.hs | 6 +-- 10 files changed, 137 insertions(+), 136 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 4b39424e9..486fddc39 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -34,53 +34,54 @@ type CachingEffects term value effects type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) newtype CachingAnalysis m (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m effects a } - deriving (Alternative, Applicative, Functor, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) + deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFresh, MonadNonDet) deriving instance Effectful effects (m effects) => Effectful effects (CachingAnalysis m effects) +deriving instance MonadEvaluator effects m => MonadEvaluator effects (CachingAnalysis m) -- TODO: reabstract these later on type InCacheEffectFor m = Reader (CacheFor m) type OutCacheEffectFor m = State (CacheFor m) -askCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) +askCache :: (Effectful effects (m effects), Member (InCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m) askCache = lift ask -localCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects a -> CachingAnalysis m effects a +localCache :: (Effectful effects (m effects), Member (InCacheEffectFor m) effects) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects a -> CachingAnalysis m effects a localCache f a = lift (local f (lower a)) -asksCache :: (Functor (m effects), Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a +asksCache :: (Functor (m effects), Effectful effects (m effects), Member (InCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a asksCache f = f <$> askCache -getsCache :: (Functor (m effects), Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a +getsCache :: (Functor (m effects), Effectful effects (m effects), Member (OutCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a getsCache f = f <$> getCache -getCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) +getCache :: (Effectful effects (m effects), Member (OutCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m) getCache = lift get -putCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CacheFor (m effects) -> CachingAnalysis m effects () +putCache :: (Effectful effects (m effects), Member (OutCacheEffectFor m) effects) => CacheFor m -> CachingAnalysis m effects () putCache = lift . put -modifyCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects, Monad (m effects)) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects () +modifyCache :: (Effectful effects (m effects), Member (OutCacheEffectFor m) effects, Monad (m effects)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. -instance ( Corecursive (TermFor (m effects)) - , Ord (TermFor (m effects)) - , Ord (ValueFor (m effects)) - , Ord (CellFor (ValueFor (m effects))) - , Ord (LocationFor (ValueFor (m effects))) +instance ( Corecursive (TermFor m) + , Ord (TermFor m) + , Ord (ValueFor m) + , Ord (CellFor (ValueFor m)) + , Ord (LocationFor (ValueFor m)) , Effectful effects (m effects) , MonadFresh (m effects) , MonadNonDet (m effects) - , Members (CachingEffectsFor (m effects)) effects - , Evaluatable (Base (TermFor (m effects))) - , Foldable (Cell (LocationFor (ValueFor (m effects)))) - , FreeVariables (TermFor (m effects)) - , MonadAnalysis (m effects) - , Recursive (TermFor (m effects)) + , Members (CachingEffectsFor m) effects + , Evaluatable (Base (TermFor m)) + , Foldable (Cell (LocationFor (ValueFor m))) + , FreeVariables (TermFor m) + , MonadAnalysis effects m + , Recursive (TermFor m) ) - => MonadAnalysis (CachingAnalysis m effects) where + => MonadAnalysis effects (CachingAnalysis m) where analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -114,26 +115,25 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m a +scatter :: (Alternative (m effects), Foldable t, MonadEvaluator effects m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m effects a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: ( Ord (ValueFor (m effects)) - , Ord (TermFor (m effects)) - , Ord (LocationFor (ValueFor (m effects))) - , Ord (CellFor (ValueFor (m effects))) +memoizeEval :: ( Ord (ValueFor m) + , Ord (TermFor m) + , Ord (LocationFor (ValueFor m)) + , Ord (CellFor (ValueFor m)) , Alternative (m effects) - , Corecursive (TermFor (m effects)) - , FreeVariables (TermFor (m effects)) - , Foldable (Cell (LocationFor (ValueFor (m effects)))) - , Functor (Base (TermFor (m effects))) + , Corecursive (TermFor m) + , FreeVariables (TermFor m) + , Foldable (Cell (LocationFor (ValueFor m))) + , Functor (Base (TermFor m)) , Effectful effects (m effects) - , Members (CachingEffectsFor (m effects)) effects - , Recursive (TermFor (m effects)) - , MonadAnalysis (m effects) - -- , Semigroup (CellFor (ValueFor (m effects))) + , Members (CachingEffectsFor m) effects + , Recursive (TermFor m) + , MonadAnalysis effects m ) - => SubtermAlgebra (Base (TermFor (m effects))) (TermFor (m effects)) (CachingAnalysis m effects (ValueFor (m effects))) + => SubtermAlgebra (Base (TermFor m)) (TermFor m) (CachingAnalysis m effects (ValueFor m)) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 5a4e11f60..3b1e82465 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,8 +13,9 @@ type DeadCode term = State (Dead term) -- | An analysis tracking dead (unreachable) code. newtype DeadCodeAnalysis m (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m effects a } - deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, Monad, MonadFail) +deriving instance MonadEvaluator effects m => MonadEvaluator effects (DeadCodeAnalysis m) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } @@ -24,11 +25,11 @@ deriving instance Ord term => Reducer term (Dead term) deriving instance Effectful effects (m effects) => Effectful effects (DeadCodeAnalysis m effects) -- | Update the current 'Dead' set. -killAll :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Dead (TermFor (m effects)) -> DeadCodeAnalysis m effects () +killAll :: (Effectful effects (m effects), Member (State (Dead (TermFor m))) effects) => Dead (TermFor m) -> DeadCodeAnalysis m effects () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Ord (TermFor (m effects)) => (TermFor (m effects)) -> DeadCodeAnalysis m effects () +revive :: (Effectful effects (m effects), Member (State (Dead (TermFor m))) effects) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m effects () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -36,16 +37,16 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter subterms term = term `cons` para (foldMap (uncurry cons)) term -instance ( Corecursive (TermFor (m effects)) +instance ( Corecursive (TermFor m) , Effectful effects (m effects) - , Foldable (Base (TermFor (m effects))) - , Member (State (Dead (TermFor (m effects)))) effects - , MonadAnalysis (m effects) - , MonadEvaluator (m effects) - , Ord (TermFor (m effects)) - , Recursive (TermFor (m effects)) + , Foldable (Base (TermFor m)) + , Member (State (Dead (TermFor m))) effects + , MonadAnalysis effects m + , MonadEvaluator effects m + , Ord (TermFor m) + , Recursive (TermFor m) ) - => MonadAnalysis (DeadCodeAnalysis m effects) where + => MonadAnalysis effects (DeadCodeAnalysis m) where analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b26b6446c..b4703078e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,29 +21,29 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) - , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) + , MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value) + , MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value) , Recursive term ) => term -> Final (EvaluatingEffects term value '[]) value -evaluate = run . evaluateModule @(Evaluating term value (EvaluatingEffects term value '[])) +evaluate = run . evaluateModule @(EvaluatingEffects term value '[]) @(Evaluating term value) -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) - , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) + , MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value) + , MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value '[]) value -evaluates pairs (_, t) = run (withModules pairs (evaluateModule @(Evaluating term value (EvaluatingEffects term value '[])) t)) +evaluates pairs (_, t) = run (withModules pairs (evaluateModule @(EvaluatingEffects term value '[]) @(Evaluating term value) t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. -withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a +withModules :: (MonadAnalysis effects m, MonadEvaluator effects m) => [(Blob, TermFor m)] -> m effects a -> m effects a withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) @@ -66,9 +66,9 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (Evaluating term value effects) where - type TermFor (Evaluating term value effects) = term - type ValueFor (Evaluating term value effects) = value +instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator effects (Evaluating term value) where + type TermFor (Evaluating term value) = term + type ValueFor (Evaluating term value) = value getGlobalEnv = lift get modifyGlobalEnv f = lift (modify f) @@ -88,9 +88,9 @@ instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (E instance ( Evaluatable (Base term) , FreeVariables term , Members (EvaluatingEffects term value '[]) effects - , MonadAddressable (LocationFor value) (Evaluating term value effects) - , MonadValue value (Evaluating term value effects) + , MonadAddressable (LocationFor value) effects (Evaluating term value) + , MonadValue value effects (Evaluating term value) , Recursive term ) - => MonadAnalysis (Evaluating term value effects) where + => MonadAnalysis effects (Evaluating term value) where analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index e2e66a701..a839b3c2c 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -18,28 +18,29 @@ type TracerFor trace m = Writer (TraceFor trace m) -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m (effects :: [* -> *]) a = TracingAnalysis { runTracingAnalysis :: m effects a } - deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail) + deriving (Applicative, Functor, Monad, MonadFail) deriving instance Effectful effects (m effects) => Effectful effects (TracingAnalysis trace m effects) +deriving instance MonadEvaluator effects m => MonadEvaluator effects (TracingAnalysis trace m) -instance ( Corecursive (TermFor (m effects)) +instance ( Corecursive (TermFor m) , Effectful effects (m effects) - , Member (TracerFor trace (m effects)) effects - , MonadAnalysis (m effects) - , MonadEvaluator (m effects) - , Ord (LocationFor (ValueFor (m effects))) - , Recursive (TermFor (m effects)) - , Reducer (ConfigurationFor (TermFor (m effects)) (ValueFor (m effects))) (TraceFor trace (m effects)) + , Member (TracerFor trace m) effects + , MonadAnalysis effects m + , MonadEvaluator effects m + , Ord (LocationFor (ValueFor m)) + , Recursive (TermFor m) + , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) ) - => MonadAnalysis (TracingAnalysis trace m effects) where + => MonadAnalysis effects (TracingAnalysis trace m) where analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) liftAnalyze analyzeTerm term trace :: ( Effectful effects (m effects) - , Member (TracerFor trace (m effects)) effects + , Member (TracerFor trace m) effects ) - => TraceFor trace (m effects) + => TraceFor trace m -> TracingAnalysis trace m effects () trace = lift . tell diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 91d2c247e..8fcc459f2 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -15,39 +15,39 @@ import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad m, Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l m where +class (Monad (m effects), Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l effects m where deref :: Address l (ValueFor m) - -> m (ValueFor m) + -> m effects (ValueFor m) alloc :: Name - -> m (Address l (ValueFor m)) + -> m effects (Address l (ValueFor m)) -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- -- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. lookupOrAlloc :: ( FreeVariables t - , MonadAddressable (LocationFor a) m - , MonadEvaluator m + , MonadAddressable (LocationFor a) effects m + , MonadEvaluator effects m , a ~ ValueFor m , Semigroup (CellFor a) ) => t -> a -> Environment (LocationFor a) a - -> m (Name, Address (LocationFor a) a) + -> m effects (Name, Address (LocationFor a) a) lookupOrAlloc term = let [name] = toList (freeVariables term) in lookupOrAlloc' name where -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. lookupOrAlloc' :: ( Semigroup (CellFor a) - , MonadAddressable (LocationFor a) m + , MonadAddressable (LocationFor a) effects m , a ~ ValueFor m - , MonadEvaluator m + , MonadEvaluator effects m ) => Name -> a -> Environment (LocationFor a) a - -> m (Name, Address (LocationFor a) a) + -> m effects (Name, Address (LocationFor a) a) lookupOrAlloc' name v env = do a <- maybe (alloc name) pure (envLookup name env) assign a v @@ -55,20 +55,20 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor a) - , MonadEvaluator m + , MonadEvaluator effects m , a ~ ValueFor m , Reducer a (CellFor a) ) => Address (LocationFor a) a -> a - -> m () + -> m effects () assign address = modifyStore . storeInsert address -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise m where +instance (Monad (m effects), MonadEvaluator effects m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise effects m where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -79,7 +79,7 @@ instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => Mona -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad m, MonadEvaluator m) => MonadAddressable Monovariant m where +instance (Alternative (m effects), Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad (m effects), MonadEvaluator effects m) => MonadAddressable Monovariant effects m where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 287957800..dfc4a8ab5 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PolyKinds, TypeFamilies #-} +{-# LANGUAGE KindSignatures, MultiParamTypeClasses, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -20,23 +20,23 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where +class (MonadEvaluator effects m, Recursive (TermFor m)) => MonadAnalysis effects m where -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. - analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) + analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m effects (ValueFor m)) - evaluateModule :: TermFor m -> m (ValueFor m) + evaluateModule :: TermFor m -> m effects (ValueFor m) evaluateModule = evaluateTerm -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. -evaluateTerm :: MonadAnalysis m => TermFor m -> m (ValueFor m) +evaluateTerm :: MonadAnalysis effects m => TermFor m -> m effects (ValueFor m) evaluateTerm = foldSubterms analyzeTerm -liftAnalyze :: ( term ~ TermFor ( m effects) - , term ~ TermFor (t m effects) - , value ~ ValueFor ( m effects) - , value ~ ValueFor (t m effects) +liftAnalyze :: ( term ~ TermFor ( m) + , term ~ TermFor (t m) + , value ~ ValueFor ( m) + , value ~ ValueFor (t m) , Coercible ( m effects value) (t m effects value) , Coercible (t m effects value) ( m effects value) , Functor (Base term) @@ -45,10 +45,10 @@ liftAnalyze :: ( term ~ TermFor ( m effects) -> SubtermAlgebra (Base term) term (t m effects value) liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -liftEvaluate :: ( term ~ TermFor ( m effects) - , term ~ TermFor (t m effects) - , value ~ ValueFor ( m effects) - , value ~ ValueFor (t m effects) +liftEvaluate :: ( term ~ TermFor ( m) + , term ~ TermFor (t m) + , value ~ ValueFor ( m) + , value ~ ValueFor (t m) , Coercible (m effects value) (t m effects value) ) => (term -> m effects value) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 77341d341..1dd3c6b66 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, TypeFamilies #-} +{-# LANGUAGE ConstrainedClassMethods, DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies #-} module Control.Abstract.Evaluator where import Data.Abstract.Configuration @@ -14,41 +14,41 @@ import Prologue -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class MonadFail m => MonadEvaluator m where +class MonadFail (m effects) => MonadEvaluator (effects :: [* -> *]) m where type TermFor m type ValueFor m -- | Retrieve the global environment. - getGlobalEnv :: m (EnvironmentFor (ValueFor m)) + getGlobalEnv :: m effects (EnvironmentFor (ValueFor m)) -- | Update the global environment. - modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m () + modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects () -- | Retrieve the local environment. - askLocalEnv :: m (EnvironmentFor (ValueFor m)) + askLocalEnv :: m effects (EnvironmentFor (ValueFor m)) -- | Run an action with a locally-modified environment. - localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m a -> m a + localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects a -> m effects a -- | Retrieve the heap. - getStore :: m (StoreFor (ValueFor m)) + getStore :: m effects (StoreFor (ValueFor m)) -- | Update the heap. - modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m () - putStore :: StoreFor (ValueFor m) -> m () + modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m effects () + putStore :: StoreFor (ValueFor m) -> m effects () putStore = modifyStore . const -- | Retrieve the table of evaluated modules. - getModuleTable :: m (ModuleTable (ValueFor m)) + getModuleTable :: m effects (ModuleTable (ValueFor m)) -- | Update the table of evaluated modules. - modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m () + modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m effects () -- | Retrieve the table of unevaluated modules. - askModuleTable :: m (ModuleTable (TermFor m)) + askModuleTable :: m effects (ModuleTable (TermFor m)) -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m a -> m a + localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m effects a -> m effects a -- | Retrieve the current root set. - askRoots :: Ord (LocationFor (ValueFor m)) => m (Live (LocationFor (ValueFor m)) (ValueFor m)) + askRoots :: Ord (LocationFor (ValueFor m)) => m effects (Live (LocationFor (ValueFor m)) (ValueFor m)) askRoots = pure mempty -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) + getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m effects (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 81dec141d..9ab5b32c0 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -16,41 +16,40 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadEvaluator m, v ~ ValueFor m) => MonadValue v m where +class (MonadEvaluator effects m, v ~ ValueFor m) => MonadValue v effects m where -- | Construct an abstract unit value. - unit :: m v + unit :: m effects v -- | Construct an abstract integral value. - integer :: Prelude.Integer -> m v + integer :: Prelude.Integer -> m effects v -- | Construct an abstract boolean value. - boolean :: Bool -> m v + boolean :: Bool -> m effects v -- | Construct an abstract string value. - string :: ByteString -> m v + string :: ByteString -> m effects v -- | Construct a floating-point value. - float :: Scientific -> m v + float :: Scientific -> m effects v -- | Eliminate boolean values. TODO: s/boolean/truthy - ifthenelse :: v -> m v -> m v -> m v + ifthenelse :: v -> m effects v -> m effects v -> m effects v -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: [Name] -> Subterm (TermFor m) (m v) -> m v + abstract :: [Name] -> Subterm (TermFor m) (m effects v) -> m effects v -- | Evaluate an application (like a function call). - apply :: v -> [Subterm (TermFor m) (m v)] -> m v + apply :: v -> [Subterm (TermFor m) (m effects v)] -> m effects v -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables t - , MonadAddressable location m - , MonadAnalysis m + , MonadAddressable location effects m + , MonadAnalysis effects m , TermFor m ~ t , ValueFor m ~ Value location t - , MonadEvaluator m , Recursive t , Semigroup (Cell location (Value location t)) ) - => MonadValue (Value location t) m where + => MonadValue (Value location t) effects m where unit = pure $ inj Value.Unit integer = pure . inj . Integer @@ -74,7 +73,7 @@ instance ( FreeVariables t localEnv (mappend bindings) (evaluateTerm body) -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative m, MonadEvaluator m, MonadFresh m, ValueFor m ~ Type) => MonadValue Type m where +instance (Alternative (m effects), MonadEvaluator effects m, MonadFresh (m effects), ValueFor m ~ Type) => MonadValue Type effects m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index b3c9c495d..3a926d675 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -31,12 +31,12 @@ class Evaluatable constr where eval :: ( term ~ TermFor m , value ~ ValueFor m , FreeVariables term - , MonadAddressable (LocationFor value) m - , MonadAnalysis m - , MonadValue value m + , MonadAddressable (LocationFor value) effects m + , MonadAnalysis effects m + , MonadValue value effects m ) - => SubtermAlgebra constr term (m value) - default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) + => SubtermAlgebra constr term (m effects value) + default eval :: (MonadAnalysis effects m, Show1 constr) => SubtermAlgebra constr term (m effects value) eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "" -- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'. @@ -74,10 +74,10 @@ instance Evaluatable [] where -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. require :: ( FreeVariables (TermFor m) - , MonadAnalysis m + , MonadAnalysis effects m ) => TermFor m - -> m (ValueFor m) + -> m effects (ValueFor m) require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup name where name = moduleName term @@ -85,10 +85,10 @@ require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup nam -- -- Always loads/evaluates. load :: ( FreeVariables (TermFor m) - , MonadAnalysis m + , MonadAnalysis effects m ) => TermFor m - -> m (ValueFor m) + -> m effects (ValueFor m) load term = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name where name = moduleName term notFound = fail ("cannot find " <> show name) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index c7d3151b4..c0444e3a7 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -44,14 +44,14 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python -typecheckPythonFile path = run . evaluateModule @(CachingAnalysis (Evaluating Python.Term Type) (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[]))) . snd <$> parseFile pythonParser path +typecheckPythonFile path = run . evaluateModule @(CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[])) @(CachingAnalysis (Evaluating Python.Term Type)) . snd <$> parseFile pythonParser path -tracePythonFile path = run . evaluateModule @(TracingAnalysis [] (Evaluating Python.Term PythonValue) (Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[]))) . snd <$> parseFile pythonParser path +tracePythonFile path = run . evaluateModule @(Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])) @(TracingAnalysis [] (Evaluating Python.Term PythonValue)) . snd <$> parseFile pythonParser path type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue) type PythonTracerEffects = DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue '[] -evaluateDeadTracePythonFile path = run . evaluateModule @(DeadCodeAnalysis PythonTracer PythonTracerEffects) . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = run . evaluateModule @PythonTracerEffects @(DeadCodeAnalysis PythonTracer) . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From 54c1f0d2e98260516a3b726738ceb643bf26c29f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 16:17:07 -0500 Subject: [PATCH 206/292] Revert "Revert "Revert "Parameterize the typeclasses by the list of effects.""" This reverts commit 81dc8c50484cf7c415eb3f754ca5fbb934517f2a. --- src/Analysis/Abstract/Caching.hs | 68 ++++++++++++++--------------- src/Analysis/Abstract/Dead.hs | 23 +++++----- src/Analysis/Abstract/Evaluating.hs | 26 +++++------ src/Analysis/Abstract/Tracing.hs | 23 +++++----- src/Control/Abstract/Addressable.hs | 26 +++++------ src/Control/Abstract/Analysis.hs | 26 +++++------ src/Control/Abstract/Evaluator.hs | 30 ++++++------- src/Control/Abstract/Value.hs | 27 ++++++------ src/Data/Abstract/Evaluatable.hs | 18 ++++---- src/Semantic/Util.hs | 6 +-- 10 files changed, 136 insertions(+), 137 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 486fddc39..4b39424e9 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -34,54 +34,53 @@ type CachingEffects term value effects type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) newtype CachingAnalysis m (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m effects a } - deriving (Alternative, Applicative, Functor, Monad, MonadFail, MonadFresh, MonadNonDet) + deriving (Alternative, Applicative, Functor, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) deriving instance Effectful effects (m effects) => Effectful effects (CachingAnalysis m effects) -deriving instance MonadEvaluator effects m => MonadEvaluator effects (CachingAnalysis m) -- TODO: reabstract these later on type InCacheEffectFor m = Reader (CacheFor m) type OutCacheEffectFor m = State (CacheFor m) -askCache :: (Effectful effects (m effects), Member (InCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m) +askCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) askCache = lift ask -localCache :: (Effectful effects (m effects), Member (InCacheEffectFor m) effects) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects a -> CachingAnalysis m effects a +localCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects a -> CachingAnalysis m effects a localCache f a = lift (local f (lower a)) -asksCache :: (Functor (m effects), Effectful effects (m effects), Member (InCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a +asksCache :: (Functor (m effects), Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a asksCache f = f <$> askCache -getsCache :: (Functor (m effects), Effectful effects (m effects), Member (OutCacheEffectFor m) effects) => (CacheFor m -> a) -> CachingAnalysis m effects a +getsCache :: (Functor (m effects), Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a getsCache f = f <$> getCache -getCache :: (Effectful effects (m effects), Member (OutCacheEffectFor m) effects) => CachingAnalysis m effects (CacheFor m) +getCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) getCache = lift get -putCache :: (Effectful effects (m effects), Member (OutCacheEffectFor m) effects) => CacheFor m -> CachingAnalysis m effects () +putCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CacheFor (m effects) -> CachingAnalysis m effects () putCache = lift . put -modifyCache :: (Effectful effects (m effects), Member (OutCacheEffectFor m) effects, Monad (m effects)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m effects () +modifyCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects, Monad (m effects)) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. -instance ( Corecursive (TermFor m) - , Ord (TermFor m) - , Ord (ValueFor m) - , Ord (CellFor (ValueFor m)) - , Ord (LocationFor (ValueFor m)) +instance ( Corecursive (TermFor (m effects)) + , Ord (TermFor (m effects)) + , Ord (ValueFor (m effects)) + , Ord (CellFor (ValueFor (m effects))) + , Ord (LocationFor (ValueFor (m effects))) , Effectful effects (m effects) , MonadFresh (m effects) , MonadNonDet (m effects) - , Members (CachingEffectsFor m) effects - , Evaluatable (Base (TermFor m)) - , Foldable (Cell (LocationFor (ValueFor m))) - , FreeVariables (TermFor m) - , MonadAnalysis effects m - , Recursive (TermFor m) + , Members (CachingEffectsFor (m effects)) effects + , Evaluatable (Base (TermFor (m effects))) + , Foldable (Cell (LocationFor (ValueFor (m effects)))) + , FreeVariables (TermFor (m effects)) + , MonadAnalysis (m effects) + , Recursive (TermFor (m effects)) ) - => MonadAnalysis effects (CachingAnalysis m) where + => MonadAnalysis (CachingAnalysis m effects) where analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -115,25 +114,26 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative (m effects), Foldable t, MonadEvaluator effects m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m effects a +scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: ( Ord (ValueFor m) - , Ord (TermFor m) - , Ord (LocationFor (ValueFor m)) - , Ord (CellFor (ValueFor m)) +memoizeEval :: ( Ord (ValueFor (m effects)) + , Ord (TermFor (m effects)) + , Ord (LocationFor (ValueFor (m effects))) + , Ord (CellFor (ValueFor (m effects))) , Alternative (m effects) - , Corecursive (TermFor m) - , FreeVariables (TermFor m) - , Foldable (Cell (LocationFor (ValueFor m))) - , Functor (Base (TermFor m)) + , Corecursive (TermFor (m effects)) + , FreeVariables (TermFor (m effects)) + , Foldable (Cell (LocationFor (ValueFor (m effects)))) + , Functor (Base (TermFor (m effects))) , Effectful effects (m effects) - , Members (CachingEffectsFor m) effects - , Recursive (TermFor m) - , MonadAnalysis effects m + , Members (CachingEffectsFor (m effects)) effects + , Recursive (TermFor (m effects)) + , MonadAnalysis (m effects) + -- , Semigroup (CellFor (ValueFor (m effects))) ) - => SubtermAlgebra (Base (TermFor m)) (TermFor m) (CachingAnalysis m effects (ValueFor m)) + => SubtermAlgebra (Base (TermFor (m effects))) (TermFor (m effects)) (CachingAnalysis m effects (ValueFor (m effects))) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 3b1e82465..5a4e11f60 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,9 +13,8 @@ type DeadCode term = State (Dead term) -- | An analysis tracking dead (unreachable) code. newtype DeadCodeAnalysis m (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m effects a } - deriving (Applicative, Functor, Monad, MonadFail) + deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail) -deriving instance MonadEvaluator effects m => MonadEvaluator effects (DeadCodeAnalysis m) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } @@ -25,11 +24,11 @@ deriving instance Ord term => Reducer term (Dead term) deriving instance Effectful effects (m effects) => Effectful effects (DeadCodeAnalysis m effects) -- | Update the current 'Dead' set. -killAll :: (Effectful effects (m effects), Member (State (Dead (TermFor m))) effects) => Dead (TermFor m) -> DeadCodeAnalysis m effects () +killAll :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Dead (TermFor (m effects)) -> DeadCodeAnalysis m effects () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful effects (m effects), Member (State (Dead (TermFor m))) effects) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m effects () +revive :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Ord (TermFor (m effects)) => (TermFor (m effects)) -> DeadCodeAnalysis m effects () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -37,16 +36,16 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter subterms term = term `cons` para (foldMap (uncurry cons)) term -instance ( Corecursive (TermFor m) +instance ( Corecursive (TermFor (m effects)) , Effectful effects (m effects) - , Foldable (Base (TermFor m)) - , Member (State (Dead (TermFor m))) effects - , MonadAnalysis effects m - , MonadEvaluator effects m - , Ord (TermFor m) - , Recursive (TermFor m) + , Foldable (Base (TermFor (m effects))) + , Member (State (Dead (TermFor (m effects)))) effects + , MonadAnalysis (m effects) + , MonadEvaluator (m effects) + , Ord (TermFor (m effects)) + , Recursive (TermFor (m effects)) ) - => MonadAnalysis effects (DeadCodeAnalysis m) where + => MonadAnalysis (DeadCodeAnalysis m effects) where analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b4703078e..b26b6446c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,29 +21,29 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value) - , MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) + , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) , Recursive term ) => term -> Final (EvaluatingEffects term value '[]) value -evaluate = run . evaluateModule @(EvaluatingEffects term value '[]) @(Evaluating term value) +evaluate = run . evaluateModule @(Evaluating term value (EvaluatingEffects term value '[])) -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (EvaluatingEffects term value '[]) (Evaluating term value) - , MonadValue value (EvaluatingEffects term value '[]) (Evaluating term value) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) + , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value '[]) value -evaluates pairs (_, t) = run (withModules pairs (evaluateModule @(EvaluatingEffects term value '[]) @(Evaluating term value) t)) +evaluates pairs (_, t) = run (withModules pairs (evaluateModule @(Evaluating term value (EvaluatingEffects term value '[])) t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. -withModules :: (MonadAnalysis effects m, MonadEvaluator effects m) => [(Blob, TermFor m)] -> m effects a -> m effects a +withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) @@ -66,9 +66,9 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator effects (Evaluating term value) where - type TermFor (Evaluating term value) = term - type ValueFor (Evaluating term value) = value +instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (Evaluating term value effects) where + type TermFor (Evaluating term value effects) = term + type ValueFor (Evaluating term value effects) = value getGlobalEnv = lift get modifyGlobalEnv f = lift (modify f) @@ -88,9 +88,9 @@ instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator ef instance ( Evaluatable (Base term) , FreeVariables term , Members (EvaluatingEffects term value '[]) effects - , MonadAddressable (LocationFor value) effects (Evaluating term value) - , MonadValue value effects (Evaluating term value) + , MonadAddressable (LocationFor value) (Evaluating term value effects) + , MonadValue value (Evaluating term value effects) , Recursive term ) - => MonadAnalysis effects (Evaluating term value) where + => MonadAnalysis (Evaluating term value effects) where analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index a839b3c2c..e2e66a701 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -18,29 +18,28 @@ type TracerFor trace m = Writer (TraceFor trace m) -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype TracingAnalysis (trace :: * -> *) m (effects :: [* -> *]) a = TracingAnalysis { runTracingAnalysis :: m effects a } - deriving (Applicative, Functor, Monad, MonadFail) + deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail) deriving instance Effectful effects (m effects) => Effectful effects (TracingAnalysis trace m effects) -deriving instance MonadEvaluator effects m => MonadEvaluator effects (TracingAnalysis trace m) -instance ( Corecursive (TermFor m) +instance ( Corecursive (TermFor (m effects)) , Effectful effects (m effects) - , Member (TracerFor trace m) effects - , MonadAnalysis effects m - , MonadEvaluator effects m - , Ord (LocationFor (ValueFor m)) - , Recursive (TermFor m) - , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) + , Member (TracerFor trace (m effects)) effects + , MonadAnalysis (m effects) + , MonadEvaluator (m effects) + , Ord (LocationFor (ValueFor (m effects))) + , Recursive (TermFor (m effects)) + , Reducer (ConfigurationFor (TermFor (m effects)) (ValueFor (m effects))) (TraceFor trace (m effects)) ) - => MonadAnalysis effects (TracingAnalysis trace m) where + => MonadAnalysis (TracingAnalysis trace m effects) where analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) liftAnalyze analyzeTerm term trace :: ( Effectful effects (m effects) - , Member (TracerFor trace m) effects + , Member (TracerFor trace (m effects)) effects ) - => TraceFor trace m + => TraceFor trace (m effects) -> TracingAnalysis trace m effects () trace = lift . tell diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 8fcc459f2..91d2c247e 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -15,39 +15,39 @@ import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad (m effects), Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l effects m where +class (Monad m, Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l m where deref :: Address l (ValueFor m) - -> m effects (ValueFor m) + -> m (ValueFor m) alloc :: Name - -> m effects (Address l (ValueFor m)) + -> m (Address l (ValueFor m)) -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- -- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. lookupOrAlloc :: ( FreeVariables t - , MonadAddressable (LocationFor a) effects m - , MonadEvaluator effects m + , MonadAddressable (LocationFor a) m + , MonadEvaluator m , a ~ ValueFor m , Semigroup (CellFor a) ) => t -> a -> Environment (LocationFor a) a - -> m effects (Name, Address (LocationFor a) a) + -> m (Name, Address (LocationFor a) a) lookupOrAlloc term = let [name] = toList (freeVariables term) in lookupOrAlloc' name where -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. lookupOrAlloc' :: ( Semigroup (CellFor a) - , MonadAddressable (LocationFor a) effects m + , MonadAddressable (LocationFor a) m , a ~ ValueFor m - , MonadEvaluator effects m + , MonadEvaluator m ) => Name -> a -> Environment (LocationFor a) a - -> m effects (Name, Address (LocationFor a) a) + -> m (Name, Address (LocationFor a) a) lookupOrAlloc' name v env = do a <- maybe (alloc name) pure (envLookup name env) assign a v @@ -55,20 +55,20 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor a) - , MonadEvaluator effects m + , MonadEvaluator m , a ~ ValueFor m , Reducer a (CellFor a) ) => Address (LocationFor a) a -> a - -> m effects () + -> m () assign address = modifyStore . storeInsert address -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Monad (m effects), MonadEvaluator effects m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise effects m where +instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise m where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -79,7 +79,7 @@ instance (Monad (m effects), MonadEvaluator effects m, LocationFor (ValueFor m) -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative (m effects), Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad (m effects), MonadEvaluator effects m) => MonadAddressable Monovariant effects m where +instance (Alternative m, Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad m, MonadEvaluator m) => MonadAddressable Monovariant m where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index dfc4a8ab5..287957800 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE KindSignatures, MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE PolyKinds, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -20,23 +20,23 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class (MonadEvaluator effects m, Recursive (TermFor m)) => MonadAnalysis effects m where +class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. - analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m effects (ValueFor m)) + analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) - evaluateModule :: TermFor m -> m effects (ValueFor m) + evaluateModule :: TermFor m -> m (ValueFor m) evaluateModule = evaluateTerm -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. -evaluateTerm :: MonadAnalysis effects m => TermFor m -> m effects (ValueFor m) +evaluateTerm :: MonadAnalysis m => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm -liftAnalyze :: ( term ~ TermFor ( m) - , term ~ TermFor (t m) - , value ~ ValueFor ( m) - , value ~ ValueFor (t m) +liftAnalyze :: ( term ~ TermFor ( m effects) + , term ~ TermFor (t m effects) + , value ~ ValueFor ( m effects) + , value ~ ValueFor (t m effects) , Coercible ( m effects value) (t m effects value) , Coercible (t m effects value) ( m effects value) , Functor (Base term) @@ -45,10 +45,10 @@ liftAnalyze :: ( term ~ TermFor ( m) -> SubtermAlgebra (Base term) term (t m effects value) liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -liftEvaluate :: ( term ~ TermFor ( m) - , term ~ TermFor (t m) - , value ~ ValueFor ( m) - , value ~ ValueFor (t m) +liftEvaluate :: ( term ~ TermFor ( m effects) + , term ~ TermFor (t m effects) + , value ~ ValueFor ( m effects) + , value ~ ValueFor (t m effects) , Coercible (m effects value) (t m effects value) ) => (term -> m effects value) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 1dd3c6b66..77341d341 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE ConstrainedClassMethods, TypeFamilies #-} module Control.Abstract.Evaluator where import Data.Abstract.Configuration @@ -14,41 +14,41 @@ import Prologue -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class MonadFail (m effects) => MonadEvaluator (effects :: [* -> *]) m where +class MonadFail m => MonadEvaluator m where type TermFor m type ValueFor m -- | Retrieve the global environment. - getGlobalEnv :: m effects (EnvironmentFor (ValueFor m)) + getGlobalEnv :: m (EnvironmentFor (ValueFor m)) -- | Update the global environment. - modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects () + modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m () -- | Retrieve the local environment. - askLocalEnv :: m effects (EnvironmentFor (ValueFor m)) + askLocalEnv :: m (EnvironmentFor (ValueFor m)) -- | Run an action with a locally-modified environment. - localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m effects a -> m effects a + localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m a -> m a -- | Retrieve the heap. - getStore :: m effects (StoreFor (ValueFor m)) + getStore :: m (StoreFor (ValueFor m)) -- | Update the heap. - modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m effects () - putStore :: StoreFor (ValueFor m) -> m effects () + modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m () + putStore :: StoreFor (ValueFor m) -> m () putStore = modifyStore . const -- | Retrieve the table of evaluated modules. - getModuleTable :: m effects (ModuleTable (ValueFor m)) + getModuleTable :: m (ModuleTable (ValueFor m)) -- | Update the table of evaluated modules. - modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m effects () + modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m () -- | Retrieve the table of unevaluated modules. - askModuleTable :: m effects (ModuleTable (TermFor m)) + askModuleTable :: m (ModuleTable (TermFor m)) -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m effects a -> m effects a + localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m a -> m a -- | Retrieve the current root set. - askRoots :: Ord (LocationFor (ValueFor m)) => m effects (Live (LocationFor (ValueFor m)) (ValueFor m)) + askRoots :: Ord (LocationFor (ValueFor m)) => m (Live (LocationFor (ValueFor m)) (ValueFor m)) askRoots = pure mempty -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m effects (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) + getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 9ab5b32c0..81dec141d 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -16,40 +16,41 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadEvaluator effects m, v ~ ValueFor m) => MonadValue v effects m where +class (MonadEvaluator m, v ~ ValueFor m) => MonadValue v m where -- | Construct an abstract unit value. - unit :: m effects v + unit :: m v -- | Construct an abstract integral value. - integer :: Prelude.Integer -> m effects v + integer :: Prelude.Integer -> m v -- | Construct an abstract boolean value. - boolean :: Bool -> m effects v + boolean :: Bool -> m v -- | Construct an abstract string value. - string :: ByteString -> m effects v + string :: ByteString -> m v -- | Construct a floating-point value. - float :: Scientific -> m effects v + float :: Scientific -> m v -- | Eliminate boolean values. TODO: s/boolean/truthy - ifthenelse :: v -> m effects v -> m effects v -> m effects v + ifthenelse :: v -> m v -> m v -> m v -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: [Name] -> Subterm (TermFor m) (m effects v) -> m effects v + abstract :: [Name] -> Subterm (TermFor m) (m v) -> m v -- | Evaluate an application (like a function call). - apply :: v -> [Subterm (TermFor m) (m effects v)] -> m effects v + apply :: v -> [Subterm (TermFor m) (m v)] -> m v -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables t - , MonadAddressable location effects m - , MonadAnalysis effects m + , MonadAddressable location m + , MonadAnalysis m , TermFor m ~ t , ValueFor m ~ Value location t + , MonadEvaluator m , Recursive t , Semigroup (Cell location (Value location t)) ) - => MonadValue (Value location t) effects m where + => MonadValue (Value location t) m where unit = pure $ inj Value.Unit integer = pure . inj . Integer @@ -73,7 +74,7 @@ instance ( FreeVariables t localEnv (mappend bindings) (evaluateTerm body) -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative (m effects), MonadEvaluator effects m, MonadFresh (m effects), ValueFor m ~ Type) => MonadValue Type effects m where +instance (Alternative m, MonadEvaluator m, MonadFresh m, ValueFor m ~ Type) => MonadValue Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 3a926d675..b3c9c495d 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -31,12 +31,12 @@ class Evaluatable constr where eval :: ( term ~ TermFor m , value ~ ValueFor m , FreeVariables term - , MonadAddressable (LocationFor value) effects m - , MonadAnalysis effects m - , MonadValue value effects m + , MonadAddressable (LocationFor value) m + , MonadAnalysis m + , MonadValue value m ) - => SubtermAlgebra constr term (m effects value) - default eval :: (MonadAnalysis effects m, Show1 constr) => SubtermAlgebra constr term (m effects value) + => SubtermAlgebra constr term (m value) + default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "" -- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'. @@ -74,10 +74,10 @@ instance Evaluatable [] where -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. require :: ( FreeVariables (TermFor m) - , MonadAnalysis effects m + , MonadAnalysis m ) => TermFor m - -> m effects (ValueFor m) + -> m (ValueFor m) require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup name where name = moduleName term @@ -85,10 +85,10 @@ require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup nam -- -- Always loads/evaluates. load :: ( FreeVariables (TermFor m) - , MonadAnalysis effects m + , MonadAnalysis m ) => TermFor m - -> m effects (ValueFor m) + -> m (ValueFor m) load term = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name where name = moduleName term notFound = fail ("cannot find " <> show name) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index c0444e3a7..c7d3151b4 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -44,14 +44,14 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python -typecheckPythonFile path = run . evaluateModule @(CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[])) @(CachingAnalysis (Evaluating Python.Term Type)) . snd <$> parseFile pythonParser path +typecheckPythonFile path = run . evaluateModule @(CachingAnalysis (Evaluating Python.Term Type) (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[]))) . snd <$> parseFile pythonParser path -tracePythonFile path = run . evaluateModule @(Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])) @(TracingAnalysis [] (Evaluating Python.Term PythonValue)) . snd <$> parseFile pythonParser path +tracePythonFile path = run . evaluateModule @(TracingAnalysis [] (Evaluating Python.Term PythonValue) (Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[]))) . snd <$> parseFile pythonParser path type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue) type PythonTracerEffects = DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue '[] -evaluateDeadTracePythonFile path = run . evaluateModule @PythonTracerEffects @(DeadCodeAnalysis PythonTracer) . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = run . evaluateModule @(DeadCodeAnalysis PythonTracer PythonTracerEffects) . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From b4563c0b46a18f3be2704827e0d51654c3c92cd8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 8 Mar 2018 16:19:44 -0500 Subject: [PATCH 207/292] Revert "Abstract the various types over the effect list." This reverts commit 960c38b41bb1db3466770d93268207ef54ddcc29. --- src/Analysis/Abstract/Caching.hs | 82 ++++++++++++++--------------- src/Analysis/Abstract/Dead.hs | 27 +++++----- src/Analysis/Abstract/Evaluating.hs | 28 +++++----- src/Analysis/Abstract/Tracing.hs | 34 ++++++------ src/Control/Abstract/Analysis.hs | 32 +++++------ src/Control/Effect.hs | 12 +++-- src/Semantic/Util.hs | 9 ++-- 7 files changed, 109 insertions(+), 115 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 4b39424e9..461183aca 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -33,54 +33,52 @@ type CachingEffects term value effects -- | The cache for term and abstract value types. type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) -newtype CachingAnalysis m (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m effects a } - deriving (Alternative, Applicative, Functor, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) - -deriving instance Effectful effects (m effects) => Effectful effects (CachingAnalysis m effects) +newtype CachingAnalysis m a = CachingAnalysis { runCachingAnalysis :: m a } + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) -- TODO: reabstract these later on type InCacheEffectFor m = Reader (CacheFor m) type OutCacheEffectFor m = State (CacheFor m) -askCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) +askCache :: (Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => CachingAnalysis m (CacheFor m) askCache = lift ask -localCache :: (Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects a -> CachingAnalysis m effects a +localCache :: (Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m a -> CachingAnalysis m a localCache f a = lift (local f (lower a)) -asksCache :: (Functor (m effects), Effectful effects (m effects), Member (InCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a +asksCache :: (Functor m, Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> a) -> CachingAnalysis m a asksCache f = f <$> askCache -getsCache :: (Functor (m effects), Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => (CacheFor (m effects) -> a) -> CachingAnalysis m effects a +getsCache :: (Functor m, Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> a) -> CachingAnalysis m a getsCache f = f <$> getCache -getCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CachingAnalysis m effects (CacheFor (m effects)) +getCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => CachingAnalysis m (CacheFor m) getCache = lift get -putCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects) => CacheFor (m effects) -> CachingAnalysis m effects () +putCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => CacheFor m -> CachingAnalysis m () putCache = lift . put -modifyCache :: (Effectful effects (m effects), Member (OutCacheEffectFor (m effects)) effects, Monad (m effects)) => (CacheFor (m effects) -> CacheFor (m effects)) -> CachingAnalysis m effects () +modifyCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m), Monad m) => (CacheFor m -> CacheFor m) -> CachingAnalysis m () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. -instance ( Corecursive (TermFor (m effects)) - , Ord (TermFor (m effects)) - , Ord (ValueFor (m effects)) - , Ord (CellFor (ValueFor (m effects))) - , Ord (LocationFor (ValueFor (m effects))) - , Effectful effects (m effects) - , MonadFresh (m effects) - , MonadNonDet (m effects) - , Members (CachingEffectsFor (m effects)) effects - , Evaluatable (Base (TermFor (m effects))) - , Foldable (Cell (LocationFor (ValueFor (m effects)))) - , FreeVariables (TermFor (m effects)) - , MonadAnalysis (m effects) - , Recursive (TermFor (m effects)) +instance ( Corecursive (TermFor m) + , Ord (TermFor m) + , Ord (ValueFor m) + , Ord (CellFor (ValueFor m)) + , Ord (LocationFor (ValueFor m)) + , Effectful m + , MonadFresh m + , MonadNonDet m + , Members (CachingEffectsFor m) (EffectsFor m) + , Evaluatable (Base (TermFor m)) + , Foldable (Cell (LocationFor (ValueFor m))) + , FreeVariables (TermFor m) + , MonadAnalysis m + , Recursive (TermFor m) ) - => MonadAnalysis (CachingAnalysis m effects) where + => MonadAnalysis (CachingAnalysis m) where analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -94,7 +92,7 @@ instance ( Corecursive (TermFor (m effects)) -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis m effects ()) + _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis m ()) getCache) mempty maybe empty scatter (cacheLookup c cache) @@ -118,22 +116,22 @@ scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (Locatio scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: ( Ord (ValueFor (m effects)) - , Ord (TermFor (m effects)) - , Ord (LocationFor (ValueFor (m effects))) - , Ord (CellFor (ValueFor (m effects))) - , Alternative (m effects) - , Corecursive (TermFor (m effects)) - , FreeVariables (TermFor (m effects)) - , Foldable (Cell (LocationFor (ValueFor (m effects)))) - , Functor (Base (TermFor (m effects))) - , Effectful effects (m effects) - , Members (CachingEffectsFor (m effects)) effects - , Recursive (TermFor (m effects)) - , MonadAnalysis (m effects) - -- , Semigroup (CellFor (ValueFor (m effects))) +memoizeEval :: ( Ord (ValueFor m) + , Ord (TermFor m) + , Ord (LocationFor (ValueFor m)) + , Ord (CellFor (ValueFor m)) + , Alternative m + , Corecursive (TermFor m) + , FreeVariables (TermFor m) + , Foldable (Cell (LocationFor (ValueFor m))) + , Functor (Base (TermFor m)) + , Effectful m + , Members (CachingEffectsFor m) (EffectsFor m) + , Recursive (TermFor m) + , MonadAnalysis m + -- , Semigroup (CellFor (ValueFor m)) ) - => SubtermAlgebra (Base (TermFor (m effects))) (TermFor (m effects)) (CachingAnalysis m effects (ValueFor (m effects))) + => SubtermAlgebra (Base (TermFor m)) (TermFor m) (CachingAnalysis m (ValueFor m)) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 5a4e11f60..5b4fe7371 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -12,8 +12,8 @@ type DeadCode term = State (Dead term) -- | An analysis tracking dead (unreachable) code. -newtype DeadCodeAnalysis m (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m effects a } - deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail) +newtype DeadCodeAnalysis m a = DeadCodeAnalysis { runDeadCodeAnalysis :: m a } + deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) -- | A set of “dead” (unreachable) terms. @@ -21,14 +21,13 @@ newtype Dead term = Dead { unDead :: Set term } deriving (Eq, Foldable, Semigroup, Monoid, Ord, Show) deriving instance Ord term => Reducer term (Dead term) -deriving instance Effectful effects (m effects) => Effectful effects (DeadCodeAnalysis m effects) -- | Update the current 'Dead' set. -killAll :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Dead (TermFor (m effects)) -> DeadCodeAnalysis m effects () +killAll :: (Effectful m, Member (State (Dead (TermFor m))) (EffectsFor m)) => Dead (TermFor m) -> DeadCodeAnalysis m () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful effects (m effects), Member (State (Dead (TermFor (m effects)))) effects) => Ord (TermFor (m effects)) => (TermFor (m effects)) -> DeadCodeAnalysis m effects () +revive :: (Effectful m, Member (State (Dead (TermFor m))) (EffectsFor m)) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -36,16 +35,16 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter subterms term = term `cons` para (foldMap (uncurry cons)) term -instance ( Corecursive (TermFor (m effects)) - , Effectful effects (m effects) - , Foldable (Base (TermFor (m effects))) - , Member (State (Dead (TermFor (m effects)))) effects - , MonadAnalysis (m effects) - , MonadEvaluator (m effects) - , Ord (TermFor (m effects)) - , Recursive (TermFor (m effects)) +instance ( Corecursive (TermFor m) + , Effectful m + , Foldable (Base (TermFor m)) + , Member (State (Dead (TermFor m))) (EffectsFor m) + , MonadAnalysis m + , MonadEvaluator m + , Ord (TermFor m) + , Recursive (TermFor m) ) - => MonadAnalysis (DeadCodeAnalysis m effects) where + => MonadAnalysis (DeadCodeAnalysis m) where analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index b26b6446c..d4a294bc2 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,26 +21,26 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) - , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) + , MonadAddressable (LocationFor value) (Evaluating term value '[]) + , MonadValue value (Evaluating term value '[]) , Recursive term ) => term -> Final (EvaluatingEffects term value '[]) value -evaluate = run . evaluateModule @(Evaluating term value (EvaluatingEffects term value '[])) +evaluate = run @(Evaluating term value '[]) . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) - , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) + , MonadAddressable (LocationFor value) (Evaluating term value '[]) + , MonadValue value (Evaluating term value '[]) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value '[]) value -evaluates pairs (_, t) = run (withModules pairs (evaluateModule @(Evaluating term value (EvaluatingEffects term value '[])) t)) +evaluates pairs (_, t) = run @(Evaluating term value '[]) (withModules pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a @@ -48,14 +48,13 @@ withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff effects a } - deriving (Applicative, Functor, Monad) +newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff (EvaluatingEffects term value 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 NonDetEff effects => Alternative (Evaluating term value effects) -deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) -deriving instance Effectful effects (Evaluating term value effects) +deriving instance Member Fail (EvaluatingEffects term value effects) => MonadFail (Evaluating term value effects) +deriving instance Member Fresh (EvaluatingEffects term value effects) => MonadFresh (Evaluating term value effects) +deriving instance Member NonDetEff (EvaluatingEffects term value effects) => Alternative (Evaluating term value effects) +deriving instance Member NonDetEff (EvaluatingEffects term value effects) => MonadNonDet (Evaluating term value effects) type EvaluatingEffects term value effects = Fail -- Failure with an error message @@ -66,7 +65,7 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (Evaluating term value effects) where +instance MonadEvaluator (Evaluating term value effects) where type TermFor (Evaluating term value effects) = term type ValueFor (Evaluating term value effects) = value @@ -87,7 +86,6 @@ instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (E instance ( Evaluatable (Base term) , FreeVariables term - , Members (EvaluatingEffects term value '[]) effects , MonadAddressable (LocationFor value) (Evaluating term value effects) , MonadValue value (Evaluating term value effects) , Recursive term diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index e2e66a701..6ece5e826 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -16,30 +16,28 @@ type TracerFor trace m = Writer (TraceFor trace m) -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -newtype TracingAnalysis (trace :: * -> *) m (effects :: [* -> *]) a - = TracingAnalysis { runTracingAnalysis :: m effects a } - deriving (Applicative, Functor, Monad, MonadEvaluator, MonadFail) +newtype TracingAnalysis (trace :: * -> *) m a + = TracingAnalysis { runTracingAnalysis :: m a } + deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) -deriving instance Effectful effects (m effects) => Effectful effects (TracingAnalysis trace m effects) - -instance ( Corecursive (TermFor (m effects)) - , Effectful effects (m effects) - , Member (TracerFor trace (m effects)) effects - , MonadAnalysis (m effects) - , MonadEvaluator (m effects) - , Ord (LocationFor (ValueFor (m effects))) - , Recursive (TermFor (m effects)) - , Reducer (ConfigurationFor (TermFor (m effects)) (ValueFor (m effects))) (TraceFor trace (m effects)) +instance ( Corecursive (TermFor m) + , Effectful m + , Member (TracerFor trace m) (EffectsFor m) + , MonadAnalysis m + , MonadEvaluator m + , Ord (LocationFor (ValueFor m)) + , Recursive (TermFor m) + , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) ) - => MonadAnalysis (TracingAnalysis trace m effects) where + => MonadAnalysis (TracingAnalysis trace m) where analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) liftAnalyze analyzeTerm term -trace :: ( Effectful effects (m effects) - , Member (TracerFor trace (m effects)) effects +trace :: ( Effectful m + , Member (TracerFor trace m) (EffectsFor m) ) - => TraceFor trace (m effects) - -> TracingAnalysis trace m effects () + => TraceFor trace m + -> TracingAnalysis trace m () trace = lift . tell diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 287957800..3bba4917c 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PolyKinds, TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -33,24 +33,24 @@ class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where evaluateTerm :: MonadAnalysis m => TermFor m -> m (ValueFor m) evaluateTerm = foldSubterms analyzeTerm -liftAnalyze :: ( term ~ TermFor ( m effects) - , term ~ TermFor (t m effects) - , value ~ ValueFor ( m effects) - , value ~ ValueFor (t m effects) - , Coercible ( m effects value) (t m effects value) - , Coercible (t m effects value) ( m effects value) +liftAnalyze :: ( term ~ TermFor m + , term ~ TermFor (t m) + , value ~ ValueFor m + , value ~ ValueFor (t m) + , Coercible ( m value) (t m value) + , Coercible (t m value) ( m value) , Functor (Base term) ) - => SubtermAlgebra (Base term) term ( m effects value) - -> SubtermAlgebra (Base term) term (t m effects value) + => SubtermAlgebra (Base term) term ( m value) + -> SubtermAlgebra (Base term) term (t m value) liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -liftEvaluate :: ( term ~ TermFor ( m effects) - , term ~ TermFor (t m effects) - , value ~ ValueFor ( m effects) - , value ~ ValueFor (t m effects) - , Coercible (m effects value) (t m effects value) +liftEvaluate :: ( term ~ TermFor m + , term ~ TermFor (t m) + , value ~ ValueFor m + , value ~ ValueFor (t m) + , Coercible (m value) (t m value) ) - => (term -> m effects value) - -> (term -> t m effects value) + => (term -> m value) + -> (term -> t m value) liftEvaluate evaluate = coerce . evaluate diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 0b1a5d80b..aa132c0b2 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -12,7 +12,7 @@ import Data.Semigroup.Reducer import Prologue -- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result. -run :: (Effectful effects m, RunEffects effects a) => m a -> Final effects a +run :: (Effectful m, RunEffects (EffectsFor m) a) => m a -> Final (EffectsFor m) a run = Effect.run . runEffects . lower -- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults. @@ -66,10 +66,12 @@ instance Ord a => RunEffect NonDetEff a where MPlus -> mappend <$> k True <*> k False) -class Effectful effects m | m -> effects where - lift :: Eff effects a -> m a - lower :: m a -> Eff effects a +class Effectful m where + type EffectsFor m :: [* -> *] + lift :: Eff (EffectsFor m) a -> m a + lower :: m a -> Eff (EffectsFor m) a -instance Effectful effects (Eff effects) where +instance Effectful (Eff effects) where + type EffectsFor (Eff effects) = effects lift = id lower = id diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index c7d3151b4..39766bc0c 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -44,14 +44,13 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python -typecheckPythonFile path = run . evaluateModule @(CachingAnalysis (Evaluating Python.Term Type) (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[]))) . snd <$> parseFile pythonParser path +typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type '[]))) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = run . evaluateModule @(TracingAnalysis [] (Evaluating Python.Term PythonValue) (Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[]))) . snd <$> parseFile pythonParser path +tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue '[Tracer [] Python.Term PythonValue])) . evaluateModule . snd <$> parseFile pythonParser path -type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue) -type PythonTracerEffects = DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': EvaluatingEffects Python.Term PythonValue '[] +type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue '[DeadCode Python.Term, Tracer [] Python.Term PythonValue]) -evaluateDeadTracePythonFile path = run . evaluateModule @(DeadCodeAnalysis PythonTracer PythonTracerEffects) . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From f68401e6d4251429476312e0f39192b2580d23a3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 10:32:48 -0500 Subject: [PATCH 208/292] Leave a note to remind myself what the analysis type could be. --- src/Semantic/Util.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 39766bc0c..8668da315 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -44,6 +44,7 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python +-- TODO: Can we phrase this type as something like (CachingAnalysis Evaluating Python.Term Type '[]) ? typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type '[]))) . evaluateModule . snd <$> parseFile pythonParser path tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue '[Tracer [] Python.Term PythonValue])) . evaluateModule . snd <$> parseFile pythonParser path From 1fd764f05e0fb5b1272f49dd119a25a01f706dbb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 10:48:50 -0500 Subject: [PATCH 209/292] Add a type family for the required effects. --- src/Analysis/Abstract/Caching.hs | 1 + src/Analysis/Abstract/Dead.hs | 1 + src/Analysis/Abstract/Evaluating.hs | 26 ++++++++++++++------------ src/Analysis/Abstract/Tracing.hs | 1 + src/Control/Abstract/Analysis.hs | 4 +++- src/Semantic/Util.hs | 8 +++++--- 6 files changed, 25 insertions(+), 16 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 461183aca..ed2778630 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -79,6 +79,7 @@ instance ( Corecursive (TermFor m) , Recursive (TermFor m) ) => MonadAnalysis (CachingAnalysis m) where + type EffectsRequiredFor (CachingAnalysis m) = CachingEffects (TermFor m) (ValueFor m) (EffectsRequiredFor m) analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 5b4fe7371..90c412e9e 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -45,6 +45,7 @@ instance ( Corecursive (TermFor m) , Recursive (TermFor m) ) => MonadAnalysis (DeadCodeAnalysis m) where + type EffectsRequiredFor (DeadCodeAnalysis m) = DeadCode (TermFor m) ': EffectsRequiredFor m analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index d4a294bc2..f717b03b2 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,26 +21,26 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value '[]) - , MonadValue value (Evaluating term value '[]) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) + , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) , Recursive term ) => term -> Final (EvaluatingEffects term value '[]) value -evaluate = run @(Evaluating term value '[]) . evaluateModule +evaluate = run @(Evaluating term value (EvaluatingEffects term value '[])) . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value '[]) - , MonadValue value (Evaluating term value '[]) + , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) + , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value '[]) value -evaluates pairs (_, t) = run @(Evaluating term value '[]) (withModules pairs (evaluateModule t)) +evaluates pairs (_, t) = run @(Evaluating term value (EvaluatingEffects term value '[])) (withModules pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a @@ -48,13 +48,13 @@ withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff (EvaluatingEffects term value effects) a } +newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff effects a } deriving (Applicative, Functor, Effectful, Monad) -deriving instance Member Fail (EvaluatingEffects term value effects) => MonadFail (Evaluating term value effects) -deriving instance Member Fresh (EvaluatingEffects term value effects) => MonadFresh (Evaluating term value effects) -deriving instance Member NonDetEff (EvaluatingEffects term value effects) => Alternative (Evaluating term value effects) -deriving instance Member NonDetEff (EvaluatingEffects term value 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 NonDetEff effects => Alternative (Evaluating term value effects) +deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) type EvaluatingEffects term value effects = Fail -- Failure with an error message @@ -65,7 +65,7 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance MonadEvaluator (Evaluating term value effects) where +instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (Evaluating term value effects) where type TermFor (Evaluating term value effects) = term type ValueFor (Evaluating term value effects) = value @@ -86,9 +86,11 @@ instance MonadEvaluator (Evaluating term value effects) where instance ( Evaluatable (Base term) , FreeVariables term + , Members (EvaluatingEffects term value '[]) effects , MonadAddressable (LocationFor value) (Evaluating term value effects) , MonadValue value (Evaluating term value effects) , Recursive term ) => MonadAnalysis (Evaluating term value effects) where + type EffectsRequiredFor (Evaluating term value effects) = EvaluatingEffects term value '[] analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 6ece5e826..352b82b00 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -30,6 +30,7 @@ instance ( Corecursive (TermFor m) , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) ) => MonadAnalysis (TracingAnalysis trace m) where + type EffectsRequiredFor (TracingAnalysis trace m) = TracerFor trace m ': EffectsRequiredFor m analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 3bba4917c..887346084 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds, KindSignatures, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -21,6 +21,8 @@ import Prologue -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where + type EffectsRequiredFor m :: [* -> *] + -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 8668da315..cbb8cba10 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -45,11 +45,13 @@ evaluateRubyFiles paths = do -- Python -- TODO: Can we phrase this type as something like (CachingAnalysis Evaluating Python.Term Type '[]) ? -typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type '[]))) . evaluateModule . snd <$> parseFile pythonParser path +typecheckPythonFile :: FilePath + -> IO (Final (EffectsRequiredFor (CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type '[])))) Type) +typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[])))) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue '[Tracer [] Python.Term PythonValue])) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])))) . evaluateModule . snd <$> parseFile pythonParser path -type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue '[DeadCode Python.Term, Tracer [] Python.Term PythonValue]) +type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[]))) evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule . snd <$> parseFile pythonParser path From 0d040911ebf12279debd0260743e937af82b20bb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 11:03:33 -0500 Subject: [PATCH 210/292] Revert "Add a type family for the required effects." This reverts commit cc352239fd94a6689ae3a03739b2feebbb7372ef. --- src/Analysis/Abstract/Caching.hs | 1 - src/Analysis/Abstract/Dead.hs | 1 - src/Analysis/Abstract/Evaluating.hs | 26 ++++++++++++-------------- src/Analysis/Abstract/Tracing.hs | 1 - src/Control/Abstract/Analysis.hs | 4 +--- src/Semantic/Util.hs | 8 +++----- 6 files changed, 16 insertions(+), 25 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index ed2778630..461183aca 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -79,7 +79,6 @@ instance ( Corecursive (TermFor m) , Recursive (TermFor m) ) => MonadAnalysis (CachingAnalysis m) where - type EffectsRequiredFor (CachingAnalysis m) = CachingEffects (TermFor m) (ValueFor m) (EffectsRequiredFor m) analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 90c412e9e..5b4fe7371 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -45,7 +45,6 @@ instance ( Corecursive (TermFor m) , Recursive (TermFor m) ) => MonadAnalysis (DeadCodeAnalysis m) where - type EffectsRequiredFor (DeadCodeAnalysis m) = DeadCode (TermFor m) ': EffectsRequiredFor m analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index f717b03b2..d4a294bc2 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,26 +21,26 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) - , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) + , MonadAddressable (LocationFor value) (Evaluating term value '[]) + , MonadValue value (Evaluating term value '[]) , Recursive term ) => term -> Final (EvaluatingEffects term value '[]) value -evaluate = run @(Evaluating term value (EvaluatingEffects term value '[])) . evaluateModule +evaluate = run @(Evaluating term value '[]) . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value (EvaluatingEffects term value '[])) - , MonadValue value (Evaluating term value (EvaluatingEffects term value '[])) + , MonadAddressable (LocationFor value) (Evaluating term value '[]) + , MonadValue value (Evaluating term value '[]) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value '[]) value -evaluates pairs (_, t) = run @(Evaluating term value (EvaluatingEffects term value '[])) (withModules pairs (evaluateModule t)) +evaluates pairs (_, t) = run @(Evaluating term value '[]) (withModules pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a @@ -48,13 +48,13 @@ withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff effects a } +newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff (EvaluatingEffects term value 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 NonDetEff effects => Alternative (Evaluating term value effects) -deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) +deriving instance Member Fail (EvaluatingEffects term value effects) => MonadFail (Evaluating term value effects) +deriving instance Member Fresh (EvaluatingEffects term value effects) => MonadFresh (Evaluating term value effects) +deriving instance Member NonDetEff (EvaluatingEffects term value effects) => Alternative (Evaluating term value effects) +deriving instance Member NonDetEff (EvaluatingEffects term value effects) => MonadNonDet (Evaluating term value effects) type EvaluatingEffects term value effects = Fail -- Failure with an error message @@ -65,7 +65,7 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (Evaluating term value effects) where +instance MonadEvaluator (Evaluating term value effects) where type TermFor (Evaluating term value effects) = term type ValueFor (Evaluating term value effects) = value @@ -86,11 +86,9 @@ instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator (E instance ( Evaluatable (Base term) , FreeVariables term - , Members (EvaluatingEffects term value '[]) effects , MonadAddressable (LocationFor value) (Evaluating term value effects) , MonadValue value (Evaluating term value effects) , Recursive term ) => MonadAnalysis (Evaluating term value effects) where - type EffectsRequiredFor (Evaluating term value effects) = EvaluatingEffects term value '[] analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 352b82b00..6ece5e826 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -30,7 +30,6 @@ instance ( Corecursive (TermFor m) , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) ) => MonadAnalysis (TracingAnalysis trace m) where - type EffectsRequiredFor (TracingAnalysis trace m) = TracerFor trace m ': EffectsRequiredFor m analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 887346084..3bba4917c 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, KindSignatures, TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -21,8 +21,6 @@ import Prologue -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where - type EffectsRequiredFor m :: [* -> *] - -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index cbb8cba10..8668da315 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -45,13 +45,11 @@ evaluateRubyFiles paths = do -- Python -- TODO: Can we phrase this type as something like (CachingAnalysis Evaluating Python.Term Type '[]) ? -typecheckPythonFile :: FilePath - -> IO (Final (EffectsRequiredFor (CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type '[])))) Type) -typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type (EvaluatingEffects Python.Term Type '[])))) . evaluateModule . snd <$> parseFile pythonParser path +typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type '[]))) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue (Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[])))) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue '[Tracer [] Python.Term PythonValue])) . evaluateModule . snd <$> parseFile pythonParser path -type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue (DeadCode Python.Term ': Tracer [] Python.Term PythonValue ': (EvaluatingEffects Python.Term PythonValue '[]))) +type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue '[DeadCode Python.Term, Tracer [] Python.Term PythonValue]) evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule . snd <$> parseFile pythonParser path From 3cdbaecc939926e610656dc68c19a302cfec351e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 12:00:20 -0500 Subject: [PATCH 211/292] Infer the effects to run analyses with. --- src/Analysis/Abstract/Caching.hs | 104 +++++++++++++--------------- src/Analysis/Abstract/Dead.hs | 30 ++++---- src/Analysis/Abstract/Evaluating.hs | 39 ++++++----- src/Analysis/Abstract/Tracing.hs | 39 ++++++----- src/Control/Abstract/Addressable.hs | 53 +++++++------- src/Control/Abstract/Analysis.hs | 33 ++++----- src/Control/Abstract/Evaluator.hs | 33 ++++----- src/Control/Abstract/Value.hs | 38 +++++----- src/Control/Effect.hs | 10 ++- src/Data/Abstract/Evaluatable.hs | 30 ++++---- src/Semantic/Util.hs | 12 ++-- 11 files changed, 203 insertions(+), 218 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 461183aca..e2c1c0714 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Caching -- ( evaluateCache ) where @@ -16,69 +16,65 @@ import Data.Monoid (Alt(..)) import Prologue -- | The effects necessary for caching analyses. -type CachingEffectsFor m - = '[ Fresh -- For 'MonadFresh'. TODO: Extract typing constraints into a separate analysis. - , NonDetEff -- For 'Alternative' & 'MonadNonDet'. - , Reader (CacheFor m) -- For the in-cache. - , State (CacheFor m) -- For the out-cache - ] - type CachingEffects term value effects = Fresh ': NonDetEff - ': Reader (Cache (LocationFor value) term value) - ': State (Cache (LocationFor value) term value) + ': Reader (CacheFor term value) + ': State (CacheFor term value) ': effects -- | The cache for term and abstract value types. -type CacheFor m = Cache (LocationFor (ValueFor m)) (TermFor m) (ValueFor m) +type CacheFor term value = Cache (LocationFor value) term value -newtype CachingAnalysis m a = CachingAnalysis { runCachingAnalysis :: m a } - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail, MonadFresh, MonadNonDet) +newtype CachingAnalysis m term value (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m term value effects a } + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) + +deriving instance MonadEvaluator term value effects m => MonadEvaluator term value effects (CachingAnalysis m) -- TODO: reabstract these later on -type InCacheEffectFor m = Reader (CacheFor m) -type OutCacheEffectFor m = State (CacheFor m) +type InCacheEffectFor term value = Reader (CacheFor term value) +type OutCacheEffectFor term value = State (CacheFor term value) -askCache :: (Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => CachingAnalysis m (CacheFor m) +askCache :: (Effectful (m term value), Member (InCacheEffectFor term value) effects) => CachingAnalysis m term value effects (CacheFor term value) askCache = lift ask -localCache :: (Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> CacheFor m) -> CachingAnalysis m a -> CachingAnalysis m a +localCache :: (Effectful (m term value), Member (InCacheEffectFor term value) effects) => (CacheFor term value -> CacheFor term value) -> CachingAnalysis m term value effects a -> CachingAnalysis m term value effects a localCache f a = lift (local f (lower a)) -asksCache :: (Functor m, Effectful m, Member (InCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> a) -> CachingAnalysis m a +asksCache :: (Functor (m term value effects), Effectful (m term value), Member (InCacheEffectFor term value) effects) => (CacheFor term value -> a) -> CachingAnalysis m term value effects a asksCache f = f <$> askCache -getsCache :: (Functor m, Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => (CacheFor m -> a) -> CachingAnalysis m a +getsCache :: (Functor (m term value effects), Effectful (m term value), Member (OutCacheEffectFor term value) effects) => (CacheFor term value -> a) -> CachingAnalysis m term value effects a getsCache f = f <$> getCache -getCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => CachingAnalysis m (CacheFor m) +getCache :: (Effectful (m term value), Member (OutCacheEffectFor term value) effects) => CachingAnalysis m term value effects (CacheFor term value) getCache = lift get -putCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m)) => CacheFor m -> CachingAnalysis m () +putCache :: (Effectful (m term value), Member (OutCacheEffectFor term value) effects) => CacheFor term value -> CachingAnalysis m term value effects () putCache = lift . put -modifyCache :: (Effectful m, Member (OutCacheEffectFor m) (EffectsFor m), Monad m) => (CacheFor m -> CacheFor m) -> CachingAnalysis m () +modifyCache :: (Effectful (m term value), Member (OutCacheEffectFor term value) effects, Monad (m term value effects)) => (CacheFor term value -> CacheFor term value) -> CachingAnalysis m term value effects () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. -instance ( Corecursive (TermFor m) - , Ord (TermFor m) - , Ord (ValueFor m) - , Ord (CellFor (ValueFor m)) - , Ord (LocationFor (ValueFor m)) - , Effectful m - , MonadFresh m - , MonadNonDet m - , Members (CachingEffectsFor m) (EffectsFor m) - , Evaluatable (Base (TermFor m)) - , Foldable (Cell (LocationFor (ValueFor m))) - , FreeVariables (TermFor m) - , MonadAnalysis m - , Recursive (TermFor m) +instance ( Corecursive term + , Ord term + , Ord value + , Ord (CellFor value) + , Ord (LocationFor value) + , Effectful (m term value) + , MonadFresh (m term value effects) + , MonadNonDet (m term value effects) + , Members (CachingEffects term value '[]) effects + , Evaluatable (Base term) + , Foldable (Cell (LocationFor value)) + , FreeVariables term + , MonadAnalysis term value effects m + , Recursive term ) - => MonadAnalysis (CachingAnalysis m) where + => MonadAnalysis term value effects (CachingAnalysis m) where + type RequiredEffects term value (CachingAnalysis m) = CachingEffects term value (RequiredEffects term value m) analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -92,7 +88,7 @@ instance ( Corecursive (TermFor m) -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis m ()) + _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis m term value effects ()) getCache) mempty maybe empty scatter (cacheLookup c cache) @@ -112,26 +108,26 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative m, Foldable t, MonadEvaluator m) => t (a, Store (LocationFor (ValueFor m)) (ValueFor m)) -> m a +scatter :: (Alternative (m term value effects), Foldable t, MonadEvaluator term value effects m) => t (a, Store (LocationFor value) value) -> m term value effects a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: ( Ord (ValueFor m) - , Ord (TermFor m) - , Ord (LocationFor (ValueFor m)) - , Ord (CellFor (ValueFor m)) - , Alternative m - , Corecursive (TermFor m) - , FreeVariables (TermFor m) - , Foldable (Cell (LocationFor (ValueFor m))) - , Functor (Base (TermFor m)) - , Effectful m - , Members (CachingEffectsFor m) (EffectsFor m) - , Recursive (TermFor m) - , MonadAnalysis m - -- , Semigroup (CellFor (ValueFor m)) +memoizeEval :: ( Ord value + , Ord term + , Ord (LocationFor value) + , Ord (CellFor value) + , Alternative (m term value effects) + , Corecursive term + , FreeVariables term + , Foldable (Cell (LocationFor value)) + , Functor (Base term) + , Effectful (m term value) + , Members (CachingEffects term value '[]) effects + , Recursive term + , MonadAnalysis term value effects m + -- , Semigroup (CellFor value) ) - => SubtermAlgebra (Base (TermFor m)) (TermFor m) (CachingAnalysis m (ValueFor m)) + => SubtermAlgebra (Base term) term (CachingAnalysis m term value effects value) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 5b4fe7371..735983006 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Dead where import Control.Abstract.Evaluator @@ -12,9 +12,10 @@ type DeadCode term = State (Dead term) -- | An analysis tracking dead (unreachable) code. -newtype DeadCodeAnalysis m a = DeadCodeAnalysis { runDeadCodeAnalysis :: m a } - deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) +newtype DeadCodeAnalysis m term value (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m term value effects a } + deriving (Applicative, Functor, Effectful, Monad, MonadFail) +deriving instance MonadEvaluator term value effects m => MonadEvaluator term value effects (DeadCodeAnalysis m) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } @@ -23,11 +24,11 @@ newtype Dead term = Dead { unDead :: Set term } deriving instance Ord term => Reducer term (Dead term) -- | Update the current 'Dead' set. -killAll :: (Effectful m, Member (State (Dead (TermFor m))) (EffectsFor m)) => Dead (TermFor m) -> DeadCodeAnalysis m () +killAll :: (Effectful (m term value), Member (State (Dead term)) effects) => Dead term -> DeadCodeAnalysis m term value effects () killAll = lift . put -- | Revive a single term, removing it from the current 'Dead' set. -revive :: (Effectful m, Member (State (Dead (TermFor m))) (EffectsFor m)) => Ord (TermFor m) => (TermFor m) -> DeadCodeAnalysis m () +revive :: (Effectful (m term value), Member (State (Dead term)) effects) => Ord term => term -> DeadCodeAnalysis m term value effects () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -35,16 +36,17 @@ subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead ter subterms term = term `cons` para (foldMap (uncurry cons)) term -instance ( Corecursive (TermFor m) - , Effectful m - , Foldable (Base (TermFor m)) - , Member (State (Dead (TermFor m))) (EffectsFor m) - , MonadAnalysis m - , MonadEvaluator m - , Ord (TermFor m) - , Recursive (TermFor m) +instance ( Corecursive term + , Effectful (m term value) + , Foldable (Base term) + , Member (State (Dead term)) effects + , MonadAnalysis term value effects m + , MonadEvaluator term value effects m + , Ord term + , Recursive term ) - => MonadAnalysis (DeadCodeAnalysis m) where + => MonadAnalysis term value effects (DeadCodeAnalysis m) where + type RequiredEffects term value (DeadCodeAnalysis m) = State (Dead term) ': RequiredEffects term value m analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index d4a294bc2..aef2dcd06 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -21,40 +21,42 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value '[]) - , MonadValue value (Evaluating term value '[]) + , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value '[]) Evaluating + , MonadValue term value (EvaluatingEffects term value '[]) Evaluating , Recursive term ) => term -> Final (EvaluatingEffects term value '[]) value -evaluate = run @(Evaluating term value '[]) . evaluateModule +evaluate = run @(Evaluating term value) @(EvaluatingEffects term value '[]) . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value '[]) - , MonadValue value (Evaluating term value '[]) + , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value '[]) Evaluating + , MonadValue term value (EvaluatingEffects term value '[]) Evaluating , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value '[]) value -evaluates pairs (_, t) = run @(Evaluating term value '[]) (withModules pairs (evaluateModule t)) +evaluates pairs (_, t) = run @(Evaluating term value) @(EvaluatingEffects term value '[]) (withModules pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. -withModules :: (MonadAnalysis m, MonadEvaluator m) => [(Blob, TermFor m)] -> m a -> m a +withModules :: MonadAnalysis term value effects m => [(Blob, term)] -> m term value effects a -> m term value effects a withModules pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first (dropExtensions . blobPath)) pairs)) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff (EvaluatingEffects term value effects) a } +newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff effects a } deriving (Applicative, Functor, Effectful, Monad) -deriving instance Member Fail (EvaluatingEffects term value effects) => MonadFail (Evaluating term value effects) -deriving instance Member Fresh (EvaluatingEffects term value effects) => MonadFresh (Evaluating term value effects) -deriving instance Member NonDetEff (EvaluatingEffects term value effects) => Alternative (Evaluating term value effects) -deriving instance Member NonDetEff (EvaluatingEffects term value 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 NonDetEff effects => Alternative (Evaluating term value effects) +deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) type EvaluatingEffects term value effects = Fail -- Failure with an error message @@ -65,10 +67,7 @@ type EvaluatingEffects term value effects ': State (ModuleTable value) -- Cache of evaluated modules ': effects -instance MonadEvaluator (Evaluating term value effects) where - type TermFor (Evaluating term value effects) = term - type ValueFor (Evaluating term value effects) = value - +instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator term value effects Evaluating where getGlobalEnv = lift get modifyGlobalEnv f = lift (modify f) @@ -86,9 +85,11 @@ instance MonadEvaluator (Evaluating term value effects) where instance ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) (Evaluating term value effects) - , MonadValue value (Evaluating term value effects) + , Members (EvaluatingEffects term value '[]) effects + , MonadAddressable (LocationFor value) term value effects Evaluating + , MonadValue term value effects Evaluating , Recursive term ) - => MonadAnalysis (Evaluating term value effects) where + => MonadAnalysis term value effects Evaluating where + type RequiredEffects term value Evaluating = EvaluatingEffects term value '[] analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 6ece5e826..1ed6bbbcb 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, KindSignatures, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Analysis @@ -9,35 +9,36 @@ import Data.Semigroup.Reducer as Reducer import Prologue type Trace trace term value = trace (ConfigurationFor term value) -type TraceFor trace m = Trace trace (TermFor m) (ValueFor m) type Tracer trace term value = Writer (Trace trace term value) -type TracerFor trace m = Writer (TraceFor trace m) -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -newtype TracingAnalysis (trace :: * -> *) m a - = TracingAnalysis { runTracingAnalysis :: m a } - deriving (Applicative, Functor, Effectful, Monad, MonadEvaluator, MonadFail) +newtype TracingAnalysis (trace :: * -> *) m term value (effects :: [* -> *]) a + = TracingAnalysis { runTracingAnalysis :: m term value effects a } + deriving (Applicative, Functor, Effectful, Monad, MonadFail) -instance ( Corecursive (TermFor m) - , Effectful m - , Member (TracerFor trace m) (EffectsFor m) - , MonadAnalysis m - , MonadEvaluator m - , Ord (LocationFor (ValueFor m)) - , Recursive (TermFor m) - , Reducer (ConfigurationFor (TermFor m) (ValueFor m)) (TraceFor trace m) +deriving instance MonadEvaluator term value effects m => MonadEvaluator term value effects (TracingAnalysis trace m) + +instance ( Corecursive term + , Effectful (m term value) + , Member (Tracer trace term value) effects + , MonadAnalysis term value effects m + , MonadEvaluator term value effects m + , Ord (LocationFor value) + , Recursive term + , Reducer (ConfigurationFor term value) (Trace trace term value) ) - => MonadAnalysis (TracingAnalysis trace m) where + => MonadAnalysis term value effects (TracingAnalysis trace m) where + type RequiredEffects term value (TracingAnalysis trace m) = Writer (Trace trace term value) ': RequiredEffects term value m analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) liftAnalyze analyzeTerm term -trace :: ( Effectful m - , Member (TracerFor trace m) (EffectsFor m) +trace :: ( Effectful (m term value) + , Member (Tracer trace term value) effects ) - => TraceFor trace m - -> TracingAnalysis trace m () + => Trace trace term value + -> TracingAnalysis trace m term value effects () trace = lift . tell diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 91d2c247e..c32a3805b 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DataKinds, FunctionalDependencies, KindSignatures, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Addressable where import Control.Abstract.Analysis @@ -15,60 +15,57 @@ import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad m, Ord l, l ~ LocationFor (ValueFor m), Reducer (ValueFor m) (Cell l (ValueFor m))) => MonadAddressable l m where - deref :: Address l (ValueFor m) - -> m (ValueFor m) +class (Monad (m term value effects), Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l term value (effects :: [* -> *]) m where + deref :: Address l value + -> m term value effects value alloc :: Name - -> m (Address l (ValueFor m)) + -> m term value effects (Address l value) -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- -- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. lookupOrAlloc :: ( FreeVariables t - , MonadAddressable (LocationFor a) m - , MonadEvaluator m - , a ~ ValueFor m - , Semigroup (CellFor a) + , MonadAddressable (LocationFor value) term value effects m + , MonadEvaluator term value effects m + , Semigroup (CellFor value) ) => t - -> a - -> Environment (LocationFor a) a - -> m (Name, Address (LocationFor a) a) + -> value + -> Environment (LocationFor value) value + -> m term value effects (Name, Address (LocationFor value) value) lookupOrAlloc term = let [name] = toList (freeVariables term) in lookupOrAlloc' name where -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. - lookupOrAlloc' :: ( Semigroup (CellFor a) - , MonadAddressable (LocationFor a) m - , a ~ ValueFor m - , MonadEvaluator m + lookupOrAlloc' :: ( Semigroup (CellFor value) + , MonadAddressable (LocationFor value) term value effects m + , MonadEvaluator term value effects m ) => Name - -> a - -> Environment (LocationFor a) a - -> m (Name, Address (LocationFor a) a) + -> value + -> Environment (LocationFor value) value + -> m term value effects (Name, Address (LocationFor value) value) lookupOrAlloc' name v env = do a <- maybe (alloc name) pure (envLookup name env) assign a v pure (name, a) -- | Write a value to the given 'Address' in the 'Store'. -assign :: ( Ord (LocationFor a) - , MonadEvaluator m - , a ~ ValueFor m - , Reducer a (CellFor a) +assign :: ( Ord (LocationFor value) + , MonadEvaluator term value effects m + , Reducer value (CellFor value) ) - => Address (LocationFor a) a - -> a - -> m () + => Address (LocationFor value) value + -> value + -> m term value effects () assign address = modifyStore . storeInsert address -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => MonadAddressable Precise m where +instance (Monad (m term value effects), LocationFor value ~ Precise, MonadEvaluator term value effects m) => MonadAddressable Precise term value effects m where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -79,7 +76,7 @@ instance (Monad m, MonadEvaluator m, LocationFor (ValueFor m) ~ Precise) => Mona -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, Ord (ValueFor m), LocationFor (ValueFor m) ~ Monovariant, Monad m, MonadEvaluator m) => MonadAddressable Monovariant m where +instance (Alternative (m term value effects), Monad (m term value effects), LocationFor value ~ Monovariant, MonadEvaluator term value effects m, Ord value) => MonadAddressable Monovariant term value effects m where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 3bba4917c..1ef8b79ed 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -20,37 +20,30 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class (MonadEvaluator m, Recursive (TermFor m)) => MonadAnalysis m where +class (MonadEvaluator term value effects m, Recursive term) => MonadAnalysis term value effects m where + type family RequiredEffects term value m :: [* -> *] -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. - analyzeTerm :: SubtermAlgebra (Base (TermFor m)) (TermFor m) (m (ValueFor m)) + analyzeTerm :: SubtermAlgebra (Base term) term (m term value effects value) - evaluateModule :: TermFor m -> m (ValueFor m) + evaluateModule :: term -> m term value effects value evaluateModule = evaluateTerm -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. -evaluateTerm :: MonadAnalysis m => TermFor m -> m (ValueFor m) +evaluateTerm :: MonadAnalysis term value effects m => term -> m term value effects value evaluateTerm = foldSubterms analyzeTerm -liftAnalyze :: ( term ~ TermFor m - , term ~ TermFor (t m) - , value ~ ValueFor m - , value ~ ValueFor (t m) - , Coercible ( m value) (t m value) - , Coercible (t m value) ( m value) +liftAnalyze :: ( Coercible ( m term value (effects :: [* -> *]) value) (t m term value effects value) + , Coercible (t m term value effects value) ( m term value effects value) , Functor (Base term) ) - => SubtermAlgebra (Base term) term ( m value) - -> SubtermAlgebra (Base term) term (t m value) + => SubtermAlgebra (Base term) term ( m term value effects value) + -> SubtermAlgebra (Base term) term (t m term value effects value) liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -liftEvaluate :: ( term ~ TermFor m - , term ~ TermFor (t m) - , value ~ ValueFor m - , value ~ ValueFor (t m) - , Coercible (m value) (t m value) +liftEvaluate :: ( Coercible (m term value (effects :: [* -> *]) value) (t m term value effects value) ) - => (term -> m value) - -> (term -> t m value) + => (term -> m term value effects value) + -> (term -> t m term value effects value) liftEvaluate evaluate = coerce . evaluate diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 77341d341..edf46b6d1 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, TypeFamilies #-} +{-# LANGUAGE ConstrainedClassMethods, DataKinds, MultiParamTypeClasses, KindSignatures, TypeFamilies #-} module Control.Abstract.Evaluator where import Data.Abstract.Configuration @@ -14,41 +14,38 @@ import Prologue -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class MonadFail m => MonadEvaluator m where - type TermFor m - type ValueFor m - +class MonadFail (m term value effects) => MonadEvaluator term value (effects :: [* -> *]) m where -- | Retrieve the global environment. - getGlobalEnv :: m (EnvironmentFor (ValueFor m)) + getGlobalEnv :: m term value effects (EnvironmentFor value) -- | Update the global environment. - modifyGlobalEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m () + modifyGlobalEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m term value effects () -- | Retrieve the local environment. - askLocalEnv :: m (EnvironmentFor (ValueFor m)) + askLocalEnv :: m term value effects (EnvironmentFor value) -- | Run an action with a locally-modified environment. - localEnv :: (EnvironmentFor (ValueFor m) -> EnvironmentFor (ValueFor m)) -> m a -> m a + localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m term value effects a -> m term value effects a -- | Retrieve the heap. - getStore :: m (StoreFor (ValueFor m)) + getStore :: m term value effects (StoreFor value) -- | Update the heap. - modifyStore :: (StoreFor (ValueFor m) -> StoreFor (ValueFor m)) -> m () - putStore :: StoreFor (ValueFor m) -> m () + modifyStore :: (StoreFor value -> StoreFor value) -> m term value effects () + putStore :: StoreFor value -> m term value effects () putStore = modifyStore . const -- | Retrieve the table of evaluated modules. - getModuleTable :: m (ModuleTable (ValueFor m)) + getModuleTable :: m term value effects (ModuleTable value) -- | Update the table of evaluated modules. - modifyModuleTable :: (ModuleTable (ValueFor m) -> ModuleTable (ValueFor m)) -> m () + modifyModuleTable :: (ModuleTable value -> ModuleTable value) -> m term value effects () -- | Retrieve the table of unevaluated modules. - askModuleTable :: m (ModuleTable (TermFor m)) + askModuleTable :: m term value effects (ModuleTable term) -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (ModuleTable (TermFor m) -> ModuleTable (TermFor m)) -> m a -> m a + localModuleTable :: (ModuleTable term -> ModuleTable term) -> m term value effects a -> m term value effects a -- | Retrieve the current root set. - askRoots :: Ord (LocationFor (ValueFor m)) => m (Live (LocationFor (ValueFor m)) (ValueFor m)) + askRoots :: Ord (LocationFor value) => m term value effects (Live (LocationFor value) value) askRoots = pure mempty -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord (LocationFor (ValueFor m)) => term -> m (Configuration (LocationFor (ValueFor m)) term (ValueFor m)) + getConfiguration :: Ord (LocationFor value) => term -> m term value effects (Configuration (LocationFor value) term value) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 81dec141d..657dfa386 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DataKinds, MultiParamTypeClasses, KindSignatures, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Value where import Control.Abstract.Addressable @@ -16,41 +16,39 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadEvaluator m, v ~ ValueFor m) => MonadValue v m where +class MonadEvaluator term value effects m => MonadValue term value effects m where -- | Construct an abstract unit value. - unit :: m v + unit :: m term value effects value -- | Construct an abstract integral value. - integer :: Prelude.Integer -> m v + integer :: Prelude.Integer -> m term value effects value -- | Construct an abstract boolean value. - boolean :: Bool -> m v + boolean :: Bool -> m term value effects value -- | Construct an abstract string value. - string :: ByteString -> m v + string :: ByteString -> m term value effects value -- | Construct a floating-point value. - float :: Scientific -> m v + float :: Scientific -> m term value effects value -- | Eliminate boolean values. TODO: s/boolean/truthy - ifthenelse :: v -> m v -> m v -> m v + ifthenelse :: value -> m term value effects value -> m term value effects value -> m term value effects value -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: [Name] -> Subterm (TermFor m) (m v) -> m v + abstract :: [Name] -> Subterm term (m term value effects value) -> m term value effects value -- | Evaluate an application (like a function call). - apply :: v -> [Subterm (TermFor m) (m v)] -> m v + apply :: value -> [Subterm term (m term value effects value)] -> m term value effects value -- | Construct a 'Value' wrapping the value arguments (if any). -instance ( FreeVariables t - , MonadAddressable location m - , MonadAnalysis m - , TermFor m ~ t - , ValueFor m ~ Value location t - , MonadEvaluator m - , Recursive t - , Semigroup (Cell location (Value location t)) +instance ( FreeVariables term + , MonadAddressable location term (Value location term) effects m + , MonadAnalysis term (Value location term) effects m + , MonadEvaluator term (Value location term) effects m + , Recursive term + , Semigroup (Cell location (Value location term)) ) - => MonadValue (Value location t) m where + => MonadValue term (Value location term) effects m where unit = pure $ inj Value.Unit integer = pure . inj . Integer @@ -74,7 +72,7 @@ instance ( FreeVariables t localEnv (mappend bindings) (evaluateTerm body) -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative m, MonadEvaluator m, MonadFresh m, ValueFor m ~ Type) => MonadValue Type m where +instance (Alternative (m term Type effects), MonadEvaluator term Type effects m, MonadFresh (m term Type effects)) => MonadValue term Type effects m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index aa132c0b2..20ef97d18 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -12,7 +12,7 @@ import Data.Semigroup.Reducer import Prologue -- | Run an 'Effectful' computation to completion, interpreting each effect with some sensible defaults, and return the 'Final' result. -run :: (Effectful m, RunEffects (EffectsFor m) a) => m a -> Final (EffectsFor m) a +run :: (Effectful m, RunEffects effects a) => m effects a -> Final effects a run = Effect.run . runEffects . lower -- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults. @@ -67,11 +67,9 @@ instance Ord a => RunEffect NonDetEff a where class Effectful m where - type EffectsFor m :: [* -> *] - lift :: Eff (EffectsFor m) a -> m a - lower :: m a -> Eff (EffectsFor m) a + lift :: Eff effects a -> m effects a + lower :: m effects a -> Eff effects a -instance Effectful (Eff effects) where - type EffectsFor (Eff effects) = effects +instance Effectful Eff where lift = id lower = id diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index b3c9c495d..6450bf488 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -28,15 +28,13 @@ import Prologue -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class Evaluatable constr where - eval :: ( term ~ TermFor m - , value ~ ValueFor m - , FreeVariables term - , MonadAddressable (LocationFor value) m - , MonadAnalysis m - , MonadValue value m + eval :: ( FreeVariables term + , MonadAddressable (LocationFor value) term value effects m + , MonadAnalysis term value effects m + , MonadValue term value effects m ) - => SubtermAlgebra constr term (m value) - default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) + => SubtermAlgebra constr term (m term value effects value) + default eval :: (MonadAnalysis term value effects m, Show1 constr) => SubtermAlgebra constr term (m term value effects value) eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "" -- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'. @@ -73,22 +71,22 @@ instance Evaluatable [] where -- | Require/import another term/file and return an Effect. -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. -require :: ( FreeVariables (TermFor m) - , MonadAnalysis m +require :: ( FreeVariables term + , MonadAnalysis term value effects m ) - => TermFor m - -> m (ValueFor m) + => term + -> m term value effects value require term = getModuleTable >>= maybe (load term) pure . moduleTableLookup name where name = moduleName term -- | Load another term/file and return an Effect. -- -- Always loads/evaluates. -load :: ( FreeVariables (TermFor m) - , MonadAnalysis m +load :: ( FreeVariables term + , MonadAnalysis term value effects m ) - => TermFor m - -> m (ValueFor m) + => term + -> m term value effects value load term = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name where name = moduleName term notFound = fail ("cannot find " <> show name) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 8668da315..4766df687 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -8,6 +8,7 @@ import Analysis.Abstract.Evaluating import Analysis.Abstract.Tracing import Analysis.Declaration import Control.Abstract.Analysis +import qualified Control.Monad.Effect as Effect import Control.Monad.IO.Class import Data.Abstract.Address import Data.Abstract.Type @@ -43,15 +44,18 @@ evaluateRubyFiles paths = do first:rest <- traverse (parseFile rubyParser) paths pure $ evaluates @RubyValue rest first +runAnalysis :: (Effectful (m term value), RunEffects (RequiredEffects term value m) a) => m term value (RequiredEffects term value m) a -> Final (RequiredEffects term value m) a +runAnalysis = Effect.run . runEffects . lower + -- Python -- TODO: Can we phrase this type as something like (CachingAnalysis Evaluating Python.Term Type '[]) ? -typecheckPythonFile path = run @(CachingAnalysis (Evaluating Python.Term Type (CachingEffects Python.Term Type '[]))) . evaluateModule . snd <$> parseFile pythonParser path +typecheckPythonFile path = runAnalysis @(CachingAnalysis Evaluating) @Python.Term @Type . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = run @(TracingAnalysis [] (Evaluating Python.Term PythonValue '[Tracer [] Python.Term PythonValue])) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = runAnalysis @(TracingAnalysis [] Evaluating) @Python.Term @PythonValue . evaluateModule . snd <$> parseFile pythonParser path -type PythonTracer = TracingAnalysis [] (Evaluating Python.Term PythonValue '[DeadCode Python.Term, Tracer [] Python.Term PythonValue]) +-- type PythonTracer = TracingAnalysis [] Evaluating Python.Term PythonValue '[DeadCode Python.Term, Tracer [] Python.Term PythonValue] -evaluateDeadTracePythonFile path = run @(DeadCodeAnalysis PythonTracer) . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCodeAnalysis (TracingAnalysis [] Evaluating)) @Python.Term @PythonValue . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From c0315632aea57c0d6eb4987220aebfb2da1a5443 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 12:08:15 -0500 Subject: [PATCH 212/292] :fire: the commented-out PythonTracer synonym. --- src/Semantic/Util.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 4766df687..702222b7a 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -53,8 +53,6 @@ typecheckPythonFile path = runAnalysis @(CachingAnalysis Evaluating) @Python.Ter tracePythonFile path = runAnalysis @(TracingAnalysis [] Evaluating) @Python.Term @PythonValue . evaluateModule . snd <$> parseFile pythonParser path --- type PythonTracer = TracingAnalysis [] Evaluating Python.Term PythonValue '[DeadCode Python.Term, Tracer [] Python.Term PythonValue] - evaluateDeadTracePythonFile path = runAnalysis @(DeadCodeAnalysis (TracingAnalysis [] Evaluating)) @Python.Term @PythonValue . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From 97fbda62a40399fb2f2f1a3272c0cddc1f3b9e25 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 12:08:24 -0500 Subject: [PATCH 213/292] Turns out yes! --- src/Semantic/Util.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 702222b7a..1d881970c 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -48,7 +48,6 @@ runAnalysis :: (Effectful (m term value), RunEffects (RequiredEffects term value runAnalysis = Effect.run . runEffects . lower -- Python --- TODO: Can we phrase this type as something like (CachingAnalysis Evaluating Python.Term Type '[]) ? typecheckPythonFile path = runAnalysis @(CachingAnalysis Evaluating) @Python.Term @Type . evaluateModule . snd <$> parseFile pythonParser path tracePythonFile path = runAnalysis @(TracingAnalysis [] Evaluating) @Python.Term @PythonValue . evaluateModule . snd <$> parseFile pythonParser path From 8299a2de68a43acea233696c7e62a3cb0861a02b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 12:09:25 -0500 Subject: [PATCH 214/292] Move runAnalysis into Control.Abstract.Analysis. --- src/Control/Abstract/Analysis.hs | 6 ++++++ src/Semantic/Util.hs | 4 ---- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 1ef8b79ed..c40b5727e 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -4,6 +4,7 @@ module Control.Abstract.Analysis , evaluateTerm , liftAnalyze , liftEvaluate +, runAnalysis , module X , Subterm(..) , SubtermAlgebra @@ -11,6 +12,7 @@ module Control.Abstract.Analysis import Control.Abstract.Evaluator as X import Control.Effect as X +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 @@ -47,3 +49,7 @@ liftEvaluate :: ( Coercible (m term value (effects :: [* -> *]) value) (t m term => (term -> m term value effects value) -> (term -> t m term value effects value) liftEvaluate evaluate = coerce . evaluate + + +runAnalysis :: (Effectful (m term value), RunEffects (RequiredEffects term value m) a) => m term value (RequiredEffects term value m) a -> Final (RequiredEffects term value m) a +runAnalysis = Effect.run . runEffects . lower diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 1d881970c..6441f8a88 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -8,7 +8,6 @@ import Analysis.Abstract.Evaluating import Analysis.Abstract.Tracing import Analysis.Declaration import Control.Abstract.Analysis -import qualified Control.Monad.Effect as Effect import Control.Monad.IO.Class import Data.Abstract.Address import Data.Abstract.Type @@ -44,9 +43,6 @@ evaluateRubyFiles paths = do first:rest <- traverse (parseFile rubyParser) paths pure $ evaluates @RubyValue rest first -runAnalysis :: (Effectful (m term value), RunEffects (RequiredEffects term value m) a) => m term value (RequiredEffects term value m) a -> Final (RequiredEffects term value m) a -runAnalysis = Effect.run . runEffects . lower - -- Python typecheckPythonFile path = runAnalysis @(CachingAnalysis Evaluating) @Python.Term @Type . evaluateModule . snd <$> parseFile pythonParser path From 80035c8fbc6dd36f9326fd9666c6fc9664c222eb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 12:11:07 -0500 Subject: [PATCH 215/292] Tidy language extensions. --- src/Control/Abstract/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index edf46b6d1..deaa4ddad 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, DataKinds, MultiParamTypeClasses, KindSignatures, TypeFamilies #-} +{-# LANGUAGE ConstrainedClassMethods, DataKinds, KindSignatures, MultiParamTypeClasses #-} module Control.Abstract.Evaluator where import Data.Abstract.Configuration From 836a76b2eaf2f99d1aad5ee95cbfa1e90412e760 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 12:24:15 -0500 Subject: [PATCH 216/292] =?UTF-8?q?EvaluatingEffects=20doesn=E2=80=99t=20n?= =?UTF-8?q?eed=20to=20prepend.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Evaluating.hs | 38 ++++++++++++++--------------- 1 file changed, 19 insertions(+), 19 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 0d3cd742d..d835f123b 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,26 +23,26 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value '[]) Evaluating - , MonadValue term value (EvaluatingEffects term value '[]) Evaluating + , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value) Evaluating + , MonadValue term value (EvaluatingEffects term value) Evaluating , Recursive term ) => term - -> Final (EvaluatingEffects term value '[]) value -evaluate = run @(Evaluating term value) @(EvaluatingEffects term value '[]) . evaluateModule + -> Final (EvaluatingEffects term value) value +evaluate = run @(Evaluating term value) @(EvaluatingEffects term value) . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value '[]) Evaluating - , MonadValue term value (EvaluatingEffects term value '[]) Evaluating + , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value) Evaluating + , MonadValue term value (EvaluatingEffects term value) Evaluating , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint - -> Final (EvaluatingEffects term value '[]) value -evaluates pairs (b, t) = run @(Evaluating term value) @(EvaluatingEffects term value '[]) (withModules b pairs (evaluateModule t)) + -> Final (EvaluatingEffects term value) value +evaluates pairs (b, t) = run @(Evaluating term value) @(EvaluatingEffects term value) (withModules b pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: MonadAnalysis term value effects m => Blob -> [(Blob, term)] -> m term value effects a -> m term value effects a @@ -64,16 +64,16 @@ deriving instance Member Fresh effects => MonadFresh (Evaluating term value deriving instance Member NonDetEff effects => Alternative (Evaluating term value effects) deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) -type EvaluatingEffects term value effects - = Fail -- Failure with an error message - ': Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) - ': State (EnvironmentFor value) -- Global (imperative) environment - ': State (StoreFor value) -- The heap - ': Reader (ModuleTable term) -- Cache of unevaluated modules - ': State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules - ': effects +type EvaluatingEffects term value + = '[ Fail -- Failure with an error message + , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) + , State (EnvironmentFor value) -- Global (imperative) environment + , State (StoreFor value) -- The heap + , Reader (ModuleTable term) -- Cache of unevaluated modules + , State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules + ] -instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator term value effects Evaluating where +instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value effects Evaluating where getGlobalEnv = lift get putGlobalEnv = lift . put modifyGlobalEnv f = lift (modify f) @@ -92,11 +92,11 @@ instance Members (EvaluatingEffects term value '[]) effects => MonadEvaluator te instance ( Evaluatable (Base term) , FreeVariables term - , Members (EvaluatingEffects term value '[]) effects + , Members (EvaluatingEffects term value) effects , MonadAddressable (LocationFor value) term value effects Evaluating , MonadValue term value effects Evaluating , Recursive term ) => MonadAnalysis term value effects Evaluating where - type RequiredEffects term value Evaluating = EvaluatingEffects term value '[] + type RequiredEffects term value Evaluating = EvaluatingEffects term value analyzeTerm = eval From e224f0c80bd3fd41ebd072819f495c821c917f51 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 12:57:20 -0500 Subject: [PATCH 217/292] :fire: the effects parameter from MonadValue. --- src/Analysis/Abstract/Evaluating.hs | 6 +++--- src/Control/Abstract/Value.hs | 28 ++++++++++++++-------------- src/Data/Abstract/Evaluatable.hs | 6 +++--- 3 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index d835f123b..05f431b03 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -24,7 +24,7 @@ evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value) Evaluating - , MonadValue term value (EvaluatingEffects term value) Evaluating + , MonadValue term value (Evaluating term value (EvaluatingEffects term value)) , Recursive term ) => term @@ -36,7 +36,7 @@ evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value) Evaluating - , MonadValue term value (EvaluatingEffects term value) Evaluating + , MonadValue term value (Evaluating term value (EvaluatingEffects term value)) , Recursive term ) => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated @@ -94,7 +94,7 @@ instance ( Evaluatable (Base term) , FreeVariables term , Members (EvaluatingEffects term value) effects , MonadAddressable (LocationFor value) term value effects Evaluating - , MonadValue term value effects Evaluating + , MonadValue term value (Evaluating term value effects) , Recursive term ) => MonadAnalysis term value effects Evaluating where diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index f25be11ee..7f35fbebe 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, MultiParamTypeClasses, KindSignatures, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DataKinds, FunctionalDependencies, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Value where import Control.Abstract.Addressable @@ -16,35 +16,35 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class MonadEvaluator term value effects m => MonadValue term value effects m where +class Monad m => MonadValue term value m | m -> term, m -> value where -- | Construct an abstract unit value. - unit :: m term value effects value + unit :: m value -- | Construct an abstract integral value. - integer :: Prelude.Integer -> m term value effects value + integer :: Prelude.Integer -> m value -- | Construct an abstract boolean value. - boolean :: Bool -> m term value effects value + boolean :: Bool -> m value -- | Construct an abstract string value. - string :: ByteString -> m term value effects value + string :: ByteString -> m value -- | Construct a floating-point value. - float :: Scientific -> m term value effects value + float :: Scientific -> m value -- | Construct an abstract interface value. - interface :: value -> m term value effects value + interface :: value -> m value -- | Eliminate boolean values. TODO: s/boolean/truthy - ifthenelse :: value -> m term value effects value -> m term value effects value -> m term value effects value + ifthenelse :: value -> m value -> m value -> m value -- | Evaluate an abstraction (a binder like a lambda or method definition). - abstract :: [Name] -> Subterm term (m term value effects value) -> m term value effects value + abstract :: [Name] -> Subterm term (m value) -> m value -- | Evaluate an application (like a function call). - apply :: value -> [Subterm term (m term value effects value)] -> m term value effects value + apply :: value -> [Subterm term (m value)] -> m value -- | Extract the environment from an interface value. - environment :: value -> m term value effects (EnvironmentFor value) + environment :: value -> m (EnvironmentFor value) -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables term @@ -54,7 +54,7 @@ instance ( FreeVariables term , Recursive term , Semigroup (Cell location (Value location term)) ) - => MonadValue term (Value location term) effects m where + => MonadValue term (Value location term) (m term (Value location term) effects) where unit = pure $ inj Value.Unit integer = pure . inj . Integer @@ -83,7 +83,7 @@ instance ( FreeVariables term | otherwise = pure mempty -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative (m term Type effects), MonadEvaluator term Type effects m, MonadFresh (m term Type effects)) => MonadValue term Type effects m where +instance (Alternative (m term Type effects), MonadEvaluator term Type effects m, MonadFresh (m term Type effects)) => MonadValue term Type (m term Type effects) where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 0ffbdcfd6..9f6c5cede 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -30,7 +30,7 @@ class Evaluatable constr where eval :: ( FreeVariables term , MonadAddressable (LocationFor value) term value effects m , MonadAnalysis term value effects m - , MonadValue term value effects m + , MonadValue term value (m term value effects) ) => SubtermAlgebra constr term (m term value effects value) default eval :: (MonadAnalysis term value effects m, Show1 constr) => SubtermAlgebra constr term (m term value effects value) @@ -71,7 +71,7 @@ instance Evaluatable [] where -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. require :: ( MonadAnalysis term value effects m - , MonadValue term value effects m + , MonadValue term value (m term value effects) ) => ModuleName -> m term value effects (EnvironmentFor value) @@ -81,7 +81,7 @@ require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup nam -- -- Always loads/evaluates. load :: ( MonadAnalysis term value effects m - , MonadValue term value effects m + , MonadValue term value (m term value effects) ) => ModuleName -> m term value effects (EnvironmentFor value) From c7bdb13cc48321811fbe810c93f92c2f507524f2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:01:11 -0500 Subject: [PATCH 218/292] :fire: the term & effects parameters from MonadAddressable. --- src/Analysis/Abstract/Evaluating.hs | 6 +++--- src/Control/Abstract/Addressable.hs | 18 +++++++++--------- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 2 +- 4 files changed, 14 insertions(+), 14 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 05f431b03..fca87ac16 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,7 +23,7 @@ import System.FilePath.Posix evaluate :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value) Evaluating + , MonadAddressable (LocationFor value) value (Evaluating term value (EvaluatingEffects term value)) , MonadValue term value (Evaluating term value (EvaluatingEffects term value)) , Recursive term ) @@ -35,7 +35,7 @@ evaluate = run @(Evaluating term value) @(EvaluatingEffects term value) . evalua evaluates :: forall value term . ( Evaluatable (Base term) , FreeVariables term - , MonadAddressable (LocationFor value) term value (EvaluatingEffects term value) Evaluating + , MonadAddressable (LocationFor value) value (Evaluating term value (EvaluatingEffects term value)) , MonadValue term value (Evaluating term value (EvaluatingEffects term value)) , Recursive term ) @@ -93,7 +93,7 @@ instance Members (EvaluatingEffects term value) effects => MonadEvaluator term v instance ( Evaluatable (Base term) , FreeVariables term , Members (EvaluatingEffects term value) effects - , MonadAddressable (LocationFor value) term value effects Evaluating + , MonadAddressable (LocationFor value) value (Evaluating term value effects) , MonadValue term value (Evaluating term value effects) , Recursive term ) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index d72663277..c3e3ae713 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -15,22 +15,22 @@ import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad (m term value effects), Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l term value (effects :: [* -> *]) m where +class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m | m -> value where deref :: Address l value - -> m term value effects value + -> m value alloc :: Name - -> m term value effects (Address l value) + -> m (Address l value) -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- -- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. -lookupOrAlloc :: ( FreeVariables t - , MonadAddressable (LocationFor value) term value effects m +lookupOrAlloc :: ( FreeVariables term + , MonadAddressable (LocationFor value) value (m term value effects) , MonadEvaluator term value effects m , Semigroup (CellFor value) ) - => t + => term -> value -> Environment (LocationFor value) value -> m term value effects (Name, Address (LocationFor value) value) @@ -39,7 +39,7 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. lookupOrAlloc' :: ( Semigroup (CellFor value) - , MonadAddressable (LocationFor value) term value effects m + , MonadAddressable (LocationFor value) value (m term value effects) , MonadEvaluator term value effects m ) => Name @@ -65,7 +65,7 @@ assign address = modifyStore . storeInsert address -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Monad (m term value effects), LocationFor value ~ Precise, MonadEvaluator term value effects m) => MonadAddressable Precise term value effects m where +instance (Monad (m term value effects), LocationFor value ~ Precise, MonadEvaluator term value effects m) => MonadAddressable Precise value (m term value effects) where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -76,7 +76,7 @@ instance (Monad (m term value effects), LocationFor value ~ Precise, MonadEvalua -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative (m term value effects), Monad (m term value effects), LocationFor value ~ Monovariant, MonadEvaluator term value effects m, Ord value) => MonadAddressable Monovariant term value effects m where +instance (Alternative (m term value effects), Monad (m term value effects), LocationFor value ~ Monovariant, MonadEvaluator term value effects m, Ord value) => MonadAddressable Monovariant value (m term value effects) where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 7f35fbebe..2a3920be4 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -48,7 +48,7 @@ class Monad m => MonadValue term value m | m -> term, m -> value where -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables term - , MonadAddressable location term (Value location term) effects m + , MonadAddressable location (Value location term) (m term (Value location term) effects) , MonadAnalysis term (Value location term) effects m , MonadEvaluator term (Value location term) effects m , Recursive term diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 9f6c5cede..9fc781122 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -28,7 +28,7 @@ import Prologue -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class Evaluatable constr where eval :: ( FreeVariables term - , MonadAddressable (LocationFor value) term value effects m + , MonadAddressable (LocationFor value) value (m term value effects) , MonadAnalysis term value effects m , MonadValue term value (m term value effects) ) From 411de015855006e9588aa5fa0b47cea9f8b7b832 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:17:48 -0500 Subject: [PATCH 219/292] Remove the effects parameters from MonadEvaluator and MonadAnalysis. --- src/Analysis/Abstract/Caching.hs | 12 +++++------ src/Analysis/Abstract/Dead.hs | 10 ++++----- src/Analysis/Abstract/Evaluating.hs | 8 ++++---- src/Analysis/Abstract/Tracing.hs | 10 ++++----- src/Control/Abstract/Addressable.hs | 20 +++++++++--------- src/Control/Abstract/Analysis.hs | 12 +++++------ src/Control/Abstract/Evaluator.hs | 32 ++++++++++++++--------------- src/Control/Abstract/Value.hs | 12 +++++------ src/Data/Abstract/Evaluatable.hs | 22 ++++++++++---------- 9 files changed, 69 insertions(+), 69 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index e2c1c0714..67fe2659e 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -29,7 +29,7 @@ type CacheFor term value = Cache (LocationFor value) term value newtype CachingAnalysis m term value (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m term value effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadEvaluator term value effects m => MonadEvaluator term value effects (CachingAnalysis m) +deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (CachingAnalysis m term value effects) -- TODO: reabstract these later on @@ -70,11 +70,11 @@ instance ( Corecursive term , Evaluatable (Base term) , Foldable (Cell (LocationFor value)) , FreeVariables term - , MonadAnalysis term value effects m + , MonadAnalysis term value (m term value effects) , Recursive term ) - => MonadAnalysis term value effects (CachingAnalysis m) where - type RequiredEffects term value (CachingAnalysis m) = CachingEffects term value (RequiredEffects term value m) + => MonadAnalysis term value (CachingAnalysis m term value effects) where + type RequiredEffects term value (CachingAnalysis m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -108,7 +108,7 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative (m term value effects), Foldable t, MonadEvaluator term value effects m) => t (a, Store (LocationFor value) value) -> m term value effects a +scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Store (LocationFor value) value) -> m a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. @@ -124,7 +124,7 @@ memoizeEval :: ( Ord value , Effectful (m term value) , Members (CachingEffects term value '[]) effects , Recursive term - , MonadAnalysis term value effects m + , MonadAnalysis term value (m term value effects) -- , Semigroup (CellFor value) ) => SubtermAlgebra (Base term) term (CachingAnalysis m term value effects value) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 735983006..685eb3327 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -15,7 +15,7 @@ type DeadCode term = State (Dead term) newtype DeadCodeAnalysis m term value (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m term value effects a } deriving (Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator term value effects m => MonadEvaluator term value effects (DeadCodeAnalysis m) +deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCodeAnalysis m term value effects) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } @@ -40,13 +40,13 @@ instance ( Corecursive term , Effectful (m term value) , Foldable (Base term) , Member (State (Dead term)) effects - , MonadAnalysis term value effects m - , MonadEvaluator term value effects m + , MonadAnalysis term value (m term value effects) + , MonadEvaluator term value (m term value effects) , Ord term , Recursive term ) - => MonadAnalysis term value effects (DeadCodeAnalysis m) where - type RequiredEffects term value (DeadCodeAnalysis m) = State (Dead term) ': RequiredEffects term value m + => MonadAnalysis term value (DeadCodeAnalysis m term value effects) where + type RequiredEffects term value (DeadCodeAnalysis m term value effects) = State (Dead term) ': RequiredEffects term value (m term value effects) analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index fca87ac16..4a2b6e48e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -45,7 +45,7 @@ evaluates :: forall value term evaluates pairs (b, t) = run @(Evaluating term value) @(EvaluatingEffects term value) (withModules b pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. -withModules :: MonadAnalysis term value effects m => Blob -> [(Blob, term)] -> m term value effects a -> m term value effects a +withModules :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a withModules Blob{..} pairs = localModuleTable (const moduleTable) where moduleTable = ModuleTable (Map.fromList (map (first moduleName) pairs)) @@ -73,7 +73,7 @@ type EvaluatingEffects term value , State (ModuleTable (EnvironmentFor value)) -- Cache of evaluated modules ] -instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value effects Evaluating where +instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where getGlobalEnv = lift get putGlobalEnv = lift . put modifyGlobalEnv f = lift (modify f) @@ -97,6 +97,6 @@ instance ( Evaluatable (Base term) , MonadValue term value (Evaluating term value effects) , Recursive term ) - => MonadAnalysis term value effects Evaluating where - type RequiredEffects term value Evaluating = EvaluatingEffects term value + => MonadAnalysis term value (Evaluating term value effects) where + type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 1ed6bbbcb..a83b7dda0 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -18,19 +18,19 @@ newtype TracingAnalysis (trace :: * -> *) m term value (effects :: [* -> *]) a = TracingAnalysis { runTracingAnalysis :: m term value effects a } deriving (Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator term value effects m => MonadEvaluator term value effects (TracingAnalysis trace m) +deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (TracingAnalysis trace m term value effects) instance ( Corecursive term , Effectful (m term value) , Member (Tracer trace term value) effects - , MonadAnalysis term value effects m - , MonadEvaluator term value effects m + , MonadAnalysis term value (m term value effects) + , MonadEvaluator term value (m term value effects) , Ord (LocationFor value) , Recursive term , Reducer (ConfigurationFor term value) (Trace trace term value) ) - => MonadAnalysis term value effects (TracingAnalysis trace m) where - type RequiredEffects term value (TracingAnalysis trace m) = Writer (Trace trace term value) ': RequiredEffects term value m + => MonadAnalysis term value (TracingAnalysis trace m term value effects) where + type RequiredEffects term value (TracingAnalysis trace m term value effects) = Writer (Trace trace term value) ': RequiredEffects term value (m term value effects) analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index c3e3ae713..bb4c209dd 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -26,26 +26,26 @@ class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => M -- -- The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers. lookupOrAlloc :: ( FreeVariables term - , MonadAddressable (LocationFor value) value (m term value effects) - , MonadEvaluator term value effects m + , MonadAddressable (LocationFor value) value m + , MonadEvaluator term value m , Semigroup (CellFor value) ) => term -> value -> Environment (LocationFor value) value - -> m term value effects (Name, Address (LocationFor value) value) + -> m (Name, Address (LocationFor value) value) lookupOrAlloc term = let [name] = toList (freeVariables term) in lookupOrAlloc' name -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address. lookupOrAlloc' :: ( Semigroup (CellFor value) - , MonadAddressable (LocationFor value) value (m term value effects) - , MonadEvaluator term value effects m + , MonadAddressable (LocationFor value) value m + , MonadEvaluator term value m ) => Name -> value -> Environment (LocationFor value) value - -> m term value effects (Name, Address (LocationFor value) value) + -> m (Name, Address (LocationFor value) value) lookupOrAlloc' name v env = do a <- maybe (alloc name) pure (envLookup name env) assign a v @@ -53,19 +53,19 @@ lookupOrAlloc' name v env = do -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord (LocationFor value) - , MonadEvaluator term value effects m + , MonadEvaluator term value m , Reducer value (CellFor value) ) => Address (LocationFor value) value -> value - -> m term value effects () + -> m () assign address = modifyStore . storeInsert address -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Monad (m term value effects), LocationFor value ~ Precise, MonadEvaluator term value effects m) => MonadAddressable Precise value (m term value effects) where +instance (Monad m, LocationFor value ~ Precise, MonadEvaluator term value m) => MonadAddressable Precise value m where deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup where -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -76,7 +76,7 @@ instance (Monad (m term value effects), LocationFor value ~ Precise, MonadEvalua -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative (m term value effects), Monad (m term value effects), LocationFor value ~ Monovariant, MonadEvaluator term value effects m, Ord value) => MonadAddressable Monovariant value (m term value effects) where +instance (Alternative m, Monad m, LocationFor value ~ Monovariant, MonadEvaluator term value m, Ord value) => MonadAddressable Monovariant value m where deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup alloc = pure . Address . Monovariant diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index c40b5727e..817a372a9 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE DataKinds, FunctionalDependencies, KindSignatures, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm @@ -22,18 +22,18 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class (MonadEvaluator term value effects m, Recursive term) => MonadAnalysis term value effects m where +class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value m | m -> term, m -> value where type family RequiredEffects term value m :: [* -> *] -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. - analyzeTerm :: SubtermAlgebra (Base term) term (m term value effects value) + analyzeTerm :: SubtermAlgebra (Base term) term (m value) - evaluateModule :: term -> m term value effects value + evaluateModule :: term -> m value evaluateModule = evaluateTerm -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. -evaluateTerm :: MonadAnalysis term value effects m => term -> m term value effects value +evaluateTerm :: MonadAnalysis term value m => term -> m value evaluateTerm = foldSubterms analyzeTerm liftAnalyze :: ( Coercible ( m term value (effects :: [* -> *]) value) (t m term value effects value) @@ -51,5 +51,5 @@ liftEvaluate :: ( Coercible (m term value (effects :: [* -> *]) value) (t m term liftEvaluate evaluate = coerce . evaluate -runAnalysis :: (Effectful (m term value), RunEffects (RequiredEffects term value m) a) => m term value (RequiredEffects term value m) a -> Final (RequiredEffects term value m) a +runAnalysis :: (Effectful (m term value), RunEffects effects a, RequiredEffects term value (m term value effects) ~ effects) => m term value effects a -> Final effects a runAnalysis = Effect.run . runEffects . lower diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 4847fae7b..d53c90268 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, DataKinds, KindSignatures, MultiParamTypeClasses #-} +{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, KindSignatures #-} module Control.Abstract.Evaluator where import Data.Abstract.Configuration @@ -14,40 +14,40 @@ import Prologue -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class MonadFail (m term value effects) => MonadEvaluator term value (effects :: [* -> *]) m where +class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where -- | Retrieve the global environment. - getGlobalEnv :: m term value effects (EnvironmentFor value) + getGlobalEnv :: m (EnvironmentFor value) -- | Set the global environment - putGlobalEnv :: EnvironmentFor value -> m term value effects () + putGlobalEnv :: EnvironmentFor value -> m () -- | Update the global environment. - modifyGlobalEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m term value effects () + modifyGlobalEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m () -- | Retrieve the local environment. - askLocalEnv :: m term value effects (EnvironmentFor value) + askLocalEnv :: m (EnvironmentFor value) -- | Run an action with a locally-modified environment. - localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m term value effects a -> m term value effects a + localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a -- | Retrieve the heap. - getStore :: m term value effects (StoreFor value) + getStore :: m (StoreFor value) -- | Update the heap. - modifyStore :: (StoreFor value -> StoreFor value) -> m term value effects () - putStore :: StoreFor value -> m term value effects () + modifyStore :: (StoreFor value -> StoreFor value) -> m () + putStore :: StoreFor value -> m () putStore = modifyStore . const -- | Retrieve the table of evaluated modules. - getModuleTable :: m term value effects (ModuleTable (EnvironmentFor value)) + getModuleTable :: m (ModuleTable (EnvironmentFor value)) -- | Update the table of evaluated modules. - modifyModuleTable :: (ModuleTable (EnvironmentFor value) -> ModuleTable (EnvironmentFor value)) -> m term value effects () + modifyModuleTable :: (ModuleTable (EnvironmentFor value) -> ModuleTable (EnvironmentFor value)) -> m () -- | Retrieve the table of unevaluated modules. - askModuleTable :: m term value effects (ModuleTable term) + askModuleTable :: m (ModuleTable term) -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (ModuleTable term -> ModuleTable term) -> m term value effects a -> m term value effects a + localModuleTable :: (ModuleTable term -> ModuleTable term) -> m a -> m a -- | Retrieve the current root set. - askRoots :: Ord (LocationFor value) => m term value effects (Live (LocationFor value) value) + askRoots :: Ord (LocationFor value) => m (Live (LocationFor value) value) askRoots = pure mempty -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord (LocationFor value) => term -> m term value effects (Configuration (LocationFor value) term value) + getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 2a3920be4..3c3006495 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -16,7 +16,7 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class Monad m => MonadValue term value m | m -> term, m -> value where +class MonadEvaluator term value m => MonadValue term value m where -- | Construct an abstract unit value. unit :: m value @@ -48,13 +48,13 @@ class Monad m => MonadValue term value m | m -> term, m -> value where -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables term - , MonadAddressable location (Value location term) (m term (Value location term) effects) - , MonadAnalysis term (Value location term) effects m - , MonadEvaluator term (Value location term) effects m + , MonadAddressable location (Value location term) m + , MonadAnalysis term (Value location term) m + , MonadEvaluator term (Value location term) m , Recursive term , Semigroup (Cell location (Value location term)) ) - => MonadValue term (Value location term) (m term (Value location term) effects) where + => MonadValue term (Value location term) m where unit = pure $ inj Value.Unit integer = pure . inj . Integer @@ -83,7 +83,7 @@ instance ( FreeVariables term | otherwise = pure mempty -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative (m term Type effects), MonadEvaluator term Type effects m, MonadFresh (m term Type effects)) => MonadValue term Type (m term Type effects) where +instance (Alternative m, MonadEvaluator term Type m, MonadFresh m) => MonadValue term Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 9fc781122..3e52fa8f5 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -28,12 +28,12 @@ import Prologue -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class Evaluatable constr where eval :: ( FreeVariables term - , MonadAddressable (LocationFor value) value (m term value effects) - , MonadAnalysis term value effects m - , MonadValue term value (m term value effects) + , MonadAddressable (LocationFor value) value m + , MonadAnalysis term value m + , MonadValue term value m ) - => SubtermAlgebra constr term (m term value effects value) - default eval :: (MonadAnalysis term value effects m, Show1 constr) => SubtermAlgebra constr term (m term value effects value) + => SubtermAlgebra constr term (m value) + default eval :: (MonadAnalysis term value m, Show1 constr) => SubtermAlgebra constr term (m value) eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "" -- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'. @@ -70,21 +70,21 @@ instance Evaluatable [] where -- | Require/import another term/file and return an Effect. -- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. -require :: ( MonadAnalysis term value effects m - , MonadValue term value (m term value effects) +require :: ( MonadAnalysis term value m + , MonadValue term value m ) => ModuleName - -> m term value effects (EnvironmentFor value) + -> m (EnvironmentFor value) require name = getModuleTable >>= maybe (load name) pure . moduleTableLookup name -- | Load another term/file and return an Effect. -- -- Always loads/evaluates. -load :: ( MonadAnalysis term value effects m - , MonadValue term value (m term value effects) +load :: ( MonadAnalysis term value m + , MonadValue term value m ) => ModuleName - -> m term value effects (EnvironmentFor value) + -> m (EnvironmentFor value) load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name where notFound = fail ("cannot load module: " <> show name) evalAndCache e = do From 7702321f95981c238455d19d6c830e1437c5622b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:20:26 -0500 Subject: [PATCH 220/292] Eta-reduce the analysis type in runAnalysis. --- src/Control/Abstract/Analysis.hs | 2 +- src/Semantic/Util.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 817a372a9..83e42294e 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -51,5 +51,5 @@ liftEvaluate :: ( Coercible (m term value (effects :: [* -> *]) value) (t m term liftEvaluate evaluate = coerce . evaluate -runAnalysis :: (Effectful (m term value), RunEffects effects a, RequiredEffects term value (m term value effects) ~ effects) => m term value effects a -> Final effects a +runAnalysis :: (Effectful m, RunEffects effects a, RequiredEffects term value (m effects) ~ effects, MonadAnalysis term value (m effects)) => m effects a -> Final effects a runAnalysis = Effect.run . runEffects . lower diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index b5ac14b62..8a4d8ea38 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,11 +46,11 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python -typecheckPythonFile path = runAnalysis @(CachingAnalysis Evaluating) @Python.Term @Type . evaluateModule . snd <$> parseFile pythonParser path +typecheckPythonFile path = runAnalysis @(CachingAnalysis Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = runAnalysis @(TracingAnalysis [] Evaluating) @Python.Term @PythonValue . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = runAnalysis @(TracingAnalysis [] Evaluating Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path -evaluateDeadTracePythonFile path = runAnalysis @(DeadCodeAnalysis (TracingAnalysis [] Evaluating)) @Python.Term @PythonValue . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCodeAnalysis (TracingAnalysis [] Evaluating) Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From 73086d9f63ad9a4d98fe40c42b7327371d7ca41c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:24:40 -0500 Subject: [PATCH 221/292] Use runAnalysis to simplify evaluate/s. --- src/Analysis/Abstract/Evaluating.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 4a2b6e48e..180583428 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -29,7 +29,7 @@ evaluate :: forall value term ) => term -> Final (EvaluatingEffects term value) value -evaluate = run @(Evaluating term value) @(EvaluatingEffects term value) . evaluateModule +evaluate = runAnalysis @(Evaluating term value) . evaluateModule -- | Evaluate terms and an entry point to a value. evaluates :: forall value term @@ -42,7 +42,7 @@ evaluates :: forall value term => [(Blob, term)] -- List of (blob, term) pairs that make up the program to be evaluated -> (Blob, term) -- Entrypoint -> Final (EvaluatingEffects term value) value -evaluates pairs (b, t) = run @(Evaluating term value) @(EvaluatingEffects term value) (withModules b pairs (evaluateModule t)) +evaluates pairs (b, t) = runAnalysis @(Evaluating term value) (withModules b pairs (evaluateModule t)) -- | Run an action with the passed ('Blob', @term@) pairs available for imports. withModules :: MonadAnalysis term value m => Blob -> [(Blob, term)] -> m a -> m a From 14e29254ddc736d35a58c4218c5be5e14a8ef133 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:33:26 -0500 Subject: [PATCH 222/292] Avoid redundant functional dependencies. --- src/Control/Abstract/Addressable.hs | 2 +- src/Control/Abstract/Analysis.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index bb4c209dd..ec78c58a7 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -15,7 +15,7 @@ import Data.Semigroup.Reducer import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. -class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m | m -> value where +class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where deref :: Address l value -> m value diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 83e42294e..4a9b58d41 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -22,7 +22,7 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value m | m -> term, m -> value where +class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value m where type family RequiredEffects term value m :: [* -> *] -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. analyzeTerm :: SubtermAlgebra (Base term) term (m value) From e33af1aa70b921f59132159411cd9267cea25e28 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:34:18 -0500 Subject: [PATCH 223/292] Simplify the superclasses of MonadValue. --- src/Control/Abstract/Value.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 3c3006495..df7c3f526 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -16,7 +16,7 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class MonadEvaluator term value m => MonadValue term value m where +class MonadAnalysis term value m => MonadValue term value m where -- | Construct an abstract unit value. unit :: m value @@ -50,7 +50,6 @@ class MonadEvaluator term value m => MonadValue term value m where instance ( FreeVariables term , MonadAddressable location (Value location term) m , MonadAnalysis term (Value location term) m - , MonadEvaluator term (Value location term) m , Recursive term , Semigroup (Cell location (Value location term)) ) @@ -83,7 +82,7 @@ instance ( FreeVariables term | otherwise = pure mempty -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. -instance (Alternative m, MonadEvaluator term Type m, MonadFresh m) => MonadValue term Type m where +instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue term Type m where abstract names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name From 90f6aec2cdfa87aa5cacfd70a4a02b4b7d8eb768 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:35:00 -0500 Subject: [PATCH 224/292] Reformat deref & alloc. --- src/Control/Abstract/Addressable.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index ec78c58a7..eb522332b 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -16,11 +16,9 @@ import Prelude hiding (fail) -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Store. class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => MonadAddressable l value m where - deref :: Address l value - -> m value + deref :: Address l value -> m value - alloc :: Name - -> m (Address l value) + alloc :: Name -> m (Address l value) -- | Look up or allocate an address for a 'Name' free in a given term & assign it a given value, returning the 'Name' paired with the address. -- From bccfdbf4d3755faf12d9adcf0215decc5a73b23a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:36:16 -0500 Subject: [PATCH 225/292] :fire: a bunch of redundant constraints. --- src/Control/Abstract/Value.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index df7c3f526..fdb50e778 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -4,7 +4,6 @@ module Control.Abstract.Value where import Control.Abstract.Addressable import Control.Abstract.Analysis import Control.Monad.Effect.Fresh -import Data.Abstract.Address import Data.Abstract.Environment import Data.Abstract.FreeVariables import Data.Abstract.Value as Value @@ -47,11 +46,8 @@ class MonadAnalysis term value m => MonadValue term value m where environment :: value -> m (EnvironmentFor value) -- | Construct a 'Value' wrapping the value arguments (if any). -instance ( FreeVariables term - , MonadAddressable location (Value location term) m +instance ( MonadAddressable location (Value location term) m , MonadAnalysis term (Value location term) m - , Recursive term - , Semigroup (Cell location (Value location term)) ) => MonadValue term (Value location term) m where From 6a99bb633c085d41f853559831845e42c978a438 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:55:33 -0500 Subject: [PATCH 226/292] :fire: some redundant constraints. --- src/Analysis/Abstract/Caching.hs | 6 ------ src/Analysis/Abstract/Dead.hs | 2 -- src/Analysis/Abstract/Tracing.hs | 2 -- 3 files changed, 10 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 67fe2659e..4f88a06df 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -67,11 +67,8 @@ instance ( Corecursive term , MonadFresh (m term value effects) , MonadNonDet (m term value effects) , Members (CachingEffects term value '[]) effects - , Evaluatable (Base term) , Foldable (Cell (LocationFor value)) - , FreeVariables term , MonadAnalysis term value (m term value effects) - , Recursive term ) => MonadAnalysis term value (CachingAnalysis m term value effects) where type RequiredEffects term value (CachingAnalysis m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) @@ -118,14 +115,11 @@ memoizeEval :: ( Ord value , Ord (CellFor value) , Alternative (m term value effects) , Corecursive term - , FreeVariables term , Foldable (Cell (LocationFor value)) , Functor (Base term) , Effectful (m term value) , Members (CachingEffects term value '[]) effects - , Recursive term , MonadAnalysis term value (m term value effects) - -- , Semigroup (CellFor value) ) => SubtermAlgebra (Base term) term (CachingAnalysis m term value effects value) memoizeEval e = do diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 685eb3327..286374145 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -41,9 +41,7 @@ instance ( Corecursive term , Foldable (Base term) , Member (State (Dead term)) effects , MonadAnalysis term value (m term value effects) - , MonadEvaluator term value (m term value effects) , Ord term - , Recursive term ) => MonadAnalysis term value (DeadCodeAnalysis m term value effects) where type RequiredEffects term value (DeadCodeAnalysis m term value effects) = State (Dead term) ': RequiredEffects term value (m term value effects) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index a83b7dda0..159606fcd 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -24,9 +24,7 @@ instance ( Corecursive term , Effectful (m term value) , Member (Tracer trace term value) effects , MonadAnalysis term value (m term value effects) - , MonadEvaluator term value (m term value effects) , Ord (LocationFor value) - , Recursive term , Reducer (ConfigurationFor term value) (Trace trace term value) ) => MonadAnalysis term value (TracingAnalysis trace m term value effects) where From ab0adf7dc83d44604078bf9dd9eddaf6e58c9d4a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:56:00 -0500 Subject: [PATCH 227/292] :fire: some redundant imports. --- src/Analysis/Abstract/Caching.hs | 1 - src/Analysis/Abstract/Dead.hs | 3 +-- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 4f88a06df..f67389a8d 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -9,7 +9,6 @@ import Control.Monad.Effect.NonDet import Data.Abstract.Address import Data.Abstract.Cache import Data.Abstract.Configuration -import Data.Abstract.Evaluatable import Data.Abstract.Store import Data.Abstract.Value import Data.Monoid (Alt(..)) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 286374145..1bed2a34b 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,8 +1,7 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Dead where -import Control.Abstract.Evaluator -import Data.Abstract.Evaluatable +import Control.Abstract.Analysis import Data.Semigroup.Reducer as Reducer import Data.Set (delete) import Prologue From 621f6f45f02e32714ff1e4775fcb9a648127036f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 13:56:08 -0500 Subject: [PATCH 228/292] :fire: a redundant export list. --- src/Analysis/Abstract/Caching.hs | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index f67389a8d..3c6bea318 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,7 +1,5 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Analysis.Abstract.Caching - -- ( evaluateCache ) - where +module Analysis.Abstract.Caching where import Control.Abstract.Analysis import Control.Monad.Effect.Fresh From c86a2a0d14c2637367d4f9b8705ed6c584a8febb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:00:09 -0500 Subject: [PATCH 229/292] :fire: Tracer. --- src/Analysis/Abstract/Tracing.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 159606fcd..a3cf9be26 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -9,7 +9,6 @@ import Data.Semigroup.Reducer as Reducer import Prologue type Trace trace term value = trace (ConfigurationFor term value) -type Tracer trace term value = Writer (Trace trace term value) -- | Trace analysis. -- @@ -22,7 +21,7 @@ deriving instance MonadEvaluator term value (m term value effects) => MonadEvalu instance ( Corecursive term , Effectful (m term value) - , Member (Tracer trace term value) effects + , Member (Writer (Trace trace term value)) effects , MonadAnalysis term value (m term value effects) , Ord (LocationFor value) , Reducer (ConfigurationFor term value) (Trace trace term value) @@ -35,7 +34,7 @@ instance ( Corecursive term liftAnalyze analyzeTerm term trace :: ( Effectful (m term value) - , Member (Tracer trace term value) effects + , Member (Writer (Trace trace term value)) effects ) => Trace trace term value -> TracingAnalysis trace m term value effects () From ebf7c039cdda97cc6c37ee042f7e0fe5b7215eaa Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:01:52 -0500 Subject: [PATCH 230/292] :fire: Trace. --- src/Analysis/Abstract/Tracing.hs | 12 +++++------- 1 file changed, 5 insertions(+), 7 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index a3cf9be26..9ba628ca5 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -8,8 +8,6 @@ import Data.Abstract.Value import Data.Semigroup.Reducer as Reducer import Prologue -type Trace trace term value = trace (ConfigurationFor term value) - -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. @@ -21,21 +19,21 @@ deriving instance MonadEvaluator term value (m term value effects) => MonadEvalu instance ( Corecursive term , Effectful (m term value) - , Member (Writer (Trace trace term value)) effects + , Member (Writer (trace (ConfigurationFor term value))) effects , MonadAnalysis term value (m term value effects) , Ord (LocationFor value) - , Reducer (ConfigurationFor term value) (Trace trace term value) + , Reducer (ConfigurationFor term value) (trace (ConfigurationFor term value)) ) => MonadAnalysis term value (TracingAnalysis trace m term value effects) where - type RequiredEffects term value (TracingAnalysis trace m term value effects) = Writer (Trace trace term value) ': RequiredEffects term value (m term value effects) + type RequiredEffects term value (TracingAnalysis trace m term value effects) = Writer (trace (ConfigurationFor term value)) ': RequiredEffects term value (m term value effects) analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) liftAnalyze analyzeTerm term trace :: ( Effectful (m term value) - , Member (Writer (Trace trace term value)) effects + , Member (Writer (trace (ConfigurationFor term value))) effects ) - => Trace trace term value + => trace (ConfigurationFor term value) -> TracingAnalysis trace m term value effects () trace = lift . tell From 5d99219f86a2d3805b9cf51b5dd8d1fb21f2dae6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:02:03 -0500 Subject: [PATCH 231/292] :fire: the DeadCode synonym. --- src/Analysis/Abstract/Dead.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 1bed2a34b..3744bbbb2 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -6,10 +6,6 @@ import Data.Semigroup.Reducer as Reducer import Data.Set (delete) import Prologue --- | The effects necessary for dead code analysis. -type DeadCode term = State (Dead term) - - -- | An analysis tracking dead (unreachable) code. newtype DeadCodeAnalysis m term value (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m term value effects a } deriving (Applicative, Functor, Effectful, Monad, MonadFail) From b40d662690cfd17337395662b487e0cdd97dd7f1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:08:46 -0500 Subject: [PATCH 232/292] Tidy up language extensions. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Control/Abstract/Addressable.hs | 2 +- src/Control/Abstract/Analysis.hs | 2 +- src/Control/Abstract/Evaluator.hs | 2 +- src/Control/Abstract/Value.hs | 2 +- src/Control/Effect.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 3c6bea318..73b0f13df 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Caching where import Control.Abstract.Analysis diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 3744bbbb2..0a779dbfd 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators #-} module Analysis.Abstract.Dead where import Control.Abstract.Analysis diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 180583428..f4cc0c59d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, MultiParamTypeClasses, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Evaluating where import Control.Abstract.Evaluator diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index eb522332b..c3ad77153 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, FunctionalDependencies, KindSignatures, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Addressable where import Control.Abstract.Analysis diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 4a9b58d41..0c0e30629 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, FunctionalDependencies, KindSignatures, TypeFamilies #-} +{-# LANGUAGE DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index d53c90268..977aad2e9 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, KindSignatures #-} +{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies #-} module Control.Abstract.Evaluator where import Data.Abstract.Configuration diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index fdb50e778..c3e6d2602 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, FunctionalDependencies, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Value where import Control.Abstract.Addressable diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 20ef97d18..8e89e29a4 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, FunctionalDependencies, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeFamilies, TypeOperators, UndecidableInstances #-} module Control.Effect where import qualified Control.Monad.Effect as Effect diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 3e52fa8f5..c6459e6f5 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DefaultSignatures, FunctionalDependencies, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE DefaultSignatures, MultiParamTypeClasses, UndecidableInstances #-} module Data.Abstract.Evaluatable ( Evaluatable(..) , module Addressable From bace1c3d74b2d413911fb59702315b8fb1b8eb30 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:11:43 -0500 Subject: [PATCH 233/292] Sort imports &c. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Evaluator.hs | 2 +- src/Control/Abstract/Value.hs | 4 ++-- 5 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 73b0f13df..7d9767b8f 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -9,7 +9,7 @@ import Data.Abstract.Cache import Data.Abstract.Configuration import Data.Abstract.Store import Data.Abstract.Value -import Data.Monoid (Alt(..)) +import Data.Monoid (Alt (..)) import Prologue -- | The effects necessary for caching analyses. diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index f4cc0c59d..6f0fbdc9d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -12,8 +12,8 @@ import Data.Abstract.Evaluatable import Data.Abstract.ModuleTable import Data.Abstract.Value import Data.Blob -import Data.List.Split (splitWhen) import qualified Data.ByteString.Char8 as BC +import Data.List.Split (splitWhen) import qualified Data.Map as Map import Prelude hiding (fail) import Prologue diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 9ba628ca5..6a4da08a7 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, KindSignatures, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing where import Control.Abstract.Analysis diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 977aad2e9..3a3cc10a5 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -2,8 +2,8 @@ module Control.Abstract.Evaluator where import Data.Abstract.Configuration -import Data.Abstract.ModuleTable import Data.Abstract.Live +import Data.Abstract.ModuleTable import Data.Abstract.Value import Prelude hiding (fail) import Prologue diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index c3e6d2602..93debc0df 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -6,11 +6,11 @@ import Control.Abstract.Analysis import Control.Monad.Effect.Fresh import Data.Abstract.Environment import Data.Abstract.FreeVariables -import Data.Abstract.Value as Value import Data.Abstract.Type as Type +import Data.Abstract.Value as Value import Data.Scientific (Scientific) -import Prologue import Prelude hiding (fail) +import Prologue -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- From e9ae4bb48b8f1e180861b7b55819b5d9d3896d8d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:13:47 -0500 Subject: [PATCH 234/292] :fire: the In/Out cache effect synonyms. --- src/Analysis/Abstract/Caching.hs | 17 +++++++---------- 1 file changed, 7 insertions(+), 10 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 7d9767b8f..0e9f84b62 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -30,28 +30,25 @@ deriving instance MonadEvaluator term value (m term value effects) => MonadEvalu -- TODO: reabstract these later on -type InCacheEffectFor term value = Reader (CacheFor term value) -type OutCacheEffectFor term value = State (CacheFor term value) - -askCache :: (Effectful (m term value), Member (InCacheEffectFor term value) effects) => CachingAnalysis m term value effects (CacheFor term value) +askCache :: (Effectful (m term value), Member (Reader (CacheFor term value)) effects) => CachingAnalysis m term value effects (CacheFor term value) askCache = lift ask -localCache :: (Effectful (m term value), Member (InCacheEffectFor term value) effects) => (CacheFor term value -> CacheFor term value) -> CachingAnalysis m term value effects a -> CachingAnalysis m term value effects a +localCache :: (Effectful (m term value), Member (Reader (CacheFor term value)) effects) => (CacheFor term value -> CacheFor term value) -> CachingAnalysis m term value effects a -> CachingAnalysis m term value effects a localCache f a = lift (local f (lower a)) -asksCache :: (Functor (m term value effects), Effectful (m term value), Member (InCacheEffectFor term value) effects) => (CacheFor term value -> a) -> CachingAnalysis m term value effects a +asksCache :: (Functor (m term value effects), Effectful (m term value), Member (Reader (CacheFor term value)) effects) => (CacheFor term value -> a) -> CachingAnalysis m term value effects a asksCache f = f <$> askCache -getsCache :: (Functor (m term value effects), Effectful (m term value), Member (OutCacheEffectFor term value) effects) => (CacheFor term value -> a) -> CachingAnalysis m term value effects a +getsCache :: (Functor (m term value effects), Effectful (m term value), Member (State (CacheFor term value)) effects) => (CacheFor term value -> a) -> CachingAnalysis m term value effects a getsCache f = f <$> getCache -getCache :: (Effectful (m term value), Member (OutCacheEffectFor term value) effects) => CachingAnalysis m term value effects (CacheFor term value) +getCache :: (Effectful (m term value), Member (State (CacheFor term value)) effects) => CachingAnalysis m term value effects (CacheFor term value) getCache = lift get -putCache :: (Effectful (m term value), Member (OutCacheEffectFor term value) effects) => CacheFor term value -> CachingAnalysis m term value effects () +putCache :: (Effectful (m term value), Member (State (CacheFor term value)) effects) => CacheFor term value -> CachingAnalysis m term value effects () putCache = lift . put -modifyCache :: (Effectful (m term value), Member (OutCacheEffectFor term value) effects, Monad (m term value effects)) => (CacheFor term value -> CacheFor term value) -> CachingAnalysis m term value effects () +modifyCache :: (Effectful (m term value), Member (State (CacheFor term value)) effects, Monad (m term value effects)) => (CacheFor term value -> CacheFor term value) -> CachingAnalysis m term value effects () modifyCache f = fmap f getCache >>= putCache -- | This instance coinductively iterates the analysis of a term until the results converge. From e48bd18d885716f8952f926cd171985759f7883a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:19:37 -0500 Subject: [PATCH 235/292] Abstract the caching functions. --- src/Analysis/Abstract/Caching.hs | 34 ++++++++++++++++++-------------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 0e9f84b62..888db567a 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -28,29 +28,33 @@ newtype CachingAnalysis m term value (effects :: [* -> *]) a = CachingAnalysis { deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (CachingAnalysis m term value effects) --- TODO: reabstract these later on +class MonadEvaluator term value m => MonadCaching term value m where + askCache :: m (CacheFor term value) + localCache :: (CacheFor term value -> CacheFor term value) -> m a -> m a -askCache :: (Effectful (m term value), Member (Reader (CacheFor term value)) effects) => CachingAnalysis m term value effects (CacheFor term value) -askCache = lift ask + getCache :: m (CacheFor term value) + putCache :: CacheFor term value -> m () -localCache :: (Effectful (m term value), Member (Reader (CacheFor term value)) effects) => (CacheFor term value -> CacheFor term value) -> CachingAnalysis m term value effects a -> CachingAnalysis m term value effects a -localCache f a = lift (local f (lower a)) - -asksCache :: (Functor (m term value effects), Effectful (m term value), Member (Reader (CacheFor term value)) effects) => (CacheFor term value -> a) -> CachingAnalysis m term value effects a +asksCache :: MonadCaching term value m => (CacheFor term value -> a) -> m a asksCache f = f <$> askCache -getsCache :: (Functor (m term value effects), Effectful (m term value), Member (State (CacheFor term value)) effects) => (CacheFor term value -> a) -> CachingAnalysis m term value effects a +getsCache :: MonadCaching term value m => (CacheFor term value -> a) -> m a getsCache f = f <$> getCache -getCache :: (Effectful (m term value), Member (State (CacheFor term value)) effects) => CachingAnalysis m term value effects (CacheFor term value) -getCache = lift get - -putCache :: (Effectful (m term value), Member (State (CacheFor term value)) effects) => CacheFor term value -> CachingAnalysis m term value effects () -putCache = lift . put - -modifyCache :: (Effectful (m term value), Member (State (CacheFor term value)) effects, Monad (m term value effects)) => (CacheFor term value -> CacheFor term value) -> CachingAnalysis m term value effects () +modifyCache :: MonadCaching term value m => (CacheFor term value -> CacheFor term value) -> m () modifyCache f = fmap f getCache >>= putCache +instance ( Effectful (m term value) + , Members (CachingEffects term value '[]) effects + , MonadEvaluator term value (m term value effects) + ) + => MonadCaching term value (CachingAnalysis m term value effects) where + askCache = lift ask + localCache f a = lift (local f (lower a)) + + getCache = lift get + putCache = lift . put + -- | This instance coinductively iterates the analysis of a term until the results converge. instance ( Corecursive term , Ord term From 08a707a7e23bf0ffb4abd95064f166c0ed7fccb3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:20:53 -0500 Subject: [PATCH 236/292] Sort some contexts. --- src/Analysis/Abstract/Caching.hs | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 888db567a..da85116e1 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -57,16 +57,16 @@ instance ( Effectful (m term value) -- | This instance coinductively iterates the analysis of a term until the results converge. instance ( Corecursive term - , Ord term - , Ord value - , Ord (CellFor value) - , Ord (LocationFor value) , Effectful (m term value) + , Foldable (Cell (LocationFor value)) + , MonadAnalysis term value (m term value effects) , MonadFresh (m term value effects) , MonadNonDet (m term value effects) , Members (CachingEffects term value '[]) effects - , Foldable (Cell (LocationFor value)) - , MonadAnalysis term value (m term value effects) + , Ord (CellFor value) + , Ord (LocationFor value) + , Ord term + , Ord value ) => MonadAnalysis term value (CachingAnalysis m term value effects) where type RequiredEffects term value (CachingAnalysis m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) @@ -107,17 +107,17 @@ scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Sto scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: ( Ord value - , Ord term - , Ord (LocationFor value) - , Ord (CellFor value) - , Alternative (m term value effects) +memoizeEval :: ( Alternative (m term value effects) , Corecursive term , Foldable (Cell (LocationFor value)) , Functor (Base term) , Effectful (m term value) , Members (CachingEffects term value '[]) effects , MonadAnalysis term value (m term value effects) + , Ord (CellFor value) + , Ord (LocationFor value) + , Ord term + , Ord value ) => SubtermAlgebra (Base term) term (CachingAnalysis m term value effects value) memoizeEval e = do From 5887d4ef1080c5836e3e462c21bdbd284ae25841 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:21:14 -0500 Subject: [PATCH 237/292] :fire: redundant Foldable constraints. --- src/Analysis/Abstract/Caching.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index da85116e1..39a252cc4 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -4,7 +4,6 @@ module Analysis.Abstract.Caching where import Control.Abstract.Analysis import Control.Monad.Effect.Fresh import Control.Monad.Effect.NonDet -import Data.Abstract.Address import Data.Abstract.Cache import Data.Abstract.Configuration import Data.Abstract.Store @@ -58,7 +57,6 @@ 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) - , Foldable (Cell (LocationFor value)) , MonadAnalysis term value (m term value effects) , MonadFresh (m term value effects) , MonadNonDet (m term value effects) @@ -109,7 +107,6 @@ scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure va -- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. memoizeEval :: ( Alternative (m term value effects) , Corecursive term - , Foldable (Cell (LocationFor value)) , Functor (Base term) , Effectful (m term value) , Members (CachingEffects term value '[]) effects From 13a6e14b58e0545c7f06ac5c9ef80a23361849ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:25:02 -0500 Subject: [PATCH 238/292] Re-export MonadFresh & MonadNonDet. --- src/Analysis/Abstract/Caching.hs | 2 -- src/Control/Abstract/Analysis.hs | 2 ++ src/Control/Abstract/Value.hs | 1 - 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 39a252cc4..31f07b2be 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -2,8 +2,6 @@ module Analysis.Abstract.Caching where import Control.Abstract.Analysis -import Control.Monad.Effect.Fresh -import Control.Monad.Effect.NonDet import Data.Abstract.Cache import Data.Abstract.Configuration import Data.Abstract.Store diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 0c0e30629..570886c83 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -14,6 +14,8 @@ import Control.Abstract.Evaluator as X import Control.Effect as X import qualified Control.Monad.Effect as Effect import Control.Monad.Effect.Fail as X +import Control.Monad.Effect.Fresh as X +import Control.Monad.Effect.NonDet as X import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X import Data.Coerce diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 93debc0df..4e55f34bd 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -3,7 +3,6 @@ module Control.Abstract.Value where import Control.Abstract.Addressable import Control.Abstract.Analysis -import Control.Monad.Effect.Fresh import Data.Abstract.Environment import Data.Abstract.FreeVariables import Data.Abstract.Type as Type From 9169a6134d6a16ceea7965eb90778d0674ce3db8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:26:30 -0500 Subject: [PATCH 239/292] Only export CachingAnalysis. --- src/Analysis/Abstract/Caching.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 31f07b2be..23d9baa33 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Analysis.Abstract.Caching where +module Analysis.Abstract.Caching +( CachingAnalysis(..) +) where import Control.Abstract.Analysis import Data.Abstract.Cache From fa14baded77cdc265b937cbb981513422fc295bf Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:27:00 -0500 Subject: [PATCH 240/292] Only export the CachingAnalysis type. --- src/Analysis/Abstract/Caching.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 23d9baa33..7bd2c1b1b 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Caching -( CachingAnalysis(..) +( type CachingAnalysis ) where import Control.Abstract.Analysis @@ -22,7 +22,7 @@ type CachingEffects term value effects -- | The cache for term and abstract value types. type CacheFor term value = Cache (LocationFor value) term value -newtype CachingAnalysis m term value (effects :: [* -> *]) a = CachingAnalysis { runCachingAnalysis :: m term value effects a } +newtype CachingAnalysis m term value (effects :: [* -> *]) a = CachingAnalysis (m term value effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (CachingAnalysis m term value effects) From 0d950057f601b9948c93dad536484f570626ead0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:27:26 -0500 Subject: [PATCH 241/292] Only export the DeadCodeAnalysis type. --- src/Analysis/Abstract/Dead.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 0a779dbfd..3c8b534bf 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators #-} -module Analysis.Abstract.Dead where +module Analysis.Abstract.Dead +( type DeadCodeAnalysis +) where import Control.Abstract.Analysis import Data.Semigroup.Reducer as Reducer @@ -7,7 +9,7 @@ import Data.Set (delete) import Prologue -- | An analysis tracking dead (unreachable) code. -newtype DeadCodeAnalysis m term value (effects :: [* -> *]) a = DeadCodeAnalysis { runDeadCodeAnalysis :: m term value effects a } +newtype DeadCodeAnalysis m term value (effects :: [* -> *]) a = DeadCodeAnalysis (m term value effects a) deriving (Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCodeAnalysis m term value effects) From b2e687afd799e37d3fb6e5320aa687cd7d0d6b42 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:28:25 -0500 Subject: [PATCH 242/292] Only export the TracingAnalysis type. --- src/Analysis/Abstract/Tracing.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 6a4da08a7..9954c57c9 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,5 +1,7 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Analysis.Abstract.Tracing where +module Analysis.Abstract.Tracing +( type TracingAnalysis +) where import Control.Abstract.Analysis import Control.Monad.Effect.Writer @@ -11,8 +13,7 @@ import Prologue -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -newtype TracingAnalysis (trace :: * -> *) m term value (effects :: [* -> *]) a - = TracingAnalysis { runTracingAnalysis :: m term value effects a } +newtype TracingAnalysis (trace :: * -> *) m term value (effects :: [* -> *]) a = TracingAnalysis (m term value effects a) deriving (Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (TracingAnalysis trace m term value effects) From 386807618a3abb94ebff7d850a207ea7341d2304 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:28:34 -0500 Subject: [PATCH 243/292] Only export the Evaluating type, evaluate, and evaluates. --- src/Analysis/Abstract/Evaluating.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 6f0fbdc9d..969a41e85 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,5 +1,9 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} -module Analysis.Abstract.Evaluating where +module Analysis.Abstract.Evaluating +( type Evaluating +, evaluate +, evaluates +) where import Control.Abstract.Evaluator import Control.Monad.Effect hiding (run) @@ -54,7 +58,7 @@ withModules Blob{..} pairs = localModuleTable (const moduleTable) toName str = qualifiedName (fmap BC.pack (splitWhen (== pathSeparator) str)) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -newtype Evaluating term value effects a = Evaluating { runEvaluating :: Eff effects a } +newtype Evaluating term value effects a = Evaluating (Eff effects a) deriving (Applicative, Functor, Effectful, Monad) From bd9b231a8357f05b26005651b85210b4e6f35490 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:29:11 -0500 Subject: [PATCH 244/292] Rename TracingAnalysis to Tracing. --- src/Analysis/Abstract/Tracing.hs | 12 ++++++------ src/Semantic/Util.hs | 4 ++-- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 9954c57c9..e0f347571 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing -( type TracingAnalysis +( type Tracing ) where import Control.Abstract.Analysis @@ -13,10 +13,10 @@ import Prologue -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -newtype TracingAnalysis (trace :: * -> *) m term value (effects :: [* -> *]) a = TracingAnalysis (m term value effects a) +newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing (m term value effects a) deriving (Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (TracingAnalysis trace m term value effects) +deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects) instance ( Corecursive term , Effectful (m term value) @@ -25,8 +25,8 @@ instance ( Corecursive term , Ord (LocationFor value) , Reducer (ConfigurationFor term value) (trace (ConfigurationFor term value)) ) - => MonadAnalysis term value (TracingAnalysis trace m term value effects) where - type RequiredEffects term value (TracingAnalysis trace m term value effects) = Writer (trace (ConfigurationFor term value)) ': RequiredEffects term value (m term value effects) + => 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) analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) @@ -36,5 +36,5 @@ trace :: ( Effectful (m term value) , Member (Writer (trace (ConfigurationFor term value))) effects ) => trace (ConfigurationFor term value) - -> TracingAnalysis trace m term value effects () + -> Tracing trace m term value effects () trace = lift . tell diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 8a4d8ea38..0102b6743 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -48,9 +48,9 @@ evaluateRubyFiles paths = do -- Python typecheckPythonFile path = runAnalysis @(CachingAnalysis Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path -tracePythonFile path = runAnalysis @(TracingAnalysis [] Evaluating Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path +tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path -evaluateDeadTracePythonFile path = runAnalysis @(DeadCodeAnalysis (TracingAnalysis [] Evaluating) Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCodeAnalysis (Tracing [] Evaluating) Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From 26295e00089fbf54a92c6ea03f4f2f782c5c73a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:30:01 -0500 Subject: [PATCH 245/292] Rename DeadCodeAnalysis to DeadCode. --- src/Analysis/Abstract/Dead.hs | 14 +++++++------- src/Semantic/Util.hs | 2 +- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 3c8b534bf..12dd0850e 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators #-} module Analysis.Abstract.Dead -( type DeadCodeAnalysis +( type DeadCode ) where import Control.Abstract.Analysis @@ -9,10 +9,10 @@ import Data.Set (delete) import Prologue -- | An analysis tracking dead (unreachable) code. -newtype DeadCodeAnalysis m term value (effects :: [* -> *]) a = DeadCodeAnalysis (m term value effects a) +newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a) deriving (Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCodeAnalysis m term value effects) +deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } @@ -21,11 +21,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 -> DeadCodeAnalysis m term value effects () +killAll :: (Effectful (m term value), Member (State (Dead term)) effects) => Dead term -> DeadCode m term value effects () killAll = lift . 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 -> DeadCodeAnalysis m term value effects () +revive :: (Effectful (m term value), Member (State (Dead term)) effects) => Ord term => term -> DeadCode m term value effects () revive t = lift (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. @@ -40,8 +40,8 @@ instance ( Corecursive term , MonadAnalysis term value (m term value effects) , Ord term ) - => MonadAnalysis term value (DeadCodeAnalysis m term value effects) where - type RequiredEffects term value (DeadCodeAnalysis m term value effects) = State (Dead term) ': RequiredEffects term value (m term value effects) + => 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) analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 0102b6743..b190d45db 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -50,7 +50,7 @@ typecheckPythonFile path = runAnalysis @(CachingAnalysis Evaluating Python.Term tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path -evaluateDeadTracePythonFile path = runAnalysis @(DeadCodeAnalysis (Tracing [] Evaluating) Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path +evaluateDeadTracePythonFile path = runAnalysis @(DeadCode (Tracing [] Evaluating) Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path evaluatePythonFile path = evaluate @PythonValue . snd <$> parseFile pythonParser path From 06e0645f838709923e190479d588fd02428196c0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:30:33 -0500 Subject: [PATCH 246/292] Rename CachingAnalysis to Caching. --- src/Analysis/Abstract/Caching.hs | 16 ++++++++-------- src/Semantic/Util.hs | 2 +- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 7bd2c1b1b..62e907842 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Caching -( type CachingAnalysis +( type Caching ) where import Control.Abstract.Analysis @@ -22,10 +22,10 @@ type CachingEffects term value effects -- | The cache for term and abstract value types. type CacheFor term value = Cache (LocationFor value) term value -newtype CachingAnalysis m term value (effects :: [* -> *]) a = CachingAnalysis (m term value effects a) +newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) -deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (CachingAnalysis m term value effects) +deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects) class MonadEvaluator term value m => MonadCaching term value m where askCache :: m (CacheFor term value) @@ -47,7 +47,7 @@ instance ( Effectful (m term value) , Members (CachingEffects term value '[]) effects , MonadEvaluator term value (m term value effects) ) - => MonadCaching term value (CachingAnalysis m term value effects) where + => MonadCaching term value (Caching m term value effects) where askCache = lift ask localCache f a = lift (local f (lower a)) @@ -66,8 +66,8 @@ instance ( Corecursive term , Ord term , Ord value ) - => MonadAnalysis term value (CachingAnalysis m term value effects) where - type RequiredEffects term value (CachingAnalysis m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) + => MonadAnalysis term value (Caching m term value effects) where + type RequiredEffects term value (Caching m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) analyzeTerm e = do c <- getConfiguration (embedSubterm e) -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -81,7 +81,7 @@ instance ( Corecursive term -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- localCache (const prevCache) (gather (memoizeEval e) :: CachingAnalysis m term value effects ()) + _ <- localCache (const prevCache) (gather (memoizeEval e) :: Caching m term value effects ()) getCache) mempty maybe empty scatter (cacheLookup c cache) @@ -116,7 +116,7 @@ memoizeEval :: ( Alternative (m term value effects) , Ord term , Ord value ) - => SubtermAlgebra (Base term) term (CachingAnalysis m term value effects value) + => SubtermAlgebra (Base term) term (Caching m term value effects value) memoizeEval e = do c <- getConfiguration (embedSubterm e) cached <- getsCache (cacheLookup c) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index b190d45db..294d88dab 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,7 +46,7 @@ evaluateRubyFiles paths = do pure $ evaluates @RubyValue rest first -- Python -typecheckPythonFile path = runAnalysis @(CachingAnalysis Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path +typecheckPythonFile path = runAnalysis @(Caching Evaluating Python.Term Type) . evaluateModule . snd <$> parseFile pythonParser path tracePythonFile path = runAnalysis @(Tracing [] Evaluating Python.Term PythonValue) . evaluateModule . snd <$> parseFile pythonParser path From d3ed05fe991b918038d5b1570b0af6d0e24e2f95 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:32:48 -0500 Subject: [PATCH 247/292] Derive a bunch more instances. --- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 12dd0850e..4c65f89ac 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -10,7 +10,7 @@ import Prologue -- | An analysis tracking dead (unreachable) code. newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a) - deriving (Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index e0f347571..d3762aba7 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Prologue -- -- 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) - deriving (Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects) From 8966824307174ef254e6bf53aaa36a303372f960 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:36:16 -0500 Subject: [PATCH 248/292] Rename lift to raise. --- src/Analysis/Abstract/Caching.hs | 8 ++++---- src/Analysis/Abstract/Dead.hs | 4 ++-- src/Analysis/Abstract/Evaluating.hs | 22 +++++++++++----------- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Effect.hs | 4 ++-- 5 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 62e907842..1ca2c44eb 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -48,11 +48,11 @@ instance ( Effectful (m term value) , MonadEvaluator term value (m term value effects) ) => MonadCaching term value (Caching m term value effects) where - askCache = lift ask - localCache f a = lift (local f (lower a)) + askCache = raise ask + localCache f a = raise (local f (lower a)) - getCache = lift get - putCache = lift . put + getCache = raise get + putCache = raise . put -- | This instance coinductively iterates the analysis of a term until the results converge. instance ( Corecursive term diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 4c65f89ac..b409e7ea0 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -22,11 +22,11 @@ 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 = lift . put +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 t = lift (modify (Dead . delete t . unDead)) +revive t = raise (modify (Dead . delete t . unDead)) -- | Compute the set of all subterms recursively. subterms :: (Ord term, Recursive term, Foldable (Base term)) => term -> Dead term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 969a41e85..4da3dff1e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -78,21 +78,21 @@ type EvaluatingEffects term value ] instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where - getGlobalEnv = lift get - putGlobalEnv = lift . put - modifyGlobalEnv f = lift (modify f) + getGlobalEnv = raise get + putGlobalEnv = raise . put + modifyGlobalEnv f = raise (modify f) - askLocalEnv = lift ask - localEnv f a = lift (local f (lower a)) + askLocalEnv = raise ask + localEnv f a = raise (local f (lower a)) - getStore = lift get - modifyStore f = lift (modify f) + getStore = raise get + modifyStore f = raise (modify f) - getModuleTable = lift get - modifyModuleTable f = lift (modify f) + getModuleTable = raise get + modifyModuleTable f = raise (modify f) - askModuleTable = lift ask - localModuleTable f a = lift (local f (lower a)) + askModuleTable = raise ask + localModuleTable f a = raise (local f (lower a)) instance ( Evaluatable (Base term) , FreeVariables term diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index d3762aba7..c0f354650 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -37,4 +37,4 @@ trace :: ( Effectful (m term value) ) => trace (ConfigurationFor term value) -> Tracing trace m term value effects () -trace = lift . tell +trace = raise . tell diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 8e89e29a4..b00623220 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -67,9 +67,9 @@ instance Ord a => RunEffect NonDetEff a where class Effectful m where - lift :: Eff effects a -> m effects a + raise :: Eff effects a -> m effects a lower :: m effects a -> Eff effects a instance Effectful Eff where - lift = id + raise = id lower = id From b3efd3b1e23691242300cb4e850573abfcdedcc1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:40:30 -0500 Subject: [PATCH 249/292] putStore is primitive. --- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Control/Abstract/Evaluator.hs | 5 +++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 4da3dff1e..c278a8fbe 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -86,7 +86,7 @@ instance Members (EvaluatingEffects term value) effects => MonadEvaluator term v localEnv f a = raise (local f (lower a)) getStore = raise get - modifyStore f = raise (modify f) + putStore = raise . put getModuleTable = raise get modifyModuleTable f = raise (modify f) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 3a3cc10a5..54ae66f56 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -30,9 +30,7 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where -- | Retrieve the heap. getStore :: m (StoreFor value) -- | Update the heap. - modifyStore :: (StoreFor value -> StoreFor value) -> m () putStore :: StoreFor value -> m () - putStore = modifyStore . const -- | Retrieve the table of evaluated modules. getModuleTable :: m (ModuleTable (EnvironmentFor value)) @@ -51,3 +49,6 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore + +modifyStore :: MonadEvaluator term value m => (StoreFor value -> StoreFor value) -> m () +modifyStore f = getStore >>= putStore . f From 546f8bb3ece2955874b0f736fcefc10cc64af653 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:41:27 -0500 Subject: [PATCH 250/292] modifyGlobalEnv is not primitive. --- src/Analysis/Abstract/Evaluating.hs | 1 - src/Control/Abstract/Evaluator.hs | 9 ++++++--- 2 files changed, 6 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c278a8fbe..c54ccdd31 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -80,7 +80,6 @@ type EvaluatingEffects term value instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where getGlobalEnv = raise get putGlobalEnv = raise . put - modifyGlobalEnv f = raise (modify f) askLocalEnv = raise ask localEnv f a = raise (local f (lower a)) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 54ae66f56..e986a20f6 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -19,8 +19,6 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where getGlobalEnv :: m (EnvironmentFor value) -- | Set the global environment putGlobalEnv :: EnvironmentFor value -> m () - -- | Update the global environment. - modifyGlobalEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m () -- | Retrieve the local environment. askLocalEnv :: m (EnvironmentFor value) @@ -29,7 +27,7 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where -- | Retrieve the heap. getStore :: m (StoreFor value) - -- | Update the heap. + -- | Set the heap. putStore :: StoreFor value -> m () -- | Retrieve the table of evaluated modules. @@ -50,5 +48,10 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value) getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore +-- | Update the global environment. +modifyGlobalEnv :: MonadEvaluator term value m => (EnvironmentFor value -> EnvironmentFor value) -> m () +modifyGlobalEnv f = getGlobalEnv >>= putGlobalEnv . f + +-- | Update the heap. modifyStore :: MonadEvaluator term value m => (StoreFor value -> StoreFor value) -> m () modifyStore f = getStore >>= putStore . f From e0076f3fb621e4690840c42e3a9f3b126214d4ac Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:46:28 -0500 Subject: [PATCH 251/292] Leave the default signature alone. --- 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 c6459e6f5..e804eb7de 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -33,7 +33,7 @@ class Evaluatable constr where , MonadValue term value m ) => SubtermAlgebra constr term (m value) - default eval :: (MonadAnalysis term value m, Show1 constr) => SubtermAlgebra constr term (m value) + default eval :: (MonadFail m, Show1 constr) => SubtermAlgebra constr term (m value) eval expr = fail $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "" -- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'. From a717bd54f7d5e8fd3d4855a1832207938928a817 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:57:09 -0500 Subject: [PATCH 252/292] Converge for the whole module, not per-term. --- src/Analysis/Abstract/Caching.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 1ca2c44eb..87fd01375 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -68,8 +68,9 @@ instance ( Corecursive term ) => MonadAnalysis term value (Caching m term value effects) where type RequiredEffects term value (Caching m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) - analyzeTerm e = do - c <- getConfiguration (embedSubterm e) + analyzeTerm = memoizeEval + evaluateModule e = do + c <- getConfiguration e -- Convergence here is predicated upon an Eq instance, not α-equivalence cache <- converge (\ prevCache -> do putCache mempty @@ -81,7 +82,7 @@ instance ( Corecursive term -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- localCache (const prevCache) (gather (memoizeEval e) :: Caching m term value effects ()) + _ <- localCache (const prevCache) (gather (evaluateModule e) :: Caching m term value effects ()) getCache) mempty maybe empty scatter (cacheLookup c cache) From 2109310e9eefb256c4d82820528633a8f7073f30 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:57:33 -0500 Subject: [PATCH 253/292] :fire: memoizeEval. --- src/Analysis/Abstract/Caching.hs | 40 +++++++++++--------------------- 1 file changed, 13 insertions(+), 27 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 87fd01375..32303153c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -68,7 +68,19 @@ instance ( Corecursive term ) => MonadAnalysis term value (Caching m term value effects) where type RequiredEffects term value (Caching m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) - analyzeTerm = memoizeEval + analyzeTerm e = do + c <- getConfiguration (embedSubterm e) + cached <- getsCache (cacheLookup c) + case cached of + Just pairs -> scatter pairs + Nothing -> do + pairs <- asksCache (fromMaybe mempty . cacheLookup c) + modifyCache (cacheSet c pairs) + v <- liftAnalyze analyzeTerm e + store' <- getStore + modifyCache (cacheInsert c (v, store')) + pure v + evaluateModule e = do c <- getConfiguration e -- Convergence here is predicated upon an Eq instance, not α-equivalence @@ -104,29 +116,3 @@ converge f = loop -- | Nondeterministically write each of a collection of stores & return their associated results. scatter :: (Alternative m, Foldable t, MonadEvaluator term value m) => t (a, Store (LocationFor value) value) -> m a scatter = getAlt . foldMap (\ (value, store') -> Alt (putStore store' *> pure value)) - --- | Evaluation of a single iteration of an analysis, given an in-cache as an oracle for results and an out-cache to record computed results in. -memoizeEval :: ( Alternative (m term value effects) - , Corecursive term - , Functor (Base term) - , Effectful (m term value) - , Members (CachingEffects term value '[]) effects - , MonadAnalysis term value (m term value effects) - , Ord (CellFor value) - , Ord (LocationFor value) - , Ord term - , Ord value - ) - => SubtermAlgebra (Base term) term (Caching m term value effects value) -memoizeEval e = do - c <- getConfiguration (embedSubterm e) - cached <- getsCache (cacheLookup c) - case cached of - Just pairs -> scatter pairs - Nothing -> do - pairs <- asksCache (fromMaybe mempty . cacheLookup c) - modifyCache (cacheSet c pairs) - v <- liftAnalyze analyzeTerm e - store' <- getStore - modifyCache (cacheInsert c (v, store')) - pure v From 346e2115e217b95b6feaaa93f2fc4a2c565d4ea9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 14:58:10 -0500 Subject: [PATCH 254/292] Evaluate the module in the underlying analysis. --- 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 32303153c..4c6ff372c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -94,7 +94,7 @@ instance ( Corecursive term -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- localCache (const prevCache) (gather (evaluateModule e) :: Caching m term value effects ()) + _ <- localCache (const prevCache) (gather (liftEvaluate evaluateModule e) :: Caching m term value effects ()) getCache) mempty maybe empty scatter (cacheLookup c cache) From 6535209dc9087d491893e2f9d92c7de14264ab6a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 15:06:18 -0500 Subject: [PATCH 255/292] Improve the API for consulting the oracle. --- src/Analysis/Abstract/Caching.hs | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 4c6ff372c..2ee37a94f 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -28,15 +28,12 @@ newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value eff deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects) class MonadEvaluator term value m => MonadCaching term value m where - askCache :: m (CacheFor term value) + consultOracle :: ConfigurationFor term value -> m (Set (value, StoreFor value)) localCache :: (CacheFor term value -> CacheFor term value) -> m a -> m a getCache :: m (CacheFor term value) putCache :: CacheFor term value -> m () -asksCache :: MonadCaching term value m => (CacheFor term value -> a) -> m a -asksCache f = f <$> askCache - getsCache :: MonadCaching term value m => (CacheFor term value -> a) -> m a getsCache f = f <$> getCache @@ -46,9 +43,13 @@ modifyCache f = fmap f getCache >>= putCache instance ( Effectful (m term value) , Members (CachingEffects term value '[]) effects , MonadEvaluator term value (m term value effects) + , Ord (CellFor value) + , Ord (LocationFor value) + , Ord term + , Ord value ) => MonadCaching term value (Caching m term value effects) where - askCache = raise ask + consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask) localCache f a = raise (local f (lower a)) getCache = raise get @@ -74,7 +75,7 @@ instance ( Corecursive term case cached of Just pairs -> scatter pairs Nothing -> do - pairs <- asksCache (fromMaybe mempty . cacheLookup c) + pairs <- consultOracle c modifyCache (cacheSet c pairs) v <- liftAnalyze analyzeTerm e store' <- getStore From a5704f49dfd076fe8bf42d1bc011cd83f8edefa5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 15:07:50 -0500 Subject: [PATCH 256/292] Improve the API for running an action with a new oracle. --- src/Analysis/Abstract/Caching.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 2ee37a94f..7271fedec 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -29,7 +29,7 @@ deriving instance MonadEvaluator term value (m term value effects) => MonadEvalu class MonadEvaluator term value m => MonadCaching term value m where consultOracle :: ConfigurationFor term value -> m (Set (value, StoreFor value)) - localCache :: (CacheFor term value -> CacheFor term value) -> m a -> m a + withOracle :: CacheFor term value -> m a -> m a getCache :: m (CacheFor term value) putCache :: CacheFor term value -> m () @@ -50,7 +50,7 @@ instance ( Effectful (m term value) ) => MonadCaching term value (Caching m term value effects) where consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask) - localCache f a = raise (local f (lower a)) + withOracle cache = raise . local (const cache) . lower getCache = raise get putCache = raise . put @@ -95,7 +95,7 @@ instance ( Corecursive term -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- localCache (const prevCache) (gather (liftEvaluate evaluateModule e) :: Caching m term value effects ()) + _ <- withOracle prevCache (gather (liftEvaluate evaluateModule e) :: Caching m term value effects ()) getCache) mempty maybe empty scatter (cacheLookup c cache) From fbd5c04227730cc9dd26d4cc46e59c8fdc2ab6c1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 15:21:12 -0500 Subject: [PATCH 257/292] Better API for isolating the cache & caching new values. --- src/Analysis/Abstract/Caching.hs | 31 ++++++++++++++----------------- 1 file changed, 14 insertions(+), 17 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 7271fedec..ede7cb914 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -31,14 +31,11 @@ class MonadEvaluator term value m => MonadCaching term value m where consultOracle :: ConfigurationFor term value -> m (Set (value, StoreFor value)) withOracle :: CacheFor term value -> m a -> m a - getCache :: m (CacheFor term value) - putCache :: CacheFor term value -> m () + lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, StoreFor value))) + setCache :: ConfigurationFor term value -> Set (value, StoreFor value) -> m () + cache :: ConfigurationFor term value -> value -> m () -getsCache :: MonadCaching term value m => (CacheFor term value -> a) -> m a -getsCache f = f <$> getCache - -modifyCache :: MonadCaching term value m => (CacheFor term value -> CacheFor term value) -> m () -modifyCache f = fmap f getCache >>= putCache + isolateCache :: m a -> m (CacheFor term value) instance ( Effectful (m term value) , Members (CachingEffects term value '[]) effects @@ -52,8 +49,11 @@ instance ( Effectful (m term value) consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask) withOracle cache = raise . local (const cache) . lower - getCache = raise get - putCache = raise . put + lookupCache configuration = raise (cacheLookup configuration <$> get) + setCache configuration = raise . modify . cacheSet configuration + cache configuration value = getStore >>= raise . modify . cacheInsert configuration . (,) value + + isolateCache action = raise (put (mempty :: CacheFor term value)) *> action *> raise get -- | This instance coinductively iterates the analysis of a term until the results converge. instance ( Corecursive term @@ -71,22 +71,20 @@ instance ( Corecursive term type RequiredEffects term value (Caching m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) analyzeTerm e = do c <- getConfiguration (embedSubterm e) - cached <- getsCache (cacheLookup c) + cached <- lookupCache c case cached of Just pairs -> scatter pairs Nothing -> do pairs <- consultOracle c - modifyCache (cacheSet c pairs) + setCache c pairs v <- liftAnalyze analyzeTerm e - store' <- getStore - modifyCache (cacheInsert c (v, store')) + cache c v pure v evaluateModule e = do c <- getConfiguration e -- Convergence here is predicated upon an Eq instance, not α-equivalence - cache <- converge (\ prevCache -> do - putCache mempty + cache <- converge (\ prevCache -> isolateCache $ do putStore (configurationStore c) -- We need to reset fresh generation so that this invocation converges. reset 0 @@ -95,8 +93,7 @@ instance ( Corecursive term -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - _ <- withOracle prevCache (gather (liftEvaluate evaluateModule e) :: Caching m term value effects ()) - getCache) mempty + withOracle prevCache (gather (liftEvaluate evaluateModule e) :: Caching m term value effects ())) mempty maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. From 53517662cfa7a02920e0f51af12b15aba2628a8c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 15:37:34 -0500 Subject: [PATCH 258/292] Roll caching an action into MonadCaching. --- src/Analysis/Abstract/Caching.hs | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index ede7cb914..c39d41a7c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -32,8 +32,7 @@ class MonadEvaluator term value m => MonadCaching term value m where withOracle :: CacheFor term value -> m a -> m a lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, StoreFor value))) - setCache :: ConfigurationFor term value -> Set (value, StoreFor value) -> m () - cache :: ConfigurationFor term value -> value -> m () + caching :: ConfigurationFor term value -> Set (value, StoreFor value) -> m value -> m value isolateCache :: m a -> m (CacheFor term value) @@ -50,8 +49,11 @@ instance ( Effectful (m term value) withOracle cache = raise . local (const cache) . lower lookupCache configuration = raise (cacheLookup configuration <$> get) - setCache configuration = raise . modify . cacheSet configuration - cache configuration value = getStore >>= raise . modify . cacheInsert configuration . (,) value + caching configuration values action = do + raise (modify (cacheSet configuration values)) + result <- (,) <$> action <*> getStore + raise (modify (cacheInsert configuration result)) + pure (fst result) isolateCache action = raise (put (mempty :: CacheFor term value)) *> action *> raise get @@ -76,10 +78,7 @@ instance ( Corecursive term Just pairs -> scatter pairs Nothing -> do pairs <- consultOracle c - setCache c pairs - v <- liftAnalyze analyzeTerm e - cache c v - pure v + caching c pairs (liftAnalyze analyzeTerm e) evaluateModule e = do c <- getConfiguration e From 56db84b3f2f6bb2cf85f40b2342079206bd17c50 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Fri, 9 Mar 2018 15:42:22 -0500 Subject: [PATCH 259/292] :fire: the Bifoldable/Bitraversable instances for Subterm. --- src/Data/Algebra.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Data/Algebra.hs b/src/Data/Algebra.hs index 55cda91c6..b2cba81c5 100644 --- a/src/Data/Algebra.hs +++ b/src/Data/Algebra.hs @@ -14,9 +14,7 @@ module Data.Algebra , openFToOpenR ) where -import Data.Bifoldable import Data.Bifunctor -import Data.Bitraversable import Data.Functor.Foldable ( Base , Corecursive(embed) , Recursive(project) @@ -50,15 +48,9 @@ type OpenRAlgebra f t a = forall b . (b -> (t, a)) -> f b -> a data Subterm t a = Subterm { subterm :: !t, subtermValue :: !a } deriving (Eq, Foldable, Functor, Ord, Show, Traversable) -instance Bifoldable Subterm where - bifoldMap f g (Subterm a b) = f a `mappend` g b - instance Bifunctor Subterm where bimap f g (Subterm a b) = Subterm (f a) (g b) -instance Bitraversable Subterm where - bitraverse f g (Subterm a b) = Subterm <$> f a <*> g b - -- | Like an R-algebra, but using 'Subterm' to label the fields instead of an anonymous pair. type SubtermAlgebra f t a = f (Subterm t a) -> a From c4f11ea6f3e56d6e1fde0595c90778e51552c074 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:22:55 -0400 Subject: [PATCH 260/292] Import monoidal maps under Monoidal. --- src/Data/Abstract/Cache.hs | 8 ++++---- src/Data/Abstract/Store.hs | 10 +++++----- 2 files changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Data/Abstract/Cache.hs b/src/Data/Abstract/Cache.hs index fc7671148..f7c9550b1 100644 --- a/src/Data/Abstract/Cache.hs +++ b/src/Data/Abstract/Cache.hs @@ -4,11 +4,11 @@ module Data.Abstract.Cache where import Data.Abstract.Address import Data.Abstract.Configuration import Data.Abstract.Store -import Data.Map.Monoidal as Map +import Data.Map.Monoidal as Monoidal import Prologue -- | A map of 'Configuration's to 'Set's of resulting values & 'Store's. -newtype Cache l t v = Cache { unCache :: Map.Map (Configuration l t v) (Set (v, Store l v)) } +newtype Cache l t v = Cache { unCache :: Monoidal.Map (Configuration l t v) (Set (v, Store l v)) } deriving instance (Eq l, Eq t, Eq v, Eq (Cell l v)) => Eq (Cache l t v) deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Ord (Cache l t v) @@ -19,11 +19,11 @@ deriving instance (Ord l, Ord t, Ord v, Ord (Cell l v)) => Reducer (Configuratio -- | Look up the resulting value & 'Store' for a given 'Configuration'. cacheLookup :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Cache l t v -> Maybe (Set (v, Store l v)) -cacheLookup key = Map.lookup key . unCache +cacheLookup key = Monoidal.lookup key . unCache -- | Set the resulting value & 'Store' for a given 'Configuration', overwriting any previous entry. cacheSet :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> Set (v, Store l v) -> Cache l t v -> Cache l t v -cacheSet key value = Cache . Map.insert key value . unCache +cacheSet key value = Cache . Monoidal.insert key value . unCache -- | Insert the resulting value & 'Store' for a given 'Configuration', appending onto any previous entry. cacheInsert :: (Ord l, Ord t, Ord v, Ord (Cell l v)) => Configuration l t v -> (v, Store l v) -> Cache l t v -> Cache l t v diff --git a/src/Data/Abstract/Store.hs b/src/Data/Abstract/Store.hs index 4dbb6270c..d92847036 100644 --- a/src/Data/Abstract/Store.hs +++ b/src/Data/Abstract/Store.hs @@ -3,12 +3,12 @@ module Data.Abstract.Store where import Data.Abstract.Address import Data.Abstract.Live -import qualified Data.Map.Monoidal as Map +import qualified Data.Map.Monoidal as Monoidal import Data.Semigroup.Reducer import Prologue -- | A map of addresses onto cells holding their values. -newtype Store l a = Store { unStore :: Map.Map l (Cell l a) } +newtype Store l a = Store { unStore :: Monoidal.Map l (Cell l a) } deriving (Generic1) deriving instance (Eq l, Eq (Cell l a)) => Eq (Store l a) @@ -26,7 +26,7 @@ deriving instance (Ord l, Reducer a (Cell l a)) => Reducer (l, a) (Store l a) -- | Look up the cell of values for an 'Address' in a 'Store', if any. storeLookup :: Ord l => Address l a -> Store l a -> Maybe (Cell l a) -storeLookup (Address address) = Map.lookup address . unStore +storeLookup (Address address) = Monoidal.lookup address . unStore -- | Look up the list of values stored for a given address, if any. storeLookupAll :: (Ord l, Foldable (Cell l)) => Address l a -> Store l a -> Maybe [a] @@ -38,8 +38,8 @@ storeInsert (Address address) value = flip snoc (address, value) -- | The number of addresses extant in a 'Store'. storeSize :: Store l a -> Int -storeSize = Map.size . unStore +storeSize = Monoidal.size . unStore -- | Restrict a 'Store' to only those 'Address'es in the given 'Live' set (in essence garbage collecting the rest). storeRestrict :: Ord l => Store l a -> Live l a -> Store l a -storeRestrict (Store m) roots = Store (Map.filterWithKey (\ address _ -> Address address `liveMember` roots) m) +storeRestrict (Store m) roots = Store (Monoidal.filterWithKey (\ address _ -> Address address `liveMember` roots) m) From 8101cde85e582cdc9311e09287f4e1f1236420bd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:27:24 -0400 Subject: [PATCH 261/292] Slightly less clever definition of parseFile. --- 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 294d88dab..57e04f5a3 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -66,7 +66,9 @@ evaluateTypeScriptFiles paths = do pure $ evaluates @TypeScriptValue rest first -parseFile parser path = runTask (file path >>= fmap . (,) <*> parse parser) +parseFile parser path = runTask $ do + blob <- file path + (,) blob <$> parse parser blob -- Diff helpers From 1e3f4a0481cbd9ca3ede12c59d4c0a06721eac91 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:27:53 -0400 Subject: [PATCH 262/292] Give a type signature for parseFile. --- src/Semantic/Util.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 57e04f5a3..6469f3b78 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -66,9 +66,10 @@ evaluateTypeScriptFiles paths = do pure $ evaluates @TypeScriptValue rest first +parseFile :: Parser term -> FilePath -> IO (Blob, term) parseFile parser path = runTask $ do blob <- file path - (,) blob <$> parse parser blob + (,) blob <$> parse parser blob -- Diff helpers From a6c1b3663df6f070920a2075976630242c8cc99c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:29:45 -0400 Subject: [PATCH 263/292] :fire: some unnecessary qualification. --- src/Semantic/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 6469f3b78..9c365f97e 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -39,7 +39,7 @@ file :: MonadIO m => FilePath -> m Blob file path = fromJust <$> IO.readFile path (languageForFilePath path) -- Ruby -evaluateRubyFile path = Prelude.fst . evaluate @RubyValue . snd <$> parseFile rubyParser path +evaluateRubyFile path = fst . evaluate @RubyValue . snd <$> parseFile rubyParser path evaluateRubyFiles paths = do first:rest <- traverse (parseFile rubyParser) paths From 06be4ab967e2a8c5db88b52dcb6276204b9932e4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:33:27 -0400 Subject: [PATCH 264/292] :memo: evaluateModule. --- 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 570886c83..4a040bb99 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -29,6 +29,7 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. analyzeTerm :: SubtermAlgebra (Base term) term (m value) + -- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs as well as each module in multi-term programs. evaluateModule :: term -> m value evaluateModule = evaluateTerm From d615c381323b9c4a5521a896033d2fe7f788f7c7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:35:22 -0400 Subject: [PATCH 265/292] :fire: liftEvaluate. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Control/Abstract/Analysis.hs | 7 ------- 3 files changed, 2 insertions(+), 9 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index c39d41a7c..44d18bb5c 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -92,7 +92,7 @@ instance ( Corecursive term -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - withOracle prevCache (gather (liftEvaluate evaluateModule e) :: Caching m term value effects ())) mempty + withOracle prevCache (gather (Caching (evaluateModule e)) :: Caching m term value effects ())) mempty maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index b409e7ea0..95a263e7e 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -48,4 +48,4 @@ instance ( Corecursive term evaluateModule term = do killAll (subterms term) - liftEvaluate evaluateModule term + DeadCode (evaluateModule term) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 4a040bb99..f03cf09e5 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -3,7 +3,6 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm , liftAnalyze -, liftEvaluate , runAnalysis , module X , Subterm(..) @@ -47,12 +46,6 @@ liftAnalyze :: ( Coercible ( m term value (effects :: [* -> *]) value) (t m ter -> SubtermAlgebra (Base term) term (t m term value effects value) liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -liftEvaluate :: ( Coercible (m term value (effects :: [* -> *]) value) (t m term value effects value) - ) - => (term -> m term value effects value) - -> (term -> t m term value effects value) -liftEvaluate evaluate = coerce . evaluate - runAnalysis :: (Effectful m, RunEffects effects a, RequiredEffects term value (m effects) ~ effects, MonadAnalysis term value (m effects)) => m effects a -> Final effects a runAnalysis = Effect.run . runEffects . lower From 848e78f9594732c91050d64bffe06a437f162eab Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:36:51 -0400 Subject: [PATCH 266/292] :memo: liftAnalyze. --- src/Control/Abstract/Analysis.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index f03cf09e5..ee8230e0d 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -38,6 +38,8 @@ class (MonadEvaluator term value m, Recursive term) => MonadAnalysis term value evaluateTerm :: MonadAnalysis term value m => term -> m value evaluateTerm = foldSubterms analyzeTerm + +-- | Lift a 'SubtermAlgebra' for an underlying analysis into a containing analysis. Use this when defining an analysis which can be composed onto other analyses to ensure that a call to 'analyzeTerm' occurs in the inner analysis and not the outer one. liftAnalyze :: ( Coercible ( m term value (effects :: [* -> *]) value) (t m term value effects value) , Coercible (t m term value effects value) ( m term value effects value) , Functor (Base term) From 52afe01b00bacd331016f700a41591a178863ae4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:37:35 -0400 Subject: [PATCH 267/292] Reformat the signature for runAnalysis. --- src/Control/Abstract/Analysis.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index ee8230e0d..b8cbd1ae5 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -49,5 +49,11 @@ liftAnalyze :: ( Coercible ( m term value (effects :: [* -> *]) value) (t m ter liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -runAnalysis :: (Effectful m, RunEffects effects a, RequiredEffects term value (m effects) ~ effects, MonadAnalysis term value (m effects)) => m effects a -> Final effects a +runAnalysis :: ( Effectful m + , RunEffects effects a + , RequiredEffects term value (m effects) ~ effects + , MonadAnalysis term value (m effects) + ) + => m effects a + -> Final effects a runAnalysis = Effect.run . runEffects . lower From 00a6c1ad3d90be6dcd205f861ba562c76150d6c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:38:32 -0400 Subject: [PATCH 268/292] :memo: runAnalysis. --- 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 b8cbd1ae5..0f849f20a 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -49,6 +49,7 @@ liftAnalyze :: ( Coercible ( m term value (effects :: [* -> *]) value) (t m ter liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) +-- | Run an analysis, performing its effects and returning the result alongside any state. runAnalysis :: ( Effectful m , RunEffects effects a , RequiredEffects term value (m effects) ~ effects From 6f6f90ac3bf14faa3cb7733c12e14fa09a127d9a Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 12 Mar 2018 10:42:52 -0400 Subject: [PATCH 269/292] Add Show constraint to MonadValue to improve error messages. Someday we will probably want our own bespoke `Debug` class so as to save on compile times associated with generating `Show` instances. But this is fine for now, and will also improve #1547. --- src/Control/Abstract/Value.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d9d89d42d..45ebc6333 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -17,7 +17,7 @@ import Prelude hiding (fail) -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (MonadEvaluator t v m) => MonadValue t v m where +class (MonadEvaluator t v m, Show v) => MonadValue t v m where -- | Construct an abstract unit value. unit :: m v @@ -49,6 +49,8 @@ class (MonadEvaluator t v m) => MonadValue t v m where -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables t + , Show t + , Show location , MonadAddressable location (Value location t) m , MonadAnalysis t (Value location t) m , MonadEvaluator t (Value location t) m @@ -66,12 +68,12 @@ instance ( FreeVariables t ifthenelse cond if' else' | Just (Boolean b) <- prj cond = if b then if' else else' - | otherwise = fail "not defined for non-boolean conditions" + | otherwise = fail ("not defined for non-boolean condition: " <> show cond) abstract names (Subterm body _) = inj . Closure names body <$> askLocalEnv apply op params = do - Closure names body env <- maybe (fail "expected a closure") pure (prj op) + Closure names body env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prj op) bindings <- foldr (\ (name, param) rest -> do v <- subtermValue param a <- alloc name From 7f70c6d7e7d3675f50e6d9e350b9cac23d25dfe5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 10:45:17 -0400 Subject: [PATCH 270/292] :memo: CachingAnalysis. --- src/Analysis/Abstract/Caching.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 44d18bb5c..f9bc5eba4 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -22,6 +22,7 @@ type CachingEffects term value effects -- | The cache for term and abstract value types. 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) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet) From e77553a3f0f820752d347c5837a320bc17a4b207 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:11:49 -0400 Subject: [PATCH 271/292] :memo: MonadCaching. --- src/Analysis/Abstract/Caching.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index f9bc5eba4..ab5a168ff 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -28,13 +28,19 @@ newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value eff deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value 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 + -- | Look up the set of values for a given configuration in the in-cache. consultOracle :: ConfigurationFor term value -> m (Set (value, StoreFor value)) + -- | Run an action with the given in-cache. withOracle :: CacheFor term value -> m a -> m a + -- | Look up the set of values for a given configuration in the out-cache. lookupCache :: ConfigurationFor term value -> m (Maybe (Set (value, StoreFor value))) + -- | Run an action, caching its result and 'Store' under the given configuration. caching :: ConfigurationFor term value -> Set (value, StoreFor value) -> m value -> m value + -- | 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) From c4fa7d54a98615ebc390b294d63b88c0b21c44e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:14:23 -0400 Subject: [PATCH 272/292] :memo: RequiredEffects. --- src/Control/Abstract/Analysis.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 0f849f20a..b50138102 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -24,7 +24,9 @@ import Prologue -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. class (MonadEvaluator term value m, Recursive term) => 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 :: [* -> *] + -- | Analyze a term using the semantics of the current analysis. This should generally only be called by definitions of 'evaluateTerm' and 'analyzeTerm' in this or other instances. analyzeTerm :: SubtermAlgebra (Base term) term (m value) From 3bcb30dd67ea0ff648d3e6b775219649805d4994 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:17:42 -0400 Subject: [PATCH 273/292] :memo: runAnalysis. --- src/Control/Abstract/Analysis.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index b50138102..8b7674b76 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -52,6 +52,8 @@ liftAnalyze analyze term = coerce (analyze (second coerce <$> term)) -- | 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'). runAnalysis :: ( Effectful m , RunEffects effects a , RequiredEffects term value (m effects) ~ effects From 3ef27e495fb905e2140ec1822bda54739156d162 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:19:52 -0400 Subject: [PATCH 274/292] Spacing. --- src/Analysis/Abstract/Caching.hs | 1 + src/Analysis/Abstract/Dead.hs | 1 + src/Analysis/Abstract/Evaluating.hs | 1 + src/Analysis/Abstract/Tracing.hs | 1 + 4 files changed, 4 insertions(+) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index ab5a168ff..77aefe7a3 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -78,6 +78,7 @@ instance ( Corecursive term ) => MonadAnalysis term value (Caching m term value effects) where type RequiredEffects term value (Caching m term value effects) = CachingEffects term value (RequiredEffects term value (m term value effects)) + analyzeTerm e = do c <- getConfiguration (embedSubterm e) cached <- lookupCache c diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 95a263e7e..ac6819993 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -42,6 +42,7 @@ instance ( Corecursive 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) + analyzeTerm term = do revive (embedSubterm term) liftAnalyze analyzeTerm term diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index c54ccdd31..08ec356fc 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -102,4 +102,5 @@ instance ( Evaluatable (Base term) ) => MonadAnalysis term value (Evaluating term value effects) where type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value + analyzeTerm = eval diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index c0f354650..58e343c73 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -27,6 +27,7 @@ instance ( Corecursive term ) => 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) + analyzeTerm term = do config <- getConfiguration (embedSubterm term) trace (Reducer.unit config) From 63f8b113fd73c514bb211037963f2de054fec5e1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:21:13 -0400 Subject: [PATCH 275/292] :memo: the CachingEffects list. --- src/Analysis/Abstract/Caching.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 77aefe7a3..11643db34 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -13,10 +13,10 @@ import Prologue -- | The effects necessary for caching analyses. type CachingEffects term value effects - = Fresh - ': NonDetEff - ': Reader (CacheFor term value) - ': State (CacheFor term value) + = Fresh -- For 'MonadFresh'. + ': NonDetEff -- For 'Alternative' and 'MonadNonDet'. + ': Reader (CacheFor term value) -- The in-cache used as an oracle while converging on a result. + ': State (CacheFor term value) -- The out-cache used to record results in each iteration of convergence. ': effects -- | The cache for term and abstract value types. From a222b10ded6440682ac2d3290d88d82226c897d5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:22:15 -0400 Subject: [PATCH 276/292] =?UTF-8?q?:memo:=20Caching=E2=80=99s=20RequiredEf?= =?UTF-8?q?fects.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Caching.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 11643db34..e06ae109a 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -77,6 +77,7 @@ instance ( Corecursive term , Ord value ) => MonadAnalysis term value (Caching m term value 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)) analyzeTerm e = do From ecd0252c9cd20e7ccfafe6d5685629a65c6f59cc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:23:33 -0400 Subject: [PATCH 277/292] :memo: analyzeTerm. --- src/Analysis/Abstract/Caching.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index e06ae109a..8d0069615 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -80,6 +80,7 @@ instance ( Corecursive term -- 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)) + -- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. analyzeTerm e = do c <- getConfiguration (embedSubterm e) cached <- lookupCache c From 8cb9298f4ceb45365160e654887cbb1889f9c744 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:24:30 -0400 Subject: [PATCH 278/292] :memo: EvaluatingEffects. --- src/Analysis/Abstract/Evaluating.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 08ec356fc..e9fa7c6a4 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -68,6 +68,7 @@ deriving instance Member Fresh effects => MonadFresh (Evaluating term value deriving instance Member NonDetEff effects => Alternative (Evaluating term value effects) deriving instance Member NonDetEff effects => MonadNonDet (Evaluating term value effects) +-- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects term value = '[ Fail -- Failure with an error message , Reader (EnvironmentFor value) -- Local environment (e.g. binding over a closure) From b21de35de8c86a84924d90e7c48e43360c4b00af Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:31:32 -0400 Subject: [PATCH 279/292] More spacing. --- src/Analysis/Abstract/Evaluating.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index e9fa7c6a4..21a099b7f 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -62,7 +62,6 @@ 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 NonDetEff effects => Alternative (Evaluating term value effects) From 0171811da457e8c5aa3743a4e128f465dd47f6b7 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:34:37 -0400 Subject: [PATCH 280/292] :memo: trace. --- src/Analysis/Abstract/Tracing.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 58e343c73..9dfe2495a 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -33,6 +33,7 @@ instance ( Corecursive term trace (Reducer.unit config) liftAnalyze analyzeTerm term +-- | Log the given trace of configurations. trace :: ( Effectful (m term value) , Member (Writer (trace (ConfigurationFor term value))) effects ) From 5c415fee15d342c88340a16a32f1e142dc147013 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:37:06 -0400 Subject: [PATCH 281/292] :memo: Effectful. --- src/Control/Effect.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index b00623220..5ce7c710c 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -66,6 +66,9 @@ instance Ord a => RunEffect NonDetEff a where MPlus -> mappend <$> k True <*> k False) +-- | Types wrapping 'Eff' actions. +-- +-- Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). class Effectful m where raise :: Eff effects a -> m effects a lower :: m effects a -> Eff effects a From fa4a74c3c1f25f024f10bc72aed98baa87536397 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:37:23 -0400 Subject: [PATCH 282/292] =?UTF-8?q?Give=20a=20kind=20signature=20for=20Eff?= =?UTF-8?q?ectful=E2=80=99s=20parameter.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Effect.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 5ce7c710c..e7758d270 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -69,7 +69,7 @@ instance Ord a => RunEffect NonDetEff a where -- | Types wrapping 'Eff' actions. -- -- Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). -class Effectful m where +class Effectful (m :: [* -> *] -> * -> *) where raise :: Eff effects a -> m effects a lower :: m effects a -> Eff effects a From 80f5a4e02477d38902880d005a28c6d070d746b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:37:56 -0400 Subject: [PATCH 283/292] :fire: redundant extensions. --- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Analysis.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 8d0069615..4bcc7b360 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Caching ( type Caching ) where diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index ac6819993..d3dfe6e83 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators #-} module Analysis.Abstract.Dead ( type DeadCode ) where diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 9dfe2495a..2af336891 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, StandaloneDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Tracing ( type Tracing ) where diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 8b7674b76..555788994 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, KindSignatures, MultiParamTypeClasses, TypeFamilies #-} +{-# LANGUAGE DataKinds, MultiParamTypeClasses, TypeFamilies #-} module Control.Abstract.Analysis ( MonadAnalysis(..) , evaluateTerm From 82c578ed0dba97d37127745ae741e886f57aed1a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:39:51 -0400 Subject: [PATCH 284/292] :memo: raise & lower. --- src/Control/Effect.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index e7758d270..a4924f3d4 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -68,9 +68,11 @@ instance Ord a => RunEffect NonDetEff a where -- | Types wrapping 'Eff' actions. -- --- Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). +-- Most instances of 'Effectful' will be derived using @-XGeneralizedNewtypeDeriving@, with these ultimately bottoming out on the instance for 'Eff' (for which 'raise' and 'lower' are simply the identity). Because of this, types can be nested arbitrarily deeply and still call 'raise'/'lower' just once to get at the (ultimately) underlying 'Eff'. class Effectful (m :: [* -> *] -> * -> *) where + -- | Raise an action in 'Eff' into an action in @m@. raise :: Eff effects a -> m effects a + -- | Lower an action in @m@ into an action in 'Eff'. lower :: m effects a -> Eff effects a instance Effectful Eff where From 35718fca9618502802e30bfb083e19bc1fc8d2ca Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:42:14 -0400 Subject: [PATCH 285/292] =?UTF-8?q?Resume=20taking=20an=20explicit=20const?= =?UTF-8?q?ructor=20in=20gather=20so=20it=20doesn=E2=80=99t=20have=20to=20?= =?UTF-8?q?be=20annotated=20with=20the=20type.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Caching.hs | 2 +- src/Control/Monad/Effect/NonDet.hs | 10 +++++----- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 4bcc7b360..871247824 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -102,7 +102,7 @@ instance ( Corecursive term -- that it doesn't "leak" to the calling context and diverge (otherwise this -- would never complete). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - withOracle prevCache (gather (Caching (evaluateModule e)) :: Caching m term value effects ())) mempty + withOracle prevCache (gather (const ()) (Caching (evaluateModule e)))) mempty maybe empty scatter (cacheLookup c cache) -- | Iterate a monadic action starting from some initial seed until the results converge. diff --git a/src/Control/Monad/Effect/NonDet.hs b/src/Control/Monad/Effect/NonDet.hs index 4b4d8afc2..f11317396 100644 --- a/src/Control/Monad/Effect/NonDet.hs +++ b/src/Control/Monad/Effect/NonDet.hs @@ -6,18 +6,18 @@ module Control.Monad.Effect.NonDet import Control.Monad.Effect.Internal import Control.Monad.Effect.NonDetEff -import Data.Semigroup.Reducer import Prologue -- | 'Monad's offering local isolation of nondeterminism effects. class (Alternative m, Monad m) => MonadNonDet m where -- | Run a computation, gathering any nondeterministically produced results into a single 'Monoid'al value. - gather :: (Monoid b, Reducer a b) - => m a -- ^ The computation to run locally-nondeterministically. - -> m b -- ^ A _deterministic_ computation producing the 'Monoid'al accumulation of the _locally-nondeterministic_ result values. + gather :: Monoid b + => (a -> b) -- ^ A function constructing a 'Monoid'al value from a single computed result. This might typically be @point@ (for @Pointed@ functors), 'pure' (for 'Applicative's), or some similar singleton constructor. + -> m a -- ^ The computation to run locally-nondeterministically. + -> m b -- ^ A _deterministic_ computation producing the 'Monoid'al accumulation of the _locally-nondeterministic_ result values. -- | Effect stacks containing 'NonDetEff' offer a 'MonadNonDet' instance which implements 'gather' by interpreting the requests for nondeterminism locally, without removing 'NonDetEff' from the stack—i.e. the _capacity_ for nondeterminism is still present in the effect stack, but any local nondeterminism has been applied. instance (NonDetEff :< fs) => MonadNonDet (Eff fs) where - gather = interpose (pure . unit) (\ m k -> case m of + gather f = interpose (pure . f) (\ m k -> case m of MZero -> pure mempty MPlus -> mappend <$> k True <*> k False) From 4e4a61f8fbd814739b7da211606184bbf6332ca0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 11:42:46 -0400 Subject: [PATCH 286/292] Tweak to the docs for gather. --- src/Control/Monad/Effect/NonDet.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Monad/Effect/NonDet.hs b/src/Control/Monad/Effect/NonDet.hs index f11317396..d195031db 100644 --- a/src/Control/Monad/Effect/NonDet.hs +++ b/src/Control/Monad/Effect/NonDet.hs @@ -12,7 +12,7 @@ import Prologue class (Alternative m, Monad m) => MonadNonDet m where -- | Run a computation, gathering any nondeterministically produced results into a single 'Monoid'al value. gather :: Monoid b - => (a -> b) -- ^ A function constructing a 'Monoid'al value from a single computed result. This might typically be @point@ (for @Pointed@ functors), 'pure' (for 'Applicative's), or some similar singleton constructor. + => (a -> b) -- ^ A function constructing a 'Monoid'al value from a single computed result. This might typically be @unit@ (for @Reducer@s), 'pure' (for 'Applicative's), or some similar singleton constructor. -> m a -- ^ The computation to run locally-nondeterministically. -> m b -- ^ A _deterministic_ computation producing the 'Monoid'al accumulation of the _locally-nondeterministic_ result values. From 371a4ae02b826a846cf0c87e44ad06727e5e41c3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 12:56:47 -0400 Subject: [PATCH 287/292] Whoops, semigroups snuck back in there. --- semantic.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/semantic.cabal b/semantic.cabal index 588a71a16..4d91706a5 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -160,7 +160,6 @@ library , parsers , recursion-schemes , reducers - , semigroups , scientific , split , stm-chans From e8c7389ffe871f40204d14bed7625aaf664cc721 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 12 Mar 2018 14:19:29 -0400 Subject: [PATCH 288/292] Evaluatable instances for VariableDeclarations and tuple literals. The VariableDeclaration instance just shells out to that for Assignment, but required the addition of a concrete tuple typle for cases such as `var x = 1, y = 2`. As an added bonus, we now get tuple evaluations in Python. This required a rejiggering of the Value type in Data.Abstract.Value - it is now a newtype over the union that contains another Value type recursively, analogous how Fix ties the knot over infinitely-nested Functor values. --- src/Control/Abstract/Value.hs | 30 ++++++++++------- src/Data/Abstract/Value.hs | 54 +++++++++++++++++++++---------- src/Data/Syntax/Declaration.hs | 11 ++++--- src/Data/Syntax/Literal.hs | 5 ++- src/Language/TypeScript/Syntax.hs | 2 ++ src/Semantic/Util.hs | 2 +- 6 files changed, 67 insertions(+), 37 deletions(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index d9d89d42d..1043b67a5 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -19,6 +19,7 @@ import Prelude hiding (fail) -- This allows us to abstract the choice of whether to evaluate under binders for different value types. class (MonadEvaluator t v m) => MonadValue t v m where -- | Construct an abstract unit value. + -- TODO: This might be the same as the empty tuple for some value types unit :: m v -- | Construct an abstract integral value. @@ -33,6 +34,9 @@ class (MonadEvaluator t v m) => MonadValue t v m where -- | Construct a floating-point value. float :: Scientific -> m v + -- | Construct an N-ary tuple of multiple (possibly-disjoint) values + multiple :: [v] -> m v + -- | Construct an abstract interface value. interface :: v -> m v @@ -57,21 +61,24 @@ instance ( FreeVariables t ) => MonadValue t (Value location t) m where - unit = pure $ inj Value.Unit - integer = pure . inj . Integer - boolean = pure . inj . Boolean - string = pure . inj . Value.String - float = pure . inj . Value.Float - interface v = inj . Value.Interface v <$> getGlobalEnv + unit = pure . injValue $ Value.Unit + integer = pure . injValue . Integer + boolean = pure . injValue . Boolean + string = pure . injValue . Value.String + float = pure . injValue . Value.Float + multiple vals = + pure . injValue $ Value.Tuple vals + + interface v = injValue . Value.Interface v <$> getGlobalEnv ifthenelse cond if' else' - | Just (Boolean b) <- prj cond = if b then if' else else' + | Just (Boolean b) <- prjValue cond = if b then if' else else' | otherwise = fail "not defined for non-boolean conditions" - abstract names (Subterm body _) = inj . Closure names body <$> askLocalEnv + abstract names (Subterm body _) = injValue . Closure names body <$> askLocalEnv apply op params = do - Closure names body env <- maybe (fail "expected a closure") pure (prj op) + Closure names body env <- maybe (fail "expected a closure") pure (prjValue op) bindings <- foldr (\ (name, param) rest -> do v <- subtermValue param a <- alloc name @@ -80,8 +87,8 @@ instance ( FreeVariables t localEnv (mappend bindings) (evaluateTerm body) environment v - | Just (Interface _ env) <- prj v = pure env - | otherwise = pure mempty + | Just (Interface _ env) <- prjValue v = pure env + | otherwise = pure mempty -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. instance (Alternative m, MonadEvaluator t Type m, MonadFresh m) => MonadValue t Type m where @@ -100,6 +107,7 @@ instance (Alternative m, MonadEvaluator t Type m, MonadFresh m) => MonadValue t boolean _ = pure Bool string _ = pure Type.String float _ = pure Type.Float + multiple = pure . Type.Product -- TODO interface = undefined diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index f6768303d..3e6a008d2 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-} +{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-} module Data.Abstract.Value where import Data.Abstract.Address @@ -13,32 +13,41 @@ import Prologue import Prelude hiding (Float, Integer, String, fail) import qualified Prelude -type ValueConstructors location - = '[Closure location +type ValueConstructors location term + = '[Closure location term , Interface location , Unit , Boolean , Float , Integer , String + , Tuple ] -- | Open union of primitive values that terms can be evaluated to. -type Value location = Union (ValueConstructors location) +-- Fix by another name. +newtype Value location term = Value { deValue :: Union (ValueConstructors location term) (Value location term) } + deriving (Eq, Show, Ord) + + +injValue :: (f :< ValueConstructors location term) => f (Value location term) -> Value location term +injValue = Value . inj + +prjValue :: (f :< ValueConstructors location term) => Value location term -> Maybe (f (Value location term)) +prjValue = prj . deValue -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union. --- TODO: Wrap the Value union in a newtype to differentiate from (eventual) à la carte Types. -- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body. -data Closure location term = Closure [Name] term (Environment location (Value location term)) +data Closure location term value = Closure [Name] term (Environment location value) deriving (Eq, Generic1, Ord, Show) -instance (Eq location) => Eq1 (Closure location) where liftEq = genericLiftEq -instance (Ord location) => Ord1 (Closure location) where liftCompare = genericLiftCompare -instance (Show location) => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec +instance (Eq location, Eq term) => Eq1 (Closure location term) where liftEq = genericLiftEq +instance (Ord location, Ord term) => Ord1 (Closure location term) where liftCompare = genericLiftCompare +instance (Show location, Show term) => Show1 (Closure location term) where liftShowsPrec = genericLiftShowsPrec -- | A program value consisting of the value of the program and it's enviornment of bindings. -data Interface location term = Interface (Value location term) (Environment location (Value location term)) +data Interface location value = Interface value (Environment location value) deriving (Eq, Generic1, Ord, Show) instance (Eq location) => Eq1 (Interface location) where liftEq = genericLiftEq @@ -46,7 +55,7 @@ instance (Ord location) => Ord1 (Interface location) where liftCompare = generic instance (Show location) => Show1 (Interface location) where liftShowsPrec = genericLiftShowsPrec -- | The unit value. Typically used to represent the result of imperative statements. -data Unit term = Unit +data Unit value = Unit deriving (Eq, Generic1, Ord, Show) instance Eq1 Unit where liftEq = genericLiftEq @@ -54,7 +63,7 @@ instance Ord1 Unit where liftCompare = genericLiftCompare instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec -- | Boolean values. -newtype Boolean term = Boolean Prelude.Bool +newtype Boolean value = Boolean Prelude.Bool deriving (Eq, Generic1, Ord, Show) instance Eq1 Boolean where liftEq = genericLiftEq @@ -62,7 +71,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec -- | Arbitrary-width integral values. -newtype Integer term = Integer Prelude.Integer +newtype Integer value = Integer Prelude.Integer deriving (Eq, Generic1, Ord, Show) instance Eq1 Integer where liftEq = genericLiftEq @@ -70,7 +79,7 @@ instance Ord1 Integer where liftCompare = genericLiftCompare instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec -- | String values. -newtype String term = String ByteString +newtype String value = String ByteString deriving (Eq, Generic1, Ord, Show) instance Eq1 String where liftEq = genericLiftEq @@ -78,13 +87,24 @@ instance Ord1 String where liftCompare = genericLiftCompare instance Show1 String where liftShowsPrec = genericLiftShowsPrec -- | Float values. -newtype Float term = Float Scientific +newtype Float value = Float Scientific deriving (Eq, Generic1, Ord, Show) instance Eq1 Float where liftEq = genericLiftEq instance Ord1 Float where liftCompare = genericLiftCompare instance Show1 Float where liftShowsPrec = genericLiftShowsPrec +-- Zero or more values. +-- TODO: Investigate whether we should use Vector for this. +-- TODO: Should we have a Some type over a nonemmpty list? Or does this merit one? + +newtype Tuple value = Tuple [value] + deriving (Eq, Generic1, Ord, Show) + +instance Eq1 Tuple where liftEq = genericLiftEq +instance Ord1 Tuple where liftCompare = genericLiftCompare +instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec + -- | The environment for an abstract value type. type EnvironmentFor v = Environment (LocationFor v) v @@ -103,8 +123,8 @@ class ValueRoots l v | v -> l where instance (FreeVariables term, Ord location) => ValueRoots location (Value location term) where valueRoots v - | Just (Closure names body env) <- prj v = envRoots env (foldr Set.delete (freeVariables body) names) - | otherwise = mempty + | Just (Closure names body env) <- prjValue v = envRoots env (foldr Set.delete (freeVariables (body :: term)) names) + | otherwise = mempty instance ValueRoots Monovariant Type.Type where valueRoots _ = mempty diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 8ed52684d..ff28948c5 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -1,11 +1,12 @@ {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-} module Data.Syntax.Declaration where -import Prologue import Data.Abstract.Environment import Data.Abstract.Evaluatable import Diffing.Algorithm import qualified Data.Map as Map +import Prelude hiding (fail) +import Prologue data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a } deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) @@ -88,7 +89,7 @@ instance Evaluatable OptionalParameter -- TODO: Should we replace this with Function and differentiate by context? -- TODO: How should we distinguish class/instance methods? - +-- TODO: It would be really nice to have a more meaningful type contained in here than [a] -- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript. newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) @@ -97,9 +98,9 @@ instance Eq1 VariableDeclaration where liftEq = genericLiftEq instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for VariableDeclaration -instance Evaluatable VariableDeclaration - +instance Evaluatable VariableDeclaration where + eval (VariableDeclaration []) = unit + eval (VariableDeclaration decs) = multiple =<< traverse subtermValue decs -- | A TypeScript/Java style interface declaration to implement. data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationBody :: !a } diff --git a/src/Data/Syntax/Literal.hs b/src/Data/Syntax/Literal.hs index b3dfd5d35..310d13396 100644 --- a/src/Data/Syntax/Literal.hs +++ b/src/Data/Syntax/Literal.hs @@ -236,9 +236,8 @@ instance Eq1 Tuple where liftEq = genericLiftEq instance Ord1 Tuple where liftCompare = genericLiftCompare instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Tuple -instance Evaluatable Tuple - +instance Evaluatable Tuple where + eval (Tuple cs) = multiple =<< traverse subtermValue cs newtype Set a = Set { setElements :: [a] } deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index bd46dc442..13b920796 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -85,6 +85,8 @@ newtype Tuple a = Tuple { _tupleElements :: [a] } instance Eq1 Tuple where liftEq = genericLiftEq instance Ord1 Tuple where liftCompare = genericLiftCompare instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec + +-- This is a tuple type, not a tuple value, so we can't lean on the shared Tuple value instance Evaluatable Tuple data Constructor a = Constructor { _constructorTypeParameters :: !a, _constructorFormalParameters :: ![a], _constructorType :: !a } diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index f1e534805..c2018da11 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -52,7 +52,7 @@ evaluateRubyFiles paths = do typecheckGoFile path = evaluateCache @Type <$> (file path >>= runTask . parse goParser) -evaluateGoFile path = evaluateCache @GoValue <$> +evaluateGoFile path = evaluate @GoValue <$> (file path >>= runTask . parse goParser) -- Python From dfc4d786e525893abfb21de5bab6a7287cdc6bb7 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 12 Mar 2018 14:24:36 -0400 Subject: [PATCH 289/292] documentation --- src/Data/Abstract/Value.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 3e6a008d2..4afcadcdd 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -29,10 +29,11 @@ type ValueConstructors location term newtype Value location term = Value { deValue :: Union (ValueConstructors location term) (Value location term) } deriving (Eq, Show, Ord) - +-- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'. injValue :: (f :< ValueConstructors location term) => f (Value location term) -> Value location term injValue = Value . inj +-- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper. prjValue :: (f :< ValueConstructors location term) => Value location term -> Maybe (f (Value location term)) prjValue = prj . deValue From f70ee19ce7be855d135a4badf9d5af6a17674381 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 14:45:22 -0400 Subject: [PATCH 290/292] =?UTF-8?q?=F0=9F=94=A5=20diffPatch?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Data/Diff.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Data/Diff.hs b/src/Data/Diff.hs index 83befa8ef..db4adb43d 100644 --- a/src/Data/Diff.hs +++ b/src/Data/Diff.hs @@ -82,11 +82,6 @@ merging :: Functor syntax => Term syntax ann -> Diff syntax ann ann merging = cata (\ (In ann syntax) -> mergeF (In (ann, ann) syntax)) -diffPatch :: Diff syntax ann1 ann2 -> Maybe (Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))) -diffPatch diff = case unDiff diff of - Patch patch -> Just patch - _ -> Nothing - diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))] diffPatches = para $ \ diff -> case diff of Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap snd) (foldMap snd) patch From 0e9ed4e9aeb0f66451c3b35170628922940a89de Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 12 Mar 2018 15:59:19 -0400 Subject: [PATCH 291/292] Use evaluateModule in load instead of evaluateTerm. --- 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 e804eb7de..d9820e8ef 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -88,7 +88,7 @@ load :: ( MonadAnalysis term value m load name = askModuleTable >>= maybe notFound evalAndCache . moduleTableLookup name where notFound = fail ("cannot load module: " <> show name) evalAndCache e = do - v <- evaluateTerm e + v <- evaluateModule e env <- environment v modifyModuleTable (moduleTableInsert name env) pure env From 578bb5c566cee7cb0826f59ba8abdafedb524f2b Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 12 Mar 2018 16:52:32 -0400 Subject: [PATCH 292/292] unnecessary import --- src/Data/Syntax/Declaration.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index ff28948c5..eb0a38798 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -5,7 +5,6 @@ import Data.Abstract.Environment import Data.Abstract.Evaluatable import Diffing.Algorithm import qualified Data.Map as Map -import Prelude hiding (fail) import Prologue data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }