From a57fd63da52ec46fb5656c307ceec90af6a6286b Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 23 Apr 2018 12:46:57 -0400 Subject: [PATCH 01/45] Add support for break and continue inside loops. Similar to @charliesome's implementation of return, we throw a non-resumable exception inside loop invocations, and handle these cases inside MonadValue's `loop` function. --- src/Analysis/Abstract/Evaluating.hs | 1 + src/Data/Abstract/Evaluatable.hs | 23 ++++++++++++++++------- src/Data/Abstract/Value.hs | 5 ++++- src/Data/Functor/Both.hs | 1 + src/Data/Syntax/Statement.hs | 11 +++++------ src/Semantic/Task.hs | 2 +- 6 files changed, 28 insertions(+), 15 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 944228e45..37dfa3502 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -33,6 +33,7 @@ deriving instance Member NonDet effects => Alternative (Evaluating location term -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects location term value = '[ Exc (ControlThrow value) + , Exc (LoopThrow value) , Resumable (EvalError value) , Resumable (ResolutionError value) , Resumable (LoadError term value) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 14e8a4eda..1630c2fac 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -4,10 +4,11 @@ module Data.Abstract.Evaluatable , MonadEvaluatable , Evaluatable(..) , Unspecialized(..) -, LoadError(..) -, EvalError(..) -, ResolutionError(..) , ControlThrow(..) +, EvalError(..) +, LoadError(..) +, LoopThrow(..) +, ResolutionError(..) , variable , evaluateTerm , evaluateModule @@ -15,6 +16,7 @@ module Data.Abstract.Evaluatable , evaluatePackage , evaluatePackageBody , throwLoadError +, throwLoop , throwEvalError , throwValueError , resolve @@ -56,17 +58,21 @@ type MonadEvaluatable location term value m = , MonadResume (ResolutionError value) m , MonadResume (AddressError location value) m , MonadExc (ControlThrow value) m + , MonadExc (LoopThrow value) m , MonadValue location value m , Recursive term , Reducer value (Cell location value) , Show location ) -data ControlThrow value where - Ret :: value -> ControlThrow value +data ControlThrow value + = Ret value + deriving (Eq, Show) -deriving instance Show value => Show (ControlThrow value) -deriving instance Eq value => Eq (ControlThrow value) +data LoopThrow value + = Brk value + | Con + deriving (Eq, Show) -- | An error thrown when we can't resolve a module from a qualified name. data ResolutionError value resume where @@ -134,6 +140,9 @@ throwLoadError = throwResumable throwEvalError :: MonadEvaluatable location term value m => EvalError value resume -> m resume throwEvalError = throwResumable +throwLoop :: MonadEvaluatable location term value m => LoopThrow value -> m a +throwLoop = throwException + data Unspecialized a b where Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index d56869e0f..ddb3fba21 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -337,4 +337,7 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value handleReturn :: ControlThrow (Value location) -> m (Value location) handleReturn (Ret v) = pure v - loop = fix + loop x = catchException (fix x) handleLoop where + handleLoop :: LoopThrow (Value location) -> m (Value location) + handleLoop (Brk v) = pure v + handleLoop Con = loop x diff --git a/src/Data/Functor/Both.hs b/src/Data/Functor/Both.hs index fb398b781..9ec907a4e 100644 --- a/src/Data/Functor/Both.hs +++ b/src/Data/Functor/Both.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fno-warn-orphans -funbox-strict-fields #-} module Data.Functor.Both ( Both diff --git a/src/Data/Syntax/Statement.hs b/src/Data/Syntax/Statement.hs index e2c6019d5..b517845c7 100644 --- a/src/Data/Syntax/Statement.hs +++ b/src/Data/Syntax/Statement.hs @@ -160,9 +160,8 @@ instance Eq1 Break where liftEq = genericLiftEq instance Ord1 Break where liftCompare = genericLiftCompare instance Show1 Break where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Break -instance Evaluatable Break - +instance Evaluatable Break where + eval (Break x) = throwLoop =<< Brk <$> subtermValue x newtype Continue a = Continue a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) @@ -171,9 +170,9 @@ instance Eq1 Continue where liftEq = genericLiftEq instance Ord1 Continue where liftCompare = genericLiftCompare instance Show1 Continue where liftShowsPrec = genericLiftShowsPrec --- TODO: Implement Eval instance for Continue -instance Evaluatable Continue - +instance Evaluatable Continue where + -- TODO: figure out what to do with the datum inside Continue. what can it represent? + eval (Continue _) = throwLoop Con newtype Retry a = Retry a deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1, Declarations1) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 4a2eed6ca..9dd1e8050 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -168,7 +168,7 @@ graphImports prelude package = analyze (Analysis.SomeAnalysis (withPrelude prelu asAnalysisForTypeOfPackage = const extractGraph result = case result of - (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))) withPrelude Nothing a = a From ab8dc613fd891576f437c19eac9360ae8285176f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 23 Apr 2018 13:09:32 -0400 Subject: [PATCH 02/45] Fix tests. --- test/Analysis/Python/Spec.hs | 4 ++-- test/Analysis/Ruby/Spec.hs | 8 ++++---- test/Analysis/TypeScript/Spec.hs | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/test/Analysis/Python/Spec.hs b/test/Analysis/Python/Spec.hs index 51a367f33..fee2db161 100644 --- a/test/Analysis/Python/Spec.hs +++ b/test/Analysis/Python/Spec.hs @@ -37,11 +37,11 @@ spec = parallel $ do it "subclasses" $ do v <- fst <$> evaluate "subclass.py" - v `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\"")))))))))) + v `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\""))))))))))) it "handles multiple inheritance left-to-right" $ do v <- fst <$> evaluate "multiple_inheritance.py" - v `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\"")))))))))) + v `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"foo!\""))))))))))) where ns n = Just . Latest . Just . injValue . Namespace n diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 45b9db269..1f9c3769e 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -33,7 +33,7 @@ spec = parallel $ do it "evaluates subclass" $ do res <- evaluate "subclass.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\""))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\"")))))))))) environment (snd res) `shouldBe` [ ("Bar", addr 6) , ("Foo", addr 3) , ("Object", addr 0) ] @@ -45,17 +45,17 @@ spec = parallel $ do it "evaluates modules" $ do res <- evaluate "modules.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\""))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\"")))))))))) environment (snd res) `shouldBe` [ ("Object", addr 0) , ("Bar", addr 3) ] it "evaluates early return statements" $ do res <- evaluate "early-return.rb" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Integer (Number.Integer 123)))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Integer (Number.Integer 123))))))))))) it "has prelude" $ do res <- fst <$> evaluate "preluded.rb" - res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\""))))))))) + res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (String "\"\"")))))))))) where ns n = Just . Latest . Just . injValue . Namespace n diff --git a/test/Analysis/TypeScript/Spec.hs b/test/Analysis/TypeScript/Spec.hs index 394559f73..81f6a9cd7 100644 --- a/test/Analysis/TypeScript/Spec.hs +++ b/test/Analysis/TypeScript/Spec.hs @@ -35,7 +35,7 @@ spec = parallel $ do it "evaluates early return statements" $ do res <- evaluate "early-return.ts" - fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Float (Number.Decimal 123.0)))))))))) + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Float (Number.Decimal 123.0))))))))))) where fixtures = "test/fixtures/typescript/analysis/" From 061b6852a8b2efbea64090eb4f6cf4ebf0690813 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 23 Apr 2018 13:14:52 -0400 Subject: [PATCH 03/45] Add test cases. --- test/Analysis/Ruby/Spec.hs | 8 ++++++++ test/fixtures/ruby/analysis/break.rb | 9 +++++++++ test/fixtures/ruby/analysis/next.rb | 12 ++++++++++++ 3 files changed, 29 insertions(+) create mode 100644 test/fixtures/ruby/analysis/break.rb create mode 100644 test/fixtures/ruby/analysis/next.rb diff --git a/test/Analysis/Ruby/Spec.hs b/test/Analysis/Ruby/Spec.hs index 1f9c3769e..7be7c6cd6 100644 --- a/test/Analysis/Ruby/Spec.hs +++ b/test/Analysis/Ruby/Spec.hs @@ -49,6 +49,14 @@ spec = parallel $ do environment (snd res) `shouldBe` [ ("Object", addr 0) , ("Bar", addr 3) ] + it "handles break correctly" $ do + res <- evaluate "break.rb" + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Integer (Number.Integer 3))))))))))) + + it "handles break correctly" $ do + res <- evaluate "next.rb" + fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Integer (Number.Integer 8))))))))))) + it "evaluates early return statements" $ do res <- evaluate "early-return.rb" fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (Right (Right (pure $ injValue (Value.Integer (Number.Integer 123))))))))))) diff --git a/test/fixtures/ruby/analysis/break.rb b/test/fixtures/ruby/analysis/break.rb new file mode 100644 index 000000000..2be1a6462 --- /dev/null +++ b/test/fixtures/ruby/analysis/break.rb @@ -0,0 +1,9 @@ +ii = 0 +while ii < 5 + ii += 1 + if ii == 3 + break + end +end + +ii diff --git a/test/fixtures/ruby/analysis/next.rb b/test/fixtures/ruby/analysis/next.rb new file mode 100644 index 000000000..d037a4e27 --- /dev/null +++ b/test/fixtures/ruby/analysis/next.rb @@ -0,0 +1,12 @@ +ii = 0 +jj = 0 +while ii < 5 + ii += 1 + jj += 1 + if (ii == 3) && (jj == 3) + ii = 0 + next + end +end + +jj From 276234ed0d7598589d8f6b06038b7cc46570026f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 23 Apr 2018 13:30:17 -0400 Subject: [PATCH 04/45] appease hlint --- 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 1630c2fac..29e4d0abd 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -65,7 +65,7 @@ type MonadEvaluatable location term value m = , Show location ) -data ControlThrow value +newtype ControlThrow value = Ret value deriving (Eq, Show) From 873091ed82c8602735241cbe5b7256306304aef4 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 23 Apr 2018 13:48:56 -0400 Subject: [PATCH 05/45] kill stray LANGUAGE pragma with which I was experimenting --- src/Data/Functor/Both.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Data/Functor/Both.hs b/src/Data/Functor/Both.hs index 9ec907a4e..fb398b781 100644 --- a/src/Data/Functor/Both.hs +++ b/src/Data/Functor/Both.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -fno-warn-orphans -funbox-strict-fields #-} module Data.Functor.Both ( Both From 09c21259a2d16f546b5453001051d81710ece83d Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Apr 2018 19:12:55 -0400 Subject: [PATCH 06/45] Parameterize all the typeclasses by the effect type. --- src/Analysis/Abstract/BadAddresses.hs | 18 +-- src/Analysis/Abstract/BadModuleResolutions.hs | 18 +-- src/Analysis/Abstract/BadValues.hs | 20 ++-- src/Analysis/Abstract/BadVariables.hs | 18 +-- src/Analysis/Abstract/Caching.hs | 34 +++--- src/Analysis/Abstract/Collecting.hs | 20 ++-- src/Analysis/Abstract/Dead.hs | 16 +-- src/Analysis/Abstract/Evaluating.hs | 14 +-- src/Analysis/Abstract/ImportGraph.hs | 35 +++--- src/Analysis/Abstract/Quiet.hs | 18 +-- src/Analysis/Abstract/Tracing.hs | 16 +-- src/Control/Abstract/Addressable.hs | 43 ++++--- src/Control/Abstract/Analysis.hs | 22 ++-- src/Control/Abstract/Evaluator.hs | 106 +++++++++--------- src/Control/Abstract/Value.hs | 96 ++++++++-------- src/Data/Abstract/Evaluatable.hs | 82 +++++++------- src/Data/Abstract/Located.hs | 4 +- src/Data/Abstract/Type.hs | 14 +-- src/Data/Abstract/Value.hs | 10 +- src/Language/Go/Syntax.hs | 2 +- src/Language/PHP/Syntax.hs | 6 +- src/Language/Python/Syntax.hs | 2 +- src/Language/Ruby/Syntax.hs | 10 +- src/Language/TypeScript/Syntax.hs | 10 +- src/Semantic/Util.hs | 2 +- 25 files changed, 317 insertions(+), 319 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index f485b2a01..6a64d8640 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -8,21 +8,21 @@ import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (BadAddresses m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadAddresses m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadAddresses m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadAddresses m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadAddresses m effects) +deriving instance MonadControl term effects m => MonadControl term effects (BadAddresses m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadAddresses m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadAddresses m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadAddresses m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) instance ( Effectful m , Member (Resumable (AddressError location value)) effects , Member (State (EvaluatingState location term value)) effects - , MonadAnalysis location term value (m effects) - , MonadValue location value (BadAddresses m effects) + , MonadAnalysis location term value effects m + , MonadValue location value effects (BadAddresses m) , Show location ) - => MonadAnalysis location term value (BadAddresses m effects) where - type Effects location term value (BadAddresses m effects) = Effects location term value (m effects) + => MonadAnalysis location term value effects (BadAddresses m) where + type Effects location term value (BadAddresses m) = 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 6e888ffec..d61693a56 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -9,21 +9,21 @@ import Prologue newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (BadModuleResolutions m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadModuleResolutions m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadModuleResolutions m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadModuleResolutions m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadModuleResolutions m effects) +deriving instance MonadControl term effects m => MonadControl term effects (BadModuleResolutions m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadModuleResolutions m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadModuleResolutions m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadModuleResolutions m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) instance ( Effectful m , Member (Resumable (ResolutionError value)) effects , Member (State (EvaluatingState location term value)) effects , Member (State [Name]) effects - , MonadAnalysis location term value (m effects) - , MonadValue location value (BadModuleResolutions m effects) + , MonadAnalysis location term value effects m + , MonadValue location value effects (BadModuleResolutions m) ) - => MonadAnalysis location term value (BadModuleResolutions m effects) where - type Effects location term value (BadModuleResolutions m effects) = State [Name] ': Effects location term value (m effects) + => MonadAnalysis location term value effects (BadModuleResolutions m) where + type Effects location term value (BadModuleResolutions m) = State [Name] ': 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 f4a026ccc..e7ae85fa6 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -3,7 +3,6 @@ module Analysis.Abstract.BadValues where import Control.Abstract.Analysis import Data.Abstract.Evaluatable -import Analysis.Abstract.Evaluating import Data.Abstract.Environment as Env import Prologue import Data.ByteString.Char8 (pack) @@ -11,21 +10,20 @@ import Data.ByteString.Char8 (pack) newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (BadValues m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadValues m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadValues m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadValues m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadValues m effects) +deriving instance MonadControl term effects m => MonadControl term effects (BadValues m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadValues m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadValues m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable 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 - , Member (State (EvaluatingState location term value)) effects , Member (State [Name]) effects - , MonadAnalysis location term value (m effects) - , MonadValue location value (BadValues m effects) + , MonadAnalysis location term value effects m + , MonadValue location value effects (BadValues m) ) - => MonadAnalysis location term value (BadValues m effects) where - type Effects location term value (BadValues m effects) = State [Name] ': Effects location term value (m effects) + => MonadAnalysis location term value effects (BadValues m) where + type Effects location term value (BadValues m) = State [Name] ': 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 1fa891778..8e96528b8 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -11,20 +11,20 @@ import Prologue newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (BadVariables m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (BadVariables m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (BadVariables m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (BadVariables m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (BadVariables m effects) +deriving instance MonadControl term effects m => MonadControl term effects (BadVariables m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadVariables m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadVariables m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadVariables m) +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 (m effects) - , MonadValue location value (BadVariables m effects) + , MonadAnalysis location term value effects m + , MonadValue location value effects (BadVariables m) ) - => MonadAnalysis location term value (BadVariables m effects) where - type Effects location term value (BadVariables m effects) = State [Name] ': Effects location term value (m effects) + => MonadAnalysis location term value effects (BadVariables m) where + type Effects location term value (BadVariables m) = State [Name] ': Effects location term value m analyzeTerm eval term = resume @(EvalError value) (liftAnalyze analyzeTerm eval term) ( \yield err -> do diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index f87ef40f7..5288152c4 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -22,36 +22,36 @@ type CachingEffects location term value effects newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (Caching m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Caching m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Caching m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Caching m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Caching m effects) +deriving instance MonadControl term effects m => MonadControl term effects (Caching m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Caching m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (Caching m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Caching m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons. -class MonadEvaluator location term value m => MonadCaching location term value m where +class MonadEvaluator location term value effects m => MonadCaching location term value effects m where -- | Look up the set of values for a given configuration in the in-cache. - consultOracle :: Configuration location term value -> m (Set (value, Heap location value)) + consultOracle :: Configuration location term value -> m effects (Set (value, Heap location value)) -- | Run an action with the given in-cache. - withOracle :: Cache location term value -> m a -> m a + withOracle :: Cache location term value -> m effects a -> m effects a -- | Look up the set of values for a given configuration in the out-cache. - lookupCache :: Configuration location term value -> m (Maybe (Set (value, Heap location value))) + lookupCache :: Configuration location term value -> m effects (Maybe (Set (value, Heap location value))) -- | Run an action, caching its result and 'Heap' under the given configuration. - caching :: Configuration location term value -> Set (value, Heap location value) -> m value -> m value + caching :: Configuration location term value -> Set (value, Heap location value) -> m effects value -> m effects value -- | Run an action starting from an empty out-cache, and return the out-cache afterwards. - isolateCache :: m a -> m (Cache location term value) + isolateCache :: m effects a -> m effects (Cache location term value) instance ( Effectful m , Members (CachingEffects location term value '[]) effects - , MonadEvaluator location term value (m effects) + , MonadEvaluator location term value effects m , Ord (Cell location value) , Ord location , Ord term , Ord value ) - => MonadCaching location term value (Caching m effects) where + => MonadCaching location term value effects (Caching m) where consultOracle configuration = raise (fromMaybe mempty . cacheLookup configuration <$> ask) withOracle cache = raise . local (const cache) . lower @@ -69,16 +69,16 @@ instance ( Alternative (m effects) , Corecursive term , Effectful m , Members (CachingEffects location term value '[]) effects - , MonadAnalysis location term value (m effects) + , MonadAnalysis location term value effects m , MonadFresh (m effects) , Ord (Cell location value) , Ord location , Ord term , Ord value ) - => MonadAnalysis location term value (Caching m effects) where + => 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 effects) = CachingEffects location term value (Effects location term value (m 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 @@ -121,5 +121,5 @@ converge f = loop loop x' -- | Nondeterministically write each of a collection of stores & return their associated results. -scatter :: (Alternative m, Foldable t, MonadEvaluator location term value m) => t (a, Heap location value) -> m a +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) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 92a3a155f..e28e91ccf 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -13,30 +13,30 @@ import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (Collecting m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Collecting m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Collecting m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Collecting m effects) +deriving instance MonadControl term effects m => MonadControl term effects (Collecting m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Collecting m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (Collecting m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Collecting m) instance ( Effectful m , Member (Reader (Live location value)) effects - , MonadEvaluator location term value (m effects) + , MonadEvaluator location term value effects m ) - => MonadEvaluator location term value (Collecting m effects) where + => MonadEvaluator location term value effects (Collecting m) where getConfiguration term = Configuration term <$> askRoots <*> getEnv <*> getHeap instance ( Effectful m , Foldable (Cell location) , Member (Reader (Live location value)) effects - , MonadAnalysis location term value (m effects) + , MonadAnalysis location term value effects m , Ord location , ValueRoots location value ) - => MonadAnalysis location term value (Collecting m effects) where - type Effects location term value (Collecting m effects) + => MonadAnalysis location term value effects (Collecting m) where + type Effects location term value (Collecting m) = Reader (Live location value) - ': Effects location term value (m effects) + ': Effects location term value m -- Small-step evaluation which garbage-collects any non-rooted addresses after evaluating each term. analyzeTerm recur term = do diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 4ff837fd0..a3b333063 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,11 +13,11 @@ import Prologue newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (DeadCode m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (DeadCode m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (DeadCode m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (DeadCode m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (DeadCode m effects) +deriving instance MonadControl term effects m => MonadControl term effects (DeadCode m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (DeadCode m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (DeadCode m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (DeadCode m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } @@ -42,12 +42,12 @@ instance ( Corecursive term , Effectful m , Foldable (Base term) , Member (State (Dead term)) effects - , MonadAnalysis location term value (m effects) + , MonadAnalysis location term value effects m , Ord term , Recursive term ) - => MonadAnalysis location term value (DeadCode m effects) where - type Effects location term value (DeadCode m effects) = State (Dead term) ': Effects location term value (m effects) + => 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) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 944228e45..a4b6663f7 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -103,7 +103,7 @@ localEvaluatingState lens f action = do v <$ lens .= original -instance Members '[Fail, State (EvaluatingState location term value)] effects => MonadControl term (Evaluating location term value effects) where +instance Members '[Fail, State (EvaluatingState location term value)] effects => MonadControl term effects (Evaluating location term value) where label term = do m <- view _jumps let i = IntMap.size m @@ -115,7 +115,7 @@ instance Members '[Fail, State (EvaluatingState location term value)] effects => instance Members '[ State (EvaluatingState location term value) , Reader (Environment location value) ] effects - => MonadEnvironment location value (Evaluating location term value effects) where + => MonadEnvironment location value effects (Evaluating location term value) where getEnv = view _environment putEnv = (_environment .=) withEnv s = localEvaluatingState _environment (const s) @@ -133,7 +133,7 @@ instance Members '[ State (EvaluatingState location term value) result <$ modifyEnv Env.pop instance Member (State (EvaluatingState location term value)) effects - => MonadHeap location value (Evaluating location term value effects) where + => MonadHeap location value effects (Evaluating location term value) where getHeap = view _heap putHeap = (_heap .=) @@ -142,7 +142,7 @@ instance Members '[ Reader (ModuleTable [Module term]) , Reader (SomeOrigin term) , Fail ] effects - => MonadModuleTable location term value (Evaluating location term value effects) where + => MonadModuleTable location term value effects (Evaluating location term value) where getModuleTable = view _modules putModuleTable = (_modules .=) @@ -157,15 +157,15 @@ instance Members '[ Reader (ModuleTable [Module term]) maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o instance Members (EvaluatingEffects location term value) effects - => MonadEvaluator location term value (Evaluating location term value effects) where + => MonadEvaluator location term value effects (Evaluating location term value) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap instance ( Corecursive term , Members (EvaluatingEffects location term value) effects , Recursive term ) - => MonadAnalysis location term value (Evaluating location term value effects) where - type Effects location term value (Evaluating location term value effects) = EvaluatingEffects location term value + => 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) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 1f44e71dc..eeefb8793 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -57,11 +57,11 @@ style = (defaultStyle vertexName) newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (ImportGraphing m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (ImportGraphing m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (ImportGraphing m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (ImportGraphing m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (ImportGraphing m effects) +deriving instance MonadControl term effects m => MonadControl term effects (ImportGraphing m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (ImportGraphing m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (ImportGraphing m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (ImportGraphing m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) instance ( Effectful m @@ -69,12 +69,12 @@ instance ( Effectful m , Member (Resumable (LoadError term value)) effects , Member (State ImportGraph) effects , Member Syntax.Identifier syntax - , MonadAnalysis (Located location term) term value (m effects) + , MonadAnalysis (Located location term) term value effects m , term ~ Term (Union syntax) ann , Show ann ) - => MonadAnalysis (Located location term) term value (ImportGraphing m effects) where - type Effects (Located location term) term value (ImportGraphing m effects) = State ImportGraph ': Effects (Located location term) term value (m effects) + => 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 @@ -102,10 +102,9 @@ moduleGraph = maybe empty (vertex . Module . BC.pack . modulePath) . withSomeOri -- | Add an edge from the current package to the passed vertex. packageInclusion :: forall m location term value effects - . ( Effectful m - , Member (Reader (SomeOrigin term)) effects + . ( Member (Reader (SomeOrigin term)) effects , Member (State ImportGraph) effects - , MonadEvaluator location term value (m effects) + , MonadEvaluator location term value effects m ) => Vertex -> ImportGraphing m effects () @@ -115,10 +114,9 @@ packageInclusion v = do -- | Add an edge from the current module to the passed vertex. moduleInclusion :: forall m location term value effects - . ( Effectful m - , Member (Reader (SomeOrigin term)) effects + . ( Member (Reader (SomeOrigin term)) effects , Member (State ImportGraph) effects - , MonadEvaluator location term value (m effects) + , MonadEvaluator location term value effects m ) => Vertex -> ImportGraphing m effects () @@ -127,10 +125,11 @@ moduleInclusion v = do appendGraph (moduleGraph @term o `connect` vertex v) -- | Add an edge from the passed variable name to the module it originated within. -variableDefinition :: ( Effectful m - , Member (State ImportGraph) effects - , MonadEvaluator (Located location term) term value (m effects) - ) => Name -> ImportGraphing m effects () +variableDefinition :: ( Member (State ImportGraph) effects + , MonadEvaluator (Located location term) term value effects m + ) + => Name + -> ImportGraphing m effects () variableDefinition name = do graph <- maybe empty (moduleGraph . origin . unAddress) <$> lookupEnv name appendGraph (vertex (Variable (unName name)) `connect` graph) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 1b7855cb8..3433a74a3 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -17,19 +17,19 @@ import Prologue newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (Quietly m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Quietly m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Quietly m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Quietly m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Quietly m effects) +deriving instance MonadControl term effects m => MonadControl term effects (Quietly m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Quietly m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (Quietly m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Quietly m) +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 (m effects) - , MonadValue location value (Quietly m effects) + , MonadAnalysis location term value effects m + , MonadValue location value effects (Quietly m) ) - => MonadAnalysis location term value (Quietly m effects) where - type Effects location term value (Quietly m effects) = Effects location term value (m effects) + => MonadAnalysis location term value effects (Quietly m) where + type Effects location term value (Quietly m) = 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 c5258b903..f28deac3c 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -16,21 +16,21 @@ import Prologue newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term (m effects) => MonadControl term (Tracing trace m effects) -deriving instance MonadEnvironment location value (m effects) => MonadEnvironment location value (Tracing trace m effects) -deriving instance MonadHeap location value (m effects) => MonadHeap location value (Tracing trace m effects) -deriving instance MonadModuleTable location term value (m effects) => MonadModuleTable location term value (Tracing trace m effects) -deriving instance MonadEvaluator location term value (m effects) => MonadEvaluator location term value (Tracing trace m effects) +deriving instance MonadControl term effects m => MonadControl term effects (Tracing trace m) +deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Tracing trace m) +deriving instance MonadHeap location value effects m => MonadHeap location value effects (Tracing trace m) +deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Tracing trace m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) instance ( Corecursive term , Effectful m , Member (Writer (trace (Configuration location term value))) effects - , MonadAnalysis location term value (m effects) + , MonadAnalysis location term value effects m , Ord location , Reducer (Configuration location term value) (trace (Configuration location term value)) ) - => MonadAnalysis location term value (Tracing trace m effects) where - type Effects location term value (Tracing trace m effects) = Writer (trace (Configuration location term value)) ': Effects location term value (m effects) + => 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) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 87b904de2..d8f616877 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeFamilies, UndecidableInstances, GADTs #-} +{-# LANGUAGE GADTs, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Addressable where import Control.Abstract.Evaluator @@ -12,28 +12,28 @@ import Prelude hiding (fail) import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. -class (MonadFresh m, Ord location) => MonadAddressable location m where - derefCell :: Address location value -> Cell location value -> m value +class (MonadFresh (m effects), Ord location) => MonadAddressable location (effects :: [* -> *]) m where + derefCell :: Address location value -> Cell location value -> m effects value - allocLoc :: Name -> m location + allocLoc :: Name -> m effects location -- | Look up or allocate an address for a 'Name'. -lookupOrAlloc :: ( MonadAddressable location m - , MonadEnvironment location value m +lookupOrAlloc :: ( MonadAddressable location effects m + , MonadEnvironment location value effects m ) => Name - -> m (Address location value) + -> m effects (Address location value) lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure -letrec :: ( MonadAddressable location m - , MonadEnvironment location value m - , MonadHeap location value m +letrec :: ( MonadAddressable location effects m + , MonadEnvironment location value effects m + , MonadHeap location value effects m , Reducer value (Cell location value) ) => Name - -> m value - -> m (value, Address location value) + -> m effects value + -> m effects (value, Address location value) letrec name body = do addr <- lookupOrAlloc name v <- localEnv (insert name addr) body @@ -41,12 +41,12 @@ letrec name body = do pure (v, addr) -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. -letrec' :: ( MonadAddressable location m - , MonadEnvironment location value m +letrec' :: ( MonadAddressable location effects m + , MonadEnvironment location value effects m ) => Name - -> (Address location value -> m value) - -> m value + -> (Address location value -> m effects value) + -> m effects value letrec' name body = do addr <- lookupOrAlloc name v <- localEnv id (body addr) @@ -55,20 +55,20 @@ letrec' name body = do -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (MonadFail m, MonadFresh m) => MonadAddressable Precise m where +instance (MonadFail (m effects), MonadFresh (m effects)) => MonadAddressable Precise effects m where derefCell addr = maybeM (uninitializedAddress addr) . unLatest allocLoc _ = Precise <$> fresh -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative m, MonadFresh m) => MonadAddressable Monovariant m where +instance (Alternative (m effects), MonadFresh (m effects)) => MonadAddressable Monovariant effects m where derefCell _ = foldMapA pure allocLoc = pure . Monovariant -- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized. -deref :: (MonadResume (AddressError location value) m, MonadAddressable location m, MonadHeap location value m) => Address location value -> m value +deref :: (MonadResume (AddressError location value) effects m, MonadAddressable location effects m, MonadHeap location value effects m) => Address location value -> m effects value deref addr = lookupHeap addr >>= maybe (throwAddressError $ UninitializedAddress addr) (derefCell addr) -alloc :: MonadAddressable location m => Name -> m (Address location value) +alloc :: MonadAddressable location effects m => Name -> m effects (Address location value) alloc = fmap Address . allocLoc -- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). @@ -86,6 +86,5 @@ instance Eq location => Eq1 (AddressError location value) where liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b -throwAddressError :: (MonadResume (AddressError location value) m) => AddressError location value resume -> m resume +throwAddressError :: (MonadResume (AddressError location value) effects m) => AddressError location value resume -> m effects resume throwAddressError = throwResumable - diff --git a/src/Control/Abstract/Analysis.hs b/src/Control/Abstract/Analysis.hs index 37ca69d60..06ccf6409 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE GADTs, PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis module Control.Abstract.Analysis ( MonadAnalysis(..) @@ -29,20 +29,20 @@ import Prologue -- | A 'Monad' in which one can evaluate some specific term type to some specific value type. -- -- This typeclass is left intentionally unconstrained to avoid circular dependencies between it and other typeclasses. -class MonadEvaluator location term value m => MonadAnalysis location term value m where +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 value)) -> m value) - -> (Base term (Subterm term (outer value)) -> m value) + analyzeTerm :: (Base term (Subterm term (outer effects value)) -> m effects value) + -> (Base term (Subterm term (outer effects value)) -> m effects value) -- | Analyze a module using the semantics of the current analysis. This should generally only be called by 'evaluateModule' and by definitions of 'analyzeModule' in instances for composite analyses. - analyzeModule :: (Module (Subterm term (outer value)) -> m value) - -> (Module (Subterm term (outer value)) -> m value) + analyzeModule :: (Module (Subterm term (outer effects value)) -> m effects value) + -> (Module (Subterm term (outer effects value)) -> m effects value) -- | Isolate the given action with an empty global environment and exports. - isolate :: m a -> m a + isolate :: m effects a -> m effects a isolate = withEnv mempty . withExports mempty @@ -57,8 +57,8 @@ liftAnalyze analyze recur term = coerce (analyze (coerceWith (sym Coercion) . r -- -- This enables us to refer to the analysis type as e.g. @Analysis1 (Analysis2 Evaluating) Term Value@ without explicitly mentioning its effects (which are inferred to be simply its 'Effects'). runAnalysis :: ( Effectful m - , Effects location term value (m effects) ~ effects - , MonadAnalysis location term value (m effects) + , Effects location term value m ~ effects + , MonadAnalysis location term value effects m , RunEffects effects a ) => m effects a @@ -69,8 +69,8 @@ runAnalysis = X.run -- | An abstraction over analyses. data SomeAnalysis m result where SomeAnalysis :: ( Effectful m - , effects ~ Effects location term value (m effects) - , MonadAnalysis location term value (m effects) + , effects ~ Effects location term value m + , MonadAnalysis location term value effects m , RunEffects effects a ) => m effects a diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 3b88a9590..261d4da1c 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, DataKinds, FunctionalDependencies, RankNTypes, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, RankNTypes, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator ( MonadEvaluator(..) , MonadEnvironment(..) @@ -39,161 +39,161 @@ import Prologue -- - environments binding names to addresses -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import -class ( MonadControl term m - , MonadEnvironment location value m - , MonadFail m - , MonadModuleTable location term value m - , MonadHeap location value m +class ( Effectful m + , MonadControl term effects m + , MonadEnvironment location value effects m + , MonadModuleTable location term value effects m + , MonadHeap location value effects m ) - => MonadEvaluator location term value m | m -> location, m -> term, m -> value where + => MonadEvaluator location term value (effects :: [* -> *]) m | m effects -> location term value where -- | Get the current 'Configuration' with a passed-in term. - getConfiguration :: Ord location => term -> m (Configuration location term value) + getConfiguration :: Ord location => term -> m effects (Configuration location term value) -- | A 'Monad' abstracting local and global environments. -class Monad m => MonadEnvironment location value m | m -> value, m -> location where +class Monad (m effects) => MonadEnvironment location value (effects :: [* -> *]) m | m effects -> value, m -> location where -- | Retrieve the environment. - getEnv :: m (Environment location value) + getEnv :: m effects (Environment location value) -- | Set the environment. - putEnv :: Environment location value -> m () + putEnv :: Environment location value -> m effects () -- | Sets the environment for the lifetime of the given action. - withEnv :: Environment location value -> m a -> m a + withEnv :: Environment location value -> m effects a -> m effects a -- | Retrieve the default environment. - defaultEnvironment :: m (Environment location value) + defaultEnvironment :: m effects (Environment location value) -- | Set the default environment for the lifetime of an action. -- Usually only invoked in a top-level evaluation function. - withDefaultEnvironment :: Environment location value -> m a -> m a + withDefaultEnvironment :: Environment location value -> m effects a -> m effects a -- | Get the global export state. - getExports :: m (Exports location value) + getExports :: m effects (Exports location value) -- | Set the global export state. - putExports :: Exports location value -> m () + putExports :: Exports location value -> m effects () -- | Sets the global export state for the lifetime of the given action. - withExports :: Exports location value -> m a -> m a + withExports :: Exports location value -> m effects a -> m effects a -- | Run an action with a locally-modified environment. - localEnv :: (Environment location value -> Environment location value) -> m a -> m a + localEnv :: (Environment location value -> Environment location value) -> m effects a -> m effects a -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. - lookupEnv :: Name -> m (Maybe (Address location value)) + lookupEnv :: Name -> m effects (Maybe (Address location value)) lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) -- | Look up a 'Name' in the environment, running an action with the resolved address (if any). - lookupWith :: (Address location value -> m a) -> Name -> m (Maybe a) + lookupWith :: (Address location value -> m effects a) -> Name -> m effects (Maybe a) lookupWith with name = do addr <- lookupEnv name maybe (pure Nothing) (fmap Just . with) addr -- | Run a computation in a new local environment. -localize :: MonadEnvironment location value m => m a -> m a +localize :: MonadEnvironment location value effects m => m effects a -> m effects a localize = localEnv id -- | Update the global environment. -modifyEnv :: MonadEnvironment location value m => (Environment location value -> Environment location value) -> m () +modifyEnv :: MonadEnvironment location value effects m => (Environment location value -> Environment location value) -> m effects () modifyEnv f = do env <- getEnv putEnv $! f env -- | Update the global export state. -modifyExports :: MonadEnvironment location value m => (Exports location value -> Exports location value) -> m () +modifyExports :: MonadEnvironment location value effects m => (Exports location value -> Exports location value) -> m effects () modifyExports f = do exports <- getExports putExports $! f exports -- | Add an export to the global export state. -addExport :: MonadEnvironment location value m => Name -> Name -> Maybe (Address location value) -> m () +addExport :: MonadEnvironment location value effects m => Name -> Name -> Maybe (Address location value) -> m effects () addExport name alias = modifyExports . Export.insert name alias -- | Obtain an environment that is the composition of the current and default environments. -- Useful for debugging. -fullEnvironment :: MonadEnvironment location value m => m (Environment location value) +fullEnvironment :: MonadEnvironment location value effects m => m effects (Environment location value) fullEnvironment = mappend <$> getEnv <*> defaultEnvironment -- | A 'Monad' abstracting a heap of values. -class Monad m => MonadHeap location value m | m -> value, m -> location where +class Monad (m effects) => MonadHeap location value (effects :: [* -> *]) m | m effects -> location value where -- | Retrieve the heap. - getHeap :: m (Heap location value) + getHeap :: m effects (Heap location value) -- | Set the heap. - putHeap :: Heap location value -> m () + putHeap :: Heap location value -> m effects () -- | Update the heap. -modifyHeap :: MonadHeap location value m => (Heap location value -> Heap location value) -> m () +modifyHeap :: MonadHeap location value effects m => (Heap location value -> Heap location value) -> m effects () modifyHeap f = do s <- getHeap putHeap $! f s -- | Look up the cell for the given 'Address' in the 'Heap'. -lookupHeap :: (MonadHeap location value m, Ord location) => Address location value -> m (Maybe (Cell location value)) +lookupHeap :: (MonadHeap location value effects m, Ord location) => Address location value -> m effects (Maybe (Cell location value)) lookupHeap = flip fmap getHeap . heapLookup -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord location - , MonadHeap location value m + , MonadHeap location value effects m , Reducer value (Cell location value) ) => Address location value -> value - -> m () + -> m effects () assign address = modifyHeap . heapInsert address -- | A 'Monad' abstracting tables of modules available for import. -class Monad m => MonadModuleTable location term value m | m -> location, m -> term, m -> value where +class Monad (m effects) => MonadModuleTable location term value (effects :: [* -> *]) m | m effects -> location term value where -- | Retrieve the table of evaluated modules. - getModuleTable :: m (ModuleTable (Environment location value, value)) + getModuleTable :: m effects (ModuleTable (Environment location value, value)) -- | Set the table of evaluated modules. - putModuleTable :: ModuleTable (Environment location value, value) -> m () + putModuleTable :: ModuleTable (Environment location value, value) -> m effects () -- | Retrieve the table of unevaluated modules. - askModuleTable :: m (ModuleTable [Module term]) + askModuleTable :: m effects (ModuleTable [Module term]) -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m a -> m a + localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m effects a -> m effects a -- | Retrieve the module load stack - getLoadStack :: m LoadStack + getLoadStack :: m effects LoadStack -- | Set the module load stack - putLoadStack :: LoadStack -> m () + putLoadStack :: LoadStack -> m effects () -- | Get the currently evaluating 'ModuleInfo'. - currentModule :: m ModuleInfo + currentModule :: m effects ModuleInfo -- | Update the evaluated module table. -modifyModuleTable :: MonadModuleTable location term value m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m () +modifyModuleTable :: MonadModuleTable location term value effects m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m effects () modifyModuleTable f = do table <- getModuleTable putModuleTable $! f table -- | Update the module load stack. -modifyLoadStack :: MonadModuleTable location term value m => (LoadStack -> LoadStack) -> m () +modifyLoadStack :: MonadModuleTable location term value effects m => (LoadStack -> LoadStack) -> m effects () modifyLoadStack f = do stack <- getLoadStack putLoadStack $! f stack -- | A 'Monad' abstracting jumps in imperative control. -class Monad m => MonadControl term m where +class Monad (m effects) => MonadControl term (effects :: [* -> *]) m where -- | Allocate a 'Label' for the given @term@. -- -- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms. - label :: term -> m Label + label :: term -> m effects Label -- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance). - goto :: Label -> m term + goto :: Label -> m effects term -- | 'Monad's which can throw exceptions of type @exc v@ which can be resumed with a value of type @v@. -class Monad m => MonadResume exc m where - throwResumable :: exc v -> m v - catchResumable :: m v -> (forall v1. exc v1 -> m v) -> m v +class Monad (m effects) => MonadResume exc (effects :: [* -> *]) m where + throwResumable :: exc v -> m effects v + catchResumable :: m effects v -> (forall v1. exc v1 -> m effects v) -> m effects v -instance (Effectful m1, Member (Resumable exc) effects, Monad (m1 effects)) => MonadResume exc (m1 effects) where +instance (Effectful m1, Member (Resumable exc) effects, Monad (m1 effects)) => MonadResume exc effects m1 where throwResumable = raise . Resumable.throwError catchResumable c f = raise (Resumable.catchError (lower c) (lower . f)) -class Monad m => MonadExc exc m where - throwException :: exc -> m v - catchException :: m v -> (exc -> m v) -> m v +class Monad (m effects) => MonadExc exc (effects :: [* -> *]) m where + throwException :: exc -> m effects v + catchException :: m effects v -> (exc -> m effects v) -> m effects v -instance (Effectful m1, Member (Exc exc) effects, Monad (m1 effects)) => MonadExc exc (m1 effects) where +instance (Effectful m1, Member (Exc exc) effects, Monad (m1 effects)) => MonadExc exc effects m1 where throwException = raise . Exception.throwError catchException c f = raise (Exception.catchError (lower c) (lower . f)) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 94bc80d1c..7859d5a6a 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -34,151 +34,151 @@ data Comparator -- | A 'Monad' abstracting the evaluation of (and under) binding constructs (functions, methods, etc). -- -- This allows us to abstract the choice of whether to evaluate under binders for different value types. -class (Monad m, Show value) => MonadValue location value m | m value -> location where +class (Monad (m effects), Show value) => MonadValue location value (effects :: [* -> *]) m | m effects value -> location where -- | Construct an abstract unit value. -- TODO: This might be the same as the empty tuple for some value types - unit :: m value + unit :: m effects value -- | Construct an abstract hole. - hole :: m value + hole :: m effects value -- | Construct an abstract integral value. - integer :: Prelude.Integer -> m value + integer :: Prelude.Integer -> m effects value -- | Lift a unary operator over a 'Num' to a function on 'value's. liftNumeric :: (forall a . Num a => a -> a) - -> (value -> m value) + -> (value -> m effects value) -- | Lift a pair of binary operators to a function on 'value's. -- You usually pass the same operator as both arguments, except in the cases where -- Haskell provides different functions for integral and fractional operations, such -- as division, exponentiation, and modulus. liftNumeric2 :: (forall a b. Number a -> Number b -> SomeNumber) - -> (value -> value -> m value) + -> (value -> value -> m effects value) -- | Lift a Comparator (usually wrapping a function like == or <=) to a function on values. - liftComparison :: Comparator -> (value -> value -> m value) + liftComparison :: Comparator -> (value -> value -> m effects value) -- | Lift a unary bitwise operator to values. This is usually 'complement'. liftBitwise :: (forall a . Bits a => a -> a) - -> (value -> m value) + -> (value -> m effects value) -- | Lift a binary bitwise operator to values. The Integral constraint is -- necessary to satisfy implementation details of Haskell left/right shift, -- but it's fine, since these are only ever operating on integral values. liftBitwise2 :: (forall a . (Integral a, Bits a) => a -> a -> a) - -> (value -> value -> m value) + -> (value -> value -> m effects value) -- | Construct an abstract boolean value. - boolean :: Bool -> m value + boolean :: Bool -> m effects value -- | Construct an abstract string value. - string :: ByteString -> m value + string :: ByteString -> m effects value -- | Construct a self-evaluating symbol value. -- TODO: Should these be interned in some table to provide stronger uniqueness guarantees? - symbol :: ByteString -> m value + symbol :: ByteString -> m effects value -- | Construct a floating-point value. - float :: Scientific -> m value + float :: Scientific -> m effects value -- | Construct a rational value. - rational :: Prelude.Rational -> m value + rational :: Prelude.Rational -> m effects value -- | Construct an N-ary tuple of multiple (possibly-disjoint) values - multiple :: [value] -> m value + multiple :: [value] -> m effects value -- | Construct an array of zero or more values. - array :: [value] -> m value + array :: [value] -> m effects value -- | Construct a key-value pair for use in a hash. - kvPair :: value -> value -> m value + kvPair :: value -> value -> m effects value -- | Extract the contents of a key-value pair as a tuple. - asPair :: value -> m (value, value) + asPair :: value -> m effects (value, value) -- | Construct a hash out of pairs. - hash :: [(value, value)] -> m value + hash :: [(value, value)] -> m effects value -- | Extract a 'ByteString' from a given value. - asString :: value -> m ByteString + asString :: value -> m effects ByteString -- | Eliminate boolean values. TODO: s/boolean/truthy - ifthenelse :: value -> m value -> m value -> m value + ifthenelse :: value -> m effects value -> m effects value -> m effects value -- | Extract a 'Bool' from a given value. - asBool :: value -> m Bool + asBool :: value -> m effects Bool -- | Construct the nil/null datatype. - null :: m value + null :: m effects value - isHole :: value -> m Bool + isHole :: value -> m effects Bool -- | Build a class value from a name and environment. klass :: Name -- ^ The new class's identifier -> [value] -- ^ A list of superclasses -> Environment location value -- ^ The environment to capture - -> m value + -> m effects value -- | Build a namespace value from a name and environment stack -- -- Namespaces model closures with monoidal environments. namespace :: Name -- ^ The namespace's identifier -> Environment location value -- ^ The environment to mappend - -> m value + -> m effects value -- | Extract the environment from any scoped object (e.g. classes, namespaces, etc). - scopedEnvironment :: value -> m (Environment location value) + scopedEnvironment :: value -> m effects (Environment location value) -- | Evaluate an abstraction (a binder like a lambda or method definition). - lambda :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value + lambda :: (FreeVariables term, MonadControl term effects m) => [Name] -> Subterm term (m effects value) -> m effects value -- | Evaluate an application (like a function call). - call :: value -> [m value] -> m value + call :: value -> [m effects value] -> m effects value -- | Primitive looping combinator, approximately equivalent to 'fix'. This should be used in place of direct recursion, as it allows abstraction over recursion. -- -- The function argument takes an action which recurs through the loop. - loop :: (m value -> m value) -> m value + loop :: (m effects value -> m effects value) -> m effects value -- | Attempt to extract a 'Prelude.Bool' from a given value. -forLoop :: (MonadEnvironment location value m, MonadValue location value m) - => m value -- ^ Initial statement - -> m value -- ^ Condition - -> m value -- ^ Increment/stepper - -> m value -- ^ Body - -> m value +forLoop :: (MonadEnvironment location value effects m, MonadValue location value effects m) + => m effects value -- ^ Initial statement + -> m effects value -- ^ Condition + -> m effects value -- ^ Increment/stepper + -> m effects value -- ^ Body + -> m effects value forLoop initial cond step body = localize (initial *> while cond (body *> step)) -- | The fundamental looping primitive, built on top of ifthenelse. -while :: MonadValue location value m - => m value - -> m value - -> m value +while :: MonadValue location value effects m + => m effects value + -> m effects value + -> m effects value while cond body = loop $ \ continue -> do this <- cond ifthenelse this (body *> continue) unit -- | Do-while loop, built on top of while. -doWhile :: MonadValue location value m - => m value - -> m value - -> m value +doWhile :: MonadValue location value effects m + => m effects value + -> m effects value + -> m effects value doWhile body cond = loop $ \ continue -> body *> do this <- cond ifthenelse this continue unit -makeNamespace :: ( MonadValue location value m - , MonadEnvironment location value m - , MonadHeap location value m +makeNamespace :: ( MonadValue location value effects m + , MonadEnvironment location value effects m + , MonadHeap location value effects m , Ord location , Reducer value (Cell location value) ) => Name -> Address location value -> [value] - -> m value + -> m effects value makeNamespace name addr supers = do superEnv <- mconcat <$> traverse scopedEnvironment supers namespaceEnv <- Env.head <$> getEnv diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 14e8a4eda..154a1d2aa 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, PolyKinds, UndecidableInstances #-} module Data.Abstract.Evaluatable ( module X , MonadEvaluatable @@ -27,6 +27,7 @@ module Data.Abstract.Evaluatable import Control.Abstract.Addressable as X import Control.Abstract.Analysis as X +import qualified Control.Monad.Effect.Exception as Exc import Data.Abstract.Address import Data.Abstract.Declarations as X import Data.Abstract.Environment as X @@ -43,20 +44,22 @@ import Data.Semigroup.Reducer hiding (unit) import Data.Term import Prologue -type MonadEvaluatable location term value m = - ( Evaluatable (Base term) +type MonadEvaluatable location term value (effects :: [* -> *]) m = + ( Declarations term + , Effectful m + , Evaluatable (Base term) , FreeVariables term - , Declarations term - , MonadAddressable location m - , MonadAnalysis location term value m - , MonadResume (Unspecialized value) m - , MonadResume (ValueError location value) m - , MonadResume (LoadError term value) m - , MonadResume (EvalError value) m - , MonadResume (ResolutionError value) m - , MonadResume (AddressError location value) m - , MonadExc (ControlThrow value) m - , MonadValue location value m + , Member (Resumable (Unspecialized value)) effects + , Member (Resumable (ValueError location value)) effects + , Member (Resumable (LoadError term value)) effects + , Member (Resumable (EvalError value)) effects + , Member (Resumable (ResolutionError value)) effects + , Member (Resumable (AddressError location value)) effects + , Member (Exc.Exc (ControlThrow value)) effects + , MonadAddressable location effects m + , MonadAnalysis location term value effects m + , MonadFail (m effects) + , MonadValue location value effects m , Recursive term , Reducer value (Cell location value) , Show location @@ -107,7 +110,7 @@ data EvalError value resume where -- | Look up and dereference the given 'Name', throwing an exception for free variables. -variable :: MonadEvaluatable location term value m => Name -> m value +variable :: MonadEvaluatable location term value effects m => Name -> m effects value variable name = lookupWith deref name >>= maybeM (throwResumable (FreeVariableError name)) deriving instance Eq (EvalError a b) @@ -125,13 +128,13 @@ instance Eq1 (EvalError term) where liftEq _ _ _ = False -throwValueError :: MonadEvaluatable location term value m => ValueError location value resume -> m resume +throwValueError :: MonadEvaluatable location term value effects m => ValueError location value resume -> m effects resume throwValueError = throwResumable -throwLoadError :: MonadEvaluatable location term value m => LoadError term value resume -> m resume +throwLoadError :: MonadEvaluatable location term value effects m => LoadError term value resume -> m effects resume throwLoadError = throwResumable -throwEvalError :: MonadEvaluatable location term value m => EvalError value resume -> m resume +throwEvalError :: MonadEvaluatable location term value effects m => EvalError value resume -> m effects resume throwEvalError = throwResumable data Unspecialized a b where @@ -147,9 +150,9 @@ instance Show1 (Unspecialized a) where -- | The 'Evaluatable' class defines the necessary interface for a term to be evaluated. While a default definition of 'eval' is given, instances with computational content must implement 'eval' to perform their small-step operational semantics. class Evaluatable constr where - eval :: MonadEvaluatable location term value m - => SubtermAlgebra constr term (m value) - default eval :: (MonadResume (Unspecialized value) m, Show1 constr) => SubtermAlgebra constr term (m value) + eval :: MonadEvaluatable location term value effects m + => SubtermAlgebra constr term (m effects value) + default eval :: (MonadResume (Unspecialized value) (effects :: [* -> *]) m, Show1 constr) => SubtermAlgebra constr term (m effects value) eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "")) @@ -173,9 +176,9 @@ instance Evaluatable [] where eval = maybe unit (runApp . foldMap1 (App . subtermValue)) . nonEmpty -- Resolve a list of module paths to a possible module table entry. -resolve :: MonadEvaluatable location term value m +resolve :: MonadEvaluatable location term value effects m => [FilePath] - -> m (Maybe ModulePath) + -> m effects (Maybe ModulePath) resolve names = do tbl <- askModuleTable pure $ find (`ModuleTable.member` tbl) names @@ -183,25 +186,25 @@ resolve names = do traceResolve :: (Show a, Show b) => a -> b -> c -> c traceResolve name path = trace ("resolved " <> show name <> " -> " <> show path) -listModulesInDir :: MonadEvaluatable location term value m +listModulesInDir :: MonadEvaluatable location term value effects m => FilePath - -> m [ModulePath] + -> m effects [ModulePath] listModulesInDir dir = ModuleTable.modulePathsInDir dir <$> askModuleTable -- | Require/import another module by name and return it's environment and value. -- -- Looks up the term's name in the cache of evaluated modules first, returns if found, otherwise loads/evaluates the module. -require :: MonadEvaluatable location term value m +require :: MonadEvaluatable location term value effects m => ModulePath - -> m (Environment location value, value) + -> m effects (Environment location value, value) require name = getModuleTable >>= maybeM (load name) . ModuleTable.lookup name -- | Load another module by name and return it's environment and value. -- -- Always loads/evaluates. -load :: MonadEvaluatable location term value m +load :: MonadEvaluatable location term value effects m => ModulePath - -> m (Environment location value, value) + -> m effects (Environment location value, value) load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= evalAndCache where notFound = throwLoadError (LoadError name) @@ -241,36 +244,35 @@ load name = askModuleTable >>= maybeM notFound . ModuleTable.lookup name >>= eva -- | Evaluate a term to a value using the semantics of the current analysis. -- -- This should always be called when e.g. evaluating the bodies of closures instead of explicitly folding either 'eval' or 'analyzeTerm' over subterms, except in 'MonadAnalysis' instances themselves. On the other hand, top-level evaluation should be performed using 'evaluateModule'. -evaluateTerm :: MonadEvaluatable location term value m +evaluateTerm :: MonadEvaluatable location term value effects m => term - -> m value + -> m effects value evaluateTerm = foldSubterms (analyzeTerm eval) -- | Evaluate a (root-level) term to a value using the semantics of the current analysis. This should be used to evaluate single-term programs, or (via 'evaluateModules') the entry point of multi-term programs. -evaluateModule :: MonadEvaluatable location term value m +evaluateModule :: MonadEvaluatable location term value effects m => Module term - -> m value + -> m effects value evaluateModule m = analyzeModule (subtermValue . moduleBody) (fmap (Subterm <*> evaluateTerm) m) -- | Evaluate with a list of modules in scope, taking the head module as the entry point. -evaluateModules :: MonadEvaluatable location term value m +evaluateModules :: MonadEvaluatable location term value effects m => [Module term] - -> m value + -> m effects value evaluateModules = fmap Prelude.head . evaluatePackageBody . Package.fromModules -- | Evaluate a given package. -evaluatePackage :: ( Effectful m - , Member (Reader (SomeOrigin term)) effects - , MonadEvaluatable location term value (m effects) +evaluatePackage :: ( Member (Reader (SomeOrigin term)) effects + , MonadEvaluatable location term value effects m ) => Package term -> m effects [value] evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBody p)) -- | Evaluate a given package body (module table and entry points). -evaluatePackageBody :: MonadEvaluatable location term value m +evaluatePackageBody :: MonadEvaluatable location term value effects m => PackageBody term - -> m [value] + -> m effects [value] evaluatePackageBody body = localModuleTable (<> packageModules body) (traverse evaluateEntryPoint (ModuleTable.toPairs (packageEntryPoints body))) where evaluateEntryPoint (m, sym) = do diff --git a/src/Data/Abstract/Located.hs b/src/Data/Abstract/Located.hs index 7414f3041..fa2f367f3 100644 --- a/src/Data/Abstract/Located.hs +++ b/src/Data/Abstract/Located.hs @@ -19,10 +19,10 @@ instance (Location location, Ord (Base term ())) => Location (Located location t instance ( Effectful m , Member (Reader (SomeOrigin term)) effects - , MonadAddressable location (m effects) + , MonadAddressable location effects m , Ord (Base term ()) ) - => MonadAddressable (Located location term) (m effects) where + => MonadAddressable (Located location term) effects m where derefCell (Address (Located loc _)) = derefCell (Address loc) allocLoc name = Located <$> allocLoc name <*> raise ask diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 3928f08c1..9e00e7d29 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -52,15 +52,15 @@ instance Ord location => ValueRoots location Type where -- | Discard the value arguments (if any), constructing a 'Type' instead. -instance ( Alternative m - , MonadAddressable location m - , MonadEnvironment location Type m - , MonadFail m - , MonadFresh m - , MonadHeap location Type m +instance ( Alternative (m effects) + , MonadAddressable location effects m + , MonadEnvironment location Type effects m + , MonadFail (m effects) + , MonadFresh (m effects) + , MonadHeap location Type effects m , Reducer Type (Cell location Type) ) - => MonadValue location Type m where + => MonadValue location Type effects m where lambda names (Subterm _ body) = do (env, tvars) <- foldr (\ name rest -> do a <- alloc name diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index d56869e0f..dab006ec3 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -198,7 +198,7 @@ instance Ord location => ValueRoots location (Value location) where -- | Construct a 'Value' wrapping the value arguments (if any). -instance forall location term m. (Monad m, MonadEvaluatable location term (Value location) m) => MonadValue location (Value location) m where +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 @@ -277,7 +277,7 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value | otherwise = throwValueError (Numeric2Error left right) where -- Dispatch whatever's contained inside a 'Number.SomeNumber' to its appropriate 'MonadValue' ctor - specialize :: MonadValue location value m => Number.SomeNumber -> m value + specialize :: MonadValue location value effects m => Number.SomeNumber -> m effects value specialize (Number.SomeNumber (Number.Integer i)) = integer i specialize (Number.SomeNumber (Number.Ratio r)) = rational r specialize (Number.SomeNumber (Number.Decimal d)) = float d @@ -295,7 +295,7 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value where -- Explicit type signature is necessary here because we're passing all sorts of things -- to these comparison functions. - go :: (Ord a, MonadValue location value m) => a -> a -> m value + go :: (Ord a, MonadValue location value effects m) => a -> a -> m effects value go l r = case comparator of Concrete f -> boolean (f l r) Generalized -> integer (orderingToInt (compare l r)) @@ -331,10 +331,10 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value localEnv (mappend bindings) (evalClosure label) Nothing -> throwValueError (CallError op) where - evalClosure :: Label -> m (Value location) + evalClosure :: Label -> m effects (Value location) evalClosure lab = catchException (goto lab >>= evaluateTerm) handleReturn - handleReturn :: ControlThrow (Value location) -> m (Value location) + handleReturn :: ControlThrow (Value location) -> m effects (Value location) handleReturn (Ret v) = pure v loop = fix diff --git a/src/Language/Go/Syntax.hs b/src/Language/Go/Syntax.hs index 70283df16..93c7c876e 100644 --- a/src/Language/Go/Syntax.hs +++ b/src/Language/Go/Syntax.hs @@ -22,7 +22,7 @@ defaultAlias :: ImportPath -> Name defaultAlias = name . BC.pack . takeFileName . unPath -- TODO: need to delineate between relative and absolute Go imports -resolveGoImport :: MonadEvaluatable location term value m => FilePath -> m [ModulePath] +resolveGoImport :: MonadEvaluatable location term value effects m => FilePath -> m effects [ModulePath] resolveGoImport relImportPath = do ModuleInfo{..} <- currentModule let relRootDir = takeDirectory modulePath diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index 088413995..b7e5a6c7f 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -34,13 +34,13 @@ instance Evaluatable VariableName -- file, the complete contents of the included file are treated as though it -- were defined inside that function. -resolvePHPName :: MonadEvaluatable location term value m => ByteString -> m ModulePath +resolvePHPName :: MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath resolvePHPName n = resolve [name] >>= maybeFail notFound where name = toName n notFound = "Unable to resolve: " <> name toName = BC.unpack . dropRelativePrefix . stripQuotes -doInclude :: MonadEvaluatable location term value m => Subterm t (m value) -> m value +doInclude :: MonadEvaluatable location term value effects m => Subterm t (m effects value) -> m effects value doInclude pathTerm = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name @@ -48,7 +48,7 @@ doInclude pathTerm = do modifyEnv (mappend importedEnv) pure v -doIncludeOnce :: MonadEvaluatable location term value m => Subterm t (m value) -> m value +doIncludeOnce :: MonadEvaluatable location term value effects m => Subterm t (m effects value) -> m effects value doIncludeOnce pathTerm = do name <- subtermValue pathTerm >>= asString path <- resolvePHPName name diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 245f06557..11edb021a 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -51,7 +51,7 @@ relativeQualifiedName prefix paths = RelativeQualifiedName (BC.unpack prefix) (J -- Subsequent imports of `parent.two` or `parent.three` will execute -- `parent/two/__init__.py` and -- `parent/three/__init__.py` respectively. -resolvePythonModules :: MonadEvaluatable location term value m => QualifiedName -> m (NonEmpty ModulePath) +resolvePythonModules :: MonadEvaluatable location term value effects m => QualifiedName -> m effects (NonEmpty ModulePath) resolvePythonModules q = do relRootDir <- rootDir q <$> currentModule for (moduleNames q) $ \name -> do diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index cea8d57a9..7ae5f525f 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -16,14 +16,14 @@ import System.FilePath.Posix -- TODO: Fully sort out ruby require/load mechanics -- -- require "json" -resolveRubyName :: forall value term location m. MonadEvaluatable location term value m => ByteString -> m ModulePath +resolveRubyName :: forall value term location effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath resolveRubyName name = do let name' = cleanNameOrPath name modulePath <- resolve [name' <.> "rb"] maybe (throwResumable @(ResolutionError value) $ RubyError name') pure modulePath -- load "/root/src/file.rb" -resolveRubyPath :: forall value term location m. MonadEvaluatable location term value m => ByteString -> m ModulePath +resolveRubyPath :: forall value term location effects m. MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath resolveRubyPath path = do let name' = cleanNameOrPath path modulePath <- resolve [name'] @@ -68,9 +68,9 @@ instance Evaluatable Require where modifyEnv (`mergeNewer` importedEnv) pure v -- Returns True if the file was loaded, False if it was already loaded. http://ruby-doc.org/core-2.5.0/Kernel.html#method-i-require -doRequire :: MonadEvaluatable location term value m +doRequire :: MonadEvaluatable location term value effects m => ModulePath - -> m (Environment location value, value) + -> m effects (Environment location value, value) doRequire name = do moduleTable <- getModuleTable case ModuleTable.lookup name moduleTable of @@ -95,7 +95,7 @@ instance Evaluatable Load where doLoad path shouldWrap eval (Load _) = fail "invalid argument supplied to load, path is required" -doLoad :: MonadEvaluatable location term value m => ByteString -> Bool -> m value +doLoad :: MonadEvaluatable location term value effects m => ByteString -> Bool -> m effects value doLoad path shouldWrap = do path' <- resolveRubyPath path (importedEnv, _) <- traceResolve path path' $ isolate (load path') diff --git a/src/Language/TypeScript/Syntax.hs b/src/Language/TypeScript/Syntax.hs index 7596f8d98..82a5bb4b3 100644 --- a/src/Language/TypeScript/Syntax.hs +++ b/src/Language/TypeScript/Syntax.hs @@ -31,7 +31,7 @@ toName = FV.name . BC.pack . unPath -- Node.js resolution algorithm: https://nodejs.org/api/modules.html#modules_all_together -- TypeScript has a couple of different strategies, but the main one mimics Node.js. -resolveWithNodejsStrategy :: forall value term location m. MonadEvaluatable location term value m => ImportPath -> [String] -> m ModulePath +resolveWithNodejsStrategy :: MonadEvaluatable location term value effects m => ImportPath -> [String] -> m effects ModulePath resolveWithNodejsStrategy (ImportPath path Relative) exts = resolveRelativePath path exts resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativePath path exts @@ -42,7 +42,7 @@ resolveWithNodejsStrategy (ImportPath path NonRelative) exts = resolveNonRelativ -- /root/src/moduleB.ts -- /root/src/moduleB/package.json (if it specifies a "types" property) -- /root/src/moduleB/index.ts -resolveRelativePath :: forall value term location m. MonadEvaluatable location term value m => FilePath -> [String] -> m ModulePath +resolveRelativePath :: forall value term location effects m. MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects ModulePath resolveRelativePath relImportPath exts = do ModuleInfo{..} <- currentModule let relRootDir = takeDirectory modulePath @@ -61,7 +61,7 @@ resolveRelativePath relImportPath exts = do -- -- /root/node_modules/moduleB.ts, etc -- /node_modules/moduleB.ts, etc -resolveNonRelativePath :: forall value term location m. MonadEvaluatable location term value m => FilePath -> [String] -> m ModulePath +resolveNonRelativePath :: forall value term location effects m. MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects ModulePath resolveNonRelativePath name exts = do ModuleInfo{..} <- currentModule go "." modulePath mempty @@ -76,7 +76,7 @@ resolveNonRelativePath name exts = do Right m -> traceResolve name m $ pure m notFound _ = throwResumable @(ResolutionError value) $ TypeScriptError name -resolveTSModule :: MonadEvaluatable location term value m => FilePath -> [String] -> m (Either [FilePath] ModulePath) +resolveTSModule :: MonadEvaluatable location term value effects m => FilePath -> [String] -> m effects (Either [FilePath] ModulePath) resolveTSModule path exts = maybe (Left searchPaths) Right <$> resolve searchPaths where searchPaths = ((path <.>) <$> exts) @@ -91,7 +91,7 @@ typescriptExtensions = ["ts", "tsx", "d.ts"] javascriptExtensions :: [String] javascriptExtensions = ["js"] -evalRequire :: MonadEvaluatable location term value m => ModulePath -> Name -> m value +evalRequire :: MonadEvaluatable location term value effects m => ModulePath -> Name -> m effects value evalRequire modulePath alias = letrec' alias $ \addr -> do (importedEnv, _) <- isolate (require modulePath) modifyEnv (mappend importedEnv) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index ca020feb0..433c3c36f 100644 --- a/src/Semantic/Util.hs +++ b/src/Semantic/Util.hs @@ -91,7 +91,7 @@ type ImportGraphingWithHoles term = ImportGraphing (EvaluatingWithHoles term) -- TODO: Remove this by exporting EvaluatingEffects runEvaluating :: forall term effects a. - ( Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise) effects) ~ effects + ( Effects Precise term (Value Precise) (Evaluating Precise term (Value Precise)) ~ effects , Corecursive term , Recursive term ) => Evaluating Precise term (Value Precise) effects a From 7e3cad0783d5203aeedf1ccc4a02896f822a6f3b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Apr 2018 19:13:17 -0400 Subject: [PATCH 07/45] :fire: some PolyKinds. --- 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 06ccf6409..7e6c60b2b 100644 --- a/src/Control/Abstract/Analysis.hs +++ b/src/Control/Abstract/Analysis.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GADTs, PolyKinds, RankNTypes, ScopedTypeVariables, TypeFamilies #-} +{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} {-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For runAnalysis module Control.Abstract.Analysis ( MonadAnalysis(..) From 9ca80fe9330ef97d8525c35a6a1a0a72606e604d Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 23 Apr 2018 19:31:56 -0400 Subject: [PATCH 08/45] Merge cruft + rename ControlThrow --- src/Analysis/Abstract/Evaluating.hs | 2 +- src/Data/Abstract/Evaluatable.hs | 6 +++--- src/Data/Abstract/Value.hs | 2 +- src/Semantic/Graph.hs | 2 +- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 37dfa3502..af17d95f9 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -32,7 +32,7 @@ deriving instance Member NonDet effects => Alternative (Evaluating location term -- | Effects necessary for evaluating (whether concrete or abstract). type EvaluatingEffects location term value - = '[ Exc (ControlThrow value) + = '[ Exc (ReturnThrow value) , Exc (LoopThrow value) , Resumable (EvalError value) , Resumable (ResolutionError value) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 96ac0f6b7..e8fa87efd 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -4,7 +4,7 @@ module Data.Abstract.Evaluatable , MonadEvaluatable , Evaluatable(..) , Unspecialized(..) -, ControlThrow(..) +, ReturnThrow(..) , EvalError(..) , LoadError(..) , LoopThrow(..) @@ -56,7 +56,7 @@ type MonadEvaluatable location term value m = , MonadResume (EvalError value) m , MonadResume (ResolutionError value) m , MonadResume (AddressError location value) m - , MonadExc (ControlThrow value) m + , MonadExc (ReturnThrow value) m , MonadExc (LoopThrow value) m , MonadValue location value m , Recursive term @@ -64,7 +64,7 @@ type MonadEvaluatable location term value m = , Show location ) -newtype ControlThrow value +newtype ReturnThrow value = Ret value deriving (Eq, Show) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index ddb3fba21..a45a67f20 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -334,7 +334,7 @@ instance forall location term m. (Monad m, MonadEvaluatable location term (Value evalClosure :: Label -> m (Value location) evalClosure lab = catchException (goto lab >>= evaluateTerm) handleReturn - handleReturn :: ControlThrow (Value location) -> m (Value location) + handleReturn :: ReturnThrow (Value location) -> m (Value location) handleReturn (Ret v) = pure v loop x = catchException (fix x) handleLoop where diff --git a/src/Semantic/Graph.hs b/src/Semantic/Graph.hs index 89e63e218..93c37d301 100644 --- a/src/Semantic/Graph.hs +++ b/src/Semantic/Graph.hs @@ -93,5 +93,5 @@ graphImports package = analyze (Analysis.SomeAnalysis (Analysis.evaluatePackage asAnalysisForTypeOfPackage = const extractGraph result = case result of - (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 ac46e338f9f04da945b76769f640d1f954e98fe8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Mon, 23 Apr 2018 19:38:21 -0400 Subject: [PATCH 09/45] :fire: MonadExc & MonadResume. --- src/Control/Abstract/Addressable.hs | 10 ++++++---- src/Control/Abstract/Evaluator.hs | 25 +++++++++---------------- src/Data/Abstract/Evaluatable.hs | 2 +- 3 files changed, 16 insertions(+), 21 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index d8f616877..dbd265708 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -3,7 +3,9 @@ module Control.Abstract.Addressable where import Control.Abstract.Evaluator import Control.Applicative +import Control.Effect import Control.Effect.Fresh +import Control.Monad.Effect.Resumable as Eff import Data.Abstract.Address import Data.Abstract.Environment (insert) import Data.Abstract.FreeVariables @@ -65,8 +67,8 @@ instance (Alternative (m effects), MonadFresh (m effects)) => MonadAddressable M allocLoc = pure . Monovariant -- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized. -deref :: (MonadResume (AddressError location value) effects m, MonadAddressable location effects m, MonadHeap location value effects m) => Address location value -> m effects value -deref addr = lookupHeap addr >>= maybe (throwAddressError $ UninitializedAddress addr) (derefCell addr) +deref :: (Effectful m, Member (Resumable (AddressError location value)) effects, MonadAddressable location effects m, MonadHeap location value effects m) => Address location value -> m effects value +deref addr = lookupHeap addr >>= maybe (throwAddressError (UninitializedAddress addr)) (derefCell addr) alloc :: MonadAddressable location effects m => Name -> m effects (Address location value) alloc = fmap Address . allocLoc @@ -86,5 +88,5 @@ instance Eq location => Eq1 (AddressError location value) where liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b -throwAddressError :: (MonadResume (AddressError location value) effects m) => AddressError location value resume -> m effects resume -throwAddressError = throwResumable +throwAddressError :: (Effectful m, Member (Resumable (AddressError location value)) effects) => AddressError location value resume -> m effects resume +throwAddressError = raise . Eff.throwError diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 261d4da1c..36ca386c4 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -15,8 +15,9 @@ module Control.Abstract.Evaluator , modifyModuleTable , modifyLoadStack , MonadControl(..) - , MonadResume(..) - , MonadExc(..) + , throwResumable + , throwException + , catchException ) where import Control.Effect @@ -181,19 +182,11 @@ class Monad (m effects) => MonadControl term (effects :: [* -> *]) m where goto :: Label -> m effects term --- | 'Monad's which can throw exceptions of type @exc v@ which can be resumed with a value of type @v@. -class Monad (m effects) => MonadResume exc (effects :: [* -> *]) m where - throwResumable :: exc v -> m effects v - catchResumable :: m effects v -> (forall v1. exc v1 -> m effects v) -> m effects v +throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v +throwResumable = raise . Resumable.throwError -instance (Effectful m1, Member (Resumable exc) effects, Monad (m1 effects)) => MonadResume exc effects m1 where - throwResumable = raise . Resumable.throwError - catchResumable c f = raise (Resumable.catchError (lower c) (lower . f)) +throwException :: (Member (Exc exc) effects, Effectful m) => exc -> m effects a +throwException = raise . Exception.throwError -class Monad (m effects) => MonadExc exc (effects :: [* -> *]) m where - throwException :: exc -> m effects v - catchException :: m effects v -> (exc -> m effects v) -> m effects v - -instance (Effectful m1, Member (Exc exc) effects, Monad (m1 effects)) => MonadExc exc effects m1 where - throwException = raise . Exception.throwError - catchException c f = raise (Exception.catchError (lower c) (lower . f)) +catchException :: (Member (Exc exc) effects, Effectful m) => m effects v -> (exc -> m effects v) -> m effects v +catchException action handler = raise (lower action `Exception.catchError` (lower . handler)) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 154a1d2aa..fd2dc2bbb 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -152,7 +152,7 @@ instance Show1 (Unspecialized a) where class Evaluatable constr where eval :: MonadEvaluatable location term value effects m => SubtermAlgebra constr term (m effects value) - default eval :: (MonadResume (Unspecialized value) (effects :: [* -> *]) m, Show1 constr) => SubtermAlgebra constr term (m effects value) + default eval :: (MonadEvaluatable location term value effects m, Show1 constr) => SubtermAlgebra constr term (m effects value) eval expr = throwResumable (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr "")) From 47ba9a6d2b5e0f435f4804fdabbed62f7f4d5dd4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:00:37 -0400 Subject: [PATCH 10/45] :fire: a couple of dependencies on EvaluatingState. --- src/Analysis/Abstract/BadAddresses.hs | 2 -- src/Analysis/Abstract/BadModuleResolutions.hs | 2 -- 2 files changed, 4 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 6a64d8640..ce385f407 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 Analysis.Abstract.Evaluating import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) @@ -16,7 +15,6 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluat instance ( Effectful m , Member (Resumable (AddressError location value)) effects - , Member (State (EvaluatingState location term value)) effects , MonadAnalysis location term value effects m , MonadValue location value effects (BadAddresses m) , Show location diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index d61693a56..84105af8b 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -3,7 +3,6 @@ module Analysis.Abstract.BadModuleResolutions where import Control.Abstract.Analysis import Data.Abstract.Evaluatable -import Analysis.Abstract.Evaluating import Prologue newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) @@ -17,7 +16,6 @@ deriving instance MonadEvaluator location term value effects m => MonadEvaluat instance ( Effectful m , Member (Resumable (ResolutionError value)) effects - , Member (State (EvaluatingState location term value)) effects , Member (State [Name]) effects , MonadAnalysis location term value effects m , MonadValue location value effects (BadModuleResolutions m) From 489d09d7b2904b93098d2afddeeb9d5d7566b12a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:06:49 -0400 Subject: [PATCH 11/45] Document the exported exception functions. --- src/Control/Abstract/Evaluator.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 36ca386c4..13018c584 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -15,6 +15,7 @@ module Control.Abstract.Evaluator , modifyModuleTable , modifyLoadStack , MonadControl(..) + -- Exceptions , throwResumable , throwException , catchException From ed8bfe488b7159b37e544651979dbc9bbad6b28e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:10:17 -0400 Subject: [PATCH 12/45] Sort the language extensions around a little. --- src/Data/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index dab006ec3..2ddd84987 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, UndecidableInstances, ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables, TypeFamilies, TypeOperators, UndecidableInstances #-} module Data.Abstract.Value where import Control.Abstract.Analysis From 584f3a7fc893def8c416d2d31c8b1ed426242210 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:12:37 -0400 Subject: [PATCH 13/45] Sort the membership constraints. --- 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 fd2dc2bbb..88e70a8c2 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -49,13 +49,13 @@ type MonadEvaluatable location term value (effects :: [* -> *]) m = , Effectful m , Evaluatable (Base term) , FreeVariables term + , Member (Exc.Exc (ControlThrow value)) effects , Member (Resumable (Unspecialized value)) effects , Member (Resumable (ValueError location value)) effects , Member (Resumable (LoadError term value)) effects , Member (Resumable (EvalError value)) effects , Member (Resumable (ResolutionError value)) effects , Member (Resumable (AddressError location value)) effects - , Member (Exc.Exc (ControlThrow value)) effects , MonadAddressable location effects m , MonadAnalysis location term value effects m , MonadFail (m effects) From 035c606dca0e50f636f888ccba59c10d80d50552 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:17:27 -0400 Subject: [PATCH 14/45] Move EvaluatingState into Evaluator and rename to EvaluatorState. --- src/Analysis/Abstract/Evaluating.hs | 80 ++++++--------------------- src/Analysis/Abstract/ImportGraph.hs | 2 +- src/Control/Abstract/Evaluator.hs | 81 +++++++++++++++++++++++----- 3 files changed, 86 insertions(+), 77 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index a4b6663f7..d537905d7 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,22 +1,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-} module Analysis.Abstract.Evaluating ( Evaluating -, EvaluatingState(..) +, EvaluatorState(..) , State ) where import Control.Abstract.Analysis import Control.Monad.Effect -import Data.Abstract.Address import Data.Abstract.Configuration import Data.Abstract.Environment as Env import Data.Abstract.Evaluatable -import Data.Abstract.Exports -import Data.Abstract.Heap import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Origin -import Data.Empty import qualified Data.IntMap as IntMap import Lens.Micro import Prelude hiding (fail) @@ -39,71 +35,29 @@ type EvaluatingEffects location 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. - , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules - , Reader (Environment location value) -- Default environment used as a fallback in lookupEnv - , State (EvaluatingState location term value) -- Environment, heap, modules, exports, and jumps. + , Fail -- Failure with an error message + , Fresh -- For allocating new addresses and/or type variables. + , Reader (SomeOrigin term) -- The current term’s origin. + , Reader (ModuleTable [Module term]) -- Cache of unevaluated modules + , Reader (Environment location value) -- Default environment used as a fallback in lookupEnv + , State (EvaluatorState location term value) -- Environment, heap, modules, exports, and jumps. ] -data EvaluatingState location term value = EvaluatingState - { environment :: Environment location value - , heap :: Heap location value - , modules :: ModuleTable (Environment location value, value) - , loadStack :: LoadStack - , exports :: Exports location value - , jumps :: IntMap.IntMap term - , origin :: SomeOrigin term - } - -deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value, Eq (Base term ())) => Eq (EvaluatingState location term value) -deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value, Ord (Base term ())) => Ord (EvaluatingState location term value) -deriving instance (Show (Cell location value), Show location, Show term, Show value, Show (Base term ())) => Show (EvaluatingState location term value) - -instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatingState location term value) where - EvaluatingState e1 h1 m1 l1 x1 j1 o1 <> EvaluatingState e2 h2 m2 l2 x2 j2 o2 = EvaluatingState (e1 <> e2) (h1 <> h2) (m1 <> m2) (l1 <> l2) (x1 <> x2) (j1 <> j2) (o1 <> o2) - -instance (Ord location, Semigroup (Cell location value)) => Empty (EvaluatingState location term value) where - empty = EvaluatingState mempty mempty mempty mempty mempty mempty mempty - -_environment :: Lens' (EvaluatingState location term value) (Environment location value) -_environment = lens environment (\ s e -> s {environment = e}) - -_heap :: Lens' (EvaluatingState location term value) (Heap location value) -_heap = lens heap (\ s h -> s {heap = h}) - -_modules :: Lens' (EvaluatingState location term value) (ModuleTable (Environment location value, value)) -_modules = lens modules (\ s m -> s {modules = m}) - -_loadStack :: Lens' (EvaluatingState location term value) LoadStack -_loadStack = lens loadStack (\ s l -> s {loadStack = l}) - -_exports :: Lens' (EvaluatingState location term value) (Exports location value) -_exports = lens exports (\ s e -> s {exports = e}) - -_jumps :: Lens' (EvaluatingState location term value) (IntMap.IntMap term) -_jumps = lens jumps (\ s j -> s {jumps = j}) - -_origin :: Lens' (EvaluatingState location term value) (SomeOrigin term) -_origin = lens origin (\ s o -> s {origin = o}) - - -(.=) :: Member (State (EvaluatingState location term value)) effects => ASetter (EvaluatingState location term value) (EvaluatingState location term value) a b -> b -> Evaluating location term value effects () +(.=) :: Member (State (EvaluatorState location term value)) effects => ASetter (EvaluatorState location term value) (EvaluatorState location term value) a b -> b -> Evaluating location term value effects () lens .= val = raise (modify' (lens .~ val)) -view :: Member (State (EvaluatingState location term value)) effects => Getting a (EvaluatingState location term value) a -> Evaluating location term value effects a +view :: Member (State (EvaluatorState location term value)) effects => Getting a (EvaluatorState location term value) a -> Evaluating location term value effects a view lens = raise (gets (^. lens)) -localEvaluatingState :: Member (State (EvaluatingState location term value)) effects => Lens' (EvaluatingState location term value) prj -> (prj -> prj) -> Evaluating location term value effects a -> Evaluating location term value effects a -localEvaluatingState lens f action = do +localEvaluatorState :: Member (State (EvaluatorState location term value)) effects => Lens' (EvaluatorState location term value) prj -> (prj -> prj) -> Evaluating location term value effects a -> Evaluating location term value effects a +localEvaluatorState lens f action = do original <- view lens lens .= f original v <- action v <$ lens .= original -instance Members '[Fail, State (EvaluatingState location term value)] effects => MonadControl term effects (Evaluating location term value) where +instance Members '[Fail, State (EvaluatorState location term value)] effects => MonadControl term effects (Evaluating location term value) where label term = do m <- view _jumps let i = IntMap.size m @@ -112,33 +66,33 @@ instance Members '[Fail, State (EvaluatingState location term value)] effects => goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure -instance Members '[ State (EvaluatingState location term value) +instance Members '[ State (EvaluatorState location term value) , Reader (Environment location value) ] effects => MonadEnvironment location value effects (Evaluating location term value) where getEnv = view _environment putEnv = (_environment .=) - withEnv s = localEvaluatingState _environment (const s) + withEnv s = localEvaluatorState _environment (const s) defaultEnvironment = raise ask withDefaultEnvironment e = raise . local (const e) . lower getExports = view _exports putExports = (_exports .=) - withExports s = localEvaluatingState _exports (const s) + withExports s = localEvaluatorState _exports (const s) localEnv f a = do modifyEnv (f . Env.push) result <- a result <$ modifyEnv Env.pop -instance Member (State (EvaluatingState location term value)) effects +instance Member (State (EvaluatorState location term value)) effects => MonadHeap location value effects (Evaluating location term value) where getHeap = view _heap putHeap = (_heap .=) instance Members '[ Reader (ModuleTable [Module term]) - , State (EvaluatingState location term value) + , State (EvaluatorState location term value) , Reader (SomeOrigin term) , Fail ] effects diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index eeefb8793..c5d80b063 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -9,7 +9,7 @@ module Analysis.Abstract.ImportGraph import qualified Algebra.Graph as G import Algebra.Graph.Class hiding (Vertex) import Algebra.Graph.Export.Dot hiding (vertexName) -import Control.Abstract.Analysis +import Control.Abstract.Analysis hiding (origin) import Data.Abstract.Address import Data.Abstract.Evaluatable (LoadError (..)) import Data.Abstract.FreeVariables diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 13018c584..16443022c 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,6 +1,15 @@ {-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, RankNTypes, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator ( MonadEvaluator(..) + -- State + , EvaluatorState(..) + , _environment + , _heap + , _modules + , _loadStack + , _exports + , _jumps + , _origin , MonadEnvironment(..) , modifyEnv , modifyExports @@ -21,19 +30,23 @@ module Control.Abstract.Evaluator , catchException ) where -import Control.Effect -import Control.Monad.Effect.Exception as Exception -import Control.Monad.Effect.Resumable as Resumable -import Data.Abstract.Address -import Data.Abstract.Configuration -import Data.Abstract.Environment as Env -import Data.Abstract.Exports as Export -import Data.Abstract.FreeVariables -import Data.Abstract.Heap -import Data.Abstract.Module -import Data.Abstract.ModuleTable -import Data.Semigroup.Reducer -import Prologue +import Control.Effect +import Control.Monad.Effect.Exception as Exception +import Control.Monad.Effect.Resumable as Resumable +import Data.Abstract.Address +import Data.Abstract.Configuration +import Data.Abstract.Environment as Env +import Data.Abstract.Exports as Export +import Data.Abstract.FreeVariables +import Data.Abstract.Heap +import Data.Abstract.Module +import Data.Abstract.ModuleTable +import Data.Abstract.Origin +import Data.Empty +import qualified Data.IntMap as IntMap +import Data.Semigroup.Reducer +import Lens.Micro +import Prologue -- | A 'Monad' providing the basic essentials for evaluation. -- @@ -51,6 +64,48 @@ class ( Effectful m -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: Ord location => term -> m effects (Configuration location term value) +data EvaluatorState location term value = EvaluatorState + { environment :: Environment location value + , heap :: Heap location value + , modules :: ModuleTable (Environment location value, value) + , loadStack :: LoadStack + , exports :: Exports location value + , jumps :: IntMap.IntMap term + , origin :: SomeOrigin term + } + +deriving instance (Eq (Cell location value), Eq location, Eq term, Eq value, Eq (Base term ())) => Eq (EvaluatorState location term value) +deriving instance (Ord (Cell location value), Ord location, Ord term, Ord value, Ord (Base term ())) => Ord (EvaluatorState location term value) +deriving instance (Show (Cell location value), Show location, Show term, Show value, Show (Base term ())) => Show (EvaluatorState location term value) + +instance (Ord location, Semigroup (Cell location value)) => Semigroup (EvaluatorState location term value) where + EvaluatorState e1 h1 m1 l1 x1 j1 o1 <> EvaluatorState e2 h2 m2 l2 x2 j2 o2 = EvaluatorState (e1 <> e2) (h1 <> h2) (m1 <> m2) (l1 <> l2) (x1 <> x2) (j1 <> j2) (o1 <> o2) + +instance (Ord location, Semigroup (Cell location value)) => Empty (EvaluatorState location term value) where + empty = EvaluatorState mempty mempty mempty mempty mempty mempty mempty + +_environment :: Lens' (EvaluatorState location term value) (Environment location value) +_environment = lens environment (\ s e -> s {environment = e}) + +_heap :: Lens' (EvaluatorState location term value) (Heap location value) +_heap = lens heap (\ s h -> s {heap = h}) + +_modules :: Lens' (EvaluatorState location term value) (ModuleTable (Environment location value, value)) +_modules = lens modules (\ s m -> s {modules = m}) + +_loadStack :: Lens' (EvaluatorState location term value) LoadStack +_loadStack = lens loadStack (\ s l -> s {loadStack = l}) + +_exports :: Lens' (EvaluatorState location term value) (Exports location value) +_exports = lens exports (\ s e -> s {exports = e}) + +_jumps :: Lens' (EvaluatorState location term value) (IntMap.IntMap term) +_jumps = lens jumps (\ s j -> s {jumps = j}) + +_origin :: Lens' (EvaluatorState location term value) (SomeOrigin term) +_origin = lens origin (\ s o -> s {origin = o}) + + -- | A 'Monad' abstracting local and global environments. class Monad (m effects) => MonadEnvironment location value (effects :: [* -> *]) m | m effects -> value, m -> location where -- | Retrieve the environment. From ddc06e6aebb2dcb40868131885979a75b3a2bc57 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:23:20 -0400 Subject: [PATCH 15/45] Define a single MonadControl instance once and for all. --- 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/Analysis/Abstract/Caching.hs | 1 - src/Analysis/Abstract/Collecting.hs | 1 - src/Analysis/Abstract/Dead.hs | 1 - src/Analysis/Abstract/Evaluating.hs | 31 ++++------- src/Analysis/Abstract/ImportGraph.hs | 1 - src/Analysis/Abstract/Quiet.hs | 1 - src/Analysis/Abstract/Tracing.hs | 1 - src/Control/Abstract/Evaluator.hs | 55 +++++++++++++------ 12 files changed, 48 insertions(+), 48 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index ce385f407..0a1b4aab8 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -7,7 +7,6 @@ import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (BadAddresses m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadAddresses m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadAddresses m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadAddresses m) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 84105af8b..e4aa6195a 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -8,7 +8,6 @@ import Prologue newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (BadModuleResolutions m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadModuleResolutions m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadModuleResolutions m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadModuleResolutions m) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index e7ae85fa6..5a912cf04 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -10,7 +10,6 @@ import Data.ByteString.Char8 (pack) newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (BadValues m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadValues m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadValues m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadValues m) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 8e96528b8..b0f7a13d7 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -11,7 +11,6 @@ import Prologue newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (BadVariables m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadVariables m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadVariables m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadVariables m) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 5288152c4..db5b1fa16 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -22,7 +22,6 @@ type CachingEffects location term value effects newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (Caching m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Caching m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (Caching m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Caching m) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index e28e91ccf..09d1e0979 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -13,7 +13,6 @@ import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (Collecting m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Collecting m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (Collecting m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Collecting m) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index a3b333063..a6a3ef596 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,7 +13,6 @@ import Prologue newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (DeadCode m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (DeadCode m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (DeadCode m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (DeadCode m) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index d537905d7..04d8a0baf 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -5,18 +5,16 @@ module Analysis.Abstract.Evaluating , State ) where -import Control.Abstract.Analysis -import Control.Monad.Effect -import Data.Abstract.Configuration -import Data.Abstract.Environment as Env -import Data.Abstract.Evaluatable -import Data.Abstract.Module -import Data.Abstract.ModuleTable -import Data.Abstract.Origin -import qualified Data.IntMap as IntMap -import Lens.Micro -import Prelude hiding (fail) -import Prologue +import Control.Abstract.Analysis +import Control.Monad.Effect +import Data.Abstract.Configuration +import Data.Abstract.Environment as Env +import Data.Abstract.Evaluatable +import Data.Abstract.Module +import Data.Abstract.ModuleTable +import Data.Abstract.Origin +import Lens.Micro +import Prologue -- | 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) @@ -57,15 +55,6 @@ localEvaluatorState lens f action = do v <$ lens .= original -instance Members '[Fail, State (EvaluatorState location term value)] effects => MonadControl term effects (Evaluating location term value) where - label term = do - m <- view _jumps - let i = IntMap.size m - _jumps .= IntMap.insert i term m - pure i - - goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure - instance Members '[ State (EvaluatorState location term value) , Reader (Environment location value) ] effects diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index c5d80b063..a1cc533d5 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -57,7 +57,6 @@ style = (defaultStyle vertexName) newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (ImportGraphing m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (ImportGraphing m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (ImportGraphing m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (ImportGraphing m) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 3433a74a3..f40226385 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -17,7 +17,6 @@ import Prologue newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (Quietly m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Quietly m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (Quietly m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Quietly m) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index f28deac3c..eb2b250df 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -16,7 +16,6 @@ import Prologue newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadControl term effects m => MonadControl term effects (Tracing trace m) deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Tracing trace m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (Tracing trace m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Tracing trace m) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 16443022c..1251f0370 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -30,23 +30,26 @@ module Control.Abstract.Evaluator , catchException ) where -import Control.Effect -import Control.Monad.Effect.Exception as Exception -import Control.Monad.Effect.Resumable as Resumable -import Data.Abstract.Address -import Data.Abstract.Configuration -import Data.Abstract.Environment as Env -import Data.Abstract.Exports as Export -import Data.Abstract.FreeVariables -import Data.Abstract.Heap -import Data.Abstract.Module -import Data.Abstract.ModuleTable -import Data.Abstract.Origin -import Data.Empty +import Control.Effect +import Control.Monad.Effect.Exception as Exception +import Control.Monad.Effect.Fail +import Control.Monad.Effect.Resumable as Resumable +import Control.Monad.Effect.State +import Data.Abstract.Address +import Data.Abstract.Configuration +import Data.Abstract.Environment as Env +import Data.Abstract.Exports as Export +import Data.Abstract.FreeVariables +import Data.Abstract.Heap +import Data.Abstract.Module +import Data.Abstract.ModuleTable +import Data.Abstract.Origin +import Data.Empty import qualified Data.IntMap as IntMap -import Data.Semigroup.Reducer -import Lens.Micro -import Prologue +import Data.Semigroup.Reducer +import Lens.Micro +import Prelude hiding (fail) +import Prologue -- | A 'Monad' providing the basic essentials for evaluation. -- @@ -55,7 +58,9 @@ import Prologue -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import class ( Effectful m - , MonadControl term effects m + , Member Fail effects + , Member (State (EvaluatorState location term value)) effects + , Monad (m effects) , MonadEnvironment location value effects m , MonadModuleTable location term value effects m , MonadHeap location value effects m @@ -106,6 +111,13 @@ _origin :: Lens' (EvaluatorState location term value) (SomeOrigin term) _origin = lens origin (\ s o -> s {origin = o}) +(.=) :: MonadEvaluator location term value effects m => ASetter (EvaluatorState location term value) (EvaluatorState location term value) a b -> b -> m effects () +lens .= val = raise (modify' (lens .~ val)) + +view :: MonadEvaluator location term value effects m => Getting a (EvaluatorState location term value) a -> m effects a +view lens = raise (gets (^. lens)) + + -- | A 'Monad' abstracting local and global environments. class Monad (m effects) => MonadEnvironment location value (effects :: [* -> *]) m | m effects -> value, m -> location where -- | Retrieve the environment. @@ -237,6 +249,15 @@ class Monad (m effects) => MonadControl term (effects :: [* -> *]) m where -- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance). goto :: Label -> m effects term +instance (Monad (m effects), MonadEvaluator location term value effects m) => MonadControl term effects m where + label term = do + m <- view _jumps + let i = IntMap.size m + _jumps .= IntMap.insert i term m + pure i + + goto label = IntMap.lookup label <$> view _jumps >>= maybe (raise (fail ("unknown label: " <> show label))) pure + throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v throwResumable = raise . Resumable.throwError From 880e5a6db17edd776426d5dea4fb8f05a6bf5268 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:26:46 -0400 Subject: [PATCH 16/45] Correct the functional dependency for MonadEnvironment. --- src/Control/Abstract/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 1251f0370..592beee83 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -119,7 +119,7 @@ view lens = raise (gets (^. lens)) -- | A 'Monad' abstracting local and global environments. -class Monad (m effects) => MonadEnvironment location value (effects :: [* -> *]) m | m effects -> value, m -> location where +class Monad (m effects) => MonadEnvironment location value (effects :: [* -> *]) m | m effects -> location value where -- | Retrieve the environment. getEnv :: m effects (Environment location value) -- | Set the environment. From b109fcd51f74f92e73909b1c6f6c211371713911 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:27:59 -0400 Subject: [PATCH 17/45] Define a single, universal instance of MonadEnvironment. --- 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/Analysis/Abstract/Caching.hs | 1 - src/Analysis/Abstract/Collecting.hs | 1 - src/Analysis/Abstract/Dead.hs | 1 - src/Analysis/Abstract/Evaluating.hs | 27 ------------------- src/Analysis/Abstract/ImportGraph.hs | 1 - src/Analysis/Abstract/Quiet.hs | 1 - src/Analysis/Abstract/Tracing.hs | 1 - src/Control/Abstract/Evaluator.hs | 27 ++++++++++++++++++- 12 files changed, 26 insertions(+), 38 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 0a1b4aab8..3f8a07c64 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -7,7 +7,6 @@ import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadAddresses m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadAddresses m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadAddresses m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index e4aa6195a..9ef310a42 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -8,7 +8,6 @@ import Prologue newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadModuleResolutions m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadModuleResolutions m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadModuleResolutions m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 5a912cf04..fe917938e 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -10,7 +10,6 @@ import Data.ByteString.Char8 (pack) newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadValues m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadValues m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadValues m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index b0f7a13d7..1cee987b6 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -11,7 +11,6 @@ import Prologue newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (BadVariables m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadVariables m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadVariables m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index db5b1fa16..15027381f 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -22,7 +22,6 @@ type CachingEffects location term value effects newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Caching m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (Caching m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Caching m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 09d1e0979..ec61d943f 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -13,7 +13,6 @@ import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Collecting m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (Collecting m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Collecting m) diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index a6a3ef596..2fac3bfb3 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,7 +13,6 @@ import Prologue newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (DeadCode m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (DeadCode m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (DeadCode m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 04d8a0baf..3d90c5030 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -47,33 +47,6 @@ lens .= val = raise (modify' (lens .~ val)) view :: Member (State (EvaluatorState location term value)) effects => Getting a (EvaluatorState location term value) a -> Evaluating location term value effects a view lens = raise (gets (^. lens)) -localEvaluatorState :: Member (State (EvaluatorState location term value)) effects => Lens' (EvaluatorState location term value) prj -> (prj -> prj) -> Evaluating location term value effects a -> Evaluating location term value effects a -localEvaluatorState lens f action = do - original <- view lens - lens .= f original - v <- action - v <$ lens .= original - - -instance Members '[ State (EvaluatorState location term value) - , Reader (Environment location value) - ] effects - => MonadEnvironment location value effects (Evaluating location term value) where - getEnv = view _environment - putEnv = (_environment .=) - withEnv s = localEvaluatorState _environment (const s) - - defaultEnvironment = raise ask - withDefaultEnvironment e = raise . local (const e) . lower - - getExports = view _exports - putExports = (_exports .=) - withExports s = localEvaluatorState _exports (const s) - - localEnv f a = do - modifyEnv (f . Env.push) - result <- a - result <$ modifyEnv Env.pop instance Member (State (EvaluatorState location term value)) effects => MonadHeap location value effects (Evaluating location term value) where diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index a1cc533d5..c64c91967 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -57,7 +57,6 @@ style = (defaultStyle vertexName) newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (ImportGraphing m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (ImportGraphing m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (ImportGraphing m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index f40226385..9a52e533f 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -17,7 +17,6 @@ import Prologue newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Quietly m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (Quietly m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Quietly m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index eb2b250df..d1a445c8d 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -16,7 +16,6 @@ import Prologue newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadEnvironment location value effects m => MonadEnvironment location value effects (Tracing trace m) deriving instance MonadHeap location value effects m => MonadHeap location value effects (Tracing trace m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Tracing trace m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 592beee83..6ef4f3090 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -33,6 +33,7 @@ module Control.Abstract.Evaluator import Control.Effect import Control.Monad.Effect.Exception as Exception import Control.Monad.Effect.Fail +import Control.Monad.Effect.Reader import Control.Monad.Effect.Resumable as Resumable import Control.Monad.Effect.State import Data.Abstract.Address @@ -59,9 +60,9 @@ import Prologue -- - tables of modules available for import class ( Effectful m , Member Fail effects + , Member (Reader (Environment location value)) effects , Member (State (EvaluatorState location term value)) effects , Monad (m effects) - , MonadEnvironment location value effects m , MonadModuleTable location term value effects m , MonadHeap location value effects m ) @@ -117,6 +118,13 @@ lens .= val = raise (modify' (lens .~ val)) view :: MonadEvaluator location term value effects m => Getting a (EvaluatorState location term value) a -> m effects a view lens = raise (gets (^. lens)) +localEvaluatorState :: MonadEvaluator location term value effects m => Lens' (EvaluatorState location term value) prj -> (prj -> prj) -> m effects a -> m effects a +localEvaluatorState lens f action = do + original <- view lens + lens .= f original + v <- action + v <$ lens .= original + -- | A 'Monad' abstracting local and global environments. class Monad (m effects) => MonadEnvironment location value (effects :: [* -> *]) m | m effects -> location value where @@ -154,6 +162,23 @@ class Monad (m effects) => MonadEnvironment location value (effects :: [* -> *]) addr <- lookupEnv name maybe (pure Nothing) (fmap Just . with) addr +instance (Monad (m effects), MonadEvaluator location term value effects m) => MonadEnvironment location value effects m where + getEnv = view _environment + putEnv = (_environment .=) + withEnv s = localEvaluatorState _environment (const s) + + defaultEnvironment = raise ask + withDefaultEnvironment e = raise . local (const e) . lower + + getExports = view _exports + putExports = (_exports .=) + withExports s = localEvaluatorState _exports (const s) + + localEnv f a = do + modifyEnv (f . Env.push) + result <- a + result <$ modifyEnv Env.pop + -- | Run a computation in a new local environment. localize :: MonadEnvironment location value effects m => m effects a -> m effects a localize = localEnv id From 7d39812ea367d15fa281a2b7dca47ea4b8526dea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:30:21 -0400 Subject: [PATCH 18/45] Define a single, universal instance of MonadHeap. --- 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/Analysis/Abstract/Caching.hs | 1 - src/Analysis/Abstract/Collecting.hs | 1 - src/Analysis/Abstract/Dead.hs | 1 - src/Analysis/Abstract/Evaluating.hs | 5 ----- src/Analysis/Abstract/ImportGraph.hs | 1 - src/Analysis/Abstract/Quiet.hs | 1 - src/Analysis/Abstract/Tracing.hs | 1 - src/Control/Abstract/Evaluator.hs | 5 ++++- 12 files changed, 4 insertions(+), 16 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 3f8a07c64..289f5ad69 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -7,7 +7,6 @@ import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadAddresses m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadAddresses m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 9ef310a42..ff03b855b 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -8,7 +8,6 @@ import Prologue newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadModuleResolutions m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadModuleResolutions m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index fe917938e..8581c1c9e 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -10,7 +10,6 @@ import Data.ByteString.Char8 (pack) newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadValues m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadValues m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 1cee987b6..098cc6841 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -11,7 +11,6 @@ import Prologue newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (BadVariables m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadVariables m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 15027381f..af41b16f9 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -22,7 +22,6 @@ type CachingEffects location term value effects newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (Caching m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Caching m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index ec61d943f..aa8de8e23 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -13,7 +13,6 @@ import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (Collecting m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Collecting m) instance ( Effectful m diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 2fac3bfb3..c1b1992b5 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,7 +13,6 @@ import Prologue newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (DeadCode m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (DeadCode m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 3d90c5030..cb9b67553 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -48,11 +48,6 @@ view :: Member (State (EvaluatorState location term value)) effects => Getting a view lens = raise (gets (^. lens)) -instance Member (State (EvaluatorState location term value)) effects - => MonadHeap location value effects (Evaluating location term value) where - getHeap = view _heap - putHeap = (_heap .=) - instance Members '[ Reader (ModuleTable [Module term]) , State (EvaluatorState location term value) , Reader (SomeOrigin term) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index c64c91967..558d62f7e 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -57,7 +57,6 @@ style = (defaultStyle vertexName) newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (ImportGraphing m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (ImportGraphing m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 9a52e533f..a83b4b734 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -17,7 +17,6 @@ import Prologue newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (Quietly m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Quietly m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index d1a445c8d..ef3d793bf 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -16,7 +16,6 @@ import Prologue newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadHeap location value effects m => MonadHeap location value effects (Tracing trace m) deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Tracing trace m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 6ef4f3090..dc3ddd627 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -64,7 +64,6 @@ class ( Effectful m , Member (State (EvaluatorState location term value)) effects , Monad (m effects) , MonadModuleTable location term value effects m - , MonadHeap location value effects m ) => MonadEvaluator location term value (effects :: [* -> *]) m | m effects -> location term value where -- | Get the current 'Configuration' with a passed-in term. @@ -211,6 +210,10 @@ class Monad (m effects) => MonadHeap location value (effects :: [* -> *]) m | m -- | Set the heap. putHeap :: Heap location value -> m effects () +instance (Monad (m effects), MonadEvaluator location term value effects m) => MonadHeap location value effects m where + getHeap = view _heap + putHeap = (_heap .=) + -- | Update the heap. modifyHeap :: MonadHeap location value effects m => (Heap location value -> Heap location value) -> m effects () modifyHeap f = do From 4978c8ce243af027b11c90fc5e5df7c8a2fc0551 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:34:50 -0400 Subject: [PATCH 19/45] Define a single, universal instance of MonadModuleTable. --- 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/Analysis/Abstract/Caching.hs | 1 - src/Analysis/Abstract/Collecting.hs | 2 -- src/Analysis/Abstract/Dead.hs | 1 - src/Analysis/Abstract/Evaluating.hs | 19 --------------- src/Analysis/Abstract/ImportGraph.hs | 1 - src/Analysis/Abstract/Quiet.hs | 1 - src/Analysis/Abstract/Tracing.hs | 1 - src/Control/Abstract/Evaluator.hs | 23 +++++++++++++++---- src/Data/Abstract/Evaluatable.hs | 4 +--- 13 files changed, 20 insertions(+), 37 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 289f5ad69..3c86e4836 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -7,7 +7,6 @@ import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadAddresses m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) instance ( Effectful m diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index ff03b855b..0985ffc37 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -8,7 +8,6 @@ import Prologue newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadModuleResolutions m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) instance ( Effectful m diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 8581c1c9e..749001fc2 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -10,7 +10,6 @@ import Data.ByteString.Char8 (pack) newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadValues m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) instance ( Effectful m diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index 098cc6841..a8686e866 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -11,7 +11,6 @@ import Prologue newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (BadVariables m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) instance ( Effectful m diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index af41b16f9..61122c5fa 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -22,7 +22,6 @@ type CachingEffects location term value effects newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Caching m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons. diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index aa8de8e23..665a7be74 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -13,8 +13,6 @@ import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Collecting m) - instance ( Effectful m , Member (Reader (Live location value)) effects , MonadEvaluator location term value effects m diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index c1b1992b5..7618d6a25 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,7 +13,6 @@ import Prologue newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (DeadCode m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) -- | A set of “dead” (unreachable) terms. diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index cb9b67553..49d04d42a 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -48,25 +48,6 @@ view :: Member (State (EvaluatorState location term value)) effects => Getting a view lens = raise (gets (^. lens)) -instance Members '[ Reader (ModuleTable [Module term]) - , State (EvaluatorState location term value) - , Reader (SomeOrigin term) - , Fail - ] effects - => MonadModuleTable location term value effects (Evaluating location term value) where - getModuleTable = view _modules - putModuleTable = (_modules .=) - - askModuleTable = raise ask - localModuleTable f a = raise (local f (lower a)) - - getLoadStack = view _loadStack - putLoadStack = (_loadStack .=) - - currentModule = do - o <- raise ask - maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o - instance Members (EvaluatingEffects location term value) effects => MonadEvaluator location term value effects (Evaluating location term value) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 558d62f7e..98ee5733b 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -57,7 +57,6 @@ style = (defaultStyle vertexName) newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (ImportGraphing m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index a83b4b734..7b438b2a3 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -17,7 +17,6 @@ import Prologue newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Quietly m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) instance ( Effectful m diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index ef3d793bf..e99d49bef 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -16,7 +16,6 @@ import Prologue newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) -deriving instance MonadModuleTable location term value effects m => MonadModuleTable location term value effects (Tracing trace m) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) instance ( Corecursive term diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index dc3ddd627..acd26ccaa 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, RankNTypes, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} module Control.Abstract.Evaluator ( MonadEvaluator(..) -- State @@ -61,9 +61,10 @@ import Prologue class ( Effectful m , Member Fail effects , Member (Reader (Environment location value)) effects + , Member (Reader (ModuleTable [Module term])) effects + , Member (Reader (SomeOrigin term)) effects , Member (State (EvaluatorState location term value)) effects - , Monad (m effects) - , MonadModuleTable location term value effects m + , MonadFail (m effects) ) => MonadEvaluator location term value (effects :: [* -> *]) m | m effects -> location term value where -- | Get the current 'Configuration' with a passed-in term. @@ -255,6 +256,20 @@ class Monad (m effects) => MonadModuleTable location term value (effects :: [* - -- | Get the currently evaluating 'ModuleInfo'. currentModule :: m effects ModuleInfo +instance (Monad (m effects), MonadEvaluator location term value effects m) => MonadModuleTable location term value effects m where + getModuleTable = view _modules + putModuleTable = (_modules .=) + + askModuleTable = raise ask + localModuleTable f a = raise (local f (lower a)) + + getLoadStack = view _loadStack + putLoadStack = (_loadStack .=) + + currentModule = do + o <- raise ask + maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o + -- | Update the evaluated module table. modifyModuleTable :: MonadModuleTable location term value effects m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m effects () modifyModuleTable f = do @@ -284,7 +299,7 @@ instance (Monad (m effects), MonadEvaluator location term value effects m) => Mo _jumps .= IntMap.insert i term m pure i - goto label = IntMap.lookup label <$> view _jumps >>= maybe (raise (fail ("unknown label: " <> show label))) pure + goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 88e70a8c2..6c0d47378 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -262,9 +262,7 @@ evaluateModules :: MonadEvaluatable location term value effects m evaluateModules = fmap Prelude.head . evaluatePackageBody . Package.fromModules -- | Evaluate a given package. -evaluatePackage :: ( Member (Reader (SomeOrigin term)) effects - , MonadEvaluatable location term value effects m - ) +evaluatePackage :: MonadEvaluatable location term value effects m => Package term -> m effects [value] evaluatePackage p = pushOrigin (packageOrigin p) (evaluatePackageBody (packageBody p)) From 2688eee32422a1cefca0cc924f7566984dc1baa5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:36:21 -0400 Subject: [PATCH 20/45] :fire: a redundant membership constraint. --- src/Control/Abstract/Evaluator.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index acd26ccaa..f388a5828 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -59,7 +59,6 @@ import Prologue -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import class ( Effectful m - , Member Fail effects , Member (Reader (Environment location value)) effects , Member (Reader (ModuleTable [Module term])) effects , Member (Reader (SomeOrigin term)) effects From 3039dcf8d0b5c00d469022ab033dc7619c166ca9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:36:32 -0400 Subject: [PATCH 21/45] :fire: a couple of redundant membership constraints on the origin. --- src/Analysis/Abstract/ImportGraph.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 98ee5733b..7a92f427f 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -98,8 +98,7 @@ moduleGraph = maybe empty (vertex . Module . BC.pack . modulePath) . withSomeOri -- | Add an edge from the current package to the passed vertex. packageInclusion :: forall m location term value effects - . ( Member (Reader (SomeOrigin term)) effects - , Member (State ImportGraph) effects + . ( Member (State ImportGraph) effects , MonadEvaluator location term value effects m ) => Vertex @@ -110,8 +109,7 @@ packageInclusion v = do -- | Add an edge from the current module to the passed vertex. moduleInclusion :: forall m location term value effects - . ( Member (Reader (SomeOrigin term)) effects - , Member (State ImportGraph) effects + . ( Member (State ImportGraph) effects , MonadEvaluator location term value effects m ) => Vertex From d79d17768b4609fd577edce4ce6d3758cd85e410 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:37:24 -0400 Subject: [PATCH 22/45] :fire: the lens helpers in Evaluating. --- src/Analysis/Abstract/Evaluating.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 49d04d42a..6a5d0b440 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -13,7 +13,6 @@ import Data.Abstract.Evaluatable import Data.Abstract.Module import Data.Abstract.ModuleTable import Data.Abstract.Origin -import Lens.Micro import Prologue -- | An analysis evaluating @term@s to @value@s with a list of @effects@ using 'Evaluatable', and producing incremental results of type @a@. @@ -41,13 +40,6 @@ type EvaluatingEffects location term value , State (EvaluatorState location term value) -- Environment, heap, modules, exports, and jumps. ] -(.=) :: Member (State (EvaluatorState location term value)) effects => ASetter (EvaluatorState location term value) (EvaluatorState location term value) a b -> b -> Evaluating location term value effects () -lens .= val = raise (modify' (lens .~ val)) - -view :: Member (State (EvaluatorState location term value)) effects => Getting a (EvaluatorState location term value) a -> Evaluating location term value effects a -view lens = raise (gets (^. lens)) - - instance Members (EvaluatingEffects location term value) effects => MonadEvaluator location term value effects (Evaluating location term value) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap From f16bf3e5ac236eebb55c9f444b8923e17bbfacd5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:43:42 -0400 Subject: [PATCH 23/45] Weaken the conditions on the MonadEvaluator & MonadAnalysis instances for Evaluating. --- src/Analysis/Abstract/Evaluating.hs | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 6a5d0b440..e1b793b2d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -40,12 +40,21 @@ type EvaluatingEffects location term value , State (EvaluatorState location term value) -- Environment, heap, modules, exports, and jumps. ] -instance Members (EvaluatingEffects location term value) effects +instance ( Member Fail effects + , Member (Reader (Environment location value)) effects + , Member (Reader (ModuleTable [Module term])) effects + , Member (Reader (SomeOrigin term)) effects + , Member (State (EvaluatorState location term value)) effects + ) => MonadEvaluator location term value effects (Evaluating location term value) where getConfiguration term = Configuration term mempty <$> getEnv <*> getHeap instance ( Corecursive term - , Members (EvaluatingEffects location term value) effects + , Member Fail effects + , Member (Reader (Environment location value)) effects + , Member (Reader (ModuleTable [Module term])) effects + , Member (Reader (SomeOrigin term)) effects + , Member (State (EvaluatorState location term value)) effects , Recursive term ) => MonadAnalysis location term value effects (Evaluating location term value) where From ca84598b92d67beb8355e9bb17264429b143247c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:46:53 -0400 Subject: [PATCH 24/45] :fire: MonadControl. --- src/Control/Abstract/Evaluator.hs | 32 +++++++++++++++---------------- src/Control/Abstract/Value.hs | 2 +- 2 files changed, 16 insertions(+), 18 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index f388a5828..4c5a21641 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -23,7 +23,9 @@ module Control.Abstract.Evaluator , MonadModuleTable(..) , modifyModuleTable , modifyLoadStack - , MonadControl(..) + -- Control + , label + , goto -- Exceptions , throwResumable , throwException @@ -282,23 +284,19 @@ modifyLoadStack f = do putLoadStack $! f stack --- | A 'Monad' abstracting jumps in imperative control. -class Monad (m effects) => MonadControl term (effects :: [* -> *]) m where - -- | Allocate a 'Label' for the given @term@. - -- - -- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms. - label :: term -> m effects Label - -- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance). - goto :: Label -> m effects term +-- | Allocate a 'Label' for the given @term@. +-- +-- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms. +label :: MonadEvaluator location term value effects m => term -> m effects Label +label term = do + m <- view _jumps + let i = IntMap.size m + _jumps .= IntMap.insert i term m + pure i -instance (Monad (m effects), MonadEvaluator location term value effects m) => MonadControl term effects m where - label term = do - m <- view _jumps - let i = IntMap.size m - _jumps .= IntMap.insert i term m - pure i - - goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure +-- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance). +goto :: MonadEvaluator location term value effects m => Label -> m effects term +goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 7859d5a6a..f0c0078d5 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -131,7 +131,7 @@ class (Monad (m effects), Show value) => MonadValue location value (effects :: [ scopedEnvironment :: value -> m effects (Environment location value) -- | Evaluate an abstraction (a binder like a lambda or method definition). - lambda :: (FreeVariables term, MonadControl term effects m) => [Name] -> Subterm term (m effects value) -> m effects value + lambda :: (FreeVariables term, MonadEvaluator location term value effects m) => [Name] -> Subterm term (m effects value) -> m effects value -- | Evaluate an application (like a function call). call :: value -> [m effects value] -> m effects value From 00b7c917aa42be9026fdfae511822cf7d426fa19 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:50:11 -0400 Subject: [PATCH 25/45] :fire: MonadModuleTable. --- src/Control/Abstract/Evaluator.hs | 76 +++++++++++++++++-------------- 1 file changed, 41 insertions(+), 35 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 4c5a21641..6409109c8 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -20,9 +20,16 @@ module Control.Abstract.Evaluator , localize , lookupHeap , assign - , MonadModuleTable(..) + -- Module tables + , getModuleTable + , putModuleTable , modifyModuleTable + , askModuleTable + , localModuleTable + , getLoadStack + , putLoadStack , modifyLoadStack + , currentModule -- Control , label , goto @@ -237,53 +244,52 @@ assign :: ( Ord location assign address = modifyHeap . heapInsert address --- | A 'Monad' abstracting tables of modules available for import. -class Monad (m effects) => MonadModuleTable location term value (effects :: [* -> *]) m | m effects -> location term value where - -- | Retrieve the table of evaluated modules. - getModuleTable :: m effects (ModuleTable (Environment location value, value)) - -- | Set the table of evaluated modules. - putModuleTable :: ModuleTable (Environment location value, value) -> m effects () +-- | Retrieve the table of evaluated modules. +getModuleTable :: MonadEvaluator location term value effects m => m effects (ModuleTable (Environment location value, value)) +getModuleTable = view _modules - -- | Retrieve the table of unevaluated modules. - askModuleTable :: m effects (ModuleTable [Module term]) - -- | Run an action with a locally-modified table of unevaluated modules. - localModuleTable :: (ModuleTable [Module term] -> ModuleTable [Module term]) -> m effects a -> m effects a - - -- | Retrieve the module load stack - getLoadStack :: m effects LoadStack - -- | Set the module load stack - putLoadStack :: LoadStack -> m effects () - - -- | Get the currently evaluating 'ModuleInfo'. - currentModule :: m effects ModuleInfo - -instance (Monad (m effects), MonadEvaluator location term value effects m) => MonadModuleTable location term value effects m where - getModuleTable = view _modules - putModuleTable = (_modules .=) - - askModuleTable = raise ask - localModuleTable f a = raise (local f (lower a)) - - getLoadStack = view _loadStack - putLoadStack = (_loadStack .=) - - currentModule = do - o <- raise ask - maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o +-- | Set the table of evaluated modules. +putModuleTable :: MonadEvaluator location term value effects m => ModuleTable (Environment location value, value) -> m effects () +putModuleTable = (_modules .=) -- | Update the evaluated module table. -modifyModuleTable :: MonadModuleTable location term value effects m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m effects () +modifyModuleTable :: MonadEvaluator location term value effects m => (ModuleTable (Environment location value, value) -> ModuleTable (Environment location value, value)) -> m effects () modifyModuleTable f = do table <- getModuleTable putModuleTable $! f table + +-- | Retrieve the table of unevaluated modules. +askModuleTable :: MonadEvaluator location term value effects m => m effects (ModuleTable [Module term]) +askModuleTable = raise ask + +-- | Run an action with a locally-modified table of unevaluated modules. +localModuleTable :: MonadEvaluator location term value effects m => (ModuleTable [Module term] -> ModuleTable [Module term]) -> m effects a -> m effects a +localModuleTable f a = raise (local f (lower a)) + + +-- | Retrieve the module load stack +getLoadStack :: MonadEvaluator location term value effects m => m effects LoadStack +getLoadStack = view _loadStack + +-- | Set the module load stack +putLoadStack :: MonadEvaluator location term value effects m => LoadStack -> m effects () +putLoadStack = (_loadStack .=) + -- | Update the module load stack. -modifyLoadStack :: MonadModuleTable location term value effects m => (LoadStack -> LoadStack) -> m effects () +modifyLoadStack :: MonadEvaluator location term value effects m => (LoadStack -> LoadStack) -> m effects () modifyLoadStack f = do stack <- getLoadStack putLoadStack $! f stack +-- | Get the currently evaluating 'ModuleInfo'. +currentModule :: forall location term value effects m . MonadEvaluator location term value effects m => m effects ModuleInfo +currentModule = do + o <- raise ask + maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o + + -- | Allocate a 'Label' for the given @term@. -- -- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms. From 1adaef0833766f17f5f50eac609f76d5df0a5e8f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 10:54:53 -0400 Subject: [PATCH 26/45] :fire: MonadHeap. --- src/Control/Abstract/Addressable.hs | 4 ++-- src/Control/Abstract/Evaluator.hs | 25 ++++++++++++------------- src/Control/Abstract/Value.hs | 2 +- src/Data/Abstract/Type.hs | 1 - 4 files changed, 15 insertions(+), 17 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index dbd265708..f99833147 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -30,7 +30,7 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( MonadAddressable location effects m , MonadEnvironment location value effects m - , MonadHeap location value effects m + , MonadEvaluator location term value effects m , Reducer value (Cell location value) ) => Name @@ -67,7 +67,7 @@ instance (Alternative (m effects), MonadFresh (m effects)) => MonadAddressable M allocLoc = pure . Monovariant -- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized. -deref :: (Effectful m, Member (Resumable (AddressError location value)) effects, MonadAddressable location effects m, MonadHeap location value effects m) => Address location value -> m effects value +deref :: (Member (Resumable (AddressError location value)) effects, MonadAddressable location effects m, MonadEvaluator location term value effects m) => Address location value -> m effects value deref addr = lookupHeap addr >>= maybe (throwAddressError (UninitializedAddress addr)) (derefCell addr) alloc :: MonadAddressable location effects m => Name -> m effects (Address location value) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 6409109c8..1f9468e09 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -15,7 +15,9 @@ module Control.Abstract.Evaluator , modifyExports , addExport , fullEnvironment - , MonadHeap(..) + -- Heap + , getHeap + , putHeap , modifyHeap , localize , lookupHeap @@ -212,30 +214,27 @@ addExport name alias = modifyExports . Export.insert name alias fullEnvironment :: MonadEnvironment location value effects m => m effects (Environment location value) fullEnvironment = mappend <$> getEnv <*> defaultEnvironment --- | A 'Monad' abstracting a heap of values. -class Monad (m effects) => MonadHeap location value (effects :: [* -> *]) m | m effects -> location value where - -- | Retrieve the heap. - getHeap :: m effects (Heap location value) - -- | Set the heap. - putHeap :: Heap location value -> m effects () +-- | Retrieve the heap. +getHeap :: MonadEvaluator location term value effects m => m effects (Heap location value) +getHeap = view _heap -instance (Monad (m effects), MonadEvaluator location term value effects m) => MonadHeap location value effects m where - getHeap = view _heap - putHeap = (_heap .=) +-- | Set the heap. +putHeap :: MonadEvaluator location term value effects m => Heap location value -> m effects () +putHeap = (_heap .=) -- | Update the heap. -modifyHeap :: MonadHeap location value effects m => (Heap location value -> Heap location value) -> m effects () +modifyHeap :: MonadEvaluator location term value effects m => (Heap location value -> Heap location value) -> m effects () modifyHeap f = do s <- getHeap putHeap $! f s -- | Look up the cell for the given 'Address' in the 'Heap'. -lookupHeap :: (MonadHeap location value effects m, Ord location) => Address location value -> m effects (Maybe (Cell location value)) +lookupHeap :: (MonadEvaluator location term value effects m, Ord location) => Address location value -> m effects (Maybe (Cell location value)) lookupHeap = flip fmap getHeap . heapLookup -- | Write a value to the given 'Address' in the 'Store'. assign :: ( Ord location - , MonadHeap location value effects m + , MonadEvaluator location term value effects m , Reducer value (Cell location value) ) => Address location value diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index f0c0078d5..49efc20b3 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -171,7 +171,7 @@ doWhile body cond = loop $ \ continue -> body *> do makeNamespace :: ( MonadValue location value effects m , MonadEnvironment location value effects m - , MonadHeap location value effects m + , MonadEvaluator location term value effects m , Ord location , Reducer value (Cell location value) ) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 9e00e7d29..6bf21810c 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -57,7 +57,6 @@ instance ( Alternative (m effects) , MonadEnvironment location Type effects m , MonadFail (m effects) , MonadFresh (m effects) - , MonadHeap location Type effects m , Reducer Type (Cell location Type) ) => MonadValue location Type effects m where From 84e91066966e7915ebc5f2f53ed849ccd3bbed97 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:02:44 -0400 Subject: [PATCH 27/45] :fire: MonadEnvironment. --- src/Control/Abstract/Addressable.hs | 5 +- src/Control/Abstract/Evaluator.hs | 142 +++++++++++++++------------- src/Control/Abstract/Value.hs | 3 +- src/Data/Abstract/Type.hs | 3 +- 4 files changed, 82 insertions(+), 71 deletions(-) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index f99833147..05a55b30d 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -21,7 +21,7 @@ class (MonadFresh (m effects), Ord location) => MonadAddressable location (effec -- | Look up or allocate an address for a 'Name'. lookupOrAlloc :: ( MonadAddressable location effects m - , MonadEnvironment location value effects m + , MonadEvaluator location term value effects m ) => Name -> m effects (Address location value) @@ -29,7 +29,6 @@ lookupOrAlloc name = lookupEnv name >>= maybe (alloc name) pure letrec :: ( MonadAddressable location effects m - , MonadEnvironment location value effects m , MonadEvaluator location term value effects m , Reducer value (Cell location value) ) @@ -44,7 +43,7 @@ letrec name body = do -- Lookup/alloc a name passing the address to a body evaluated in a new local environment. letrec' :: ( MonadAddressable location effects m - , MonadEnvironment location value effects m + , MonadEvaluator location term value effects m ) => Name -> (Address location value -> m effects value) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 1f9468e09..0d224869b 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -10,16 +10,27 @@ module Control.Abstract.Evaluator , _exports , _jumps , _origin - , MonadEnvironment(..) + -- Environment + , getEnv + , putEnv , modifyEnv + , withEnv + , defaultEnvironment + , withDefaultEnvironment + , fullEnvironment + , getExports + , putExports , modifyExports , addExport - , fullEnvironment + , withExports + , localEnv + , localize + , lookupEnv + , lookupWith -- Heap , getHeap , putHeap , modifyHeap - , localize , lookupHeap , assign -- Module tables @@ -136,83 +147,84 @@ localEvaluatorState lens f action = do v <$ lens .= original --- | A 'Monad' abstracting local and global environments. -class Monad (m effects) => MonadEnvironment location value (effects :: [* -> *]) m | m effects -> location value where - -- | Retrieve the environment. - getEnv :: m effects (Environment location value) - -- | Set the environment. - putEnv :: Environment location value -> m effects () - -- | Sets the environment for the lifetime of the given action. - withEnv :: Environment location value -> m effects a -> m effects a +-- | Retrieve the environment. +getEnv :: MonadEvaluator location term value effects m => m effects (Environment location value) +getEnv = view _environment - -- | Retrieve the default environment. - defaultEnvironment :: m effects (Environment location value) - - -- | Set the default environment for the lifetime of an action. - -- Usually only invoked in a top-level evaluation function. - withDefaultEnvironment :: Environment location value -> m effects a -> m effects a - - -- | Get the global export state. - getExports :: m effects (Exports location value) - -- | Set the global export state. - putExports :: Exports location value -> m effects () - -- | Sets the global export state for the lifetime of the given action. - withExports :: Exports location value -> m effects a -> m effects a - - -- | Run an action with a locally-modified environment. - localEnv :: (Environment location value -> Environment location value) -> m effects a -> m effects a - - -- | Look a 'Name' up in the current environment, trying the default environment if no value is found. - lookupEnv :: Name -> m effects (Maybe (Address location value)) - lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) - - -- | Look up a 'Name' in the environment, running an action with the resolved address (if any). - lookupWith :: (Address location value -> m effects a) -> Name -> m effects (Maybe a) - lookupWith with name = do - addr <- lookupEnv name - maybe (pure Nothing) (fmap Just . with) addr - -instance (Monad (m effects), MonadEvaluator location term value effects m) => MonadEnvironment location value effects m where - getEnv = view _environment - putEnv = (_environment .=) - withEnv s = localEvaluatorState _environment (const s) - - defaultEnvironment = raise ask - withDefaultEnvironment e = raise . local (const e) . lower - - getExports = view _exports - putExports = (_exports .=) - withExports s = localEvaluatorState _exports (const s) - - localEnv f a = do - modifyEnv (f . Env.push) - result <- a - result <$ modifyEnv Env.pop - --- | Run a computation in a new local environment. -localize :: MonadEnvironment location value effects m => m effects a -> m effects a -localize = localEnv id +-- | Set the environment. +putEnv :: MonadEvaluator location term value effects m => Environment location value -> m effects () +putEnv = (_environment .=) -- | Update the global environment. -modifyEnv :: MonadEnvironment location value effects m => (Environment location value -> Environment location value) -> m effects () +modifyEnv :: MonadEvaluator location term value effects m => (Environment location value -> Environment location value) -> m effects () modifyEnv f = do env <- getEnv putEnv $! f env +-- | Sets the environment for the lifetime of the given action. +withEnv :: MonadEvaluator location term value effects m => Environment location value -> m effects a -> m effects a +withEnv s = localEvaluatorState _environment (const s) + + +-- | Retrieve the default environment. +defaultEnvironment :: MonadEvaluator location term value effects m => m effects (Environment location value) +defaultEnvironment = raise ask + +-- | Set the default environment for the lifetime of an action. +-- Usually only invoked in a top-level evaluation function. +withDefaultEnvironment :: MonadEvaluator location term value effects m => Environment location value -> m effects a -> m effects a +withDefaultEnvironment e = raise . local (const e) . lower + +-- | Obtain an environment that is the composition of the current and default environments. +-- Useful for debugging. +fullEnvironment :: MonadEvaluator location term value effects m => m effects (Environment location value) +fullEnvironment = mappend <$> getEnv <*> defaultEnvironment + + +-- | Get the global export state. +getExports :: MonadEvaluator location term value effects m => m effects (Exports location value) +getExports = view _exports + +-- | Set the global export state. +putExports :: MonadEvaluator location term value effects m => Exports location value -> m effects () +putExports = (_exports .=) + -- | Update the global export state. -modifyExports :: MonadEnvironment location value effects m => (Exports location value -> Exports location value) -> m effects () +modifyExports :: MonadEvaluator location term value effects m => (Exports location value -> Exports location value) -> m effects () modifyExports f = do exports <- getExports putExports $! f exports -- | Add an export to the global export state. -addExport :: MonadEnvironment location value effects m => Name -> Name -> Maybe (Address location value) -> m effects () +addExport :: MonadEvaluator location term value effects m => Name -> Name -> Maybe (Address location value) -> m effects () addExport name alias = modifyExports . Export.insert name alias --- | Obtain an environment that is the composition of the current and default environments. --- Useful for debugging. -fullEnvironment :: MonadEnvironment location value effects m => m effects (Environment location value) -fullEnvironment = mappend <$> getEnv <*> defaultEnvironment +-- | Sets the global export state for the lifetime of the given action. +withExports :: MonadEvaluator location term value effects m => Exports location value -> m effects a -> m effects a +withExports s = localEvaluatorState _exports (const s) + + +-- | Run an action with a locally-modified environment. +localEnv :: MonadEvaluator location term value effects m => (Environment location value -> Environment location value) -> m effects a -> m effects a +localEnv f a = do + modifyEnv (f . Env.push) + result <- a + result <$ modifyEnv Env.pop + +-- | Run a computation in a new local environment. +localize :: MonadEvaluator location term value effects m => m effects a -> m effects a +localize = localEnv id + +-- | Look a 'Name' up in the current environment, trying the default environment if no value is found. +lookupEnv :: MonadEvaluator location term value effects m => Name -> m effects (Maybe (Address location value)) +lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) + +-- | Look up a 'Name' in the environment, running an action with the resolved address (if any). +lookupWith :: MonadEvaluator location term value effects m => (Address location value -> m effects a) -> Name -> m effects (Maybe a) +lookupWith with name = do + addr <- lookupEnv name + maybe (pure Nothing) (fmap Just . with) addr + -- | Retrieve the heap. getHeap :: MonadEvaluator location term value effects m => m effects (Heap location value) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 49efc20b3..b85e27f7b 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -142,7 +142,7 @@ class (Monad (m effects), Show value) => MonadValue location value (effects :: [ -- | Attempt to extract a 'Prelude.Bool' from a given value. -forLoop :: (MonadEnvironment location value effects m, MonadValue location value effects m) +forLoop :: (MonadEvaluator location term value effects m, MonadValue location value effects m) => m effects value -- ^ Initial statement -> m effects value -- ^ Condition -> m effects value -- ^ Increment/stepper @@ -170,7 +170,6 @@ doWhile body cond = loop $ \ continue -> body *> do ifthenelse this continue unit makeNamespace :: ( MonadValue location value effects m - , MonadEnvironment location value effects m , MonadEvaluator location term value effects m , Ord location , Reducer value (Cell location value) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 6bf21810c..a2b4fd40e 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TypeFamilies, UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- For the MonadValue instance, which requires MonadEvaluator to resolve its functional dependency. module Data.Abstract.Type where import Control.Abstract.Analysis @@ -54,7 +55,7 @@ instance Ord location => ValueRoots location Type where -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Alternative (m effects) , MonadAddressable location effects m - , MonadEnvironment location Type effects m + , MonadEvaluator location term Type effects m , MonadFail (m effects) , MonadFresh (m effects) , Reducer Type (Cell location Type) From 56f8f199646c3eca199afe499571bc3df1018d74 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:04:29 -0400 Subject: [PATCH 28/45] Add section comments for each group of functions. --- src/Control/Abstract/Evaluator.hs | 68 +++++++++++++++++++------------ 1 file changed, 43 insertions(+), 25 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 0d224869b..6bee310d6 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -18,15 +18,16 @@ module Control.Abstract.Evaluator , defaultEnvironment , withDefaultEnvironment , fullEnvironment + , localEnv + , localize + , lookupEnv + , lookupWith + -- Exports , getExports , putExports , modifyExports , addExport , withExports - , localEnv - , localize - , lookupEnv - , lookupWith -- Heap , getHeap , putHeap @@ -91,6 +92,9 @@ class ( Effectful m -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: Ord location => term -> m effects (Configuration location term value) + +-- State + data EvaluatorState location term value = EvaluatorState { environment :: Environment location value , heap :: Heap location value @@ -111,6 +115,9 @@ instance (Ord location, Semigroup (Cell location value)) => Semigroup (Evaluator instance (Ord location, Semigroup (Cell location value)) => Empty (EvaluatorState location term value) where empty = EvaluatorState mempty mempty mempty mempty mempty mempty mempty + +-- Lenses + _environment :: Lens' (EvaluatorState location term value) (Environment location value) _environment = lens environment (\ s e -> s {environment = e}) @@ -147,6 +154,8 @@ localEvaluatorState lens f action = do v <$ lens .= original +-- Environment + -- | Retrieve the environment. getEnv :: MonadEvaluator location term value effects m => m effects (Environment location value) getEnv = view _environment @@ -180,6 +189,29 @@ withDefaultEnvironment e = raise . local (const e) . lower fullEnvironment :: MonadEvaluator location term value effects m => m effects (Environment location value) fullEnvironment = mappend <$> getEnv <*> defaultEnvironment +-- | Run an action with a locally-modified environment. +localEnv :: MonadEvaluator location term value effects m => (Environment location value -> Environment location value) -> m effects a -> m effects a +localEnv f a = do + modifyEnv (f . Env.push) + result <- a + result <$ modifyEnv Env.pop + +-- | Run a computation in a new local environment. +localize :: MonadEvaluator location term value effects m => m effects a -> m effects a +localize = localEnv id + +-- | Look a 'Name' up in the current environment, trying the default environment if no value is found. +lookupEnv :: MonadEvaluator location term value effects m => Name -> m effects (Maybe (Address location value)) +lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) + +-- | Look up a 'Name' in the environment, running an action with the resolved address (if any). +lookupWith :: MonadEvaluator location term value effects m => (Address location value -> m effects a) -> Name -> m effects (Maybe a) +lookupWith with name = do + addr <- lookupEnv name + maybe (pure Nothing) (fmap Just . with) addr + + +-- Exports -- | Get the global export state. getExports :: MonadEvaluator location term value effects m => m effects (Exports location value) @@ -204,27 +236,7 @@ withExports :: MonadEvaluator location term value effects m => Exports location withExports s = localEvaluatorState _exports (const s) --- | Run an action with a locally-modified environment. -localEnv :: MonadEvaluator location term value effects m => (Environment location value -> Environment location value) -> m effects a -> m effects a -localEnv f a = do - modifyEnv (f . Env.push) - result <- a - result <$ modifyEnv Env.pop - --- | Run a computation in a new local environment. -localize :: MonadEvaluator location term value effects m => m effects a -> m effects a -localize = localEnv id - --- | Look a 'Name' up in the current environment, trying the default environment if no value is found. -lookupEnv :: MonadEvaluator location term value effects m => Name -> m effects (Maybe (Address location value)) -lookupEnv name = (<|>) <$> (Env.lookup name <$> getEnv) <*> (Env.lookup name <$> defaultEnvironment) - --- | Look up a 'Name' in the environment, running an action with the resolved address (if any). -lookupWith :: MonadEvaluator location term value effects m => (Address location value -> m effects a) -> Name -> m effects (Maybe a) -lookupWith with name = do - addr <- lookupEnv name - maybe (pure Nothing) (fmap Just . with) addr - +-- Heap -- | Retrieve the heap. getHeap :: MonadEvaluator location term value effects m => m effects (Heap location value) @@ -255,6 +267,8 @@ assign :: ( Ord location assign address = modifyHeap . heapInsert address +-- Module table + -- | Retrieve the table of evaluated modules. getModuleTable :: MonadEvaluator location term value effects m => m effects (ModuleTable (Environment location value, value)) getModuleTable = view _modules @@ -301,6 +315,8 @@ currentModule = do maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o +-- Control + -- | Allocate a 'Label' for the given @term@. -- -- Labels must be allocated before being jumped to with 'goto', but are suitable for nonlocal jumps; thus, they can be used to implement coroutines, exception handling, call with current continuation, and other esoteric control mechanisms. @@ -316,6 +332,8 @@ goto :: MonadEvaluator location term value effects m => Label -> m effects term goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure +-- Exceptions + throwResumable :: (Member (Resumable exc) effects, Effectful m) => exc v -> m effects v throwResumable = raise . Resumable.throwError From 889e9844032a9bdceec30793ff5a0c6765f5a9bb Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:04:38 -0400 Subject: [PATCH 29/45] =?UTF-8?q?Don=E2=80=99t=20export=20the=20lenses.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Control/Abstract/Evaluator.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 6bee310d6..0b1fff0b1 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -3,13 +3,6 @@ module Control.Abstract.Evaluator ( MonadEvaluator(..) -- State , EvaluatorState(..) - , _environment - , _heap - , _modules - , _loadStack - , _exports - , _jumps - , _origin -- Environment , getEnv , putEnv From d3af580585b5d9a341da92c94a5e32191691893b Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:06:31 -0400 Subject: [PATCH 30/45] Clean up the language extensions. --- 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 e1b793b2d..f424fdb33 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, TypeFamilies, UndecidableInstances, ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies #-} module Analysis.Abstract.Evaluating ( Evaluating , EvaluatorState(..) From b311764651f4997def9a6a8980c30212740f044f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:06:43 -0400 Subject: [PATCH 31/45] Clean up some more language extensions. --- src/Control/Abstract/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 0b1fff0b1..82d278a55 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies, UndecidableInstances #-} +{-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies, RankNTypes, ScopedTypeVariables, TypeFamilies #-} module Control.Abstract.Evaluator ( MonadEvaluator(..) -- State From 5fa6dc28ea6a290d70c2006c0487e15f8a7eab30 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:16:35 -0400 Subject: [PATCH 32/45] :fire: MonadFresh. --- 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/Caching.hs | 4 ++-- src/Analysis/Abstract/Collecting.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 1 - src/Analysis/Abstract/ImportGraph.hs | 2 +- src/Analysis/Abstract/Quiet.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Addressable.hs | 6 +++--- src/Control/Effect/Fresh.hs | 16 ++++++---------- src/Data/Abstract/Type.hs | 2 +- 14 files changed, 21 insertions(+), 26 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 3c86e4836..53d7fb259 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -5,7 +5,7 @@ import Control.Abstract.Analysis import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 0985ffc37..566c12448 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -6,7 +6,7 @@ import Data.Abstract.Evaluatable import Prologue newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index 749001fc2..a0394caa9 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -8,7 +8,7 @@ import Prologue import Data.ByteString.Char8 (pack) newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index a8686e866..bf2274dd5 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -9,7 +9,7 @@ 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) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 61122c5fa..8cf3b411f 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -20,7 +20,7 @@ type CachingEffects location term value 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) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) @@ -64,9 +64,9 @@ instance ( Effectful m instance ( Alternative (m effects) , Corecursive term , Effectful m + , Member Fresh effects , Members (CachingEffects location term value '[]) effects , MonadAnalysis location term value effects m - , MonadFresh (m effects) , Ord (Cell location value) , Ord location , Ord term diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 665a7be74..653ce6cc7 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -11,7 +11,7 @@ import Data.Abstract.Live import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) instance ( Effectful m , Member (Reader (Live location value)) effects diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index 7618d6a25..e0ab5e42f 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -11,7 +11,7 @@ import Prologue -- | An analysis tracking dead (unreachable) code. newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index f424fdb33..162722778 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -20,7 +20,6 @@ newtype Evaluating location term value effects a = Evaluating (Eff effects a) deriving (Applicative, Functor, Effectful, Monad) deriving instance Member Fail effects => MonadFail (Evaluating location term value effects) -deriving instance Member Fresh effects => MonadFresh (Evaluating location term value effects) deriving instance Member NonDet effects => Alternative (Evaluating location term value effects) -- | Effects necessary for evaluating (whether concrete or abstract). diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 7a92f427f..a90b9bae4 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -55,7 +55,7 @@ style = (defaultStyle vertexName) edgeAttributes _ _ = [] newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 7b438b2a3..1829d1380 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -15,7 +15,7 @@ import Prologue -- -- 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) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index e99d49bef..7e092567c 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Prologue -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh) + deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 05a55b30d..2739abaee 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -14,7 +14,7 @@ import Prelude hiding (fail) import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. -class (MonadFresh (m effects), Ord location) => MonadAddressable location (effects :: [* -> *]) m where +class (Effectful m, Member Fresh effects, Monad (m effects), Ord location) => MonadAddressable location (effects :: [* -> *]) m where derefCell :: Address location value -> Cell location value -> m effects value allocLoc :: Name -> m effects location @@ -56,12 +56,12 @@ letrec' name body = do -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (MonadFail (m effects), MonadFresh (m effects)) => MonadAddressable Precise effects m where +instance (Effectful m, Member Fresh effects, MonadFail (m effects)) => MonadAddressable Precise effects m where derefCell addr = maybeM (uninitializedAddress addr) . unLatest allocLoc _ = Precise <$> fresh -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically. -instance (Alternative (m effects), MonadFresh (m effects)) => MonadAddressable Monovariant effects m where +instance (Alternative (m effects), Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Monovariant effects m where derefCell _ = foldMapA pure allocLoc = pure . Monovariant diff --git a/src/Control/Effect/Fresh.hs b/src/Control/Effect/Fresh.hs index 8db9ef609..6be171dea 100644 --- a/src/Control/Effect/Fresh.hs +++ b/src/Control/Effect/Fresh.hs @@ -11,17 +11,13 @@ data Fresh a where -- | Request a fresh variable name. Fresh :: Fresh Int --- | 'Monad's offering a (resettable) sequence of guaranteed-fresh type variables. -class Monad m => MonadFresh m where - -- | Get a fresh variable name, guaranteed unused (since the last 'reset'). - fresh :: m 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 :: Int -> m () - -instance (Fresh :< fs) => MonadFresh (Eff fs) where - fresh = send Fresh - reset = send . Reset +-- | 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 -- | 'Fresh' effects are interpreted starting from 0, incrementing the current name with each request for a fresh name, and overwriting the counter on reset. diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index a2b4fd40e..79b977a1c 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -54,10 +54,10 @@ instance Ord location => ValueRoots location Type where -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Alternative (m effects) + , Member Fresh effects , MonadAddressable location effects m , MonadEvaluator location term Type effects m , MonadFail (m effects) - , MonadFresh (m effects) , Reducer Type (Cell location Type) ) => MonadValue location Type effects m where From d1adb3939fde04411b76ea79cfd2968827841a1c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:34:13 -0400 Subject: [PATCH 33/45] Differentiate between unallocated and uninitialized addresses. --- src/Analysis/Abstract/BadAddresses.hs | 5 ++++- src/Control/Abstract/Addressable.hs | 24 +++++++++++++----------- 2 files changed, 17 insertions(+), 12 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 53d7fb259..90859556a 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 Data.Abstract.Address import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) @@ -13,6 +14,7 @@ instance ( Effectful m , Member (Resumable (AddressError location value)) effects , MonadAnalysis location term value effects m , MonadValue location value effects (BadAddresses m) + , Monoid (Cell location value) , Show location ) => MonadAnalysis location term value effects (BadAddresses m) where @@ -22,6 +24,7 @@ instance ( Effectful m \yield error -> do traceM ("AddressError:" <> show error) case error of - (UninitializedAddress _) -> hole >>= yield) + UnallocatedAddress _ -> yield mempty + UninitializedAddress _ -> hole >>= yield) analyzeModule = liftAnalyze analyzeModule diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 2739abaee..96e423405 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -10,12 +10,11 @@ import Data.Abstract.Address import Data.Abstract.Environment (insert) import Data.Abstract.FreeVariables import Data.Semigroup.Reducer -import Prelude hiding (fail) import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. class (Effectful m, Member Fresh effects, Monad (m effects), Ord location) => MonadAddressable location (effects :: [* -> *]) m where - derefCell :: Address location value -> Cell location value -> m effects value + derefCell :: Address location value -> Cell location value -> m effects (Maybe value) allocLoc :: Name -> m effects location @@ -56,27 +55,28 @@ letrec' name body = do -- Instances -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written. -instance (Effectful m, Member Fresh effects, MonadFail (m effects)) => MonadAddressable Precise effects m where - derefCell addr = maybeM (uninitializedAddress addr) . unLatest +instance (Effectful m, Member Fresh effects, Monad (m effects)) => MonadAddressable Precise effects m where + derefCell _ = pure . unLatest allocLoc _ = Precise <$> 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 - derefCell _ = foldMapA pure + derefCell _ cell | null cell = pure Nothing + | otherwise = Just <$> foldMapA pure cell allocLoc = pure . Monovariant -- | Dereference the given 'Address'in the heap, or fail if the address is uninitialized. deref :: (Member (Resumable (AddressError location value)) effects, MonadAddressable location effects m, MonadEvaluator location term value effects m) => Address location value -> m effects value -deref addr = lookupHeap addr >>= maybe (throwAddressError (UninitializedAddress addr)) (derefCell addr) +deref addr = do + cell <- lookupHeap addr >>= maybeM (throwAddressError (UnallocatedAddress addr)) + derefed <- derefCell addr cell + maybeM (throwAddressError (UninitializedAddress addr)) derefed alloc :: MonadAddressable location effects m => Name -> m effects (Address location value) alloc = fmap Address . allocLoc --- | Fail with a message denoting an uninitialized address (i.e. one which was 'alloc'ated, but never 'assign'ed a value before being 'deref'erenced). -uninitializedAddress :: (MonadFail m, Show location) => Address location value -> m a -uninitializedAddress addr = fail $ "uninitialized address: " <> show addr - data AddressError location value resume where + UnallocatedAddress :: Address location value -> AddressError location value (Cell location value) UninitializedAddress :: Address location value -> AddressError location value value deriving instance Eq location => Eq (AddressError location value resume) @@ -84,7 +84,9 @@ deriving instance Show location => Show (AddressError location value resume) instance Show location => Show1 (AddressError location value) where liftShowsPrec _ _ = showsPrec instance Eq location => Eq1 (AddressError location value) where - liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b + liftEq _ (UninitializedAddress a) (UninitializedAddress b) = a == b + liftEq _ (UnallocatedAddress a) (UnallocatedAddress b) = a == b + liftEq _ _ _ = False throwAddressError :: (Effectful m, Member (Resumable (AddressError location value)) effects) => AddressError location value resume -> m effects resume From 61452e897821f0bc128d209fb44c887c6963b1d9 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:37:06 -0400 Subject: [PATCH 34/45] Spacing. --- src/Analysis/Abstract/BadAddresses.hs | 2 +- src/Analysis/Abstract/BadModuleResolutions.hs | 2 +- src/Analysis/Abstract/BadVariables.hs | 2 +- src/Analysis/Abstract/Caching.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/ImportGraph.hs | 2 +- src/Analysis/Abstract/Quiet.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- 8 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 90859556a..8e9f8443a 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -8,7 +8,7 @@ import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) instance ( Effectful m , Member (Resumable (AddressError location value)) effects diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 566c12448..57c0b3d70 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -8,7 +8,7 @@ import Prologue newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) instance ( Effectful m , Member (Resumable (ResolutionError value)) effects diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index bf2274dd5..d186e197f 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -11,7 +11,7 @@ import Prologue newtype BadVariables m (effects :: [* -> *]) a = BadVariables (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) instance ( Effectful m , Member (Resumable (EvalError value)) effects diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 8cf3b411f..62322c087 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -22,7 +22,7 @@ type CachingEffects location term value effects newtype Caching m (effects :: [* -> *]) a = Caching (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons. class MonadEvaluator location term value effects m => MonadCaching location term value effects m where diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index e0ab5e42f..a3b76305a 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -13,7 +13,7 @@ import Prologue newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) -- | A set of “dead” (unreachable) terms. newtype Dead term = Dead { unDead :: Set term } diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index a90b9bae4..64af78c47 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -57,7 +57,7 @@ style = (defaultStyle vertexName) newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) instance ( Effectful m diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index 1829d1380..bda68a9e9 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -17,7 +17,7 @@ import Prologue newtype Quietly m (effects :: [* -> *]) a = Quietly (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) instance ( Effectful m , Member (Resumable (Unspecialized value)) effects diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 7e092567c..5f723dbd4 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -16,7 +16,7 @@ import Prologue newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) -deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) +deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) instance ( Corecursive term , Effectful m From 812adece0f9cad3d2fe4915a13e810afa9ddd1ba Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:45:35 -0400 Subject: [PATCH 35/45] :fire: all the MonadFail instances. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit We can still fail using `raise (fail …)`, but it’s less convenient now. --- 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/Caching.hs | 2 +- src/Analysis/Abstract/Collecting.hs | 2 +- src/Analysis/Abstract/Dead.hs | 2 +- src/Analysis/Abstract/Evaluating.hs | 1 - src/Analysis/Abstract/ImportGraph.hs | 2 +- src/Analysis/Abstract/Quiet.hs | 2 +- src/Analysis/Abstract/Tracing.hs | 2 +- src/Control/Abstract/Evaluator.hs | 7 +++--- src/Data/Abstract/Evaluatable.hs | 2 +- src/Data/Abstract/Type.hs | 24 ++++++++++--------- src/Language/PHP/Syntax.hs | 4 ++-- src/Language/Python/Syntax.hs | 4 ++-- src/Language/Ruby/Syntax.hs | 2 +- 17 files changed, 33 insertions(+), 31 deletions(-) diff --git a/src/Analysis/Abstract/BadAddresses.hs b/src/Analysis/Abstract/BadAddresses.hs index 8e9f8443a..345ab93ca 100644 --- a/src/Analysis/Abstract/BadAddresses.hs +++ b/src/Analysis/Abstract/BadAddresses.hs @@ -6,7 +6,7 @@ import Data.Abstract.Address import Prologue newtype BadAddresses m (effects :: [* -> *]) a = BadAddresses (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadAddresses m) diff --git a/src/Analysis/Abstract/BadModuleResolutions.hs b/src/Analysis/Abstract/BadModuleResolutions.hs index 57c0b3d70..be4eccba0 100644 --- a/src/Analysis/Abstract/BadModuleResolutions.hs +++ b/src/Analysis/Abstract/BadModuleResolutions.hs @@ -6,7 +6,7 @@ import Data.Abstract.Evaluatable import Prologue newtype BadModuleResolutions m (effects :: [* -> *]) a = BadModuleResolutions (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadModuleResolutions m) diff --git a/src/Analysis/Abstract/BadValues.hs b/src/Analysis/Abstract/BadValues.hs index a0394caa9..68eeb6b97 100644 --- a/src/Analysis/Abstract/BadValues.hs +++ b/src/Analysis/Abstract/BadValues.hs @@ -8,7 +8,7 @@ import Prologue import Data.ByteString.Char8 (pack) newtype BadValues m (effects :: [* -> *]) a = BadValues (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadValues m) diff --git a/src/Analysis/Abstract/BadVariables.hs b/src/Analysis/Abstract/BadVariables.hs index d186e197f..608f8515d 100644 --- a/src/Analysis/Abstract/BadVariables.hs +++ b/src/Analysis/Abstract/BadVariables.hs @@ -9,7 +9,7 @@ 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) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (BadVariables m) diff --git a/src/Analysis/Abstract/Caching.hs b/src/Analysis/Abstract/Caching.hs index 62322c087..b6a949198 100644 --- a/src/Analysis/Abstract/Caching.hs +++ b/src/Analysis/Abstract/Caching.hs @@ -20,7 +20,7 @@ type CachingEffects location term value 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) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Caching m) diff --git a/src/Analysis/Abstract/Collecting.hs b/src/Analysis/Abstract/Collecting.hs index 653ce6cc7..ab22cccd4 100644 --- a/src/Analysis/Abstract/Collecting.hs +++ b/src/Analysis/Abstract/Collecting.hs @@ -11,7 +11,7 @@ import Data.Abstract.Live import Prologue newtype Collecting m (effects :: [* -> *]) a = Collecting (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) instance ( Effectful m , Member (Reader (Live location value)) effects diff --git a/src/Analysis/Abstract/Dead.hs b/src/Analysis/Abstract/Dead.hs index a3b76305a..8a4541aa8 100644 --- a/src/Analysis/Abstract/Dead.hs +++ b/src/Analysis/Abstract/Dead.hs @@ -11,7 +11,7 @@ import Prologue -- | An analysis tracking dead (unreachable) code. newtype DeadCode m (effects :: [* -> *]) a = DeadCode (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (DeadCode m) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 162722778..1390ca7be 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -19,7 +19,6 @@ import Prologue newtype Evaluating location term value effects a = Evaluating (Eff effects a) deriving (Applicative, Functor, Effectful, Monad) -deriving instance Member Fail effects => MonadFail (Evaluating location term value effects) deriving instance Member NonDet effects => Alternative (Evaluating location term value effects) -- | Effects necessary for evaluating (whether concrete or abstract). diff --git a/src/Analysis/Abstract/ImportGraph.hs b/src/Analysis/Abstract/ImportGraph.hs index 64af78c47..b2c4496db 100644 --- a/src/Analysis/Abstract/ImportGraph.hs +++ b/src/Analysis/Abstract/ImportGraph.hs @@ -55,7 +55,7 @@ style = (defaultStyle vertexName) edgeAttributes _ _ = [] newtype ImportGraphing m (effects :: [* -> *]) a = ImportGraphing (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (ImportGraphing m) diff --git a/src/Analysis/Abstract/Quiet.hs b/src/Analysis/Abstract/Quiet.hs index bda68a9e9..523377ce7 100644 --- a/src/Analysis/Abstract/Quiet.hs +++ b/src/Analysis/Abstract/Quiet.hs @@ -15,7 +15,7 @@ import Prologue -- -- 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) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Quietly m) diff --git a/src/Analysis/Abstract/Tracing.hs b/src/Analysis/Abstract/Tracing.hs index 5f723dbd4..244859bb7 100644 --- a/src/Analysis/Abstract/Tracing.hs +++ b/src/Analysis/Abstract/Tracing.hs @@ -14,7 +14,7 @@ import Prologue -- -- Instantiating @trace@ to @[]@ yields a linear trace analysis, while @Set@ yields a reachable state analysis. newtype Tracing (trace :: * -> *) m (effects :: [* -> *]) a = Tracing (m effects a) - deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail) + deriving (Alternative, Applicative, Functor, Effectful, Monad) deriving instance MonadEvaluator location term value effects m => MonadEvaluator location term value effects (Tracing trace m) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 82d278a55..3aa72e77c 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -75,11 +75,12 @@ import Prologue -- - a heap mapping addresses to (possibly sets of) values -- - tables of modules available for import class ( Effectful m + , Member Fail effects , Member (Reader (Environment location value)) effects , Member (Reader (ModuleTable [Module term])) effects , Member (Reader (SomeOrigin term)) effects , Member (State (EvaluatorState location term value)) effects - , MonadFail (m effects) + , Monad (m effects) ) => MonadEvaluator location term value (effects :: [* -> *]) m | m effects -> location term value where -- | Get the current 'Configuration' with a passed-in term. @@ -305,7 +306,7 @@ modifyLoadStack f = do currentModule :: forall location term value effects m . MonadEvaluator location term value effects m => m effects ModuleInfo currentModule = do o <- raise ask - maybeFail "unable to get currentModule" $ withSomeOrigin (originModule @term) o + maybeM (raise (fail "unable to get currentModule")) $ withSomeOrigin (originModule @term) o -- Control @@ -322,7 +323,7 @@ label term = do -- | “Jump” to a previously-allocated 'Label' (retrieving the @term@ at which it points, which can then be evaluated in e.g. a 'MonadAnalysis' instance). goto :: MonadEvaluator location term value effects m => Label -> m effects term -goto label = IntMap.lookup label <$> view _jumps >>= maybe (fail ("unknown label: " <> show label)) pure +goto label = IntMap.lookup label <$> view _jumps >>= maybe (raise (fail ("unknown label: " <> show label))) pure -- Exceptions diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 6c0d47378..f7c978090 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -50,6 +50,7 @@ type MonadEvaluatable location term value (effects :: [* -> *]) m = , Evaluatable (Base term) , FreeVariables term , Member (Exc.Exc (ControlThrow value)) effects + , Member Fail effects , Member (Resumable (Unspecialized value)) effects , Member (Resumable (ValueError location value)) effects , Member (Resumable (LoadError term value)) effects @@ -58,7 +59,6 @@ type MonadEvaluatable location term value (effects :: [* -> *]) m = , Member (Resumable (AddressError location value)) effects , MonadAddressable location effects m , MonadAnalysis location term value effects m - , MonadFail (m effects) , MonadValue location value effects m , Recursive term , Reducer value (Cell location value) diff --git a/src/Data/Abstract/Type.hs b/src/Data/Abstract/Type.hs index 79b977a1c..31bb51c28 100644 --- a/src/Data/Abstract/Type.hs +++ b/src/Data/Abstract/Type.hs @@ -35,7 +35,7 @@ data Type -- | Unify two 'Type's. -unify :: MonadFail m => Type -> Type -> m Type +unify :: (Effectful m, Applicative (m effects), Member Fail effects) => Type -> Type -> m effects Type unify (a1 :-> b1) (a2 :-> b2) = (:->) <$> unify a1 a2 <*> unify b1 b2 unify a Null = pure a unify Null b = pure b @@ -45,7 +45,7 @@ unify a (Var _) = pure a unify (Product as) (Product bs) = Product <$> sequenceA (alignWith (these pure pure unify) as bs) unify t1 t2 | t1 == t2 = pure t2 - | otherwise = fail ("cannot unify " ++ show t1 ++ " with " ++ show t2) + | otherwise = raise (fail ("cannot unify " ++ show t1 ++ " with " ++ show t2)) instance Ord location => ValueRoots location Type where @@ -54,10 +54,10 @@ instance Ord location => ValueRoots location Type where -- | Discard the value arguments (if any), constructing a 'Type' instead. instance ( Alternative (m effects) + , Member Fail effects , Member Fresh effects , MonadAddressable location effects m , MonadEvaluator location term Type effects m - , MonadFail (m effects) , Reducer Type (Cell location Type) ) => MonadValue location Type effects m where @@ -91,9 +91,9 @@ instance ( Alternative (m effects) scopedEnvironment _ = pure mempty - asString _ = fail "Must evaluate to Value to use asString" - asPair _ = fail "Must evaluate to Value to use asPair" - asBool _ = fail "Must evaluate to Value to use asBool" + asString _ = raise (fail "Must evaluate to Value to use asString") + asPair _ = raise (fail "Must evaluate to Value to use asPair") + asBool _ = raise (fail "Must evaluate to Value to use asBool") isHole ty = pure (ty == Hole) @@ -101,7 +101,7 @@ instance ( Alternative (m effects) liftNumeric _ Float = pure Float liftNumeric _ Int = pure Int - liftNumeric _ _ = fail "Invalid type in unary numeric operation" + liftNumeric _ _ = raise (fail "Invalid type in unary numeric operation") liftNumeric2 _ left right = case (left, right) of (Float, Int) -> pure Float @@ -109,10 +109,10 @@ instance ( Alternative (m effects) _ -> unify left right liftBitwise _ Int = pure Int - liftBitwise _ t = fail ("Invalid type passed to unary bitwise operation: " <> show t) + liftBitwise _ t = raise (fail ("Invalid type passed to unary bitwise operation: " <> show t)) liftBitwise2 _ Int Int = pure Int - liftBitwise2 _ t1 t2 = fail ("Invalid types passed to binary bitwise operation: " <> show (t1, t2)) + liftBitwise2 _ t1 t2 = raise (fail ("Invalid types passed to binary bitwise operation: " <> show (t1, t2))) liftComparison (Concrete _) left right = case (left, right) of (Float, Int) -> pure Bool @@ -126,7 +126,9 @@ instance ( Alternative (m effects) call op params = do tvar <- fresh paramTypes <- sequenceA params - _ :-> ret <- op `unify` (Product paramTypes :-> Var tvar) - pure ret + unified <- op `unify` (Product paramTypes :-> Var tvar) + case unified of + _ :-> ret -> pure ret + _ -> raise (fail "unification with a function produced something other than a function") loop f = f empty diff --git a/src/Language/PHP/Syntax.hs b/src/Language/PHP/Syntax.hs index b7e5a6c7f..4c8a6ff39 100644 --- a/src/Language/PHP/Syntax.hs +++ b/src/Language/PHP/Syntax.hs @@ -35,7 +35,7 @@ instance Evaluatable VariableName -- were defined inside that function. resolvePHPName :: MonadEvaluatable location term value effects m => ByteString -> m effects ModulePath -resolvePHPName n = resolve [name] >>= maybeFail notFound +resolvePHPName n = resolve [name] >>= maybeM (raise (fail notFound)) where name = toName n notFound = "Unable to resolve: " <> name toName = BC.unpack . dropRelativePrefix . stripQuotes @@ -366,7 +366,7 @@ instance Evaluatable Namespace where eval Namespace{..} = go names where names = freeVariables (subterm namespaceName) - go [] = fail "expected at least one free variable in namespaceName, found none" + go [] = raise (fail "expected at least one free variable in namespaceName, found none") -- The last name creates a closure over the namespace body. go [name] = letrec' name $ \addr -> subtermValue namespaceBody *> makeNamespace name addr [] diff --git a/src/Language/Python/Syntax.hs b/src/Language/Python/Syntax.hs index 11edb021a..86d9ca63e 100644 --- a/src/Language/Python/Syntax.hs +++ b/src/Language/Python/Syntax.hs @@ -74,7 +74,7 @@ resolvePythonModules q = do let searchPaths = [ path "__init__.py" , path <.> ".py" ] - resolve searchPaths >>= maybeFail (notFound searchPaths) + resolve searchPaths >>= maybeM (raise (fail (notFound searchPaths))) friendlyName :: QualifiedName -> String friendlyName (QualifiedName xs) = intercalate "." (NonEmpty.toList xs) @@ -121,7 +121,7 @@ instance Show1 QualifiedImport where liftShowsPrec = genericLiftShowsPrec -- import a.b.c instance Evaluatable QualifiedImport where - eval (QualifiedImport (RelativeQualifiedName _ _)) = fail "technically this is not allowed in python" + eval (QualifiedImport (RelativeQualifiedName _ _)) = raise (fail "technically this is not allowed in python") eval (QualifiedImport name@(QualifiedName qualifiedName)) = do modulePaths <- resolvePythonModules name go (NonEmpty.zip (FV.name . BC.pack <$> qualifiedName) modulePaths) diff --git a/src/Language/Ruby/Syntax.hs b/src/Language/Ruby/Syntax.hs index 7ae5f525f..158e2dcf1 100644 --- a/src/Language/Ruby/Syntax.hs +++ b/src/Language/Ruby/Syntax.hs @@ -93,7 +93,7 @@ instance Evaluatable Load where path <- subtermValue x >>= asString shouldWrap <- subtermValue wrap >>= asBool doLoad path shouldWrap - eval (Load _) = fail "invalid argument supplied to load, path is required" + eval (Load _) = raise (fail "invalid argument supplied to load, path is required") doLoad :: MonadEvaluatable location term value effects m => ByteString -> Bool -> m effects value doLoad path shouldWrap = do From 3e3f21c1d7bc9006826218358eefb875002d981a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:48:39 -0400 Subject: [PATCH 36/45] Use maybeM in Data.Scientific.Exts to fail parsing. --- src/Data/Scientific/Exts.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/src/Data/Scientific/Exts.hs b/src/Data/Scientific/Exts.hs index 9f43028f1..50df2a55d 100644 --- a/src/Data/Scientific/Exts.hs +++ b/src/Data/Scientific/Exts.hs @@ -3,16 +3,15 @@ module Data.Scientific.Exts , parseScientific ) where -import Prelude hiding (filter, null, takeWhile) - import Control.Applicative -import Control.Monad +import Control.Monad hiding (fail) import Data.Attoparsec.ByteString.Char8 import Data.ByteString.Char8 hiding (readInt, takeWhile) import Data.Char (isOctDigit) import Data.Scientific -import Data.Semigroup import Numeric +import Prelude hiding (fail, filter, null, takeWhile) +import Prologue hiding (null) import Text.Read (readMaybe) parseScientific :: ByteString -> Either String Scientific @@ -38,9 +37,9 @@ parser = signed (choice [hex, oct, bin, dec]) where -- The ending stanza. Note the explicit endOfInput call to ensure we haven't left any dangling input. done = skipWhile (inClass "iIjJlL") *> endOfInput - -- Wrapper around readMaybe. Analogous to maybeFail in the Prologue, but no need to pull that in. + -- Wrapper around readMaybe. attempt :: Read a => String -> Parser a - attempt str = maybe (fail ("No parse: " <> str)) pure (readMaybe str) + attempt str = maybeM (fail ("No parse: " <> str)) (readMaybe str) -- Parse a hex value, leaning on the parser provided by Attoparsec. hex = fromIntegral <$> (string "0x" *> hexadecimal @Integer) From ba52638f40506314f97bf5c8a555adcc9b4f7d2e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:48:43 -0400 Subject: [PATCH 37/45] :fire: maybeFail. --- src/Prologue.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/src/Prologue.hs b/src/Prologue.hs index d4603dc8f..f91d501ab 100644 --- a/src/Prologue.hs +++ b/src/Prologue.hs @@ -3,7 +3,6 @@ module Prologue ( module X , foldMapA , maybeM - , maybeFail , maybeLast , fromMaybeLast ) where @@ -73,7 +72,3 @@ fromMaybeLast b = fromMaybe b . getLast . foldMap (Last . Just) -- | Extract the 'Just' of a 'Maybe' in an 'Applicative' context or, given 'Nothing', run the provided action. maybeM :: Applicative f => f a -> Maybe a -> f a maybeM f = maybe f pure - --- | Either extract the 'Just' of a 'Maybe' or invoke 'fail' with the provided string. -maybeFail :: MonadFail m => String -> Maybe a -> m a -maybeFail s = maybeM (X.fail s) From 1c1fda485c3074a579db2fd993489e6b1a354f25 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:49:04 -0400 Subject: [PATCH 38/45] :fire: a language extension. --- src/Semantic/Util.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Semantic/Util.hs b/src/Semantic/Util.hs index 433c3c36f..055f28f42 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 DataKinds, MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators #-} +{-# LANGUAGE MonoLocalBinds, ScopedTypeVariables, TypeFamilies, TypeOperators #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} module Semantic.Util where From 8c972edd98282afc0a2dc385d0ab8687afaf6845 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 11:49:41 -0400 Subject: [PATCH 39/45] :fire: a use of PolyKinds. --- 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 f7c978090..920e88b62 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, PolyKinds, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, KindSignatures, UndecidableInstances #-} module Data.Abstract.Evaluatable ( module X , MonadEvaluatable From aab795d9bb4c747fcc1920892c778e35c6c9704e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 12:00:43 -0400 Subject: [PATCH 40/45] Correct an import in the specs. --- test/SpecHelpers.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/SpecHelpers.hs b/test/SpecHelpers.hs index e9cc3b47c..7bab8a4f4 100644 --- a/test/SpecHelpers.hs +++ b/test/SpecHelpers.hs @@ -12,7 +12,7 @@ module SpecHelpers ( , TestEvaluating , ) where -import Analysis.Abstract.Evaluating as X (EvaluatingState(..)) +import Control.Abstract.Evaluator as X (EvaluatorState(..)) import Data.Abstract.Address as X import Data.Abstract.FreeVariables as X hiding (dropExtension) import Data.Abstract.Heap as X From a85e41666b1eb1fedb40007335e3ea0b9c46a2e4 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 12:01:28 -0400 Subject: [PATCH 41/45] =?UTF-8?q?Don=E2=80=99t=20re-export=20EvaluatorStat?= =?UTF-8?q?e=20&=20State=20from=20Evaluating.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/Analysis/Abstract/Evaluating.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 558ddd2e7..3733d5374 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -1,8 +1,6 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, RankNTypes, ScopedTypeVariables, TypeFamilies #-} module Analysis.Abstract.Evaluating ( Evaluating -, EvaluatorState(..) -, State ) where import Control.Abstract.Analysis From af6e09a7350f5e9588aafac2497a4928101bf49f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 12:09:23 -0400 Subject: [PATCH 42/45] :fire: a redundant kind signature. --- src/Control/Abstract/Evaluator.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Evaluator.hs b/src/Control/Abstract/Evaluator.hs index 3aa72e77c..6cf18eadb 100644 --- a/src/Control/Abstract/Evaluator.hs +++ b/src/Control/Abstract/Evaluator.hs @@ -82,7 +82,7 @@ class ( Effectful m , Member (State (EvaluatorState location term value)) effects , Monad (m effects) ) - => MonadEvaluator location term value (effects :: [* -> *]) m | m effects -> location term value where + => MonadEvaluator location term value effects m | m effects -> location term value where -- | Get the current 'Configuration' with a passed-in term. getConfiguration :: Ord location => term -> m effects (Configuration location term value) From 145d48ede4c132054607debd2777edf1308df78a Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 12:09:41 -0400 Subject: [PATCH 43/45] And another. --- 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 96e423405..c5f070e97 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -13,7 +13,7 @@ import Data.Semigroup.Reducer import Prologue -- | Defines 'alloc'ation and 'deref'erencing of 'Address'es in a Heap. -class (Effectful m, Member Fresh effects, Monad (m effects), Ord location) => MonadAddressable location (effects :: [* -> *]) m where +class (Effectful m, Member Fresh effects, Monad (m effects), Ord location) => MonadAddressable location effects m where derefCell :: Address location value -> Cell location value -> m effects (Maybe value) allocLoc :: Name -> m effects location From 447bb428a407f2918bc9cc3559ece23526fd000f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 12:10:11 -0400 Subject: [PATCH 44/45] And another. --- src/Data/Abstract/Evaluatable.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 16c5ebf14..7a036fa8f 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, KindSignatures, UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, UndecidableInstances #-} module Data.Abstract.Evaluatable ( module X , MonadEvaluatable @@ -45,7 +45,7 @@ import Data.Semigroup.Reducer hiding (unit) import Data.Term import Prologue -type MonadEvaluatable location term value (effects :: [* -> *]) m = +type MonadEvaluatable location term value effects m = ( Declarations term , Effectful m , Evaluatable (Base term) From 9c8aff921fe718421ddd7b551b29328519744f88 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 24 Apr 2018 12:15:29 -0400 Subject: [PATCH 45/45] Tidy up the Control.Abstract.Value language extensions. --- src/Control/Abstract/Value.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index b85e27f7b..fa7fa1908 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FunctionalDependencies, GADTs, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-} +{-# LANGUAGE FunctionalDependencies, GADTs, KindSignatures, Rank2Types #-} module Control.Abstract.Value ( MonadValue(..) , Comparator(..)