Merge pull request #1821 from github/evaluator-dsl

Evaluator DSL

semantic.cabal

@@ -236,12 +236,13 @@ test-suite test
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test
   main-is:             Spec.hs
-  other-modules:       Assigning.Assignment.Spec
+  other-modules:       Analysis.Go.Spec
-                     , Analysis.Go.Spec
                      , Analysis.PHP.Spec
                      , Analysis.Python.Spec
                      , Analysis.Ruby.Spec
                      , Analysis.TypeScript.Spec
+                     , Assigning.Assignment.Spec
+                     , Control.Abstract.Evaluator.Spec
                      , Data.Diff.Spec
                      , Data.Abstract.Path.Spec
                      , Data.Functor.Classes.Generic.Spec

src/Control/Abstract/Addressable.hs

@@ -58,6 +58,21 @@ letrec' name body = do
   v <- localEnv id (body addr)
   v <$ modifyEnv (insert name addr)
 
+
+-- | Look up and dereference the given 'Name', throwing an exception for free variables.
+variable :: ( Addressable location effects
+            , Members '[ Reader (Environment location value)
+                       , Resumable (AddressError location value)
+                       , Resumable (EnvironmentError value)
+                       , State (Environment location value)
+                       , State (Heap location value)
+                       ] effects
+            )
+         => Name
+         -> Evaluator location term value effects value
+variable name = lookupEnv name >>= maybe (freeVariableError name) deref
+
+
 -- Instances
 
 -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.

src/Control/Abstract/Environment.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE GADTs, RankNTypes, TypeOperators #-}
 module Control.Abstract.Environment
 ( Environment
 , getEnv
@@ -10,7 +11,10 @@ module Control.Abstract.Environment
 , localEnv
 , localize
 , lookupEnv
-, lookupWith
+, EnvironmentError(..)
+, freeVariableError
+, runEnvironmentError
+, runEnvironmentErrorWith
 ) where
 
 import Control.Abstract.Evaluator
@@ -65,8 +69,21 @@ localize = localEnv id
 lookupEnv :: Members '[Reader (Environment location value), State (Environment location value)] effects => Name -> Evaluator location term value 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 :: Members '[Reader (Environment location value), State (Environment location value)] effects => (Address location value -> Evaluator location term value effects a) -> Name -> Evaluator location term value effects (Maybe a)
+-- | Errors involving the environment.
-lookupWith with name = do
+data EnvironmentError value return where
-  addr <- lookupEnv name
+  FreeVariable :: Name -> EnvironmentError value value
-  maybe (pure Nothing) (fmap Just . with) addr
+
+deriving instance Eq (EnvironmentError value return)
+deriving instance Show (EnvironmentError value return)
+instance Show1 (EnvironmentError value) where liftShowsPrec _ _ = showsPrec
+instance Eq1 (EnvironmentError value) where liftEq _ (FreeVariable n1) (FreeVariable n2) = n1 == n2
+
+freeVariableError :: Member (Resumable (EnvironmentError value)) effects => Name -> Evaluator location term value effects value
+freeVariableError = throwResumable . FreeVariable
+
+runEnvironmentError :: Evaluator location term value (Resumable (EnvironmentError value) ': effects) a -> Evaluator location term value effects (Either (SomeExc (EnvironmentError value)) a)
+runEnvironmentError = raiseHandler runError
+
+runEnvironmentErrorWith :: (forall resume . EnvironmentError value resume -> Evaluator location term value effects resume) -> Evaluator location term value (Resumable (EnvironmentError value) ': effects) a -> Evaluator location term value effects a
+runEnvironmentErrorWith = runResumableWith

src/Control/Abstract/Value.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE FunctionalDependencies, GADTs, KindSignatures, Rank2Types #-}
+{-# LANGUAGE GADTs, KindSignatures, Rank2Types #-}
 module Control.Abstract.Value
 ( AbstractValue(..)
 , AbstractHole(..)
@@ -40,7 +40,7 @@ class AbstractHole value where
 -- | 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 Show value => AbstractValue location term value (effects :: [* -> *]) | effects value -> location where
+class Show value => AbstractValue location term value (effects :: [* -> *]) where
   -- | Construct an abstract unit value.
   --   TODO: This might be the same as the empty tuple for some value types
   unit :: Evaluator location term value effects value

src/Control/Effect.hs

@@ -8,6 +8,7 @@ module Control.Effect
 , throwResumable
 -- * Handlers
 , run
+, runM
 , runEffect
 , raiseHandler
 , runReader
@@ -53,6 +54,9 @@ throwResumable = raise . throwError
 run :: Effectful m => m '[] a -> a
 run = Eff.run . lower
 
+runM :: (Effectful m, Monad f) => m '[f] a -> f a
+runM = Eff.runM . lower
+
 runEffect :: Effectful m => (forall v . effect v -> (v -> m effects a) -> m effects a) -> m (effect ': effects) a -> m effects a
 runEffect handler = raiseHandler (Eff.relay pure (\ effect yield -> lower (handler effect (raise . yield))))
 

src/Data/Abstract/Evaluatable.hs

@@ -8,7 +8,6 @@ module Data.Abstract.Evaluatable
 , EvalError(..)
 , runEvalError
 , runEvalErrorWith
-, variable
 , evaluateInScopedEnv
 , evaluatePackageWith
 , evaluatePackageBodyWith
@@ -59,6 +58,7 @@ type EvaluatableConstraints location term value effects =
              , Reader (ModuleTable [Module term])
              , Reader PackageInfo
              , Resumable (AddressError location value)
+             , Resumable (EnvironmentError value)
              , Resumable (EvalError value)
              , Resumable (LoadError term)
              , Resumable ResolutionError
@@ -76,8 +76,6 @@ type EvaluatableConstraints location term value effects =
 
 -- | The type of error thrown when failing to evaluate a term.
 data EvalError value resume where
-  -- Indicates we weren't able to dereference a name from the evaluated environment.
-  FreeVariableError :: Name -> EvalError value value
   FreeVariablesError :: [Name] -> EvalError value Name
   -- Indicates that our evaluator wasn't able to make sense of these literals.
   IntegerFormatError  :: ByteString -> EvalError value Integer
@@ -108,25 +106,11 @@ evaluateInScopedEnv scopedEnvTerm term = do
   scopedEnv <- scopedEnvironment value
   maybe (throwEvalError (EnvironmentLookupError value)) (flip localEnv term . mergeEnvs) scopedEnv
 
--- | Look up and dereference the given 'Name', throwing an exception for free variables.
-variable :: ( Addressable location effects
-            , Members '[ Reader (Environment location value)
-                       , Resumable (AddressError location value)
-                       , Resumable (EvalError value)
-                       , State (Environment location value)
-                       , State (Heap location value)
-                       ] effects
-            )
-         => Name
-         -> Evaluator location term value effects value
-variable name = lookupWith deref name >>= maybeM (throwResumable (FreeVariableError name))
-
 deriving instance Eq a => Eq (EvalError a b)
 deriving instance Show a => Show (EvalError a b)
 instance Show value => Show1 (EvalError value) where
   liftShowsPrec _ _ = showsPrec
 instance Eq term => Eq1 (EvalError term) where
-  liftEq _ (FreeVariableError a) (FreeVariableError b)     = a == b
   liftEq _ (FreeVariablesError a) (FreeVariablesError b)   = a == b
   liftEq _ DefaultExportError DefaultExportError           = True
   liftEq _ (ExportError a b) (ExportError c d)             = (a == c) && (b == d)

src/Data/Abstract/Value.hs

@@ -222,7 +222,6 @@ instance ( Addressable location effects
                     , State (Heap location (Value location))
                     , State (JumpTable term)
                     ] effects
-         , Recursive term
          , Reducer (Value location) (Cell location (Value location))
          , Show location
          )

src/Semantic/Graph.hs

@@ -5,6 +5,7 @@ import           Analysis.Abstract.Evaluating
 import           Analysis.Abstract.Graph
 import           Control.Effect (runIgnoringTraces)
 import qualified Control.Exception as Exc
+import           Control.Monad.Effect (relayState)
 import           Data.Abstract.Address
 import           Data.Abstract.Evaluatable
 import           Data.Abstract.Located
@@ -48,6 +49,7 @@ graph graphType renderer project
             . resumingLoadError
             . resumingUnspecialized
             . resumingValueError
+            . resumingEnvironmentError
             . resumingEvalError
             . resumingResolutionError
             . resumingAddressError
@@ -89,18 +91,15 @@ resumingResolutionError = runResolutionErrorWith (\ err -> traceM ("ResolutionEr
 resumingLoadError :: Evaluator location term value (Resumable (LoadError term) ': effects) a -> Evaluator location term value effects a
 resumingLoadError = runLoadErrorWith (\ (LoadError _) -> pure [])
 
-resumingEvalError :: (AbstractHole value, Show value) => Evaluator location term value (Resumable (EvalError value) ': State [Name] ': effects) a -> Evaluator location term value effects (a, [Name])
+resumingEvalError :: (AbstractHole value, Show value) => Evaluator location term value (Resumable (EvalError value) ': effects) a -> Evaluator location term value effects a
-resumingEvalError
+resumingEvalError = runEvalErrorWith (\ err -> traceM ("EvalError" <> show err) *> case err of
-  = runState []
-  . runEvalErrorWith (\ err -> traceM ("EvalError" <> show err) *> case err of
   EnvironmentLookupError{} -> pure hole
   DefaultExportError{}     -> pure ()
   ExportError{}            -> pure ()
   IntegerFormatError{}     -> pure 0
   FloatFormatError{}       -> pure 0
   RationalFormatError{}    -> pure 0
-    FreeVariableError name   -> raise (modify' (name :)) $> hole
+  FreeVariablesError names -> pure (fromMaybeLast "unknown" names))
-    FreeVariablesError names -> raise (modify' (names <>)) $> fromMaybeLast "unknown" names)
 
 resumingUnspecialized :: AbstractHole value => Evaluator location term value (Resumable (Unspecialized value) ': effects) a -> Evaluator location term value effects a
 resumingUnspecialized = runUnspecializedWith (\ err@(Unspecialized _) -> traceM ("Unspecialized:" <> show err) $> hole)
@@ -125,3 +124,6 @@ resumingValueError = runValueErrorWith (\ err -> traceM ("ValueError" <> show er
   Bitwise2Error{}   -> pure hole
   KeyValueError{}   -> pure (hole, hole)
   ArithmeticError{} -> pure hole)
+
+resumingEnvironmentError :: AbstractHole value => Evaluator location term value (Resumable (EnvironmentError value) ': effects) a -> Evaluator location term value effects (a, [Name])
+resumingEnvironmentError = raiseHandler (relayState [] (fmap pure . flip (,)) (\ names (Resumable (FreeVariable name)) yield -> yield (name : names) hole))

src/Semantic/Util.hs

@@ -7,7 +7,6 @@ import           Analysis.Abstract.Collecting
 import           Analysis.Abstract.Evaluating as X
 import           Control.Abstract.Evaluator
 import           Control.Effect (runPrintingTraces)
-import           Control.Monad.Effect (runM)
 import           Data.Abstract.Address
 import           Data.Abstract.Evaluatable
 import           Data.Abstract.Value
@@ -27,38 +26,43 @@ import qualified Language.Python.Assignment as Python
 import qualified Language.Ruby.Assignment as Ruby
 
 justEvaluating
-  = runM . lower
+  = runM
+  . fmap (first reassociate)
   . evaluating
   . runPrintingTraces
   . runLoadError
   . runValueError
   . runUnspecialized
   . runResolutionError
+  . runEnvironmentError
   . runEvalError
   . runAddressError
   . constrainedToValuePrecise
 
 evaluatingWithHoles
-  = runM . lower
+  = runM
   . evaluating
   . runPrintingTraces
   . resumingLoadError
   . resumingUnspecialized
   . resumingValueError
+  . resumingEnvironmentError
   . resumingEvalError
   . resumingResolutionError
-  . resumingAddressError @(Value Precise)
+  . resumingAddressError @(Value Precise) @Precise
   . constrainedToValuePrecise
 
 -- The order is significant here: caching has to run before typeChecking, or else we’ll nondeterministically produce TypeErrors as part of the result set. While this is probably actually correct, it will require us to have an Ord instance for TypeError, which we don’t have yet.
 checking
-  = runM . lower
+  = runM
+  . fmap (first reassociate)
   . evaluating
   . runPrintingTraces
   . providingLiveSet
   . runLoadError
   . runUnspecialized
   . runResolutionError
+  . runEnvironmentError
   . runEvalError
   . runAddressError
   . runTypeError
@@ -93,3 +97,12 @@ parseFile parser = runTask . (parse parser <=< readBlob . file)
 
 blob :: FilePath -> IO Blob
 blob = runTask . readBlob . file
+
+
+injectConst :: a -> SomeExc (Sum '[Const a])
+injectConst = SomeExc . injectSum . Const
+
+mergeExcs :: Either (SomeExc (Sum excs)) (Either (SomeExc exc) result) -> Either (SomeExc (Sum (exc ': excs))) result
+mergeExcs = either (\ (SomeExc sum) -> Left (SomeExc (weakenSum sum))) (either (\ (SomeExc exc) -> Left (SomeExc (injectSum exc))) Right)
+
+reassociate = mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . mergeExcs . first injectConst

test/Analysis/Python/Spec.hs

@@ -40,11 +40,11 @@ spec = parallel $ do
 
     it "subclasses" $ do
       v <- fst <$> evaluate "subclass.py"
-      v `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"bar\"")))))))))
+      v `shouldBe` Right [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 (pure (injValue (String "\"foo!\"")))))))))
+      v `shouldBe` Right [injValue (String "\"foo!\"")]
 
   where
     ns n = Just . Latest . Just . injValue . Namespace n

test/Analysis/Ruby/Spec.hs

@@ -9,6 +9,7 @@ import Control.Monad.Effect (SomeExc(..))
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Map
 import Data.Map.Monoidal as Map
+import Data.Sum
 import qualified Language.Ruby.Assignment as Ruby
 import qualified Data.Language as Language
 
@@ -30,12 +31,12 @@ spec = parallel $ do
 
     it "evaluates load with wrapper" $ do
       res <- evaluate "load-wrap.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc (FreeVariableError "foo")))))))
+      fst res `shouldBe` Left (SomeExc (injectSum (FreeVariable "foo" :: EnvironmentError (Value Precise) (Value Precise))))
       environment (snd res) `shouldBe` [ ("Object", addr 0) ]
 
     it "evaluates subclass" $ do
       res <- evaluate "subclass.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<bar>\"")))))))))
+      fst res `shouldBe` Right [injValue (String "\"<bar>\"")]
       environment (snd res) `shouldBe` [ ("Bar", addr 6)
                                        , ("Foo", addr 3)
                                        , ("Object", addr 0) ]
@@ -47,29 +48,29 @@ spec = parallel $ do
 
     it "evaluates modules" $ do
       res <- evaluate "modules.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<hello>\"")))))))))
+      fst res `shouldBe` Right [injValue (String "\"<hello>\"")]
       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 (pure (injValue (Value.Integer (Number.Integer 3))))))))))
+      fst res `shouldBe` Right [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 (pure (injValue (Value.Integer (Number.Integer 8))))))))))
+      fst res `shouldBe` Right [injValue (Value.Integer (Number.Integer 8))]
 
     it "calls functions with arguments" $ do
       res <- evaluate "call.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 579))))))))))
+      fst res `shouldBe` Right [injValue (Value.Integer (Number.Integer 579))]
 
     it "evaluates early return statements" $ do
       res <- evaluate "early-return.rb"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Integer (Number.Integer 123))))))))))
+      fst res `shouldBe` Right [injValue (Value.Integer (Number.Integer 123))]
 
     it "has prelude" $ do
       res <- fst <$> evaluate "preluded.rb"
-      res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (String "\"<foo>\"")))))))))
+      res `shouldBe` Right [injValue (String "\"<foo>\"")]
 
   where
     ns n = Just . Latest . Just . injValue . Namespace n

test/Analysis/TypeScript/Spec.hs

@@ -6,6 +6,7 @@ import qualified Language.TypeScript.Assignment as TypeScript
 import Data.Abstract.Value as Value
 import Data.Abstract.Number as Number
 import qualified Data.Language as Language
+import Data.Sum
 
 import SpecHelpers
 
@@ -34,11 +35,11 @@ spec = parallel $ do
 
     it "fails exporting symbols not defined in the module" $ do
       v <- fst <$> evaluate "bad-export.ts"
-      v `shouldBe` Right (Right (Right (Right (Right (Left (SomeExc (ExportError "foo.ts" (Name "pip"))))))))
+      v `shouldBe` Left (SomeExc (injectSum (ExportError "foo.ts" (Name "pip") :: EvalError (Value Precise) ())))
 
     it "evaluates early return statements" $ do
       res <- evaluate "early-return.ts"
-      fst res `shouldBe` Right (Right (Right (Right (Right (Right (Right (pure (injValue (Value.Float (Number.Decimal 123.0))))))))))
+      fst res `shouldBe` Right [injValue (Value.Float (Number.Decimal 123.0))]
 
   where
     fixtures = "test/fixtures/typescript/analysis/"

test/Control/Abstract/Evaluator/Spec.hs

@@ -0,0 +1,73 @@
+module Control.Abstract.Evaluator.Spec where
+
+import Analysis.Abstract.Evaluating (evaluating)
+import Control.Abstract
+import Data.Abstract.Module
+import qualified Data.Abstract.Number as Number
+import Data.Abstract.Package
+import qualified Data.Abstract.Value as Value
+import Data.Algebra
+import Data.Bifunctor (first)
+import Data.Functor.Const
+import Data.Sum
+import SpecHelpers hiding (Term, reassociate)
+
+spec :: Spec
+spec = parallel $ do
+  it "constructs integers" $ do
+    (expected, _) <- evaluate (integer 123)
+    expected `shouldBe` Right (Value.injValue (Value.Integer (Number.Integer 123)))
+
+  it "calls functions" $ do
+    (expected, _) <- evaluate $ do
+      identity <- lambda [name "x"] (term (variable (name "x")))
+      call identity [integer 123]
+    expected `shouldBe` Right (Value.injValue (Value.Integer (Number.Integer 123)))
+
+evaluate
+  = runM
+  . fmap (first reassociate)
+  . evaluating
+  . runReader (PackageInfo (name "test") Nothing)
+  . runReader (ModuleInfo "test/Control/Abstract/Evaluator/Spec.hs")
+  . Value.runValueError
+  . runEnvironmentError
+  . runAddressError
+  . runValue
+runValue = runEvalClosure (runValue . runTerm) . runReturn . runLoopControl
+
+reassociate :: Either String (Either (SomeExc exc1) (Either (SomeExc exc2) (Either (SomeExc exc3) result))) -> Either (SomeExc (Sum '[Const String, exc1, exc2, exc3])) result
+reassociate (Left s) = Left (SomeExc (injectSum (Const s)))
+reassociate (Right (Right (Right (Right a)))) = Right a
+
+term :: TermEvaluator Value -> Subterm Term (TermEvaluator Value)
+term eval = Subterm (Term eval) eval
+
+type TermEffects
+  = '[ LoopControl Value
+     , Return Value
+     , EvalClosure Term Value
+     , Resumable (AddressError Precise Value)
+     , Resumable (EnvironmentError Value)
+     , Resumable (Value.ValueError Precise Value)
+     , Reader ModuleInfo
+     , Reader PackageInfo
+     , Fail
+     , Fresh
+     , Reader (Environment Precise Value)
+     , State (Environment Precise Value)
+     , State (Heap Precise Value)
+     , State (ModuleTable (Environment Precise Value, Value))
+     , State (Exports Precise Value)
+     , State (JumpTable Term)
+     , IO
+     ]
+
+type TermEvaluator = Evaluator Precise Term Value TermEffects
+
+type Value = Value.Value Precise
+newtype Term = Term { runTerm :: TermEvaluator Value }
+
+instance Show Term where showsPrec d _ = showParen (d > 10) $ showString "Term _"
+
+instance FreeVariables Term where freeVariables _ = []

test/Spec.hs

@@ -6,6 +6,7 @@ import qualified Analysis.Python.Spec
 import qualified Analysis.Ruby.Spec
 import qualified Analysis.TypeScript.Spec
 import qualified Assigning.Assignment.Spec
+import qualified Control.Abstract.Evaluator.Spec
 import qualified Data.Diff.Spec
 import qualified Data.Abstract.Path.Spec
 import qualified Data.Functor.Classes.Generic.Spec
@@ -35,6 +36,7 @@ main = hspec $ do
     describe "Analysis.Ruby" Analysis.Ruby.Spec.spec
     describe "Analysis.TypeScript" Analysis.TypeScript.Spec.spec
     describe "Assigning.Assignment" Assigning.Assignment.Spec.spec
+    describe "Control.Abstract.Evaluator" Control.Abstract.Evaluator.Spec.spec
     describe "Data.Diff" Data.Diff.Spec.spec
     describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
     describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec

test/SpecHelpers.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE GADTs, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
 module SpecHelpers
 ( module X
 , diffFilePaths
@@ -22,6 +21,7 @@ import Data.Abstract.FreeVariables as X hiding (dropExtension)
 import Data.Abstract.Heap as X
 import Data.Abstract.ModuleTable as X hiding (lookup)
 import Data.Abstract.Value (Namespace(..), Value, ValueError, injValue, runValueError)
+import Data.Bifunctor (first)
 import Data.Blob as X
 import Data.File as X
 import Data.Functor.Listable as X
@@ -70,12 +70,14 @@ readFilePair paths = let paths' = fmap file paths in
 
 testEvaluating
   = run
+  . fmap (first reassociate)
   . evaluating
   . runIgnoringTraces
   . runLoadError
   . runValueError
   . runUnspecialized
   . runResolutionError
+  . runEnvironmentError
   . runEvalError
   . runAddressError
   . constrainedToValuePrecise