Merge branch 'imports,-graphed' into evaluate-in-the-outer-analysis

.stylish-haskell.yaml

@@ -218,6 +218,7 @@ newline: native
 # command line instead of using language pragmas in the file. stylish-haskell
 # needs to be aware of these, so it can parse the file correctly.
 language_extensions:
+  - ExplicitNamespaces
   - DeriveFoldable
   - DeriveFunctor
   - DeriveGeneric

src/Analysis/Abstract/Evaluating.hs

@@ -1,4 +1,5 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types, ScopedTypeVariables,
+             StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Analysis.Abstract.Evaluating
 ( type Evaluating
 , findValue
@@ -31,7 +32,8 @@ deriving instance Member NonDet    effects => MonadNonDet (Evaluating term value
 
 -- | Effects necessary for evaluating (whether concrete or abstract).
 type EvaluatingEffects term value
-  = '[ Resumable Prelude.String value
+  = '[ Resumable (ValueExc value)
+     , Resumable (Unspecialized value)
      , Fail                                               -- Failure with an error message
      , Reader [Module term]                               -- The stack of currently-evaluating modules.
      , State  (EnvironmentFor value)                      -- Environments (both local and global)
@@ -44,8 +46,8 @@ type EvaluatingEffects term value
      ]
 
 -- | Find the value in the 'Final' result of running.
-findValue :: forall value term effects . (effects ~ RequiredEffects term value (Evaluating term value effects))
+findValue :: forall value term effects. (effects ~ RequiredEffects term value (Evaluating term value effects))
-          => Final effects value -> Either Prelude.String (Either Prelude.String value)
+          => Final effects value -> Either Prelude.String (Either (SomeExc (Unspecialized value)) (Either (SomeExc (ValueExc value)) value))
 findValue (((((v, _), _), _), _), _) = v
 
 -- | Find the 'Environment' in the 'Final' result of running.
@@ -110,7 +112,7 @@ instance ( Members (EvaluatingEffects term value) effects
          => MonadAnalysis term value (Evaluating term value effects) where
   type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value
 
-  analyzeTerm eval term = resumeException @value (eval term) (\yield exc -> string (BC.pack exc) >>= yield)
+  analyzeTerm eval term = resumeException @(Unspecialized value) (eval term) (\yield (Unspecialized str) -> string (BC.pack str) >>= yield)
 
   analyzeModule eval m = pushModule (subterm <$> m) (eval m)
 

src/Control/Abstract/Evaluator.hs

@@ -177,10 +177,10 @@ class Monad m => MonadControl term m | m -> term 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 term
 
-class Monad m => MonadThrow exc v m where
+class Monad m => MonadThrow exc m where
-  throwException :: exc -> m v
+  throwException :: exc v -> m v
 
-instance (Effectful m, Members '[Resumable exc value] effects, Monad (m effects)) => MonadThrow exc value (m effects) where
+instance (Effectful m, Members '[Resumable exc] effects, Monad (m effects)) => MonadThrow exc (m effects) where
   throwException = raise . throwError
 
 

src/Control/Abstract/Value.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, MultiParamTypeClasses, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Value
 ( MonadValue(..)
 , Comparator(..)
@@ -7,6 +7,7 @@ module Control.Abstract.Value
 , forLoop
 , toBool
 , ValueRoots(..)
+, ValueExc(..)
 , EnvironmentFor
 , ExportsFor
 , HeapFor
@@ -167,3 +168,18 @@ doWhile body cond = loop $ \ continue -> body *> do
 class ValueRoots value where
   -- | Compute the set of addresses rooted by a given value.
   valueRoots :: value -> LiveFor value
+
+
+-- The type of exceptions that can be thrown when constructing values in `MonadValue`.
+data ValueExc value resume where
+  ValueExc :: Prelude.String -> ValueExc value value
+  StringExc :: Prelude.String -> ValueExc value ByteString
+
+instance Eq1 (ValueExc value) where
+  liftEq _ (ValueExc a)  (ValueExc b)  = a == b
+  liftEq _ (StringExc a) (StringExc b) = a == b
+  liftEq _ _             _             = False
+
+deriving instance Show (ValueExc value resume)
+instance Show1 (ValueExc value) where
+  liftShowsPrec _ _ = showsPrec

src/Control/Effect.hs

@@ -1,13 +1,13 @@
-{-# LANGUAGE TypeFamilies, TypeOperators, UndecidableInstances, ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Effect where
 
 import Control.Monad.Effect as Effect
 import Control.Monad.Effect.Fail
 import Control.Monad.Effect.NonDet
 import Control.Monad.Effect.Reader
+import Control.Monad.Effect.Resumable
 import Control.Monad.Effect.State
 import Control.Monad.Effect.Writer
-import Control.Monad.Effect.Resumable
 import Data.Semigroup.Reducer
 import Prologue
 
@@ -64,11 +64,11 @@ instance Ord a => RunEffect NonDet a where
   runEffect = runNonDet unit
 
 -- | 'Resumable' effects are interpreted into 'Either' s.t. failures are in 'Left' and successful results are in 'Right'.
-instance RunEffect (Resumable exc v) a where
+instance RunEffect (Resumable exc) a where
-  type Result (Resumable exc v) a = Either exc a
+  type Result (Resumable exc) a = Either (SomeExc exc) a
   runEffect = runError
 
-resumeException :: forall v m exc e a. (Effectful m, Resumable exc v :< e) => m e a -> ((v -> m e a) -> exc -> m e a) -> m e a
+resumeException :: (Resumable exc :< e, Effectful m) => m e a -> (forall v . (v -> m e a) -> exc v -> m e a) -> m e a
 resumeException m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
 
 -- | Reassociate 'Either's, combining errors into 'Left' values and successes in a single level of 'Right'.

src/Data/Abstract/Evaluatable.hs

@@ -1,8 +1,9 @@
-{-# LANGUAGE ConstraintKinds, DefaultSignatures, UndecidableInstances #-}
+{-# LANGUAGE ConstraintKinds, DefaultSignatures, GADTs, UndecidableInstances #-}
 module Data.Abstract.Evaluatable
 ( module X
 , MonadEvaluatable
 , Evaluatable(..)
+, Unspecialized(..)
 , evaluateTerm
 , evaluateModule
 , withModules
@@ -29,18 +30,29 @@ type MonadEvaluatable term value m =
   , FreeVariables term
   , MonadAddressable (LocationFor value) value m
   , MonadAnalysis term value m
-  , MonadThrow Prelude.String value m
+  , MonadThrow (Unspecialized value) m
   , MonadValue value m
   , Recursive term
   , Show (LocationFor value)
   )
 
+data Unspecialized a b where
+  Unspecialized :: { getUnspecialized :: Prelude.String } -> Unspecialized value value
+
+instance Eq1 (Unspecialized a) where
+  liftEq _ (Unspecialized a) (Unspecialized b) = a == b
+
+deriving instance Eq (Unspecialized a b)
+deriving instance Show (Unspecialized a b)
+instance Show1 (Unspecialized a) where
+  liftShowsPrec _ _ = showsPrec
+
 -- | 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 term value m
        => SubtermAlgebra constr term (m value)
-  default eval :: (MonadThrow Prelude.String value m, Show1 constr) => SubtermAlgebra constr term (m value)
+  default eval :: (MonadThrow (Unspecialized value) m, Show1 constr) => SubtermAlgebra constr term (m value)
-  eval expr = throwException $ "Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""
+  eval expr = throwException (Unspecialized ("Eval unspecialized for " ++ liftShowsPrec (const (const id)) (const id) 0 expr ""))
 
 
 -- Instances

test/Analysis/Python/Spec.hs

@@ -30,11 +30,11 @@ spec = parallel $ do
 
     it "subclasses" $ do
       v <- findValue <$> evaluate "subclass.py"
-      v `shouldBe` Right (Right (injValue (String "\"bar\"")))
+      v `shouldBe` Right (Right (Right (injValue (String "\"bar\""))))
 
     it "handles multiple inheritance left-to-right" $ do
       v <- findValue <$> evaluate "multiple_inheritance.py"
-      v `shouldBe` Right (Right (injValue (String "\"foo!\"")))
+      v `shouldBe` Right (Right (Right (injValue (String "\"foo!\""))))
 
   where
     addr = Address . Precise

test/Analysis/Ruby/Spec.hs

@@ -30,11 +30,11 @@ spec = parallel $ do
 
     it "subclass" $ do
       res <- findValue <$> evaluate "subclass.rb"
-      res `shouldBe` Right (Right (injValue (String "\"<bar>\"")))
+      res `shouldBe` Right (Right (Right (injValue (String "\"<bar>\""))))
 
     it "has prelude" $ do
       res <- findValue <$> evaluate "preluded.rb"
-      res `shouldBe` Right (Right (injValue (String "\"<foo>\"")))
+      res `shouldBe` Right (Right (Right (injValue (String "\"<foo>\""))))
 
   where
     addr = Address . Precise

test/fixtures/ruby/analysis/src/main.rb

@@ -0,0 +1,10 @@
+require File.join(__FILE__, "../foo.rb")
+require "foo"
+
+bar()
+
+# def foo
+#   return "in foo"
+# end
+
+foo()

vendor/effects

@@ -1 +1 @@
-Subproject commit 7d4525db7b6a12c0a34da5f70a97db137c144c60
+Subproject commit 74c1ca98ae9007e64fdc3f819b7d096ff7f802f7