Merge branch 'master' into imports,-graphed

.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,6 @@
-{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE DataKinds, GADTs, GeneralizedNewtypeDeriving, MultiParamTypeClasses, Rank2Types, ScopedTypeVariables,
+             StandaloneDeriving, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 module Analysis.Abstract.Evaluating
 ( type Evaluating
 , findValue
@@ -8,24 +10,24 @@ module Analysis.Abstract.Evaluating
 , load
 ) where
 
-import Control.Abstract.Evaluator
+import           Control.Abstract.Evaluator
-import Control.Monad.Effect
+import           Control.Monad.Effect
-import Control.Monad.Effect.Resumable
+import           Control.Monad.Effect.Resumable
-import Data.Abstract.Configuration
+import           Data.Abstract.Configuration
+import           Data.Abstract.Environment (Environment)
 import qualified Data.Abstract.Environment as Env
-import Data.Abstract.Environment (Environment)
+import           Data.Abstract.Evaluatable
-import Data.Abstract.Heap (Heap(..))
+import           Data.Abstract.Exports (Exports)
 import qualified Data.Abstract.Exports as Export
-import Data.Abstract.Exports (Exports)
+import           Data.Abstract.Heap
-import Data.Abstract.Evaluatable
+import           Data.Abstract.Module
-import Data.Abstract.Module
+import           Data.Abstract.ModuleTable
-import Data.Abstract.ModuleTable
+import           Data.Abstract.Value
-import Data.Abstract.Value
-import qualified Data.IntMap as IntMap
-import Prelude hiding (fail)
-import Prologue hiding (throwError)
 import qualified Data.ByteString.Char8 as BC
+import qualified Data.IntMap as IntMap
 import qualified Data.Map.Monoidal as Monoidal
+import           Prelude hiding (fail)
+import           Prologue hiding (throwError)
 
 -- | Require/import another module by name and return it's environment and value.
 --
@@ -78,7 +80,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
+     , 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)
@@ -91,8 +94,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))
 findValue (((((v, _), _), _), _), _) = v
 
 -- | Find the 'Environment' in the 'Final' result of running.
@@ -106,7 +109,11 @@ findHeap :: forall value term effects . (effects ~ RequiredEffects term value (E
 findHeap (((((_, _), Heap heap), _), _), _) = heap
 
 
-instance Members '[Resumable Prelude.String value] effects => MonadThrow Prelude.String value (Evaluating term value effects) where
+resumeException :: forall exc m e a. (Effectful m, Resumable exc :< e) => 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)))
+
+
+instance (Monad (m effects), Effectful m, Members '[Resumable exc] effects) => MonadThrow exc (m effects) where
    throwException = raise . throwError
 
 instance Members '[Fail, State (IntMap.IntMap term)] effects => MonadControl term (Evaluating term value effects) where
@@ -165,7 +172,7 @@ instance ( Evaluatable (Base term)
          => MonadAnalysis term value (Evaluating term value effects) where
   type RequiredEffects term value (Evaluating term value effects) = EvaluatingEffects term value
 
-  analyzeTerm term = resumeException @value (eval term) (\yield exc -> string (BC.pack exc) >>= yield)
+  analyzeTerm term = resumeException @(Unspecialized value) (eval term) (\yield (Unspecialized str) -> string (BC.pack str) >>= yield)
 
   analyzeModule m = pushModule (subterm <$> m) (subtermValue (moduleBody m))
 

src/Control/Abstract/Evaluator.hs

@@ -168,5 +168,5 @@ class Monad m => MonadControl term 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 term
 
-class Monad m => MonadThrow exc v m | m -> exc where
+class Monad m => MonadThrow exc m where
-  throwException :: exc -> m v
+  throwException :: exc v -> m v

src/Control/Abstract/Value.hs

@@ -1,17 +1,18 @@
-{-# LANGUAGE MultiParamTypeClasses, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
+{-# LANGUAGE GADTs, MultiParamTypeClasses, Rank2Types, StandaloneDeriving, TypeFamilies, TypeOperators,
+             UndecidableInstances #-}
 module Control.Abstract.Value where
 
-import Control.Abstract.Addressable
+import           Control.Abstract.Addressable
-import Control.Abstract.Analysis
+import           Control.Abstract.Analysis
 import qualified Data.Abstract.Environment as Env
-import Data.Abstract.FreeVariables
+import           Data.Abstract.FreeVariables
-import Data.Abstract.Number as Number
+import           Data.Abstract.Number as Number
-import Data.Abstract.Type as Type
+import           Data.Abstract.Type as Type
-import Data.Abstract.Value as Value
+import           Data.Abstract.Value as Value
-import Data.Scientific (Scientific)
+import           Data.Scientific (Scientific)
 import qualified Data.Set as Set
-import Prelude hiding (fail)
+import           Prelude hiding (fail)
-import Prologue
+import           Prologue
 
 -- | This datum is passed into liftComparison to handle the fact that Ruby and PHP
 --   have built-in generalized-comparison ("spaceship") operators. If you want to
@@ -153,10 +154,26 @@ doWhile body cond = loop $ \ continue -> body *> do
   this <- cond
   ifthenelse this continue unit
 
+
+-- The type of exceptions that can be thrown when constructing values in `MonadValue`.
+data ValueExc v where
+  ValueExc :: Prelude.String -> ValueExc Value
+  StringExc :: Prelude.String -> ValueExc ByteString
+
+instance Eq1 ValueExc where
+  liftEq _ (ValueExc a) (ValueExc b)   = a == b
+  liftEq _ (StringExc a) (StringExc b) = a == b
+  liftEq _ _ _                         = False
+
+deriving instance Show (ValueExc v)
+instance Show1 ValueExc where
+  liftShowsPrec _ _ = showsPrec
+
 -- | Construct a 'Value' wrapping the value arguments (if any).
 instance ( Monad m
          , MonadAddressable location Value m
          , MonadAnalysis term Value m
+         , MonadThrow ValueExc m
          )
          => MonadValue Value m where
 
@@ -184,7 +201,6 @@ instance ( Monad m
     product <- mconcat <$> traverse scopedEnvironment supers
     pure . injValue $ Class n (Env.push product <> env)
 
-
   namespace n env = do
     maybeAddr <- lookupEnv n
     env' <- maybe (pure mempty) (asNamespaceEnv <=< deref) maybeAddr
@@ -200,7 +216,7 @@ instance ( Monad m
 
   asString v
     | Just (Value.String n) <- prjValue v = pure n
-    | otherwise                           = fail ("expected " <> show v <> " to be a string")
+    | otherwise                           = throwException (StringExc ("expected " <> show v <> " to be a string"))
 
   ifthenelse cond if' else'
     | Just (Boolean b) <- prjValue cond = if b then if' else else'

src/Control/Effect.hs

@@ -5,9 +5,9 @@ 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,13 +64,10 @@ 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 m handle = raise (resumeError (lower m) (\yield -> lower . handle (raise . yield)))
-
 
 -- | Types wrapping 'Eff' actions.
 --

src/Data/Abstract/Evaluatable.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DefaultSignatures, MultiParamTypeClasses, UndecidableInstances #-}
+{-# LANGUAGE DefaultSignatures, MultiParamTypeClasses, UndecidableInstances, GADTs, StandaloneDeriving #-}
 module Data.Abstract.Evaluatable
 ( Evaluatable(..)
 , module Addressable
@@ -6,6 +6,7 @@ module Data.Abstract.Evaluatable
 , module FreeVariables
 , module Value
 , MonadEvaluator(..)
+, Unspecialized(..)
 ) where
 
 import Control.Abstract.Addressable as Addressable
@@ -20,6 +21,16 @@ import Data.Semigroup.App
 import Data.Term
 import Prologue
 
+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
@@ -28,11 +39,11 @@ class Evaluatable constr where
           , MonadAnalysis term value m
           , MonadValue value m
           , Show (LocationFor value)
-          , MonadThrow Prelude.String value m
+          , MonadThrow (Unspecialized 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 ""))
 
 -- | If we can evaluate any syntax which can occur in a 'Union', we can evaluate the 'Union'.
 instance Apply Evaluatable fs => Evaluatable (Union fs) where

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