From e6010b75cdee4d02d73d526b4224263e0cecddce Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 12:34:17 -0400 Subject: [PATCH 01/74] Spacing. --- src/Semantic/Graph.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 93c37d301..2ae2d1566 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -70,8 +70,7 @@ type ImportGraphAnalysis term effects value = value -- | Render the import graph for a given 'Package'. -graphImports :: ( - Show ann +graphImports :: ( Show ann , Ord ann , Apply Analysis.Declarations1 syntax , Apply Analysis.Evaluatable syntax From 70080feadb61ae1aa1a8784a5e32f1d12a362acc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 12:35:34 -0400 Subject: [PATCH 02/74] :fire: a redundant equality constraint. --- src/Semantic/Graph.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 2ae2d1566..59d68944a 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -81,9 +81,8 @@ graphImports :: ( Show ann , Apply Show1 syntax , Member Syntax.Identifier syntax , Members '[Exc SomeException, Task] effs - , term ~ Term (Union syntax) ann ) - => Package term -> Eff effs Abstract.ImportGraph + => Package (Term (Union syntax) ann) -> Eff effs Abstract.ImportGraph graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= extractGraph where asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value From e2bdb23564c2bc5bbf3c3a11a11f81c335c29787 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 13:01:16 -0400 Subject: [PATCH 03/74] Define an analysis which fails on errors. --- src/Semantic/Util.hs | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index b0995c1e8..05d2098f0 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,5 +1,5 @@ -- MonoLocalBinds is to silence a warning about a simplifiable constraint. -{-# LANGUAGE MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.Util where @@ -40,6 +40,22 @@ import qualified Language.Python.Assignment as Python import qualified Language.Ruby.Assignment as Ruby import qualified Language.TypeScript.Assignment as TypeScript +-- | An analysis that fails on errors. +newtype Erroring m (effects :: [* -> *]) a = Erroring (m effects a) + deriving (Alternative, Applicative, Effectful, Functor, Monad) + +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring m) +instance MonadAnalysis location term value effects m + => MonadAnalysis location term value effects (Erroring m) where + type Effects location term value (Erroring m) + = Resumable (AddressError location value) + ': Resumable (EvalError value) + ': Resumable (ResolutionError value) + ': Resumable (ValueError location value) + ': Effects location term value m + + analyzeTerm = liftAnalyze analyzeTerm + analyzeModule = liftAnalyze analyzeModule -- type TestEvaluating term = Evaluating Precise term (Value Precise) type JustEvaluating term = Evaluating (Located Precise term) term (Value (Located Precise term)) From 4b48d7c858f03af2011c3199af21856331ed5854 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 13:01:30 -0400 Subject: [PATCH 04/74] Add BadAddresses to EvaluatingWithHoles. --- 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 05d2098f0..a0ae241df 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -3,6 +3,7 @@ {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.Util where +import Analysis.Abstract.BadAddresses import Analysis.Abstract.BadModuleResolutions import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables @@ -59,7 +60,7 @@ instance MonadAnalysis location term value effects m -- type TestEvaluating term = Evaluating Precise term (Value Precise) type JustEvaluating term = Evaluating (Located Precise term) term (Value (Located Precise term)) -type EvaluatingWithHoles term = BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))) +type EvaluatingWithHoles term = BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term))))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Nothing path From b042a6a6d4c4d2903fc4932771dde04bccb6b2cd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 13:01:56 -0400 Subject: [PATCH 05/74] Provide resumable exceptions in the analyses which resume them. --- src/Analysis/Abstract/BadAddresses.hs | 2 +- src/Analysis/Abstract/BadModuleResolutions.hs | 2 +- src/Analysis/Abstract/BadValues.hs | 2 +- src/Analysis/Abstract/BadVariables.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 4 ---- src/Semantic/Graph.hs | 2 +- src/Semantic/Util.hs | 2 +- 7 files changed, 6 insertions(+), 10 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 345ab93ca..fbece2cb3 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -18,7 +18,7 @@ instance ( Effectful m , Show location ) => MonadAnalysis location term value effects (BadAddresses m) where - type Effects location term value (BadAddresses m) = Effects location term value m + type Effects location term value (BadAddresses m) = Resumable (AddressError location value) ': Effects location term value m analyzeTerm eval term = resume @(AddressError location value) (liftAnalyze analyzeTerm eval term) ( \yield error -> do diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index be4eccba0..bade43f3e 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -17,7 +17,7 @@ instance ( Effectful m , MonadValue location value effects (BadModuleResolutions m) ) => MonadAnalysis location term value effects (BadModuleResolutions m) where - type Effects location term value (BadModuleResolutions m) = State [Name] ': Effects location term value m + type Effects location term value (BadModuleResolutions m) = State [Name] ': Resumable (ResolutionError value) ': Effects location term value m analyzeTerm eval term = resume @(ResolutionError value) (liftAnalyze analyzeTerm eval term) ( \yield error -> do diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 68eeb6b97..5a4e0368e 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -19,7 +19,7 @@ instance ( Effectful m , MonadValue location value effects (BadValues m) ) => MonadAnalysis location term value effects (BadValues m) where - type Effects location term value (BadValues m) = State [Name] ': Effects location term value m + type Effects location term value (BadValues m) = State [Name] ': Resumable (ValueError location value) ': Effects location term value m analyzeTerm eval term = resume @(ValueError location value) (liftAnalyze analyzeTerm eval term) ( \yield error -> do diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 608f8515d..baecf561a 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -20,7 +20,7 @@ instance ( Effectful m , MonadValue location value effects (BadVariables m) ) => MonadAnalysis location term value effects (BadVariables m) where - type Effects location term value (BadVariables m) = State [Name] ': Effects location term value m + type Effects location term value (BadVariables m) = State [Name] ': Resumable (EvalError value) ': Effects location term value m analyzeTerm eval term = resume @(EvalError value) (liftAnalyze analyzeTerm eval term) ( \yield err -> do diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 3733d5374..05a058811 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -23,12 +23,8 @@ deriving instance Member NonDet effects => Alternative (Evaluating location term type EvaluatingEffects location term value = '[ Exc (ReturnThrow value) , Exc (LoopThrow value) - , Resumable (EvalError value) - , Resumable (ResolutionError value) , Resumable (LoadError term value) - , Resumable (ValueError location value) , Resumable (Unspecialized value) - , Resumable (AddressError location value) , Fail -- Failure with an error message , Fresh -- For allocating new addresses and/or type variables. , Reader (SomeOrigin term) -- The current term’s origin. diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 59d68944a..3c5631de1 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -91,5 +91,5 @@ graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage asAnalysisForTypeOfPackage = const extractGraph result = case result of - (Right (Right (Right (Right (Right (Right (Right (Right (Right ((((_, graph), _), _), _))))))))), _) -> pure $! graph + (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph), _), _), _)))))), _) -> pure $! graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index a0ae241df..b16d99bc7 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -59,7 +59,7 @@ instance MonadAnalysis location term value effects m analyzeModule = liftAnalyze analyzeModule -- type TestEvaluating term = Evaluating Precise term (Value Precise) -type JustEvaluating term = Evaluating (Located Precise term) term (Value (Located Precise term)) +type JustEvaluating term = Erroring (Evaluating (Located Precise term) term (Value (Located Precise term))) type EvaluatingWithHoles term = BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term))))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) From dae310c357a865eb803f694b8151f3975b8efe52 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 13:04:46 -0400 Subject: [PATCH 06/74] Use one Erroring analysis per error type. --- src/Semantic/Util.hs | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index b16d99bc7..41982af46 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -42,24 +42,24 @@ import qualified Language.Ruby.Assignment as Ruby import qualified Language.TypeScript.Assignment as TypeScript -- | An analysis that fails on errors. -newtype Erroring m (effects :: [* -> *]) a = Erroring (m effects a) +newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring (m effects a) deriving (Alternative, Applicative, Effectful, Functor, Monad) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m) instance MonadAnalysis location term value effects m - => MonadAnalysis location term value effects (Erroring m) where - type Effects location term value (Erroring m) - = Resumable (AddressError location value) - ': Resumable (EvalError value) - ': Resumable (ResolutionError value) - ': Resumable (ValueError location value) - ': Effects location term value m + => MonadAnalysis location term value effects (Erroring exc m) where + type Effects location term value (Erroring exc m) = Resumable exc ': Effects location term value m analyzeTerm = liftAnalyze analyzeTerm analyzeModule = liftAnalyze analyzeModule -- type TestEvaluating term = Evaluating Precise term (Value Precise) -type JustEvaluating term = Erroring (Evaluating (Located Precise term) term (Value (Located Precise term))) +type JustEvaluating term + = Erroring (AddressError (Located Precise term) (Value (Located Precise term))) + (Erroring (EvalError (Value (Located Precise term))) + (Erroring (ResolutionError (Value (Located Precise term))) + (Erroring (ValueError (Located Precise term) (Value (Located Precise term))) + (Evaluating (Located Precise term) term (Value (Located Precise term)))))) type EvaluatingWithHoles term = BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term))))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) From e05c0aab2adb5833ffcf2c1accf2a5f934a34d7e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 14:14:00 -0400 Subject: [PATCH 07/74] Align some things. --- src/Semantic/Util.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 41982af46..932a24382 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -56,10 +56,10 @@ instance MonadAnalysis location term value effects m -- type TestEvaluating term = Evaluating Precise term (Value Precise) type JustEvaluating term = Erroring (AddressError (Located Precise term) (Value (Located Precise term))) - (Erroring (EvalError (Value (Located Precise term))) - (Erroring (ResolutionError (Value (Located Precise term))) - (Erroring (ValueError (Located Precise term) (Value (Located Precise term))) - (Evaluating (Located Precise term) term (Value (Located Precise term)))))) + ( Erroring (EvalError (Value (Located Precise term))) + ( Erroring (ResolutionError (Value (Located Precise term))) + ( Erroring (ValueError (Located Precise term) (Value (Located Precise term))) + ( Evaluating (Located Precise term) term (Value (Located Precise term)))))) type EvaluatingWithHoles term = BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term))))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) From 4cc2edbfb3c58941d19416c0f50e5c5a80c6357e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 14:14:20 -0400 Subject: [PATCH 08/74] Spacing. --- src/Semantic/Util.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 932a24382..9f185a42e 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -46,6 +46,7 @@ newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring (m effects deriving (Alternative, Applicative, Effectful, Functor, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m) + instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Erroring exc m) where type Effects location term value (Erroring exc m) = Resumable exc ': Effects location term value m From 2875aa90a388ab3b438592c626c6cecb19aa6d37 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 14:59:24 -0400 Subject: [PATCH 09/74] Tidy up the ImportGraphing language extensions. --- src/Analysis/Abstract/ImportGraph.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index b2c4496db..0e5e45d2f 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, - TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.ImportGraph ( ImportGraph(..) , renderImportGraph From 6de62e0cf8cfc87fbd8e0820aab7a7e9849052c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 16:55:35 -0400 Subject: [PATCH 10/74] :fire: some redundant parens. --- src/Analysis/Abstract/BadModuleResolutions.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index bade43f3e..d77aa5e4a 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -23,7 +23,7 @@ instance ( Effectful m \yield error -> do traceM ("ResolutionError:" <> show error) case error of - (RubyError nameToResolve) -> yield nameToResolve - (TypeScriptError nameToResolve) -> yield nameToResolve) + RubyError nameToResolve -> yield nameToResolve + TypeScriptError nameToResolve -> yield nameToResolve) analyzeModule = liftAnalyze analyzeModule From 54d373d5ce8192ac0d63b964ac0340f0f67e4c48 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 16:55:49 -0400 Subject: [PATCH 11/74] :fire: a redundant State effect. --- src/Analysis/Abstract/BadModuleResolutions.hs | 3 +-- src/Semantic/Graph.hs | 2 +- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index d77aa5e4a..47fd322c9 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -12,12 +12,11 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator instance ( Effectful m , Member (Resumable (ResolutionError value)) effects - , Member (State [Name]) effects , MonadAnalysis location term value effects m , MonadValue location value effects (BadModuleResolutions m) ) => MonadAnalysis location term value effects (BadModuleResolutions m) where - type Effects location term value (BadModuleResolutions m) = State [Name] ': Resumable (ResolutionError value) ': Effects location term value m + type Effects location term value (BadModuleResolutions m) = Resumable (ResolutionError value) ': Effects location term value m analyzeTerm eval term = resume @(ResolutionError value) (liftAnalyze analyzeTerm eval term) ( \yield error -> do diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 3c5631de1..7c6936d63 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -91,5 +91,5 @@ graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage asAnalysisForTypeOfPackage = const extractGraph result = case result of - (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph), _), _), _)))))), _) -> pure $! graph + (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph)), _), _)))))), _) -> pure $! graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) From 77e8c4c6edfc4d657b6a9d404b4ea3a417add6fc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 16:59:19 -0400 Subject: [PATCH 12/74] :fire: some redundant language extensions. --- src/Analysis/Abstract/BadAddresses.hs | 2 +- src/Analysis/Abstract/BadModuleResolutions.hs | 2 +- src/Analysis/Abstract/BadValues.hs | 2 +- src/Analysis/Abstract/BadVariables.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index fbece2cb3..2290acff8 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.BadAddresses where import Control.Abstract.Analysis diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 47fd322c9..b6a6575fb 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.BadModuleResolutions where import Control.Abstract.Analysis diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 5a4e0368e..2cca5c984 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.BadValues where import Control.Abstract.Analysis diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index baecf561a..89a5c803f 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.BadVariables ( BadVariables ) where From 739687f70e3d1d1812798ff3cb689ba123bbd7c8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 16:59:38 -0400 Subject: [PATCH 13/74] :fire: a redundant State effect. --- src/Analysis/Abstract/BadValues.hs | 4 +--- src/Semantic/Graph.hs | 2 +- 2 files changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 2cca5c984..7d9b4a1d3 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -2,7 +2,6 @@ module Analysis.Abstract.BadValues where import Control.Abstract.Analysis -import Data.Abstract.Evaluatable import Data.Abstract.Environment as Env import Prologue import Data.ByteString.Char8 (pack) @@ -14,12 +13,11 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluat instance ( Effectful m , Member (Resumable (ValueError location value)) effects - , Member (State [Name]) effects , MonadAnalysis location term value effects m , MonadValue location value effects (BadValues m) ) => MonadAnalysis location term value effects (BadValues m) where - type Effects location term value (BadValues m) = State [Name] ': Resumable (ValueError location value) ': Effects location term value m + type Effects location term value (BadValues m) = Resumable (ValueError location value) ': Effects location term value m analyzeTerm eval term = resume @(ValueError location value) (liftAnalyze analyzeTerm eval term) ( \yield error -> do diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 7c6936d63..28d38d093 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -91,5 +91,5 @@ graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage asAnalysisForTypeOfPackage = const extractGraph result = case result of - (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph)), _), _)))))), _) -> pure $! graph + (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph)), _))))))), _) -> pure $! graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) From 25af1cfcaaf828937186510cecfc85f8be2ded7c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:31:09 -0400 Subject: [PATCH 14/74] Define an Interpreter typeclass for effectful computations which can interpret their effects. --- src/Control/Abstract/Analysis.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 7e6c60b2b..a160eabdc 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE FunctionalDependencies, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis module Control.Abstract.Analysis ( MonadAnalysis(..) +, Interpreter(..) , liftAnalyze , runAnalysis , SomeAnalysis(..) @@ -45,6 +46,9 @@ class MonadEvaluator location term value effects m => MonadAnalysis location ter isolate :: m effects a -> m effects a isolate = withEnv mempty . withExports mempty +class Effectful m => Interpreter effects result function m | m effects result -> function where + interpret :: m effects result -> function + -- | 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 effects value) (t m (effects :: [* -> *]) value) From 68b748139dea25f89e4a70de22847b51a09f7641 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:39:01 -0400 Subject: [PATCH 15/74] Swap the order of the BadVariables effects. --- src/Analysis/Abstract/BadVariables.hs | 2 +- src/Semantic/Graph.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 89a5c803f..e4db58e14 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -20,7 +20,7 @@ instance ( Effectful m , MonadValue location value effects (BadVariables m) ) => MonadAnalysis location term value effects (BadVariables m) where - type Effects location term value (BadVariables m) = State [Name] ': Resumable (EvalError value) ': Effects location term value m + type Effects location term value (BadVariables m) = Resumable (EvalError value) ': State [Name] ': Effects location term value m analyzeTerm eval term = resume @(EvalError value) (liftAnalyze analyzeTerm eval term) ( \yield err -> do diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 28d38d093..e46023d6a 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -91,5 +91,5 @@ graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage asAnalysisForTypeOfPackage = const extractGraph result = case result of - (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph)), _))))))), _) -> pure $! graph + (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph))), _)))))), _) -> pure $! graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) From 5df26fd4a961b10063785fe2ce4823792e312146 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:39:12 -0400 Subject: [PATCH 16/74] Define an Interpreter instance for BadAddresses. --- src/Analysis/Abstract/BadAddresses.hs | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 2290acff8..ebff75da9 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -2,6 +2,7 @@ module Analysis.Abstract.BadAddresses where import Control.Abstract.Analysis +import Control.Monad.Effect.Internal hiding (interpret) import Data.Abstract.Address import Prologue @@ -28,3 +29,12 @@ instance ( Effectful m UninitializedAddress _ -> hole >>= yield) analyzeModule = liftAnalyze analyzeModule + +instance ( Interpreter effects result rest m + , MonadValue location value effects m + , Monoid (Cell location value) + ) + => Interpreter (Resumable (AddressError location value) ': effects) result rest (BadAddresses m) where + interpret = interpret . raise @m . relay pure (\ (Resumable err) yield -> case err of + UnallocatedAddress _ -> yield mempty + UninitializedAddress _ -> lower @m hole >>= yield) . lower From ef4ed428cfb2872836103f27064f745527c163da Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:39:21 -0400 Subject: [PATCH 17/74] Define an Interpreter instance for BadModuleResolutions. --- src/Analysis/Abstract/BadModuleResolutions.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index b6a6575fb..7cbf12815 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -2,6 +2,7 @@ module Analysis.Abstract.BadModuleResolutions where import Control.Abstract.Analysis +import Control.Monad.Effect.Internal hiding (interpret) import Data.Abstract.Evaluatable import Prologue @@ -26,3 +27,9 @@ instance ( Effectful m TypeScriptError nameToResolve -> yield nameToResolve) analyzeModule = liftAnalyze analyzeModule + +instance Interpreter effects result rest m + => Interpreter (Resumable (ResolutionError value) ': effects) result rest (BadModuleResolutions m) where + interpret = interpret . raise @m . relay pure (\ (Resumable err) yield -> case err of + RubyError nameToResolve -> yield nameToResolve + TypeScriptError nameToResolve -> yield nameToResolve) . lower From 5536876e138a39577b6558c444775b9808b0ebef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:39:32 -0400 Subject: [PATCH 18/74] Define an Interpreter instance for BadValues. --- src/Analysis/Abstract/BadValues.hs | 24 +++++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 7d9b4a1d3..1151d3d4f 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -2,9 +2,10 @@ module Analysis.Abstract.BadValues where import Control.Abstract.Analysis +import Control.Monad.Effect.Internal hiding (interpret) import Data.Abstract.Environment as Env -import Prologue import Data.ByteString.Char8 (pack) +import Prologue newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad) @@ -39,3 +40,24 @@ instance ( Effectful m ) analyzeModule = liftAnalyze analyzeModule + +instance ( Interpreter effects result rest m + , MonadEvaluator location term value effects m + , MonadValue location value effects m + , Show value + ) + => Interpreter (Resumable (ValueError location value) ': effects) result rest (BadValues m) where + interpret = interpret . raise @m . relay pure (\ (Resumable err) yield -> case err of + ScopedEnvironmentError{} -> do + env <- lower @m getEnv + yield (Env.push env) + CallError val -> yield val + StringError val -> yield (pack (show val)) + BoolError{} -> yield True + NumericError{} -> lower @m hole >>= yield + Numeric2Error{} -> lower @m hole >>= yield + ComparisonError{} -> lower @m hole >>= yield + NamespaceError{} -> lower @m getEnv >>= yield + BitwiseError{} -> lower @m hole >>= yield + Bitwise2Error{} -> lower @m hole >>= yield + KeyValueError{} -> lower @m hole >>= \x -> yield (x, x)) . lower From 7a86d74d10a94a1b480210c5d7027b94978c5f28 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:39:46 -0400 Subject: [PATCH 19/74] Define an Interpreter instance for BadVariables. --- src/Analysis/Abstract/BadVariables.hs | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index e4db58e14..3149345ee 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -4,6 +4,7 @@ module Analysis.Abstract.BadVariables ) where import Control.Abstract.Analysis +import Control.Monad.Effect.Internal hiding (interpret) import Data.Abstract.Evaluatable import Prologue @@ -35,3 +36,21 @@ instance ( Effectful m FreeVariablesError names -> raise (modify' (names <>)) >> yield (fromMaybeLast "unknown" names)) analyzeModule = liftAnalyze analyzeModule + +instance ( Interpreter effects (result, [Name]) rest m + , MonadValue location value (State [Name] ': effects) m + ) + => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) result rest (BadVariables m) where + interpret + = interpret + . raise @m + . flip runState [] + . relay pure (\ (Resumable err) yield -> case err of + DefaultExportError{} -> yield () + ExportError{} -> yield () + IntegerFormatError{} -> yield 0 + FloatFormatError{} -> yield 0 + RationalFormatError{} -> yield 0 + FreeVariableError name -> modify' (name :) >> lower @m hole >>= yield + FreeVariablesError names -> modify' (names <>) >> yield (fromMaybeLast "unknown" names)) + . lower From b032d919002b69fcbe2812d87aeca9c98ab08c26 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:39:57 -0400 Subject: [PATCH 20/74] Define an Interpreter instance for Erroring. --- src/Semantic/Util.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 9f185a42e..8df728ba5 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -54,6 +54,10 @@ instance MonadAnalysis location term value effects m analyzeTerm = liftAnalyze analyzeTerm analyzeModule = liftAnalyze analyzeModule +instance Interpreter effects (Either (SomeExc exc) result) rest m + => Interpreter (Resumable exc ': effects) result rest (Erroring exc m) where + interpret = interpret . raise @m . runError . lower + -- type TestEvaluating term = Evaluating Precise term (Value Precise) type JustEvaluating term = Erroring (AddressError (Located Precise term) (Value (Located Precise term))) From 1cedeac8e133d1a65c9091b554f43f40ad11485c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:44:23 -0400 Subject: [PATCH 21/74] Move Erroring into its own module. --- semantic.cabal | 1 + src/Analysis/Abstract/Erroring.hs | 24 ++++++++++++++++++++++++ src/Semantic/Util.hs | 22 +++------------------- 3 files changed, 28 insertions(+), 19 deletions(-) create mode 100644 src/Analysis/Abstract/Erroring.hs diff --git a/semantic.cabal b/semantic.cabal index 108fded1a..6e715627f 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -22,6 +22,7 @@ library , Analysis.Abstract.Caching , Analysis.Abstract.Collecting , Analysis.Abstract.Dead + , Analysis.Abstract.Erroring , Analysis.Abstract.Evaluating , Analysis.Abstract.ImportGraph , Analysis.Abstract.Quiet diff --git a/src/Analysis/Abstract/Erroring.hs b/src/Analysis/Abstract/Erroring.hs new file mode 100644 index 000000000..09f891ff1 --- /dev/null +++ b/src/Analysis/Abstract/Erroring.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +module Analysis.Abstract.Erroring +( Erroring +) where + +import Control.Abstract.Analysis +import Prologue + +-- | An analysis that fails on errors. +newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring (m effects a) + deriving (Alternative, Applicative, Effectful, Functor, Monad) + +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m) + +instance MonadAnalysis location term value effects m + => MonadAnalysis location term value effects (Erroring exc m) where + type Effects location term value (Erroring exc m) = Resumable exc ': Effects location term value m + + analyzeTerm = liftAnalyze analyzeTerm + analyzeModule = liftAnalyze analyzeModule + +instance Interpreter effects (Either (SomeExc exc) result) rest m + => Interpreter (Resumable exc ': effects) result rest (Erroring exc m) where + interpret = interpret . raise @m . runError . lower diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 8df728ba5..09d5e7751 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -1,5 +1,5 @@ -- MonoLocalBinds is to silence a warning about a simplifiable constraint. -{-# LANGUAGE GeneralizedNewtypeDeriving, MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE MonoLocalBinds, TypeOperators #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.Util where @@ -7,7 +7,8 @@ import Analysis.Abstract.BadAddresses import Analysis.Abstract.BadModuleResolutions import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables -import Analysis.Abstract.Evaluating as X +import Analysis.Abstract.Erroring +import Analysis.Abstract.Evaluating import Analysis.Abstract.ImportGraph import Analysis.Abstract.Quiet import Analysis.Declaration @@ -41,23 +42,6 @@ import qualified Language.Python.Assignment as Python import qualified Language.Ruby.Assignment as Ruby import qualified Language.TypeScript.Assignment as TypeScript --- | An analysis that fails on errors. -newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring (m effects a) - deriving (Alternative, Applicative, Effectful, Functor, Monad) - -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m) - -instance MonadAnalysis location term value effects m - => MonadAnalysis location term value effects (Erroring exc m) where - type Effects location term value (Erroring exc m) = Resumable exc ': Effects location term value m - - analyzeTerm = liftAnalyze analyzeTerm - analyzeModule = liftAnalyze analyzeModule - -instance Interpreter effects (Either (SomeExc exc) result) rest m - => Interpreter (Resumable exc ': effects) result rest (Erroring exc m) where - interpret = interpret . raise @m . runError . lower - -- type TestEvaluating term = Evaluating Precise term (Value Precise) type JustEvaluating term = Erroring (AddressError (Located Precise term) (Value (Located Precise term))) From 0adb878ccf6807ed46e2c2e2471c4894a0351280 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:47:17 -0400 Subject: [PATCH 22/74] Re-export relay from Analysis. --- src/Analysis/Abstract/BadAddresses.hs | 1 - src/Analysis/Abstract/BadModuleResolutions.hs | 1 - src/Analysis/Abstract/BadValues.hs | 1 - src/Analysis/Abstract/BadVariables.hs | 1 - src/Control/Abstract/Analysis.hs | 1 + 5 files changed, 1 insertion(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index ebff75da9..09997b21d 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -2,7 +2,6 @@ module Analysis.Abstract.BadAddresses where import Control.Abstract.Analysis -import Control.Monad.Effect.Internal hiding (interpret) import Data.Abstract.Address import Prologue diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 7cbf12815..6c13330eb 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -2,7 +2,6 @@ module Analysis.Abstract.BadModuleResolutions where import Control.Abstract.Analysis -import Control.Monad.Effect.Internal hiding (interpret) import Data.Abstract.Evaluatable import Prologue diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 1151d3d4f..64cf2df1d 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -2,7 +2,6 @@ module Analysis.Abstract.BadValues where import Control.Abstract.Analysis -import Control.Monad.Effect.Internal hiding (interpret) import Data.Abstract.Environment as Env import Data.ByteString.Char8 (pack) import Prologue diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 3149345ee..089d0c651 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -4,7 +4,6 @@ module Analysis.Abstract.BadVariables ) where import Control.Abstract.Analysis -import Control.Monad.Effect.Internal hiding (interpret) import Data.Abstract.Evaluatable import Prologue diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index a160eabdc..4b31b773f 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -18,6 +18,7 @@ import Control.Abstract.Value as X import Control.Effect as X import Control.Effect.Fresh as X import Control.Monad.Effect.Fail as X +import Control.Monad.Effect.Internal as X (relay) import Control.Monad.Effect.NonDet as X import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X From db99f9efade6f40f9f129d45e67bfd48af02b7e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:49:26 -0400 Subject: [PATCH 23/74] Define an Interpreter instance for Tracing. --- src/Analysis/Abstract/Tracing.hs | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 244859bb7..686141e9f 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -34,3 +34,9 @@ instance ( Corecursive term liftAnalyze analyzeTerm recur term analyzeModule = liftAnalyze analyzeModule + +instance ( Interpreter effects (result, trace (Configuration location term value)) rest m + , Monoid (trace (Configuration location term value)) + ) + => Interpreter (Writer (trace (Configuration location term value)) ': effects) result rest (Tracing trace m) where + interpret = interpret . raise @m . runWriter . lower From 882a542d19454096d6431a65cf36a0ff84213f1d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:51:56 -0400 Subject: [PATCH 24/74] Define a MonadAnalysis instance for DeadCode. --- src/Analysis/Abstract/Dead.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 8a4541aa8..1943db0ba 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Dead ( DeadCode ) where @@ -52,3 +52,9 @@ instance ( Corecursive term analyzeModule recur m = do killAll (subterms (subterm (moduleBody m))) liftAnalyze analyzeModule recur m + +instance ( Interpreter effects (result, Dead term) rest m + , Ord term + ) + => Interpreter (State (Dead term) ': effects) result rest (DeadCode m) where + interpret = interpret . raise @m . flip runState mempty . lower From b4dd5cffc81234e8661efa3c16d4bbfb35e50e16 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:53:18 -0400 Subject: [PATCH 25/74] Define an Interpreter instance for Quietly. --- src/Analysis/Abstract/Quiet.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 523377ce7..8b1491592 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -31,3 +31,7 @@ instance ( Effectful m traceM ("Unspecialized:" <> show err) >> hole >>= yield) analyzeModule = liftAnalyze analyzeModule + +instance Interpreter effects result rest m + => Interpreter effects result rest (Quietly m) where + interpret (Quietly m) = interpret m From ff3ba0fa9dc3251da220708839c50a284fd5714b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:55:38 -0400 Subject: [PATCH 26/74] Define an Interpreter instance for Collecting. --- src/Analysis/Abstract/Collecting.hs | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index ab22cccd4..d993b6cd6 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Collecting ( Collecting ) where @@ -76,3 +76,10 @@ reachable roots heap = go mempty roots Just (a, as) -> go (liveInsert a seen) (case heapLookupAll a heap of Just values -> liveDifference (foldr ((<>) . valueRoots) mempty values <> as) seen _ -> seen) + + +instance ( Interpreter effects result rest m + , Ord location + ) + => Interpreter (Reader (Live location value) ': effects) result rest (Collecting m) where + interpret = interpret . raise @m . flip runReader mempty . lower From c07272bc7e5d891b78af74f2fedb908b12db6d03 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 18:57:22 -0400 Subject: [PATCH 27/74] Define an Interpreter instance for ImportGraphing. --- src/Analysis/Abstract/ImportGraph.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 0e5e45d2f..d7f2e8301 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -169,3 +169,8 @@ vertexToType :: Vertex -> Text vertexToType Package{} = "package" vertexToType Module{} = "module" vertexToType Variable{} = "variable" + + +instance Interpreter effects (result, ImportGraph) rest m + => Interpreter (State ImportGraph ': effects) result rest (ImportGraphing m) where + interpret = interpret . raise @m . flip runState mempty . lower From ef45f3b2ecd470638c8dccf091c00623cf428e8f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 19:02:15 -0400 Subject: [PATCH 28/74] Define an Interpreter instance for Caching. --- src/Analysis/Abstract/Caching.hs | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index b6a949198..3ba992347 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -119,3 +119,19 @@ converge f = loop -- | Nondeterministically write each of a collection of stores & return their associated results. scatter :: (Alternative (m effects), Foldable t, MonadEvaluator location term value effects m) => t (a, Heap location value) -> m effects a scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value) + + +instance ( Interpreter effects ([result], Cache location term value) rest m + , Ord (Cell location value) + , Ord location + , Ord term + , Ord value + ) + => Interpreter (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) result rest (Caching m) where + interpret + = interpret + . raise @m + . flip runState mempty + . flip runReader mempty + . makeChoiceA @[] + . lower From c9e893dd34c5850a89d24f40dc9ba2420ee85789 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 19:05:00 -0400 Subject: [PATCH 29/74] Define an Interpreter instance for Eff. --- src/Control/Abstract/Analysis.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 4b31b773f..1b76fcdb1 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -18,7 +18,7 @@ import Control.Abstract.Value as X import Control.Effect as X import Control.Effect.Fresh as X import Control.Monad.Effect.Fail as X -import Control.Monad.Effect.Internal as X (relay) +import Control.Monad.Effect.Internal as X (Eff, relay) import Control.Monad.Effect.NonDet as X import Control.Monad.Effect.Reader as X import Control.Monad.Effect.State as X @@ -50,6 +50,9 @@ class MonadEvaluator location term value effects m => MonadAnalysis location ter class Effectful m => Interpreter effects result function m | m effects result -> function where interpret :: m effects result -> function +instance Interpreter '[] result result Eff where + interpret = X.run + -- | 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 effects value) (t m (effects :: [* -> *]) value) From abcf625569c83b430b0a6549a21434a99e1db1f8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 19:16:24 -0400 Subject: [PATCH 30/74] Define an Interpreter instance for Evaluating. --- src/Analysis/Abstract/Evaluating.hs | 34 +++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 05a058811..684c6ba82 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -4,9 +4,11 @@ module Analysis.Abstract.Evaluating ) where import Control.Abstract.Analysis -import Control.Monad.Effect +import Control.Monad.Effect.Exception as Exc +import Control.Monad.Effect.Resumable as Res +import Data.Abstract.Address import Data.Abstract.Configuration -import Data.Abstract.Environment as Env +import Data.Abstract.Environment import Data.Abstract.Evaluatable import Data.Abstract.Module import Data.Abstract.ModuleTable @@ -56,3 +58,31 @@ instance ( Corecursive term analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term) analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) + + +instance ( Ord location + , Semigroup (Cell location value) + ) + => Interpreter + (EvaluatingEffects location term value) result + ( Either String + (Either (SomeExc (Unspecialized value)) + (Either (SomeExc (LoadError term value)) + (Either (LoopThrow value) + (Either (ReturnThrow value) + result)))) + , EvaluatorState location term value) + (Evaluating location term value) where + interpret + = interpret + . flip runState (EvaluatorState mempty mempty mempty mempty mempty mempty mempty) + . flip runReader mempty -- Reader (Environment location value) + . flip runReader mempty -- Reader (ModuleTable [Module term]) + . flip runReader mempty -- Reader (SomeOrigin term) + . runEffect + . runFail + . Res.runError + . Res.runError + . Exc.runError + . Exc.runError + . lower From beea1ba3c20ebe4b10b771f7459341c59965a155 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 19:26:08 -0400 Subject: [PATCH 31/74] :fire: a redundant $!. --- src/Semantic/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index e46023d6a..94eb894b7 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -91,5 +91,5 @@ graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage asAnalysisForTypeOfPackage = const extractGraph result = case result of - (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph))), _)))))), _) -> pure $! graph + (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph))), _)))))), _) -> pure graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) From 2da077217cc46d84d476036215b36640b568e590 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 19:44:10 -0400 Subject: [PATCH 32/74] Move Unspecialized handling into Quietly. --- src/Analysis/Abstract/Evaluating.hs | 5 +---- src/Analysis/Abstract/Quiet.hs | 17 ++++++++++++----- src/Semantic/Util.hs | 3 ++- 3 files changed, 15 insertions(+), 10 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 684c6ba82..9cb205a1a 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -26,7 +26,6 @@ type EvaluatingEffects location term value = '[ Exc (ReturnThrow value) , Exc (LoopThrow value) , Resumable (LoadError term value) - , Resumable (Unspecialized value) , Fail -- Failure with an error message , Fresh -- For allocating new addresses and/or type variables. , Reader (SomeOrigin term) -- The current term’s origin. @@ -66,11 +65,10 @@ instance ( Ord location => Interpreter (EvaluatingEffects location term value) result ( Either String - (Either (SomeExc (Unspecialized value)) (Either (SomeExc (LoadError term value)) (Either (LoopThrow value) (Either (ReturnThrow value) - result)))) + result))) , EvaluatorState location term value) (Evaluating location term value) where interpret @@ -82,7 +80,6 @@ instance ( Ord location . runEffect . runFail . Res.runError - . Res.runError . Exc.runError . Exc.runError . lower diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 8b1491592..b63467f7b 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeApplications, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Quiet ( Quietly ) where @@ -25,13 +25,20 @@ instance ( Effectful m , MonadValue location value effects (Quietly m) ) => MonadAnalysis location term value effects (Quietly m) where - type Effects location term value (Quietly m) = Effects location term value m + type Effects location term value (Quietly m) = Resumable (Unspecialized value) ': Effects location term value m analyzeTerm eval term = resume @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield err@(Unspecialized _) -> traceM ("Unspecialized:" <> show err) >> hole >>= yield) analyzeModule = liftAnalyze analyzeModule -instance Interpreter effects result rest m - => Interpreter effects result rest (Quietly m) where - interpret (Quietly m) = interpret m +instance ( Interpreter effects result rest m + , MonadValue location value effects m + ) + => Interpreter (Resumable (Unspecialized value) ': effects) result rest (Quietly m) where + interpret + = interpret + . raise @m + . relay pure (\ (Resumable err) yield -> case err of + Unspecialized _ -> lower @m hole >>= yield) + . lower diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 09d5e7751..32e3e6f39 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -47,8 +47,9 @@ type JustEvaluating term = Erroring (AddressError (Located Precise term) (Value (Located Precise term))) ( Erroring (EvalError (Value (Located Precise term))) ( Erroring (ResolutionError (Value (Located Precise term))) + ( Erroring (Unspecialized (Value (Located Precise term))) ( Erroring (ValueError (Located Precise term) (Value (Located Precise term))) - ( Evaluating (Located Precise term) term (Value (Located Precise term)))))) + ( Evaluating (Located Precise term) term (Value (Located Precise term))))))) type EvaluatingWithHoles term = BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term))))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) From 8d5efedf57f05f336c41392920632625206fd23d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 19:55:51 -0400 Subject: [PATCH 33/74] Generalize throwValueError, throwLoadError, and throwEvalError. --- 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 7a036fa8f..3ef6880f5 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -133,13 +133,13 @@ instance Eq1 (EvalError term) where liftEq _ _ _ = False -throwValueError :: MonadEvaluatable location term value effects m => ValueError location value resume -> m effects resume +throwValueError :: (Member (Resumable (ValueError location value)) effects, MonadEvaluator location term value effects m) => ValueError location value resume -> m effects resume throwValueError = throwResumable -throwLoadError :: MonadEvaluatable location term value effects m => LoadError term value resume -> m effects resume +throwLoadError :: (Member (Resumable (LoadError term value)) effects, MonadEvaluator location term value effects m) => LoadError term value resume -> m effects resume throwLoadError = throwResumable -throwEvalError :: MonadEvaluatable location term value effects m => EvalError value resume -> m effects resume +throwEvalError :: (Member (Resumable (EvalError value)) effects, MonadEvaluator location term value effects m) => EvalError value resume -> m effects resume throwEvalError = throwResumable throwLoop :: MonadEvaluatable location term value effects m => LoopThrow value -> m effects a From 0d6cf853334125e115a28cde9a4163ffe10c2199 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 20:01:05 -0400 Subject: [PATCH 34/74] Generalize the type of variable. --- 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 3ef6880f5..f1405a0c1 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -115,7 +115,7 @@ data EvalError value resume where -- | Look up and dereference the given 'Name', throwing an exception for free variables. -variable :: MonadEvaluatable location term value effects m => Name -> m effects value +variable :: (Member (Resumable (AddressError location value)) effects, Member (Resumable (EvalError value)) effects, MonadAddressable location effects m, MonadEvaluator location term value effects m) => Name -> m effects value variable name = lookupWith deref name >>= maybeM (throwResumable (FreeVariableError name)) deriving instance Eq (EvalError a b) From 02572cb49d45037f2c824b54c8aed69706588ace Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:04:30 -0400 Subject: [PATCH 35/74] Parens. --- src/Analysis/Abstract/BadValues.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 64cf2df1d..febf0a635 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -27,7 +27,7 @@ instance ( Effectful m env <- getEnv yield (Env.push env) CallError val -> yield val - StringError val -> yield (pack $ show val) + StringError val -> yield (pack (show val)) BoolError{} -> yield True NumericError{} -> hole >>= yield Numeric2Error{} -> hole >>= yield From e3e64179940e7b4520c15b5e51e3631bead285c5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:06:36 -0400 Subject: [PATCH 36/74] Extract holes into a new, relatively unconstrained typeclass. --- src/Analysis/Abstract/BadAddresses.hs | 4 ++-- src/Analysis/Abstract/BadValues.hs | 5 +++-- src/Analysis/Abstract/BadVariables.hs | 4 ++-- src/Analysis/Abstract/Quiet.hs | 4 ++-- src/Control/Abstract/Value.hs | 7 ++++--- src/Data/Abstract/Type.hs | 4 +++- src/Data/Abstract/Value.hs | 4 +++- 7 files changed, 19 insertions(+), 13 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 09997b21d..782d359e6 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -13,7 +13,7 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator instance ( Effectful m , Member (Resumable (AddressError location value)) effects , MonadAnalysis location term value effects m - , MonadValue location value effects (BadAddresses m) + , MonadHole value effects (BadAddresses m) , Monoid (Cell location value) , Show location ) @@ -30,7 +30,7 @@ instance ( Effectful m analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects result rest m - , MonadValue location value effects m + , MonadHole value effects m , Monoid (Cell location value) ) => Interpreter (Resumable (AddressError location value) ': effects) result rest (BadAddresses m) where diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index febf0a635..9911314ee 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -14,7 +14,8 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluat instance ( Effectful m , Member (Resumable (ValueError location value)) effects , MonadAnalysis location term value effects m - , MonadValue location value effects (BadValues m) + , MonadHole value effects (BadValues m) + , Show value ) => MonadAnalysis location term value effects (BadValues m) where type Effects location term value (BadValues m) = Resumable (ValueError location value) ': Effects location term value m @@ -42,7 +43,7 @@ instance ( Effectful m instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m - , MonadValue location value effects m + , MonadHole value effects m , Show value ) => Interpreter (Resumable (ValueError location value) ': effects) result rest (BadValues m) where diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 089d0c651..7a6206480 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -17,7 +17,7 @@ instance ( Effectful m , Member (Resumable (EvalError value)) effects , Member (State [Name]) effects , MonadAnalysis location term value effects m - , MonadValue location value effects (BadVariables m) + , MonadHole value effects (BadVariables m) ) => MonadAnalysis location term value effects (BadVariables m) where type Effects location term value (BadVariables m) = Resumable (EvalError value) ': State [Name] ': Effects location term value m @@ -37,7 +37,7 @@ instance ( Effectful m analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects (result, [Name]) rest m - , MonadValue location value (State [Name] ': effects) m + , MonadHole value (State [Name] ': effects) m ) => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) result rest (BadVariables m) where interpret diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index b63467f7b..e7569f64e 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -22,7 +22,7 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator instance ( Effectful m , Member (Resumable (Unspecialized value)) effects , MonadAnalysis location term value effects m - , MonadValue location value effects (Quietly m) + , MonadHole value effects (Quietly m) ) => MonadAnalysis location term value effects (Quietly m) where type Effects location term value (Quietly m) = Resumable (Unspecialized value) ': Effects location term value m @@ -33,7 +33,7 @@ instance ( Effectful m analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects result rest m - , MonadValue location value effects m + , MonadHole value effects m ) => Interpreter (Resumable (Unspecialized value) ': effects) result rest (Quietly m) where interpret diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index fa7fa1908..681f67773 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FunctionalDependencies, GADTs, KindSignatures, Rank2Types #-} module Control.Abstract.Value ( MonadValue(..) +, MonadHole(..) , Comparator(..) , while , doWhile @@ -31,6 +32,9 @@ data Comparator = Concrete (forall a . Ord a => a -> a -> Bool) | Generalized +class Monad (m effects) => MonadHole value (effects :: [* -> *]) m where + hole :: m effects value + -- | 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. @@ -39,9 +43,6 @@ class (Monad (m effects), Show value) => MonadValue location value (effects :: [ -- TODO: This might be the same as the empty tuple for some value types unit :: m effects value - -- | Construct an abstract hole. - hole :: m effects value - -- | Construct an abstract integral value. integer :: Prelude.Integer -> m effects value diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 31bb51c28..6d0c06a61 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -52,6 +52,9 @@ instance Ord location => ValueRoots location Type where valueRoots _ = mempty +instance Monad (m effects) => MonadHole Type effects m where + hole = pure Hole + -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Alternative (m effects) , Member Fail effects @@ -71,7 +74,6 @@ instance ( Alternative (m effects) ret <- localEnv (mappend env) body pure (Product tvars :-> ret) - hole = pure Hole unit = pure Unit integer _ = pure Int boolean _ = pure Bool diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 256af31c5..2d8cf59e3 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -197,9 +197,11 @@ instance Ord location => ValueRoots location (Value location) where | otherwise = mempty +instance Monad (m effects) => MonadHole (Value location) effects m where + hole = pure (injValue Hole) + -- | Construct a 'Value' wrapping the value arguments (if any). instance (Monad (m effects), MonadEvaluatable location term (Value location) effects m) => MonadValue location (Value location) effects m where - hole = pure . injValue $ Hole unit = pure . injValue $ Unit integer = pure . injValue . Integer . Number.Integer boolean = pure . injValue . Boolean From d0b31667abe3c6c04c21290fb1161eca4faab891 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:06:45 -0400 Subject: [PATCH 37/74] :fire: a redundant language extension. --- src/Semantic/Graph.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 94eb894b7..aca348af9 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, ScopedTypeVariables #-} +{-# LANGUAGE GADTs #-} module Semantic.Graph where import qualified Analysis.Abstract.ImportGraph as Abstract From 5b18b47db73d93eb476c23ea786e21c796f2d458 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:07:27 -0400 Subject: [PATCH 38/74] Interpreters determine their effects. --- src/Analysis/Abstract/BadAddresses.hs | 2 ++ src/Analysis/Abstract/BadModuleResolutions.hs | 5 ++++- src/Analysis/Abstract/BadVariables.hs | 2 ++ src/Analysis/Abstract/Caching.hs | 2 ++ src/Analysis/Abstract/Collecting.hs | 2 ++ src/Analysis/Abstract/Dead.hs | 2 ++ src/Analysis/Abstract/Quiet.hs | 2 ++ src/Analysis/Abstract/Tracing.hs | 2 ++ src/Control/Abstract/Analysis.hs | 2 +- 9 files changed, 19 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 782d359e6..a583d588d 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadAddresses where import Control.Abstract.Analysis @@ -30,6 +31,7 @@ instance ( Effectful m analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects result rest m + , MonadEvaluator location term value effects m , MonadHole value effects m , Monoid (Cell location value) ) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 6c13330eb..a7bfd3e7f 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadModuleResolutions where import Control.Abstract.Analysis @@ -27,7 +28,9 @@ instance ( Effectful m analyzeModule = liftAnalyze analyzeModule -instance Interpreter effects result rest m +instance ( Interpreter effects result rest m + , MonadEvaluator location term value effects m + ) => Interpreter (Resumable (ResolutionError value) ': effects) result rest (BadModuleResolutions m) where interpret = interpret . raise @m . relay pure (\ (Resumable err) yield -> case err of RubyError nameToResolve -> yield nameToResolve diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 7a6206480..f30e69354 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadVariables ( BadVariables ) where @@ -37,6 +38,7 @@ instance ( Effectful m analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects (result, [Name]) rest m + , MonadEvaluator location term value effects m , MonadHole value (State [Name] ': effects) m ) => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) result rest (BadVariables m) where diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 3ba992347..e9e547125 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Caching ( Caching ) where @@ -122,6 +123,7 @@ scatter = foldMapA (\ (value, heap') -> putHeap heap' $> value) instance ( Interpreter effects ([result], Cache location term value) rest m + , MonadEvaluator location term value effects m , Ord (Cell location value) , Ord location , Ord term diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index d993b6cd6..0ca52844f 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Collecting ( Collecting ) where @@ -79,6 +80,7 @@ reachable roots heap = go mempty roots instance ( Interpreter effects result rest m + , MonadEvaluator location term value effects m , Ord location ) => Interpreter (Reader (Live location value) ': effects) result rest (Collecting m) where diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 1943db0ba..f1d534deb 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Dead ( DeadCode ) where @@ -54,6 +55,7 @@ instance ( Corecursive term liftAnalyze analyzeModule recur m instance ( Interpreter effects (result, Dead term) rest m + , MonadEvaluator location term value effects m , Ord term ) => Interpreter (State (Dead term) ': effects) result rest (DeadCode m) where diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index e7569f64e..7f6e2a1d6 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Quiet ( Quietly ) where @@ -33,6 +34,7 @@ instance ( Effectful m analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects result rest m + , MonadEvaluator location term value effects m , MonadHole value effects m ) => Interpreter (Resumable (Unspecialized value) ': effects) result rest (Quietly m) where diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 686141e9f..62f10071a 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Tracing ( Tracing ) where @@ -36,6 +37,7 @@ instance ( Corecursive term analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects (result, trace (Configuration location term value)) rest m + , MonadEvaluator location term value effects m , Monoid (trace (Configuration location term value)) ) => Interpreter (Writer (trace (Configuration location term value)) ': effects) result rest (Tracing trace m) where diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 1b76fcdb1..be05b9020 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -47,7 +47,7 @@ class MonadEvaluator location term value effects m => MonadAnalysis location ter isolate :: m effects a -> m effects a isolate = withEnv mempty . withExports mempty -class Effectful m => Interpreter effects result function m | m effects result -> function where +class Effectful m => Interpreter effects result function m | m -> effects, m result -> function where interpret :: m effects result -> function instance Interpreter '[] result result Eff where From 227b3296c5745e4f77a58cebd63cf1f6cc14595a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:26:48 -0400 Subject: [PATCH 39/74] runAnalysis & runSomeAnalysis use Interpreter. --- src/Control/Abstract/Analysis.hs | 16 ++++++---------- src/Semantic/Graph.hs | 2 +- 2 files changed, 7 insertions(+), 11 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index be05b9020..de0a85531 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -65,25 +65,21 @@ liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . r -- -- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects'). runAnalysis :: ( Effectful m - , Effects location term value m ~ effects - , MonadAnalysis location term value effects m - , RunEffects effects a + , Interpreter effects a function m ) => m effects a - -> Final effects a -runAnalysis = X.run + -> function +runAnalysis = interpret -- | An abstraction over analyses. data SomeAnalysis m result where SomeAnalysis :: ( Effectful m - , effects ~ Effects location term value m - , MonadAnalysis location term value effects m - , RunEffects effects a + , Interpreter effects a function m ) => m effects a - -> SomeAnalysis m (Final effects a) + -> SomeAnalysis m function -- | Run an abstracted analysis. runSomeAnalysis :: SomeAnalysis m result -> result -runSomeAnalysis (SomeAnalysis a) = X.run a +runSomeAnalysis (SomeAnalysis a) = interpret a diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index aca348af9..0eed57ce4 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -91,5 +91,5 @@ graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage asAnalysisForTypeOfPackage = const extractGraph result = case result of - (Right (Right (Right (Right (Right (Right (Right (Right (Right (_, graph))), _)))))), _) -> pure graph + (Right (Right (Right (Right ((_, graph), _)))), _) -> pure graph _ -> throwError (toException (Exc.ErrorCall ("graphImports: import graph rendering failed " <> show result))) From 4ddbe2b1327d33866b6f8f89c65ac678acff7223 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:28:57 -0400 Subject: [PATCH 40/74] Move Interpreter into Control.Effect. --- src/Control/Abstract/Analysis.hs | 9 +-------- src/Control/Effect.hs | 10 +++++++++- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index de0a85531..64667a90b 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE FunctionalDependencies, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis module Control.Abstract.Analysis ( MonadAnalysis(..) -, Interpreter(..) , liftAnalyze , runAnalysis , SomeAnalysis(..) @@ -47,12 +46,6 @@ class MonadEvaluator location term value effects m => MonadAnalysis location ter isolate :: m effects a -> m effects a isolate = withEnv mempty . withExports mempty -class Effectful m => Interpreter effects result function m | m -> effects, m result -> function where - interpret :: m effects result -> function - -instance Interpreter '[] result result Eff where - interpret = X.run - -- | 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 effects value) (t m (effects :: [* -> *]) value) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 5750f90d9..a348b4f72 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-} module Control.Effect ( Control.Effect.run , RunEffects(..) , RunEffect(..) , Effectful(..) +, Interpreter(..) , resume , mergeEither ) where @@ -102,3 +103,10 @@ class Effectful (m :: [* -> *] -> * -> *) where instance Effectful Eff where raise = id lower = id + + +class Effectful m => Interpreter effects result function m | m -> effects, m result -> function where + interpret :: m effects result -> function + +instance Interpreter '[] result result Eff where + interpret = Effect.run From dabca7feeaae6a70faaf8e913ee8a3e8f65d847e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:44:22 -0400 Subject: [PATCH 41/74] Bump effects for https://github.com/joshvera/effects/pull/33 --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 06b08cd63..130ab5b9b 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 06b08cd6354b109581388d40181e96de856b698a +Subproject commit 130ab5b9b941d946d425afe86cf5e85bf90241b6 From 86ef19bbb04b0f4ef911804eac286c6022762930 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:52:44 -0400 Subject: [PATCH 42/74] Bump effects to master. --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 130ab5b9b..3cfec9b10 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 130ab5b9b941d946d425afe86cf5e85bf90241b6 +Subproject commit 3cfec9b10c759e0daba43aaecafe9bf513292e6e From 192367da0be71ec528912b364bb718744ad7c9a9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:58:21 -0400 Subject: [PATCH 43/74] Extract a runFresh helper. --- src/Control/Effect/Fresh.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Control/Effect/Fresh.hs b/src/Control/Effect/Fresh.hs index 6be171dea..dbdf9baa8 100644 --- a/src/Control/Effect/Fresh.hs +++ b/src/Control/Effect/Fresh.hs @@ -19,9 +19,11 @@ fresh = raise (send Fresh) reset :: (Effectful m, Member Fresh effects) => Int -> m effects () reset = raise . send . Reset +runFresh :: Eff (Fresh ': effects) a -> Eff effects a +runFresh = relayState (0 :: Int) (const pure) (\ s action k -> case action of + Fresh -> k (succ s) s + Reset s' -> k s' ()) -- | 'Fresh' effects are interpreted starting from 0, incrementing the current name with each request for a fresh name, and overwriting the counter on reset. instance RunEffect Fresh a where - runEffect = relayState (0 :: Int) (const pure) (\ s action k -> case action of - Fresh -> k (succ s) s - Reset s' -> k s' ()) + runEffect = runFresh From 2c770138ececd6a7c158892ed1853515365b6dba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 09:58:42 -0400 Subject: [PATCH 44/74] Use runFresh instead of runEffect. --- 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 9cb205a1a..3182f6f52 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -77,7 +77,7 @@ instance ( Ord location . flip runReader mempty -- Reader (Environment location value) . flip runReader mempty -- Reader (ModuleTable [Module term]) . flip runReader mempty -- Reader (SomeOrigin term) - . runEffect + . runFresh . runFail . Res.runError . Exc.runError From 7cf79573e3c28b88fba941c1f551ecf2e5705761 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 10:01:36 -0400 Subject: [PATCH 45/74] :fire: RunEffects/RunEffect. --- src/Control/Effect.hs | 86 +++---------------------------------- src/Control/Effect/Fresh.hs | 4 -- 2 files changed, 6 insertions(+), 84 deletions(-) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index a348b4f72..bb3de720f 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -1,89 +1,15 @@ -{-# LANGUAGE FunctionalDependencies, RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies, RankNTypes #-} module Control.Effect -( Control.Effect.run -, RunEffects(..) -, RunEffect(..) -, Effectful(..) +( Effectful(..) , Interpreter(..) , resume , mergeEither ) where -import Control.Monad.Effect as Effect -import Control.Monad.Effect.Exception as Exception -import Control.Monad.Effect.Fail -import Control.Monad.Effect.NonDet -import Control.Monad.Effect.Reader -import Control.Monad.Effect.Resumable as Resumable -import Control.Monad.Effect.State -import Control.Monad.Effect.Writer -import Data.Empty as E -import Data.Semigroup.Reducer -import Prologue +import Control.Monad.Effect as Effect +import Control.Monad.Effect.Resumable as Resumable --- | 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 = runEffects . lower - --- | A typeclass to run a computation to completion, interpreting each effect with some sensible defaults. -class RunEffects fs a where - -- | The final result type of the computation, factoring in the results of any effects, e.g. pairing 'State' results with the final state, wrapping 'Fail' results in 'Either', etc. - type Final fs a - runEffects :: Eff fs a -> Final fs a - -instance (RunEffect f a, RunEffects fs (Result f a)) => RunEffects (f ': fs) a where - type Final (f ': fs) a = Final fs (Result f a) - runEffects = runEffects . runEffect - -instance RunEffects '[] a where - type Final '[] a = a - runEffects = Effect.run - - --- | A typeclass to interpret a single effect with some sensible defaults (defined per-effect). -class RunEffect f a where - -- | The incremental result of an effect w.r.t. the parameter value, factoring in the interpretation of the effect. - type Result f a - type instance Result f a = a - - -- | Interpret the topmost effect in a computation with some sensible defaults (defined per-effect), and return the incremental 'Result'. - runEffect :: Eff (f ': fs) a -> Eff fs (Result f a) - --- | 'State' effects with 'Monoid'al states are interpreted starting from the 'mempty' state value into a pair of result value and final state. -instance E.Empty b => RunEffect (State b) a where - type Result (State b) a = (a, b) - runEffect = flip runState E.empty - --- | 'Reader' effects with 'Monoid'al environments are interpreted starting from the 'mempty' environment value. -instance Monoid b => RunEffect (Reader b) a where - runEffect = flip runReader mempty - --- | 'Fail' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'. -instance RunEffect Fail a where - type Result Fail a = Either String a - runEffect = runFail - --- | 'Writer' effects are interpreted into a pair of result value and final log. -instance Monoid w => RunEffect (Writer w) a where - type Result (Writer w) a = (a, w) - runEffect = runWriter - --- | 'NonDet' effects are interpreted into a nondeterministic set of result values. -instance Ord a => RunEffect NonDet a where - type Result NonDet a = Set a - runEffect = runNonDet unit - --- | 'Resumable' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'. -instance RunEffect (Resumable exc) a where - type Result (Resumable exc) a = Either (SomeExc exc) a - runEffect = Resumable.runError - --- | Standard (non-resumable) exceptions, as above, are rendered into 'Left's and 'Right's. -instance RunEffect (Exc exc) a where - type Result (Exc exc) a = Either exc a - runEffect = Exception.runError - -resume :: (Resumable exc :< e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a +resume :: (Member (Resumable exc) e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a resume m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield))) -- | Reassociate 'Either's, combining errors into 'Left' values and successes in a single level of 'Right'. @@ -94,7 +20,7 @@ mergeEither = either (Left . Left) (either (Left . Right) Right) -- | 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). 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 +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'. diff --git a/src/Control/Effect/Fresh.hs b/src/Control/Effect/Fresh.hs index dbdf9baa8..35515ef85 100644 --- a/src/Control/Effect/Fresh.hs +++ b/src/Control/Effect/Fresh.hs @@ -23,7 +23,3 @@ runFresh :: Eff (Fresh ': effects) a -> Eff effects a runFresh = relayState (0 :: Int) (const pure) (\ s action k -> case action of Fresh -> k (succ s) s Reset s' -> k s' ()) - --- | 'Fresh' effects are interpreted starting from 0, incrementing the current name with each request for a fresh name, and overwriting the counter on reset. -instance RunEffect Fresh a where - runEffect = runFresh From b074cc35ab0de64251e497e92f2e1aa98ca33eef Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 10:02:08 -0400 Subject: [PATCH 46/74] :fire: mergeEither. --- src/Control/Effect.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index bb3de720f..3c5cb5071 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -3,7 +3,6 @@ module Control.Effect ( Effectful(..) , Interpreter(..) , resume -, mergeEither ) where import Control.Monad.Effect as Effect @@ -12,10 +11,6 @@ import Control.Monad.Effect.Resumable as Resumable resume :: (Member (Resumable exc) e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a resume m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield))) --- | Reassociate 'Either's, combining errors into 'Left' values and successes in a single level of 'Right'. -mergeEither :: Either a (Either b c) -> Either (Either a b) c -mergeEither = either (Left . Left) (either (Left . Right) Right) - -- | Types wrapping 'Eff' actions. -- From 9b7079c9eb19d4a4162e1f0100b5e68fe2e8c0e1 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 10:40:20 -0400 Subject: [PATCH 47/74] Bump effects for https://github.com/joshvera/effects/pull/34 --- vendor/effects | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vendor/effects b/vendor/effects index 3cfec9b10..635733602 160000 --- a/vendor/effects +++ b/vendor/effects @@ -1 +1 @@ -Subproject commit 3cfec9b10c759e0daba43aaecafe9bf513292e6e +Subproject commit 635733602419b0a0da86bf06a1de3d5bc67ab3d4 From 0b0bd2a1a821e9bd41a11e3c98ac2410a7071ddb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 10:40:58 -0400 Subject: [PATCH 48/74] :fire: Control.Effect.Fresh in favour of Control.Monad.Effect.Fresh. --- semantic.cabal | 2 -- src/Analysis/Abstract/Caching.hs | 8 ++++++-- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Control/Abstract/Addressable.hs | 4 ++-- src/Control/Abstract/Analysis.hs | 2 +- src/Control/Effect/Fresh.hs | 25 ------------------------- src/Data/Abstract/Type.hs | 4 ++-- 7 files changed, 12 insertions(+), 35 deletions(-) delete mode 100644 src/Control/Effect/Fresh.hs diff --git a/semantic.cabal b/semantic.cabal index 6e715627f..b41291640 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -45,8 +45,6 @@ library , Control.Abstract.Value -- Control flow , Control.Effect - -- Effects used for program analysis - , Control.Effect.Fresh -- Datatypes for abstract interpretation , Data.Abstract.Address , Data.Abstract.Cache diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index e9e547125..3a31734c7 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -5,6 +5,7 @@ module Analysis.Abstract.Caching ) where import Control.Abstract.Analysis +import Control.Monad.Effect hiding (interpret) import Data.Abstract.Address import Data.Abstract.Cache import Data.Abstract.Configuration @@ -93,15 +94,18 @@ instance ( Alternative (m effects) cache <- converge (\ prevCache -> isolateCache $ do putHeap (configurationHeap c) -- We need to reset fresh generation so that this invocation converges. - reset 0 + 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). We don’t need to use the values, so we 'gather' the -- nondeterministic values into @()@. - withOracle prevCache (raise (gather (const ()) (lower (liftAnalyze analyzeModule recur m))))) mempty + withOracle prevCache (raise (gather (const ()) (lower (liftAnalyze analyzeModule recur m))))) mempty maybe empty scatter (cacheLookup c cache) +reset :: (Effectful m, Member Fresh effects) => Int -> m effects a -> m effects a +reset start = raise . interposeState start (const pure) (\ counter Fresh yield -> (yield $! succ counter) counter) . lower + -- | 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 diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 3182f6f52..3ccad25e0 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -77,7 +77,7 @@ instance ( Ord location . flip runReader mempty -- Reader (Environment location value) . flip runReader mempty -- Reader (ModuleTable [Module term]) . flip runReader mempty -- Reader (SomeOrigin term) - . runFresh + . flip runFresh' 0 . runFail . Res.runError . Exc.runError diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index c5f070e97..0fe6f8b0d 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -4,7 +4,7 @@ module Control.Abstract.Addressable where import Control.Abstract.Evaluator import Control.Applicative import Control.Effect -import Control.Effect.Fresh +import Control.Monad.Effect.Fresh import Control.Monad.Effect.Resumable as Eff import Data.Abstract.Address import Data.Abstract.Environment (insert) @@ -57,7 +57,7 @@ letrec' name body = do -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. instance (Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Precise effects m where derefCell _ = pure . unLatest - allocLoc _ = Precise <$> fresh + allocLoc _ = Precise <$> raise fresh -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. instance (Alternative (m effects), Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Monovariant effects m where diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 64667a90b..28a4e1e60 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -15,8 +15,8 @@ import Control.Abstract.Addressable as X import Control.Abstract.Evaluator as X import Control.Abstract.Value as X import Control.Effect as X -import Control.Effect.Fresh as X import Control.Monad.Effect.Fail as X +import Control.Monad.Effect.Fresh as X import Control.Monad.Effect.Internal as X (Eff, relay) import Control.Monad.Effect.NonDet as X import Control.Monad.Effect.Reader as X diff --git a/src/Control/Effect/Fresh.hs b/src/Control/Effect/Fresh.hs deleted file mode 100644 index 35515ef85..000000000 --- a/src/Control/Effect/Fresh.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE GADTs, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-} -module Control.Effect.Fresh where - -import Control.Effect -import Control.Monad.Effect.Internal - --- | An effect offering a (resettable) sequence of always-incrementing, and therefore “fresh,” type variables. -data Fresh a where - -- | Request a reset of the sequence of variable names. - Reset :: Int -> Fresh () - -- | Request a fresh variable name. - Fresh :: Fresh Int - --- | Get a fresh variable name, guaranteed unused (since the last 'reset'). -fresh :: (Effectful m, Member Fresh effects) => m effects Int -fresh = raise (send Fresh) - --- | Reset the sequence of variable names. Useful to avoid complicated alpha-equivalence comparisons when iteratively recomputing the results of an analysis til convergence. -reset :: (Effectful m, Member Fresh effects) => Int -> m effects () -reset = raise . send . Reset - -runFresh :: Eff (Fresh ': effects) a -> Eff effects a -runFresh = relayState (0 :: Int) (const pure) (\ s action k -> case action of - Fresh -> k (succ s) s - Reset s' -> k s' ()) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 6d0c06a61..002cc70d8 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -67,7 +67,7 @@ instance ( Alternative (m effects) lambda names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name - tvar <- Var <$> fresh + tvar <- Var <$> raise fresh assign a tvar (env, tvars) <- rest pure (Env.insert name a env, tvar : tvars)) (pure mempty) names @@ -126,7 +126,7 @@ instance ( Alternative (m effects) _ -> unify left right $> Bool call op params = do - tvar <- fresh + tvar <- raise fresh paramTypes <- sequenceA params unified <- op `unify` (Product paramTypes :-> Var tvar) case unified of From 76b00d1074897b8e6ddb672d740b58715b0e64e8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 11:57:01 -0400 Subject: [PATCH 49/74] :fire: the Effects type family. --- src/Analysis/Abstract/BadAddresses.hs | 4 +--- src/Analysis/Abstract/BadModuleResolutions.hs | 4 +--- src/Analysis/Abstract/BadValues.hs | 4 +--- src/Analysis/Abstract/BadVariables.hs | 4 +--- src/Analysis/Abstract/Caching.hs | 5 +---- src/Analysis/Abstract/Collecting.hs | 6 +----- src/Analysis/Abstract/Dead.hs | 4 +--- src/Analysis/Abstract/Erroring.hs | 4 +--- src/Analysis/Abstract/Evaluating.hs | 4 +--- src/Analysis/Abstract/ImportGraph.hs | 6 ++---- src/Analysis/Abstract/Quiet.hs | 4 +--- src/Analysis/Abstract/Tracing.hs | 4 +--- src/Control/Abstract/Analysis.hs | 5 +---- 13 files changed, 14 insertions(+), 44 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index a583d588d..e0561d136 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadAddresses where @@ -19,8 +19,6 @@ instance ( Effectful m , Show location ) => MonadAnalysis location term value effects (BadAddresses m) where - type Effects location term value (BadAddresses m) = Resumable (AddressError location value) ': Effects location term value m - analyzeTerm eval term = resume @(AddressError location value) (liftAnalyze analyzeTerm eval term) ( \yield error -> do traceM ("AddressError:" <> show error) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index a7bfd3e7f..627494c53 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadModuleResolutions where @@ -17,8 +17,6 @@ instance ( Effectful m , MonadValue location value effects (BadModuleResolutions m) ) => MonadAnalysis location term value effects (BadModuleResolutions m) where - type Effects location term value (BadModuleResolutions m) = Resumable (ResolutionError value) ': Effects location term value m - analyzeTerm eval term = resume @(ResolutionError value) (liftAnalyze analyzeTerm eval term) ( \yield error -> do traceM ("ResolutionError:" <> show error) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 9911314ee..d34b555f2 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.BadValues where import Control.Abstract.Analysis @@ -18,8 +18,6 @@ instance ( Effectful m , Show value ) => MonadAnalysis location term value effects (BadValues m) where - type Effects location term value (BadValues m) = Resumable (ValueError location value) ': Effects location term value m - analyzeTerm eval term = resume @(ValueError location value) (liftAnalyze analyzeTerm eval term) ( \yield error -> do traceM ("ValueError" <> show error) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index f30e69354..1441d8f24 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadVariables ( BadVariables @@ -21,8 +21,6 @@ instance ( Effectful m , MonadHole value effects (BadVariables m) ) => MonadAnalysis location term value effects (BadVariables m) where - type Effects location term value (BadVariables m) = Resumable (EvalError value) ': State [Name] ': Effects location term value m - analyzeTerm eval term = resume @(EvalError value) (liftAnalyze analyzeTerm eval term) ( \yield err -> do traceM ("EvalError" <> show err) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 3a31734c7..93ff42f19 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Caching ( Caching @@ -75,9 +75,6 @@ instance ( Alternative (m effects) , Ord value ) => MonadAnalysis location term value effects (Caching m) where - -- We require the 'CachingEffects' in addition to the underlying analysis’ 'Effects'. - type Effects location term value (Caching m) = CachingEffects location term value (Effects location term value m) - -- Analyze a term using the in-cache as an oracle & storing the results of the analysis in the out-cache. analyzeTerm recur e = do c <- getConfiguration (embedSubterm e) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 0ca52844f..087df6144 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Collecting ( Collecting @@ -30,10 +30,6 @@ instance ( Effectful m , ValueRoots location value ) => MonadAnalysis location term value effects (Collecting m) where - type Effects location term value (Collecting m) - = Reader (Live location value) - ': Effects location term value m - -- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term. analyzeTerm recur term = do roots <- askRoots diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index f1d534deb..785531d42 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Dead ( DeadCode @@ -44,8 +44,6 @@ instance ( Corecursive term , Recursive term ) => MonadAnalysis location term value effects (DeadCode m) where - type Effects location term value (DeadCode m) = State (Dead term) ': Effects location term value m - analyzeTerm recur term = do revive (embedSubterm term) liftAnalyze analyzeTerm recur term diff --git a/src/Analysis/Abstract/Erroring.hs b/src/Analysis/Abstract/Erroring.hs index 09f891ff1..70c6c6cad 100644 --- a/src/Analysis/Abstract/Erroring.hs +++ b/src/Analysis/Abstract/Erroring.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Erroring ( Erroring ) where @@ -14,8 +14,6 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Erroring exc m) where - type Effects location term value (Erroring exc m) = Resumable exc ': Effects location term value m - analyzeTerm = liftAnalyze analyzeTerm analyzeModule = liftAnalyze analyzeModule diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 3ccad25e0..38a445f2b 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, ScopedTypeVariables #-} module Analysis.Abstract.Evaluating ( Evaluating ) where @@ -52,8 +52,6 @@ instance ( Corecursive term , Recursive term ) => MonadAnalysis location term value effects (Evaluating location term value) where - type Effects location term value (Evaluating location term value) = EvaluatingEffects location term value - analyzeTerm eval term = pushOrigin (termOrigin (embedSubterm term)) (eval term) analyzeModule eval m = pushOrigin (moduleOrigin (subterm <$> m)) (eval m) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index d7f2e8301..2c8e51474 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.ImportGraph ( ImportGraph(..) , renderImportGraph @@ -65,12 +65,10 @@ instance ( Effectful m , Member (State ImportGraph) effects , Member Syntax.Identifier syntax , MonadAnalysis (Located location term) term value effects m - , term ~ Term (Union syntax) ann , Show ann + , term ~ Term (Union syntax) ann ) => MonadAnalysis (Located location term) term value effects (ImportGraphing m) where - type Effects (Located location term) term value (ImportGraphing m) = State ImportGraph ': Effects (Located location term) term value m - analyzeTerm eval term@(In ann syntax) = do traceShowM ann case prj syntax of diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 7f6e2a1d6..284b85c78 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Quiet ( Quietly @@ -26,8 +26,6 @@ instance ( Effectful m , MonadHole value effects (Quietly m) ) => MonadAnalysis location term value effects (Quietly m) where - type Effects location term value (Quietly m) = Resumable (Unspecialized value) ': Effects location term value m - analyzeTerm eval term = resume @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield err@(Unspecialized _) -> traceM ("Unspecialized:" <> show err) >> hole >>= yield) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 62f10071a..6aaef9460 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Tracing ( Tracing @@ -27,8 +27,6 @@ instance ( Corecursive term , Reducer (Configuration location term value) (trace (Configuration location term value)) ) => MonadAnalysis location term value effects (Tracing trace m) where - type Effects location term value (Tracing trace m) = Writer (trace (Configuration location term value)) ': Effects location term value m - analyzeTerm recur term = do config <- getConfiguration (embedSubterm term) raise (tell @(trace (Configuration location term value)) (Reducer.unit config)) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 28a4e1e60..c555d369b 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE GADTs, KindSignatures, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis module Control.Abstract.Analysis ( MonadAnalysis(..) @@ -31,9 +31,6 @@ import Prologue -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. class MonadEvaluator location term value effects m => MonadAnalysis location term value effects m where - -- | The effects necessary to run the analysis. Analyses which are composed on top of (wrap) other analyses should include the inner analyses 'Effects' in their own list. - type family Effects location term value m :: [* -> *] - -- | Analyze a term using the semantics of the current analysis. analyzeTerm :: (Base term (Subterm term (outer effects value)) -> m effects value) -> (Base term (Subterm term (outer effects value)) -> m effects value) From 7670c44a5e0f97fea42b322265693bc939f69ddb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:03:17 -0400 Subject: [PATCH 50/74] :memo: Interpreter. --- src/Control/Effect.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index 3c5cb5071..de346321c 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -26,6 +26,9 @@ instance Effectful Eff where lower = id +-- | Interpreters determine and interpret a list of effects, optionally taking extra arguments. +-- +-- Instances will generally be defined recursively in terms of underlying interpreters, bottoming out with the instance for 'Eff' which uses 'Effect.run' to produce a final value. class Effectful m => Interpreter effects result function m | m -> effects, m result -> function where interpret :: m effects result -> function From 6c1eb6f12023c22ef8157bf665c702f3a608ca3a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:05:36 -0400 Subject: [PATCH 51/74] Use the Empty instances for the initial values. --- src/Analysis/Abstract/Evaluating.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 38a445f2b..d518dbc83 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -13,7 +13,8 @@ import Data.Abstract.Evaluatable import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Origin -import Prologue +import Data.Empty +import Prologue hiding (empty) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. newtype Evaluating location term value effects a = Evaluating (Eff effects a) @@ -71,10 +72,10 @@ instance ( Ord location (Evaluating location term value) where interpret = interpret - . flip runState (EvaluatorState mempty mempty mempty mempty mempty mempty mempty) - . flip runReader mempty -- Reader (Environment location value) - . flip runReader mempty -- Reader (ModuleTable [Module term]) - . flip runReader mempty -- Reader (SomeOrigin term) + . flip runState (EvaluatorState empty empty empty empty empty empty empty) + . flip runReader empty -- Reader (Environment location value) + . flip runReader empty -- Reader (ModuleTable [Module term]) + . flip runReader empty -- Reader (SomeOrigin term) . flip runFresh' 0 . runFail . Res.runError From 2270b0378f317ecb37435915083c9605aa232ff2 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:18:46 -0400 Subject: [PATCH 52/74] Handle ArithmeticError. --- src/Analysis/Abstract/BadValues.hs | 33 +++++++++++++++++------------- 1 file changed, 19 insertions(+), 14 deletions(-) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 959c6f88b..ca2df4c57 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -46,17 +46,22 @@ instance ( Interpreter effects result rest m , Show value ) => Interpreter (Resumable (ValueError location value) ': effects) result rest (BadValues m) where - interpret = interpret . raise @m . relay pure (\ (Resumable err) yield -> case err of - ScopedEnvironmentError{} -> do - env <- lower @m getEnv - yield (Env.push env) - CallError val -> yield val - StringError val -> yield (pack (show val)) - BoolError{} -> yield True - NumericError{} -> lower @m hole >>= yield - Numeric2Error{} -> lower @m hole >>= yield - ComparisonError{} -> lower @m hole >>= yield - NamespaceError{} -> lower @m getEnv >>= yield - BitwiseError{} -> lower @m hole >>= yield - Bitwise2Error{} -> lower @m hole >>= yield - KeyValueError{} -> lower @m hole >>= \x -> yield (x, x)) . lower + interpret + = interpret + . raise @m + . relay pure (\ (Resumable err) yield -> case err of + ScopedEnvironmentError{} -> do + env <- lower @m getEnv + yield (Env.push env) + CallError val -> yield val + StringError val -> yield (pack (show val)) + BoolError{} -> yield True + NumericError{} -> lower @m hole >>= yield + Numeric2Error{} -> lower @m hole >>= yield + ComparisonError{} -> lower @m hole >>= yield + NamespaceError{} -> lower @m getEnv >>= yield + BitwiseError{} -> lower @m hole >>= yield + Bitwise2Error{} -> lower @m hole >>= yield + KeyValueError{} -> lower @m hole >>= \x -> yield (x, x) + ArithmeticError{} -> lower @m hole >>= yield) + . lower From 16393af491ea04caee1debfd972c38e3e7700f3a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:29:04 -0400 Subject: [PATCH 53/74] Spacing. --- src/Analysis/Abstract/BadValues.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index ca2df4c57..bcb3c2e34 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -9,7 +9,7 @@ import Prologue newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) instance ( Effectful m , Member (Resumable (ValueError location value)) effects From fb75b282be12760a0b929ec0ab5f8d0400a4c455 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:29:16 -0400 Subject: [PATCH 54/74] Add a helper to raise an effect handler into an Effectful computation. --- src/Control/Effect.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Control/Effect.hs b/src/Control/Effect.hs index de346321c..eb9e0e09a 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE FunctionalDependencies, RankNTypes #-} +{-# LANGUAGE FunctionalDependencies, RankNTypes, TypeOperators #-} module Control.Effect ( Effectful(..) +, raiseHandler , Interpreter(..) , resume ) where @@ -25,6 +26,9 @@ instance Effectful Eff where raise = id lower = id +raiseHandler :: Effectful m => (Eff (effect ': effects) a -> Eff effects b) -> m (effect ': effects) a -> m effects b +raiseHandler handler = raise . handler . lower + -- | Interpreters determine and interpret a list of effects, optionally taking extra arguments. -- From 8ba011ea8d8bf5b5a64d5f5e9a8abc11f1bed7d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:29:51 -0400 Subject: [PATCH 55/74] =?UTF-8?q?Use=20raiseHandler=20to=20lift=20BadValue?= =?UTF-8?q?s=E2=80=99=20handler.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/BadValues.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index bcb3c2e34..0728e5286 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -6,7 +6,7 @@ import Data.Abstract.Environment as Env import Data.ByteString.Char8 (pack) import Prologue -newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) +newtype BadValues m (effects :: [* -> *]) a = BadValues { runBadValues :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) @@ -48,8 +48,8 @@ instance ( Interpreter effects result rest m => Interpreter (Resumable (ValueError location value) ': effects) result rest (BadValues m) where interpret = interpret - . raise @m - . relay pure (\ (Resumable err) yield -> case err of + . runBadValues + . raiseHandler (relay pure (\ (Resumable err) yield -> case err of ScopedEnvironmentError{} -> do env <- lower @m getEnv yield (Env.push env) @@ -63,5 +63,4 @@ instance ( Interpreter effects result rest m BitwiseError{} -> lower @m hole >>= yield Bitwise2Error{} -> lower @m hole >>= yield KeyValueError{} -> lower @m hole >>= \x -> yield (x, x) - ArithmeticError{} -> lower @m hole >>= yield) - . lower + ArithmeticError{} -> lower @m hole >>= yield)) From 4be5418b9268b2ec023a1b99ba0128f2444573d6 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:34:08 -0400 Subject: [PATCH 56/74] Correct the type of TestEvaluating. --- test/SpecHelpers.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 7bab8a4f4..846c5e8e7 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -68,7 +68,13 @@ readFilePair paths = let paths' = fmap file paths in readFileVerbatim :: FilePath -> IO Verbatim readFileVerbatim = fmap verbatim . B.readFile -type TestEvaluating term = Evaluating Precise term (Value Precise) +type TestEvaluating term + = Erroring (AddressError Precise (Value Precise)) + ( Erroring (EvalError (Value Precise)) + ( Erroring (ResolutionError (Value Precise)) + ( Erroring (Unspecialized (Value Precise)) + ( Erroring (ValueError Precise (Value Precise)) + ( Evaluating Precise term (Value Precise)))))) ns n = Just . Latest . Just . injValue . Namespace n addr = Address . Precise From ddef5564994367324e0a25807fcd86c4cd2a0bcd Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:38:28 -0400 Subject: [PATCH 57/74] Import Erroring. --- test/SpecHelpers.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 846c5e8e7..6a869c88c 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -12,6 +12,8 @@ module SpecHelpers ( , TestEvaluating , ) where +import Analysis.Abstract.Erroring +import Analysis.Abstract.Evaluating import Control.Abstract.Evaluator as X (EvaluatorState(..)) import Data.Abstract.Address as X import Data.Abstract.FreeVariables as X hiding (dropExtension) @@ -50,7 +52,6 @@ import Test.LeanCheck as X import qualified Data.ByteString as B import qualified Semantic.IO as IO import Data.Abstract.Value -import Analysis.Abstract.Evaluating -- | Returns an s-expression formatted diff for the specified FilePath pair. diffFilePaths :: Both FilePath -> IO ByteString From 73839b88e5a6b960a829cf1c1084a3c984728459 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:43:02 -0400 Subject: [PATCH 58/74] :fire: a redundant language extension. --- src/Control/Abstract/Addressable.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 0fe6f8b0d..e0be2834c 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE GADTs, UndecidableInstances #-} module Control.Abstract.Addressable where import Control.Abstract.Evaluator From 22c8fec448140f0277a44b42cbdeae96ea758587 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:46:01 -0400 Subject: [PATCH 59/74] Import the other exceptions. --- test/SpecHelpers.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index 6a869c88c..904d20361 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -14,8 +14,11 @@ module SpecHelpers ( import Analysis.Abstract.Erroring import Analysis.Abstract.Evaluating +import Control.Abstract.Addressable import Control.Abstract.Evaluator as X (EvaluatorState(..)) +import Control.Abstract.Value import Data.Abstract.Address as X +import Data.Abstract.Evaluatable import Data.Abstract.FreeVariables as X hiding (dropExtension) import Data.Abstract.Heap as X import Data.Abstract.ModuleTable as X hiding (lookup) From a4bef770cc8d558081037ec56b7db84fb2d84726 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:47:45 -0400 Subject: [PATCH 60/74] Generalize raiseHandler. --- 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 eb9e0e09a..f827c2c1a 100644 --- a/src/Control/Effect.hs +++ b/src/Control/Effect.hs @@ -26,7 +26,7 @@ instance Effectful Eff where raise = id lower = id -raiseHandler :: Effectful m => (Eff (effect ': effects) a -> Eff effects b) -> m (effect ': effects) a -> m effects b +raiseHandler :: Effectful m => (Eff effectsA a -> Eff effectsB b) -> m effectsA a -> m effectsB b raiseHandler handler = raise . handler . lower From 50bbe11d8d5582c8b55d3b703add77a9b9f96a29 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 12:52:09 -0400 Subject: [PATCH 61/74] =?UTF-8?q?Interpret=20all=20of=20the=20analyses?= =?UTF-8?q?=E2=80=99=20effects=20using=20raiseHandler.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/BadAddresses.hs | 11 +++++---- src/Analysis/Abstract/BadModuleResolutions.hs | 11 +++++---- src/Analysis/Abstract/BadVariables.hs | 24 +++++++++---------- src/Analysis/Abstract/Caching.hs | 14 +++++------ src/Analysis/Abstract/Collecting.hs | 4 ++-- src/Analysis/Abstract/Dead.hs | 4 ++-- src/Analysis/Abstract/Erroring.hs | 4 ++-- src/Analysis/Abstract/Evaluating.hs | 23 +++++++++--------- src/Analysis/Abstract/ImportGraph.hs | 4 ++-- src/Analysis/Abstract/Quiet.hs | 8 +++---- src/Analysis/Abstract/Tracing.hs | 4 ++-- 11 files changed, 58 insertions(+), 53 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index e0561d136..bb6a970bd 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -6,7 +6,7 @@ import Control.Abstract.Analysis import Data.Abstract.Address import Prologue -newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) +newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses { runBadAddresses :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) @@ -34,6 +34,9 @@ instance ( Interpreter effects result rest m , Monoid (Cell location value) ) => Interpreter (Resumable (AddressError location value) ': effects) result rest (BadAddresses m) where - interpret = interpret . raise @m . relay pure (\ (Resumable err) yield -> case err of - UnallocatedAddress _ -> yield mempty - UninitializedAddress _ -> lower @m hole >>= yield) . lower + interpret + = interpret + . runBadAddresses + . raiseHandler (relay pure (\ (Resumable err) yield -> case err of + UnallocatedAddress _ -> yield mempty + UninitializedAddress _ -> lower @m hole >>= yield)) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 627494c53..08d0c1acc 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -6,7 +6,7 @@ import Control.Abstract.Analysis import Data.Abstract.Evaluatable import Prologue -newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) +newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions { runBadModuleResolutions :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) @@ -30,6 +30,9 @@ instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m ) => Interpreter (Resumable (ResolutionError value) ': effects) result rest (BadModuleResolutions m) where - interpret = interpret . raise @m . relay pure (\ (Resumable err) yield -> case err of - RubyError nameToResolve -> yield nameToResolve - TypeScriptError nameToResolve -> yield nameToResolve) . lower + interpret + = interpret + . runBadModuleResolutions + . raiseHandler (relay pure (\ (Resumable err) yield -> case err of + RubyError nameToResolve -> yield nameToResolve + TypeScriptError nameToResolve -> yield nameToResolve)) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 1441d8f24..49eae9d8f 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -9,7 +9,7 @@ import Data.Abstract.Evaluatable import Prologue -- An analysis that resumes from evaluation errors and records the list of unresolved free variables. -newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) +newtype BadVariables m (effects :: [* -> *]) a = BadVariables { runBadVariables :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) @@ -42,14 +42,14 @@ instance ( Interpreter effects (result, [Name]) rest m => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) result rest (BadVariables m) where interpret = interpret - . raise @m - . flip runState [] - . relay pure (\ (Resumable err) yield -> case err of - DefaultExportError{} -> yield () - ExportError{} -> yield () - IntegerFormatError{} -> yield 0 - FloatFormatError{} -> yield 0 - RationalFormatError{} -> yield 0 - FreeVariableError name -> modify' (name :) >> lower @m hole >>= yield - FreeVariablesError names -> modify' (names <>) >> yield (fromMaybeLast "unknown" names)) - . lower + . runBadVariables + . raiseHandler + ( flip runState [] + . relay pure (\ (Resumable err) yield -> case err of + DefaultExportError{} -> yield () + ExportError{} -> yield () + IntegerFormatError{} -> yield 0 + FloatFormatError{} -> yield 0 + RationalFormatError{} -> yield 0 + FreeVariableError name -> modify' (name :) >> lower @m hole >>= yield + FreeVariablesError names -> modify' (names <>) >> yield (fromMaybeLast "unknown" names))) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 93ff42f19..325c7c425 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -21,7 +21,7 @@ type CachingEffects location term value effects ': effects -- | A (coinductively-)cached analysis suitable for guaranteeing termination of (suitably finitized) analyses over recursive programs. -newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) +newtype Caching m (effects :: [* -> *]) a = Caching { runCaching :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) @@ -101,7 +101,7 @@ instance ( Alternative (m effects) maybe empty scatter (cacheLookup c cache) reset :: (Effectful m, Member Fresh effects) => Int -> m effects a -> m effects a -reset start = raise . interposeState start (const pure) (\ counter Fresh yield -> (yield $! succ counter) counter) . lower +reset start = raiseHandler (interposeState start (const pure) (\ counter Fresh yield -> (yield $! succ counter) counter)) -- | Iterate a monadic action starting from some initial seed until the results converge. -- @@ -133,8 +133,8 @@ instance ( Interpreter effects ([result], Cache location term value) rest m => Interpreter (NonDet ': Reader (Cache location term value) ': State (Cache location term value) ': effects) result rest (Caching m) where interpret = interpret - . raise @m - . flip runState mempty - . flip runReader mempty - . makeChoiceA @[] - . lower + . runCaching + . raiseHandler + ( flip runState mempty + . flip runReader mempty + . makeChoiceA @[]) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 087df6144..a71fecba5 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -11,7 +11,7 @@ import Data.Abstract.Heap import Data.Abstract.Live import Prologue -newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) +newtype Collecting m (effects :: [* -> *]) a = Collecting { runCollecting :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) instance ( Effectful m @@ -80,4 +80,4 @@ instance ( Interpreter effects result rest m , Ord location ) => Interpreter (Reader (Live location value) ': effects) result rest (Collecting m) where - interpret = interpret . raise @m . flip runReader mempty . lower + interpret = interpret . runCollecting . raiseHandler (flip runReader mempty) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 785531d42..5dcc0f1d3 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -11,7 +11,7 @@ import Data.Set (delete) import Prologue -- | An analysis tracking dead (unreachable) code. -newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) +newtype DeadCode m (effects :: [* -> *]) a = DeadCode { runDeadCode :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) @@ -57,4 +57,4 @@ instance ( Interpreter effects (result, Dead term) rest m , Ord term ) => Interpreter (State (Dead term) ': effects) result rest (DeadCode m) where - interpret = interpret . raise @m . flip runState mempty . lower + interpret = interpret . runDeadCode . raiseHandler (flip runState mempty) diff --git a/src/Analysis/Abstract/Erroring.hs b/src/Analysis/Abstract/Erroring.hs index 70c6c6cad..3df22eff9 100644 --- a/src/Analysis/Abstract/Erroring.hs +++ b/src/Analysis/Abstract/Erroring.hs @@ -7,7 +7,7 @@ import Control.Abstract.Analysis import Prologue -- | An analysis that fails on errors. -newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring (m effects a) +newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring { runErroring :: m effects a } deriving (Alternative, Applicative, Effectful, Functor, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m) @@ -19,4 +19,4 @@ instance MonadAnalysis location term value effects m instance Interpreter effects (Either (SomeExc exc) result) rest m => Interpreter (Resumable exc ': effects) result rest (Erroring exc m) where - interpret = interpret . raise @m . runError . lower + interpret = interpret . runErroring . raiseHandler runError diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index d518dbc83..9d71a0c6e 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -17,7 +17,7 @@ import Data.Empty import Prologue hiding (empty) -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. -newtype Evaluating location term value effects a = Evaluating (Eff effects a) +newtype Evaluating location term value effects a = Evaluating { runEvaluating :: Eff effects a } deriving (Applicative, Functor, Effectful, Monad) deriving instance Member NonDet effects => Alternative (Evaluating location term value effects) @@ -72,13 +72,14 @@ instance ( Ord location (Evaluating location term value) where interpret = interpret - . flip runState (EvaluatorState empty empty empty empty empty empty empty) - . flip runReader empty -- Reader (Environment location value) - . flip runReader empty -- Reader (ModuleTable [Module term]) - . flip runReader empty -- Reader (SomeOrigin term) - . flip runFresh' 0 - . runFail - . Res.runError - . Exc.runError - . Exc.runError - . lower + . runEvaluating + . raiseHandler + ( flip runState (EvaluatorState empty empty empty empty empty empty empty) + . flip runReader empty -- Reader (Environment location value) + . flip runReader empty -- Reader (ModuleTable [Module term]) + . flip runReader empty -- Reader (SomeOrigin term) + . flip runFresh' 0 + . runFail + . Res.runError + . Exc.runError + . Exc.runError) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 2c8e51474..7343a0b12 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -53,7 +53,7 @@ style = (defaultStyle vertexName) edgeAttributes Variable{} Module{} = [ "color" := "blue" ] edgeAttributes _ _ = [] -newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) +newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing { runImportGraphing :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) @@ -171,4 +171,4 @@ vertexToType Variable{} = "variable" instance Interpreter effects (result, ImportGraph) rest m => Interpreter (State ImportGraph ': effects) result rest (ImportGraphing m) where - interpret = interpret . raise @m . flip runState mempty . lower + interpret = interpret . runImportGraphing . raiseHandler (flip runState mempty) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 284b85c78..6d20663c8 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -15,7 +15,7 @@ import Prologue -- > runAnalysis @(Quietly (Evaluating term value)) (…) -- -- Note that exceptions thrown by other analyses may not be caught if 'Quietly' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery. -newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) +newtype Quietly m (effects :: [* -> *]) a = Quietly { runQuietly :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) @@ -38,7 +38,5 @@ instance ( Interpreter effects result rest m => Interpreter (Resumable (Unspecialized value) ': effects) result rest (Quietly m) where interpret = interpret - . raise @m - . relay pure (\ (Resumable err) yield -> case err of - Unspecialized _ -> lower @m hole >>= yield) - . lower + . runQuietly + . raiseHandler (relay pure (\ (Resumable (Unspecialized _)) yield -> lower @m hole >>= yield)) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 6aaef9460..955065fac 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Prologue -- | Trace analysis. -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. -newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) +newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing { runTracing :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) @@ -39,4 +39,4 @@ instance ( Interpreter effects (result, trace (Configuration location term value , Monoid (trace (Configuration location term value)) ) => Interpreter (Writer (trace (Configuration location term value)) ': effects) result rest (Tracing trace m) where - interpret = interpret . raise @m . runWriter . lower + interpret = interpret . runTracing . raiseHandler runWriter From 437569218217a97f76b448c53f3a867c10441c33 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 15:28:24 -0400 Subject: [PATCH 62/74] Rephrase MonadHole as a pure AbstractHole class. --- src/Analysis/Abstract/BadAddresses.hs | 8 ++--- src/Analysis/Abstract/BadValues.hs | 48 +++++++++++++-------------- src/Analysis/Abstract/BadVariables.hs | 8 ++--- src/Analysis/Abstract/Quiet.hs | 8 ++--- src/Control/Abstract/Value.hs | 6 ++-- src/Data/Abstract/Type.hs | 4 +-- src/Data/Abstract/Value.hs | 6 ++-- 7 files changed, 44 insertions(+), 44 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index bb6a970bd..f31eef4fb 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -14,7 +14,7 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator instance ( Effectful m , Member (Resumable (AddressError location value)) effects , MonadAnalysis location term value effects m - , MonadHole value effects (BadAddresses m) + , AbstractHole value , Monoid (Cell location value) , Show location ) @@ -24,13 +24,13 @@ instance ( Effectful m traceM ("AddressError:" <> show error) case error of UnallocatedAddress _ -> yield mempty - UninitializedAddress _ -> hole >>= yield) + UninitializedAddress _ -> yield hole) analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m - , MonadHole value effects m + , AbstractHole value , Monoid (Cell location value) ) => Interpreter (Resumable (AddressError location value) ': effects) result rest (BadAddresses m) where @@ -39,4 +39,4 @@ instance ( Interpreter effects result rest m . runBadAddresses . raiseHandler (relay pure (\ (Resumable err) yield -> case err of UnallocatedAddress _ -> yield mempty - UninitializedAddress _ -> lower @m hole >>= yield)) + UninitializedAddress _ -> yield hole)) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 0728e5286..74585352a 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -14,7 +14,7 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator instance ( Effectful m , Member (Resumable (ValueError location value)) effects , MonadAnalysis location term value effects m - , MonadHole value effects (BadValues m) + , AbstractHole value , Show value ) => MonadAnalysis location term value effects (BadValues m) where @@ -25,24 +25,24 @@ instance ( Effectful m ScopedEnvironmentError{} -> do env <- getEnv yield (Env.push env) - CallError val -> yield val - StringError val -> yield (pack (show val)) - BoolError{} -> yield True - NumericError{} -> hole >>= yield - Numeric2Error{} -> hole >>= yield - ComparisonError{} -> hole >>= yield - NamespaceError{} -> getEnv >>= yield - BitwiseError{} -> hole >>= yield - Bitwise2Error{} -> hole >>= yield - KeyValueError{} -> hole >>= \x -> yield (x, x) - ArithmeticError{} -> hole >>= yield + CallError val -> yield val + StringError val -> yield (pack (show val)) + BoolError{} -> yield True + NumericError{} -> yield hole + Numeric2Error{} -> yield hole + ComparisonError{} -> yield hole + NamespaceError{} -> getEnv >>= yield + BitwiseError{} -> yield hole + Bitwise2Error{} -> yield hole + KeyValueError{} -> yield (hole, hole) + ArithmeticError{} -> yield hole ) analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m - , MonadHole value effects m + , AbstractHole value , Show value ) => Interpreter (Resumable (ValueError location value) ': effects) result rest (BadValues m) where @@ -53,14 +53,14 @@ instance ( Interpreter effects result rest m ScopedEnvironmentError{} -> do env <- lower @m getEnv yield (Env.push env) - CallError val -> yield val - StringError val -> yield (pack (show val)) - BoolError{} -> yield True - NumericError{} -> lower @m hole >>= yield - Numeric2Error{} -> lower @m hole >>= yield - ComparisonError{} -> lower @m hole >>= yield - NamespaceError{} -> lower @m getEnv >>= yield - BitwiseError{} -> lower @m hole >>= yield - Bitwise2Error{} -> lower @m hole >>= yield - KeyValueError{} -> lower @m hole >>= \x -> yield (x, x) - ArithmeticError{} -> lower @m hole >>= yield)) + CallError val -> yield val + StringError val -> yield (pack (show val)) + BoolError{} -> yield True + NumericError{} -> yield hole + Numeric2Error{} -> yield hole + ComparisonError{} -> yield hole + NamespaceError{} -> lower @m getEnv >>= yield + BitwiseError{} -> yield hole + Bitwise2Error{} -> yield hole + KeyValueError{} -> yield (hole, hole) + ArithmeticError{} -> yield hole)) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 49eae9d8f..e96a6d7cc 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -18,7 +18,7 @@ instance ( Effectful m , Member (Resumable (EvalError value)) effects , Member (State [Name]) effects , MonadAnalysis location term value effects m - , MonadHole value effects (BadVariables m) + , AbstractHole value ) => MonadAnalysis location term value effects (BadVariables m) where analyzeTerm eval term = resume @(EvalError value) (liftAnalyze analyzeTerm eval term) ( @@ -30,14 +30,14 @@ instance ( Effectful m IntegerFormatError{} -> yield 0 FloatFormatError{} -> yield 0 RationalFormatError{} -> yield 0 - FreeVariableError name -> raise (modify' (name :)) >> hole >>= yield + FreeVariableError name -> raise (modify' (name :)) >> yield hole FreeVariablesError names -> raise (modify' (names <>)) >> yield (fromMaybeLast "unknown" names)) analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects (result, [Name]) rest m , MonadEvaluator location term value effects m - , MonadHole value (State [Name] ': effects) m + , AbstractHole value ) => Interpreter (Resumable (EvalError value) ': State [Name] ': effects) result rest (BadVariables m) where interpret @@ -51,5 +51,5 @@ instance ( Interpreter effects (result, [Name]) rest m IntegerFormatError{} -> yield 0 FloatFormatError{} -> yield 0 RationalFormatError{} -> yield 0 - FreeVariableError name -> modify' (name :) >> lower @m hole >>= yield + FreeVariableError name -> modify' (name :) >> yield hole FreeVariablesError names -> modify' (names <>) >> yield (fromMaybeLast "unknown" names))) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 6d20663c8..0e6ddf6e2 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -23,20 +23,20 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluator instance ( Effectful m , Member (Resumable (Unspecialized value)) effects , MonadAnalysis location term value effects m - , MonadHole value effects (Quietly m) + , AbstractHole value ) => MonadAnalysis location term value effects (Quietly m) where analyzeTerm eval term = resume @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield err@(Unspecialized _) -> - traceM ("Unspecialized:" <> show err) >> hole >>= yield) + traceM ("Unspecialized:" <> show err) >> yield hole) analyzeModule = liftAnalyze analyzeModule instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m - , MonadHole value effects m + , AbstractHole value ) => Interpreter (Resumable (Unspecialized value) ': effects) result rest (Quietly m) where interpret = interpret . runQuietly - . raiseHandler (relay pure (\ (Resumable (Unspecialized _)) yield -> lower @m hole >>= yield)) + . raiseHandler (relay pure (\ (Resumable (Unspecialized _)) yield -> yield hole)) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index f1c2c8533..41be65930 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,7 +1,7 @@ {-# LANGUAGE FunctionalDependencies, GADTs, KindSignatures, Rank2Types #-} module Control.Abstract.Value ( MonadValue(..) -, MonadHole(..) +, AbstractHole(..) , Comparator(..) , while , doWhile @@ -32,8 +32,8 @@ data Comparator = Concrete (forall a . Ord a => a -> a -> Bool) | Generalized -class Monad (m effects) => MonadHole value (effects :: [* -> *]) m where - hole :: m effects value +class AbstractHole value where + hole :: value -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 002cc70d8..b26d714c0 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -52,8 +52,8 @@ instance Ord location => ValueRoots location Type where valueRoots _ = mempty -instance Monad (m effects) => MonadHole Type effects m where - hole = pure Hole +instance AbstractHole Type where + hole = Hole -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Alternative (m effects) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index c0dfcaf94..71d6dca76 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -198,8 +198,8 @@ instance Ord location => ValueRoots location (Value location) where | otherwise = mempty -instance Monad (m effects) => MonadHole (Value location) effects m where - hole = pure (injValue Hole) +instance AbstractHole (Value location) where + hole = injValue Hole -- | Construct a 'Value' wrapping the value arguments (if any). instance (Monad (m effects), MonadEvaluatable location term (Value location) effects m) => MonadValue location (Value location) effects m where @@ -249,7 +249,7 @@ instance (Monad (m effects), MonadEvaluatable location term (Value location) eff ifthenelse cond if' else' = do isHole <- isHole cond if isHole then - hole + pure hole else do bool <- asBool cond if bool then if' else else' From 3df75c2947c28493791370d47f604347aa4034e3 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 15:41:30 -0400 Subject: [PATCH 63/74] Derive a bunch of MonadAnalysis instances. --- src/Analysis/Abstract/BadAddresses.hs | 23 +++---------- src/Analysis/Abstract/BadModuleResolutions.hs | 20 ++---------- src/Analysis/Abstract/BadValues.hs | 32 ++----------------- src/Analysis/Abstract/BadVariables.hs | 28 +++------------- src/Analysis/Abstract/Erroring.hs | 6 +--- src/Analysis/Abstract/Quiet.hs | 14 ++------ 6 files changed, 16 insertions(+), 107 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index f31eef4fb..183841e2f 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -10,33 +10,18 @@ newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses { runBadAddresses deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) - -instance ( Effectful m - , Member (Resumable (AddressError location value)) effects - , MonadAnalysis location term value effects m - , AbstractHole value - , Monoid (Cell location value) - , Show location - ) - => MonadAnalysis location term value effects (BadAddresses m) where - analyzeTerm eval term = resume @(AddressError location value) (liftAnalyze analyzeTerm eval term) ( - \yield error -> do - traceM ("AddressError:" <> show error) - case error of - UnallocatedAddress _ -> yield mempty - UninitializedAddress _ -> yield hole) - - analyzeModule = liftAnalyze analyzeModule +deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadAddresses m) instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m , AbstractHole value , Monoid (Cell location value) + , Show location ) => Interpreter (Resumable (AddressError location value) ': effects) result rest (BadAddresses m) where interpret = interpret . runBadAddresses - . raiseHandler (relay pure (\ (Resumable err) yield -> case err of - UnallocatedAddress _ -> yield mempty + . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("AddressError:" <> show err) *> case err of + UnallocatedAddress _ -> yield mempty UninitializedAddress _ -> yield hole)) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 08d0c1acc..212ae9d52 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -10,21 +10,7 @@ newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions { deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) - -instance ( Effectful m - , Member (Resumable (ResolutionError value)) effects - , MonadAnalysis location term value effects m - , MonadValue location value effects (BadModuleResolutions m) - ) - => MonadAnalysis location term value effects (BadModuleResolutions m) where - analyzeTerm eval term = resume @(ResolutionError value) (liftAnalyze analyzeTerm eval term) ( - \yield error -> do - traceM ("ResolutionError:" <> show error) - case error of - RubyError nameToResolve -> yield nameToResolve - TypeScriptError nameToResolve -> yield nameToResolve) - - analyzeModule = liftAnalyze analyzeModule +deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadModuleResolutions m) instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m @@ -33,6 +19,6 @@ instance ( Interpreter effects result rest m interpret = interpret . runBadModuleResolutions - . raiseHandler (relay pure (\ (Resumable err) yield -> case err of - RubyError nameToResolve -> yield nameToResolve + . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ResolutionError:" <> show err) *> case err of + RubyError nameToResolve -> yield nameToResolve TypeScriptError nameToResolve -> yield nameToResolve)) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 74585352a..cf32d8165 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -10,35 +10,7 @@ newtype BadValues m (effects :: [* -> *]) a = BadValues { runBadValues :: m effe deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) - -instance ( Effectful m - , Member (Resumable (ValueError location value)) effects - , MonadAnalysis location term value effects m - , AbstractHole value - , Show value - ) - => MonadAnalysis location term value effects (BadValues m) where - analyzeTerm eval term = resume @(ValueError location value) (liftAnalyze analyzeTerm eval term) ( - \yield error -> do - traceM ("ValueError" <> show error) - case error of - ScopedEnvironmentError{} -> do - env <- getEnv - yield (Env.push env) - CallError val -> yield val - StringError val -> yield (pack (show val)) - BoolError{} -> yield True - NumericError{} -> yield hole - Numeric2Error{} -> yield hole - ComparisonError{} -> yield hole - NamespaceError{} -> getEnv >>= yield - BitwiseError{} -> yield hole - Bitwise2Error{} -> yield hole - KeyValueError{} -> yield (hole, hole) - ArithmeticError{} -> yield hole - ) - - analyzeModule = liftAnalyze analyzeModule +deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadValues m) instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m @@ -49,7 +21,7 @@ instance ( Interpreter effects result rest m interpret = interpret . runBadValues - . raiseHandler (relay pure (\ (Resumable err) yield -> case err of + . raiseHandler (relay pure (\ (Resumable err) yield -> traceM ("ValueError" <> show err) *> case err of ScopedEnvironmentError{} -> do env <- lower @m getEnv yield (Env.push env) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index e96a6d7cc..6bbb4c9ae 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -13,27 +13,7 @@ newtype BadVariables m (effects :: [* -> *]) a = BadVariables { runBadVariables deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) - -instance ( Effectful m - , Member (Resumable (EvalError value)) effects - , Member (State [Name]) effects - , MonadAnalysis location term value effects m - , AbstractHole value - ) - => MonadAnalysis location term value effects (BadVariables m) where - analyzeTerm eval term = resume @(EvalError value) (liftAnalyze analyzeTerm eval term) ( - \yield err -> do - traceM ("EvalError" <> show err) - case err of - DefaultExportError{} -> yield () - ExportError{} -> yield () - IntegerFormatError{} -> yield 0 - FloatFormatError{} -> yield 0 - RationalFormatError{} -> yield 0 - FreeVariableError name -> raise (modify' (name :)) >> yield hole - FreeVariablesError names -> raise (modify' (names <>)) >> yield (fromMaybeLast "unknown" names)) - - analyzeModule = liftAnalyze analyzeModule +deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadVariables m) instance ( Interpreter effects (result, [Name]) rest m , MonadEvaluator location term value effects m @@ -45,11 +25,11 @@ instance ( Interpreter effects (result, [Name]) rest m . runBadVariables . raiseHandler ( flip runState [] - . relay pure (\ (Resumable err) yield -> case err of + . relay pure (\ (Resumable err) yield -> traceM ("EvalError" <> show err) *> case err of DefaultExportError{} -> yield () ExportError{} -> yield () IntegerFormatError{} -> yield 0 FloatFormatError{} -> yield 0 RationalFormatError{} -> yield 0 - FreeVariableError name -> modify' (name :) >> yield hole - FreeVariablesError names -> modify' (names <>) >> yield (fromMaybeLast "unknown" names))) + FreeVariableError name -> modify' (name :) *> yield hole + FreeVariablesError names -> modify' (names <>) *> yield (fromMaybeLast "unknown" names))) diff --git a/src/Analysis/Abstract/Erroring.hs b/src/Analysis/Abstract/Erroring.hs index 3df22eff9..132e52310 100644 --- a/src/Analysis/Abstract/Erroring.hs +++ b/src/Analysis/Abstract/Erroring.hs @@ -11,11 +11,7 @@ newtype Erroring (exc :: * -> *) m (effects :: [* -> *]) a = Erroring { runError deriving (Alternative, Applicative, Effectful, Functor, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Erroring exc m) - -instance MonadAnalysis location term value effects m - => MonadAnalysis location term value effects (Erroring exc m) where - analyzeTerm = liftAnalyze analyzeTerm - analyzeModule = liftAnalyze analyzeModule +deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Erroring exc m) instance Interpreter effects (Either (SomeExc exc) result) rest m => Interpreter (Resumable exc ': effects) result rest (Erroring exc m) where diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 0e6ddf6e2..9a8b1f462 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -19,17 +19,7 @@ newtype Quietly m (effects :: [* -> *]) a = Quietly { runQuietly :: m effects a deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) - -instance ( Effectful m - , Member (Resumable (Unspecialized value)) effects - , MonadAnalysis location term value effects m - , AbstractHole value - ) - => MonadAnalysis location term value effects (Quietly m) where - analyzeTerm eval term = resume @(Unspecialized value) (liftAnalyze analyzeTerm eval term) (\yield err@(Unspecialized _) -> - traceM ("Unspecialized:" <> show err) >> yield hole) - - analyzeModule = liftAnalyze analyzeModule +deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Quietly m) instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m @@ -39,4 +29,4 @@ instance ( Interpreter effects result rest m interpret = interpret . runQuietly - . raiseHandler (relay pure (\ (Resumable (Unspecialized _)) yield -> yield hole)) + . raiseHandler (relay pure (\ (Resumable err@(Unspecialized _)) yield -> traceM ("Unspecialized:" <> show err) *> yield hole)) From 6646c8ca2788307d554c6fd9fa013022499897f8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 15:44:44 -0400 Subject: [PATCH 64/74] Rename Quietly to BadSyntax. --- semantic.cabal | 10 +++++----- .../Abstract/{Quiet.hs => BadSyntax.hs} | 18 +++++++++--------- src/Semantic/Util.hs | 4 ++-- 3 files changed, 16 insertions(+), 16 deletions(-) rename src/Analysis/Abstract/{Quiet.hs => BadSyntax.hs} (67%) diff --git a/semantic.cabal b/semantic.cabal index b41291640..7f548c8c6 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -16,16 +16,16 @@ library exposed-modules: -- Analyses & term annotations Analysis.Abstract.BadAddresses - Analysis.Abstract.BadVariables - Analysis.Abstract.BadValues - Analysis.Abstract.BadModuleResolutions + , Analysis.Abstract.BadSyntax + , Analysis.Abstract.BadModuleResolutions + , Analysis.Abstract.BadVariables + , Analysis.Abstract.BadValues , Analysis.Abstract.Caching , Analysis.Abstract.Collecting , Analysis.Abstract.Dead , Analysis.Abstract.Erroring , Analysis.Abstract.Evaluating , Analysis.Abstract.ImportGraph - , Analysis.Abstract.Quiet , Analysis.Abstract.Tracing , Analysis.CallGraph , Analysis.ConstructorName @@ -49,11 +49,11 @@ library , Data.Abstract.Address , Data.Abstract.Cache , Data.Abstract.Configuration + , Data.Abstract.Declarations , Data.Abstract.Environment , Data.Abstract.Evaluatable , Data.Abstract.Exports , Data.Abstract.FreeVariables - , Data.Abstract.Declarations , Data.Abstract.Heap , Data.Abstract.Live , Data.Abstract.Located diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/BadSyntax.hs similarity index 67% rename from src/Analysis/Abstract/Quiet.hs rename to src/Analysis/Abstract/BadSyntax.hs index 9a8b1f462..647baa968 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/BadSyntax.hs @@ -1,7 +1,7 @@ {-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint -module Analysis.Abstract.Quiet -( Quietly +module Analysis.Abstract.BadSyntax +( BadSyntax ) where import Control.Abstract.Analysis @@ -12,21 +12,21 @@ import Prologue -- -- Use it by composing it onto an analysis: -- --- > runAnalysis @(Quietly (Evaluating term value)) (…) +-- > runAnalysis @(BadSyntax (Evaluating term value)) (…) -- --- Note that exceptions thrown by other analyses may not be caught if 'Quietly' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery. -newtype Quietly m (effects :: [* -> *]) a = Quietly { runQuietly :: m effects a } +-- Note that exceptions thrown by other analyses may not be caught if 'BadSyntax' doesn’t know about them, i.e. if they’re not part of the generic 'MonadValue', 'MonadAddressable', etc. machinery. +newtype BadSyntax m (effects :: [* -> *]) a = BadSyntax { runBadSyntax :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) -deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (Quietly m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadSyntax m) +deriving instance MonadAnalysis location term value effects m => MonadAnalysis location term value effects (BadSyntax m) instance ( Interpreter effects result rest m , MonadEvaluator location term value effects m , AbstractHole value ) - => Interpreter (Resumable (Unspecialized value) ': effects) result rest (Quietly m) where + => Interpreter (Resumable (Unspecialized value) ': effects) result rest (BadSyntax m) where interpret = interpret - . runQuietly + . runBadSyntax . raiseHandler (relay pure (\ (Resumable err@(Unspecialized _)) yield -> traceM ("Unspecialized:" <> show err) *> yield hole)) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 32e3e6f39..45525747b 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -5,12 +5,12 @@ module Semantic.Util where import Analysis.Abstract.BadAddresses import Analysis.Abstract.BadModuleResolutions +import Analysis.Abstract.BadSyntax import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables import Analysis.Abstract.Erroring import Analysis.Abstract.Evaluating import Analysis.Abstract.ImportGraph -import Analysis.Abstract.Quiet import Analysis.Declaration import Control.Abstract.Analysis import Data.Abstract.Address @@ -50,7 +50,7 @@ type JustEvaluating term ( Erroring (Unspecialized (Value (Located Precise term))) ( Erroring (ValueError (Located Precise term) (Value (Located Precise term))) ( Evaluating (Located Precise term) term (Value (Located Precise term))))))) -type EvaluatingWithHoles term = BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term))))))) +type EvaluatingWithHoles term = BadAddresses (BadModuleResolutions (BadVariables (BadValues (BadSyntax (Evaluating (Located Precise term) term (Value (Located Precise term))))))) type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) evalGoProject path = runAnalysis @(JustEvaluating Go.Term) <$> evaluateProject goParser Nothing path From 1542832f45f135b91f15e20b8e91683cc377d130 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 15:46:20 -0400 Subject: [PATCH 65/74] Fix a stale reference to Quietly. --- src/Semantic/Graph.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 0eed57ce4..a31b28ab2 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -15,10 +15,10 @@ import Data.Abstract.Located import Data.Abstract.Address import Analysis.Abstract.BadAddresses import Analysis.Abstract.BadModuleResolutions +import Analysis.Abstract.BadSyntax import Analysis.Abstract.BadValues import Analysis.Abstract.BadVariables import Analysis.Abstract.Evaluating -import Analysis.Abstract.Quiet import Data.Output import Parsing.Parser import Prologue hiding (MonadError (..)) @@ -65,7 +65,7 @@ parsePackage parser preludeFile project@Project{..} = do type ImportGraphAnalysis term effects value = Abstract.ImportGraphing - (BadAddresses (BadModuleResolutions (BadVariables (BadValues (Quietly (Evaluating (Located Precise term) term (Value (Located Precise term)))))))) + (BadAddresses (BadModuleResolutions (BadVariables (BadValues (BadSyntax (Evaluating (Located Precise term) term (Value (Located Precise term)))))))) effects value From beb7261608f044675945316090c79c6a9b7e30a4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 16:49:27 -0400 Subject: [PATCH 66/74] Derive the MonadAnalysis instance for TypeChecking. --- src/Analysis/Abstract/TypeChecking.hs | 33 +++++++-------------------- 1 file changed, 8 insertions(+), 25 deletions(-) diff --git a/src/Analysis/Abstract/TypeChecking.hs b/src/Analysis/Abstract/TypeChecking.hs index 5585abea4..f70637307 100644 --- a/src/Analysis/Abstract/TypeChecking.hs +++ b/src/Analysis/Abstract/TypeChecking.hs @@ -11,36 +11,19 @@ import Prologue hiding (TypeError) newtype TypeChecking m (effects :: [* -> *]) a = TypeChecking { runTypeChecking :: m effects a } deriving (Alternative, Applicative, Functor, Effectful, Monad) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (TypeChecking m) - -instance ( Effectful m - , Alternative (m effects) - , MonadAnalysis location term Type effects m - , Member (Resumable TypeError) effects - , Member NonDet effects - , MonadValue location Type effects (TypeChecking m) - ) - => MonadAnalysis location term Type effects (TypeChecking m) where - analyzeTerm eval term = - resume @TypeError (liftAnalyze analyzeTerm eval term) ( - \yield err -> case err of - -- TODO: These should all yield both sides of the exception, - -- but something is mysteriously busted in the innards of typechecking, - -- so doing that just yields an empty list in the result type, which isn't - -- extraordinarily helpful. Better for now to just die with an error and - -- tackle this issue in a separate PR. - BitOpError{} -> throwResumable err - NumOpError{} -> throwResumable err - UnificationError{} -> throwResumable err - ) - - analyzeModule = liftAnalyze analyzeModule +deriving instance MonadEvaluator location term Type effects m => MonadEvaluator location term Type effects (TypeChecking m) +deriving instance MonadAnalysis location term Type effects m => MonadAnalysis location term Type effects (TypeChecking m) instance ( Interpreter effects (Either (SomeExc TypeError) result) rest m - , MonadEvaluator location term value effects m + , MonadEvaluator location term Type effects m ) => Interpreter (Resumable TypeError ': effects) result rest (TypeChecking m) where interpret = interpret . runTypeChecking + -- TODO: We should handle TypeError by yielding both sides of the exception, + -- but something is mysteriously busted in the innards of typechecking, + -- so doing that just yields an empty list in the result type, which isn't + -- extraordinarily helpful. Better for now to just die with an error and + -- tackle this issue in a separate PR. . raiseHandler runError From 028c94e4eccff722b7fdeca90fb613964def7db9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 16:50:45 -0400 Subject: [PATCH 67/74] Tidy up a bunch of language extensions. --- src/Analysis/Abstract/BadAddresses.hs | 2 +- src/Analysis/Abstract/BadModuleResolutions.hs | 2 +- src/Analysis/Abstract/BadSyntax.hs | 2 +- src/Analysis/Abstract/BadVariables.hs | 2 +- src/Analysis/Abstract/Collecting.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Erroring.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Analysis/Abstract/TypeChecking.hs | 2 +- src/Control/Abstract/Analysis.hs | 2 +- 10 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 183841e2f..e98acd943 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadAddresses where diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index a381834d0..034d6ef99 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadModuleResolutions where diff --git a/src/Analysis/Abstract/BadSyntax.hs b/src/Analysis/Abstract/BadSyntax.hs index 647baa968..149703171 100644 --- a/src/Analysis/Abstract/BadSyntax.hs +++ b/src/Analysis/Abstract/BadSyntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadSyntax ( BadSyntax diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 6bbb4c9ae..119282cd3 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.BadVariables ( BadVariables diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index a71fecba5..5374223df 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Collecting ( Collecting diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 5dcc0f1d3..e171a6dd5 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the Interpreter instance’s MonadEvaluator constraint module Analysis.Abstract.Dead ( DeadCode diff --git a/src/Analysis/Abstract/Erroring.hs b/src/Analysis/Abstract/Erroring.hs index 132e52310..edca0febb 100644 --- a/src/Analysis/Abstract/Erroring.hs +++ b/src/Analysis/Abstract/Erroring.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.Erroring ( Erroring ) where diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 9d71a0c6e..dc98b67ea 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, KindSignatures, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Analysis.Abstract.Evaluating ( Evaluating ) where diff --git a/src/Analysis/Abstract/TypeChecking.hs b/src/Analysis/Abstract/TypeChecking.hs index f70637307..b909280e3 100644 --- a/src/Analysis/Abstract/TypeChecking.hs +++ b/src/Analysis/Abstract/TypeChecking.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, ScopedTypeVariables, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving, KindSignatures, TypeOperators, UndecidableInstances #-} module Analysis.Abstract.TypeChecking ( TypeChecking diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index c555d369b..bb39a3058 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, KindSignatures, RankNTypes, ScopedTypeVariables #-} +{-# LANGUAGE GADTs, KindSignatures #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis module Control.Abstract.Analysis ( MonadAnalysis(..) From 90e9fbb7081ea691dc07d2720c4d05de293bf52d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 16:58:25 -0400 Subject: [PATCH 68/74] Just say empty. --- 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 dc98b67ea..e6662ca5c 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -74,7 +74,7 @@ instance ( Ord location = interpret . runEvaluating . raiseHandler - ( flip runState (EvaluatorState empty empty empty empty empty empty empty) + ( flip runState empty -- State (EvaluatorState location term value) . flip runReader empty -- Reader (Environment location value) . flip runReader empty -- Reader (ModuleTable [Module term]) . flip runReader empty -- Reader (SomeOrigin term) From 61974e5446475a9deadc9ea9aec8538e1c81731e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 17:06:02 -0400 Subject: [PATCH 69/74] Analyze tasks embed the analysis directly. --- src/Semantic/Graph.hs | 2 +- src/Semantic/Task.hs | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index c2601522c..a676382c5 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -81,7 +81,7 @@ graphImports :: ( Show ann , Members '[Exc SomeException, Task] effs ) => Package (Term (Union syntax) ann) -> Eff effs Abstract.ImportGraph -graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package)) >>= extractGraph +graphImports package = analyze (Analysis.evaluatePackage package `asAnalysisForTypeOfPackage` package) >>= extractGraph where asAnalysisForTypeOfPackage :: ImportGraphAnalysis term effs value -> Package term diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index a9ff0360c..847617874 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -88,7 +88,7 @@ parse :: Member Task effs => Parser term -> Blob -> Eff effs term parse parser = send . Parse parser -- | A task running some 'Analysis.MonadAnalysis' to completion. -analyze :: Member Task effs => Analysis.SomeAnalysis m result -> Eff effs result +analyze :: (Analysis.Interpreter analysisEffects result function m, Member Task effs) => m analysisEffects result -> Eff effs function analyze = send . Analyze -- | A task which decorates a 'Term' with values computed using the supplied 'RAlgebra' function. @@ -131,7 +131,7 @@ runTaskWithOptions options task = do -- | An effect describing high-level tasks to be performed. data Task output where Parse :: Parser term -> Blob -> Task term - Analyze :: Analysis.SomeAnalysis m result -> Task result + Analyze :: Analysis.Interpreter effects result function m => m effects result -> Task function Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> Task (Term f (Record (field ': fields))) Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2) Render :: Renderer input output -> input -> Task output @@ -140,7 +140,7 @@ data Task output where runTaskF :: Members '[Reader Options, Telemetry, Exc SomeException, IO] effs => Eff (Task ': effs) a -> Eff effs a runTaskF = interpret $ \ task -> case task of Parse parser blob -> runParser blob parser - Analyze analysis -> pure (Analysis.runSomeAnalysis analysis) + Analyze analysis -> pure (Analysis.runAnalysis analysis) Decorate algebra term -> pure (decoratorWithAlgebra algebra term) Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2) Render renderer input -> pure (renderer input) From 5293609c57b5876efaa1b3aba694d49985bf5b78 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 17:06:14 -0400 Subject: [PATCH 70/74] :fire: SomeAnalysis. --- src/Control/Abstract/Analysis.hs | 15 --------------- 1 file changed, 15 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index bb39a3058..7404376a8 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -4,8 +4,6 @@ module Control.Abstract.Analysis ( MonadAnalysis(..) , liftAnalyze , runAnalysis -, SomeAnalysis(..) -, runSomeAnalysis , module X , Subterm(..) , SubtermAlgebra @@ -60,16 +58,3 @@ runAnalysis :: ( Effectful m => m effects a -> function runAnalysis = interpret - - --- | An abstraction over analyses. -data SomeAnalysis m result where - SomeAnalysis :: ( Effectful m - , Interpreter effects a function m - ) - => m effects a - -> SomeAnalysis m function - --- | Run an abstracted analysis. -runSomeAnalysis :: SomeAnalysis m result -> result -runSomeAnalysis (SomeAnalysis a) = interpret a From 11ee69e8d21dffef590117e35771cc65ffb4637a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 17:06:25 -0400 Subject: [PATCH 71/74] :fire: redundant re-exports. --- src/Control/Abstract/Analysis.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 7404376a8..3cd920b59 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -5,8 +5,6 @@ module Control.Abstract.Analysis , liftAnalyze , runAnalysis , module X -, Subterm(..) -, SubtermAlgebra ) where import Control.Abstract.Addressable as X From 463f221955a9113843d478a6b2a1d38e5ee8265f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 17:06:42 -0400 Subject: [PATCH 72/74] :fire: a 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 3cd920b59..a631d264e 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, KindSignatures #-} +{-# LANGUAGE KindSignatures #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis module Control.Abstract.Analysis ( MonadAnalysis(..) From f264a605ed223d6de5a936574007e3daa278461e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 17:12:10 -0400 Subject: [PATCH 73/74] Fix up the specs. --- test/Analysis/Ruby/Spec.hs | 2 +- test/Analysis/TypeScript/Spec.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 245738ae9..5514f546c 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -30,7 +30,7 @@ spec = parallel $ do it "evaluates load with wrapper" $ do res <- evaluate "load-wrap.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo")))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo"))))))))) environment (snd res) `shouldBe` [ ("Object", addr 0) ] it "evaluates subclass" $ do diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 0bff99808..f2d4cee02 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -34,7 +34,7 @@ spec = parallel $ do it "fails exporting symbols not defined in the module" $ do v <- fst <$> evaluate "bad-export.ts" - v `shouldBe` Right (Right (Right (Right (Right (Right (Left (SomeExc $ ExportError "foo.ts" (Name "pip")))))))) + v `shouldBe` Right (Right (Right (Right (Right (Right (Right (Left (SomeExc (ExportError "foo.ts" (Name "pip")))))))))) it "evaluates early return statements" $ do res <- evaluate "early-return.ts" From 39e9dc84a62d45a2b276c4a4dd10d8af416b3a2e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Wed, 25 Apr 2018 17:34:43 -0400 Subject: [PATCH 74/74] =?UTF-8?q?Apply=20some=20=E2=80=9Chints,=E2=80=9D?= =?UTF-8?q?=20begrudgingly.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Collecting.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/ImportGraph.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 5374223df..b270e8b43 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -80,4 +80,4 @@ instance ( Interpreter effects result rest m , Ord location ) => Interpreter (Reader (Live location value) ': effects) result rest (Collecting m) where - interpret = interpret . runCollecting . raiseHandler (flip runReader mempty) + interpret = interpret . runCollecting . raiseHandler (`runReader` mempty) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index e171a6dd5..b9f0de2f0 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -57,4 +57,4 @@ instance ( Interpreter effects (result, Dead term) rest m , Ord term ) => Interpreter (State (Dead term) ': effects) result rest (DeadCode m) where - interpret = interpret . runDeadCode . raiseHandler (flip runState mempty) + interpret = interpret . runDeadCode . raiseHandler (`runState` mempty) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index fa4e0b5d9..7d7be3612 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -170,4 +170,4 @@ vertexToType Variable{} = "variable" instance Interpreter effects (result, ImportGraph) rest m => Interpreter (State ImportGraph ': effects) result rest (ImportGraphing m) where - interpret = interpret . runImportGraphing . raiseHandler (flip runState mempty) + interpret = interpret . runImportGraphing . raiseHandler (`runState` mempty)