Merge remote-tracking branch 'origin/master' into typescript-exports

src/Analysis/Abstract/Caching.hs

@@ -26,6 +26,9 @@ type CacheFor term value = Cache (LocationFor value) term value
 newtype Caching m term value (effects :: [* -> *]) a = Caching (m term value effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
+deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Caching m term value effects)
+deriving instance MonadStore value (m term value effects) => MonadStore value (Caching m term value effects)
+deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Caching m term value effects)
 deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Caching m term value effects)
 
 -- | Functionality used to perform caching analysis. This is not exported, and exists primarily for organizational reasons.

src/Analysis/Abstract/Dead.hs

@@ -12,6 +12,9 @@ import Prologue
 newtype DeadCode m term value (effects :: [* -> *]) a = DeadCode (m term value effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
+deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (DeadCode m term value effects)
+deriving instance MonadStore value (m term value effects) => MonadStore value (DeadCode m term value effects)
+deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (DeadCode m term value effects)
 deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (DeadCode m term value effects)
 
 -- | A set of “dead” (unreachable) terms.

src/Analysis/Abstract/Evaluating.hs

@@ -12,6 +12,7 @@ import Control.Monad.Effect.Fresh
 import Control.Monad.Effect.NonDet
 import Control.Monad.Effect.Reader
 import Control.Monad.Effect.State
+import Data.Abstract.Configuration
 import Data.Abstract.Evaluatable
 import Data.Abstract.Address
 import Data.Abstract.ModuleTable
@@ -80,7 +81,7 @@ type EvaluatingEffects term value
      , State (Map Name (Name, Maybe (Address (LocationFor value) value))) -- Set of exports
      ]
 
-instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where
+instance Members '[Reader (EnvironmentFor value), State (EnvironmentFor value)] effects => MonadEnvironment value (Evaluating term value effects) where
   getGlobalEnv = raise get
   putGlobalEnv = raise . put
   withGlobalEnv s = raise . localState s . lower
@@ -92,15 +93,20 @@ instance Members (EvaluatingEffects term value) effects => MonadEvaluator term v
   askLocalEnv = raise ask
   localEnv f a = raise (local f (lower a))
 
+instance Member (State (StoreFor value)) effects => MonadStore value (Evaluating term value effects) where
   getStore = raise get
   putStore = raise . put
 
+instance Members '[Reader (ModuleTable term), State (ModuleTable (EnvironmentFor value))] effects => MonadModuleTable term value (Evaluating term value effects) where
   getModuleTable = raise get
-  modifyModuleTable f = raise (modify f)
+  putModuleTable = raise . put
 
   askModuleTable = raise ask
   localModuleTable f a = raise (local f (lower a))
 
+instance Members (EvaluatingEffects term value) effects => MonadEvaluator term value (Evaluating term value effects) where
+  getConfiguration term = Configuration term mempty <$> askLocalEnv <*> getStore
+
 instance ( Evaluatable (Base term)
          , FreeVariables term
          , Members (EvaluatingEffects term value) effects

src/Analysis/Abstract/Tracing.hs

@@ -17,6 +17,9 @@ import Prologue hiding (trace)
 newtype Tracing (trace :: * -> *) m term value (effects :: [* -> *]) a = Tracing (m term value effects a)
   deriving (Alternative, Applicative, Functor, Effectful, Monad, MonadFail, MonadFresh, MonadNonDet)
 
+deriving instance MonadEnvironment value (m term value effects) => MonadEnvironment value (Tracing trace m term value effects)
+deriving instance MonadStore value (m term value effects) => MonadStore value (Tracing trace m term value effects)
+deriving instance MonadModuleTable term value (m term value effects) => MonadModuleTable term value (Tracing trace m term value effects)
 deriving instance MonadEvaluator term value (m term value effects) => MonadEvaluator term value (Tracing trace m term value effects)
 
 instance ( Corecursive term

src/Control/Abstract/Addressable.hs

@@ -25,7 +25,7 @@ class (Monad m, Ord l, l ~ LocationFor value, Reducer value (Cell l value)) => M
 --   The term is expected to contain one and only one free 'Name', meaning that care should be taken to apply this only to e.g. identifiers.
 lookupOrAlloc :: ( FreeVariables term
                  , MonadAddressable (LocationFor value) value m
-                 , MonadEvaluator term value m
+                 , MonadStore value m
                  , Semigroup (CellFor value)
                  )
                  => term
@@ -38,7 +38,7 @@ lookupOrAlloc term = let [name] = toList (freeVariables term) in
 -- | Look up or allocate an address for a 'Name' & assign it a given value, returning the 'Name' paired with the address.
 lookupOrAlloc' :: ( Semigroup (CellFor value)
                   , MonadAddressable (LocationFor value) value m
-                  , MonadEvaluator term value m
+                  , MonadStore value m
                   )
                   => Name
                   -> value
@@ -49,21 +49,11 @@ lookupOrAlloc' name v env = do
   assign a v
   pure (name, a)
 
--- | Write a value to the given 'Address' in the 'Store'.
-assign :: ( Ord (LocationFor value)
-          , MonadEvaluator term value m
-          , Reducer value (CellFor value)
-          )
-          => Address (LocationFor value) value
-          -> value
-          -> m ()
-assign address = modifyStore . storeInsert address
-
 
 -- Instances
 
 -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
-instance (Monad m, LocationFor value ~ Precise, MonadEvaluator term value m) => MonadAddressable Precise value m where
+instance (MonadFail m, LocationFor value ~ Precise, MonadStore value m) => MonadAddressable Precise value m where
   deref = maybe uninitializedAddress (pure . unLatest) <=< flip fmap getStore . storeLookup
     where
       -- | 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).
@@ -74,7 +64,7 @@ instance (Monad m, LocationFor value ~ Precise, MonadEvaluator term value m) =>
 
 
 -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
-instance (Alternative m, Monad m, LocationFor value ~ Monovariant, MonadEvaluator term value m, Ord value) => MonadAddressable Monovariant value m where
+instance (Alternative m, LocationFor value ~ Monovariant, MonadStore value m, Ord value) => MonadAddressable Monovariant value m where
   deref = asum . maybe [] (map pure . toList) <=< flip fmap getStore . storeLookup
 
   alloc = pure . Address . Monovariant

src/Control/Abstract/Evaluator.hs

@@ -1,12 +1,23 @@
 {-# LANGUAGE ConstrainedClassMethods, FunctionalDependencies #-}
-module Control.Abstract.Evaluator where
+module Control.Abstract.Evaluator
+( MonadEvaluator(..)
+, MonadEnvironment(..)
+, modifyGlobalEnv
+, MonadStore(..)
+, modifyStore
+, assign
+, MonadModuleTable(..)
+, modifyModuleTable
+) where
 
 import Data.Abstract.Address
 import Data.Abstract.Configuration
 import Data.Abstract.FreeVariables
 import Data.Abstract.Live
 import Data.Abstract.ModuleTable
+import Data.Abstract.Store
 import Data.Abstract.Value
+import Data.Semigroup.Reducer
 import Prelude hiding (fail)
 import Prologue
 
@@ -16,7 +27,17 @@ import Prologue
 --   - environments binding names to addresses
 --   - a heap mapping addresses to (possibly sets of) values
 --   - tables of modules available for import
-class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where
+class ( MonadEnvironment value m
+      , MonadFail m
+      , MonadModuleTable term value m
+      , MonadStore value m
+      )
+      => MonadEvaluator term value m | m -> term, m -> value where
+  -- | Get the current 'Configuration' with a passed-in term.
+  getConfiguration :: Ord (LocationFor value) => term -> m (ConfigurationFor term value)
+
+-- | A 'Monad' abstracting local and global environments.
+class Monad m => MonadEnvironment value m | m -> value where
   -- | Retrieve the global environment.
   getGlobalEnv :: m (EnvironmentFor value)
   -- | Set the global environment
@@ -35,33 +56,51 @@ class MonadFail m => MonadEvaluator term value m | m -> term, m -> value where
   -- | Run an action with a locally-modified environment.
   localEnv :: (EnvironmentFor value -> EnvironmentFor value) -> m a -> m a
 
+-- | Update the global environment.
+modifyGlobalEnv :: MonadEvaluator term value m => (EnvironmentFor value -> EnvironmentFor value) -> m  ()
+modifyGlobalEnv f = do
+  env <- getGlobalEnv
+  putGlobalEnv $! f env
+
+
+-- | A 'Monad' abstracting a heap of values.
+class Monad m => MonadStore value m | m -> value where
   -- | Retrieve the heap.
   getStore :: m (StoreFor value)
   -- | Set the heap.
   putStore :: StoreFor value -> m ()
 
+-- | Update the heap.
+modifyStore :: MonadStore value m => (StoreFor value -> StoreFor value) -> m ()
+modifyStore f = do
+  s <- getStore
+  putStore $! f s
+
+-- | Write a value to the given 'Address' in the 'Store'.
+assign :: ( Ord (LocationFor value)
+          , MonadStore value m
+          , Reducer value (CellFor value)
+          )
+          => Address (LocationFor value) value
+          -> value
+          -> m ()
+assign address = modifyStore . storeInsert address
+
+
+-- | A 'Monad' abstracting tables of modules available for import.
+class Monad m => MonadModuleTable term value m | m -> term, m -> value where
   -- | Retrieve the table of evaluated modules.
   getModuleTable :: m (ModuleTable (EnvironmentFor value))
-  -- | Update the table of evaluated modules.
-  modifyModuleTable :: (ModuleTable (EnvironmentFor value) -> ModuleTable (EnvironmentFor value)) -> m ()
+  -- | Set the table of evaluated modules.
+  putModuleTable :: ModuleTable (EnvironmentFor value) -> m ()
 
   -- | Retrieve the table of unevaluated modules.
   askModuleTable :: m (ModuleTable term)
   -- | Run an action with a locally-modified table of unevaluated modules.
   localModuleTable :: (ModuleTable term -> ModuleTable term) -> m a -> m a
 
-  -- | Retrieve the current root set.
-  askRoots :: Ord (LocationFor value) => m (Live (LocationFor value) value)
-  askRoots = pure mempty
-
-  -- | Get the current 'Configuration' with a passed-in term.
-  getConfiguration :: Ord (LocationFor value) => term -> m (Configuration (LocationFor value) term value)
-  getConfiguration term = Configuration term <$> askRoots <*> askLocalEnv <*> getStore
-
--- | Update the global environment.
-modifyGlobalEnv :: MonadEvaluator term value m => (EnvironmentFor value -> EnvironmentFor value) -> m  ()
-modifyGlobalEnv f = getGlobalEnv >>= putGlobalEnv . f
-
--- | Update the heap.
-modifyStore :: MonadEvaluator term value m => (StoreFor value -> StoreFor value) -> m ()
-modifyStore f = getStore >>= putStore . f
+-- | Update the evaluated module table.
+modifyModuleTable :: MonadModuleTable term value m => (ModuleTable (EnvironmentFor value) -> ModuleTable (EnvironmentFor value)) -> m ()
+modifyModuleTable f = do
+  table <- getModuleTable
+  putModuleTable $! f table

src/Control/Abstract/Value.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE MultiParamTypeClasses, UndecidableInstances, TypeApplications #-}
+{-# LANGUAGE MultiParamTypeClasses, Rank2Types, TypeFamilies, TypeOperators, UndecidableInstances #-}
 module Control.Abstract.Value where
 
 import Control.Abstract.Addressable
@@ -7,8 +7,8 @@ import Data.Abstract.Environment
 import Data.Abstract.FreeVariables
 import Data.Abstract.Type as Type
 import Data.Abstract.Value as Value
-import Data.Scientific (Scientific)
 import qualified Data.Map as Map
+import Data.Scientific (Scientific, fromFloatDigits, toRealFloat)
 import Prelude hiding (fail)
 import Prologue
 
@@ -23,6 +23,18 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   -- | Construct an abstract integral value.
   integer :: Prelude.Integer -> m value
 
+  -- | Lift a unary operator over a 'Num' to a function on 'value's.
+  liftNumeric  :: (forall a . Num a => a -> a)
+               -> (value -> m 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 . (Real a, Floating a) => a -> a -> a)
+               -> (forall b . Integral b           => b -> b -> b)
+               -> (value -> value -> m value)
+
   -- | Construct an abstract boolean value.
   boolean :: Bool -> m value
 
@@ -39,7 +51,7 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   interface :: value -> m value
 
   -- | Eliminate boolean values. TODO: s/boolean/truthy
-  ifthenelse :: value -> m value -> m value -> m value
+  ifthenelse :: value -> m a -> m a -> m a
 
   -- | Evaluate an abstraction (a binder like a lambda or method definition).
   abstract :: [Name] -> Subterm term (m value) -> m value
@@ -49,6 +61,10 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   -- | Extract the environment from an interface value.
   environment :: value -> m (EnvironmentFor value)
 
+-- | Attempt to extract a 'Prelude.Bool' from a given value.
+toBool :: MonadValue term value m => value -> m Bool
+toBool v = ifthenelse v (pure True) (pure False)
+
 -- | Construct a 'Value' wrapping the value arguments (if any).
 instance ( MonadAddressable location (Value location term) m
          , MonadAnalysis term (Value location term) m
@@ -78,6 +94,26 @@ instance ( MonadAddressable location (Value location term) m
     | Just (Boolean b) <- prjValue cond = if b then if' else else'
     | otherwise = fail ("not defined for non-boolean conditions: " <> show cond)
 
+  liftNumeric f arg
+    | Just (Integer i)     <- prjValue arg = pure . injValue . Integer     $ f i
+    | Just (Value.Float i) <- prjValue arg = pure . injValue . Value.Float $ f i
+    | otherwise = fail ("Invalid operand to liftNumeric: " <> show arg)
+
+  liftNumeric2 f g left right
+    | Just (Integer i, Integer j)         <- prjPair pair = pure . injValue . Integer $ g i j
+    | Just (Integer i, Value.Float j)     <- prjPair pair = pure . injValue . float   $ f (fromIntegral i) (munge j)
+    | Just (Value.Float i, Value.Float j) <- prjPair pair = pure . injValue . float   $ f (munge i) (munge j)
+    | Just (Value.Float i, Integer j)     <- prjPair pair = pure . injValue . float   $ f (munge i) (fromIntegral j)
+    | otherwise = fail ("Invalid operands to liftNumeric2: " <> show pair)
+      where
+        -- Yucky hack to work around the lack of a Floating instance for Scientific.
+        -- This may possibly lose precision, but there's little we can do about that.
+        munge :: Scientific -> Double
+        munge = toRealFloat
+        float :: Double -> Value.Float a
+        float = Value.Float . fromFloatDigits
+        pair = (left, right)
+
   abstract names (Subterm body _) = injValue . Closure names body <$> askLocalEnv
 
   apply op params = do
@@ -116,6 +152,16 @@ instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue
 
   ifthenelse cond if' else' = unify cond Bool *> (if' <|> else')
 
+  liftNumeric _ Type.Float = pure Type.Float
+  liftNumeric _ Int        = pure Int
+  liftNumeric _ _          = fail "Invalid type in unary numeric operation"
+
+  liftNumeric2 _ _ left right = case (left, right) of
+    (Type.Float, Int) -> pure Type.Float
+    (Int, Type.Float) -> pure Type.Float
+    _                 -> unify left right
+
+
   apply op params = do
     tvar <- fresh
     paramTypes <- traverse subtermValue params

src/Data/Abstract/Value.hs

@@ -37,6 +37,13 @@ injValue = Value . inj
 prjValue :: (f :< ValueConstructors location term) => Value location term -> Maybe (f (Value location term))
 prjValue = prj . deValue
 
+-- | Convenience function for projecting two values.
+prjPair :: ( f :< ValueConstructors loc term1 , g :< ValueConstructors loc term2)
+        => (Value loc term1, Value loc term2)
+        -> Maybe (f (Value loc term1), g (Value loc term2))
+prjPair = bitraverse prjValue prjValue
+
+
 -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union.
 
 -- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body.

src/Data/Syntax/Expression.hs

@@ -2,7 +2,9 @@
 module Data.Syntax.Expression where
 
 import Data.Abstract.Evaluatable
+import Data.Fixed
 import Diffing.Algorithm
+import Prelude hiding (fail)
 import Prologue hiding (apply)
 
 -- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
@@ -51,8 +53,15 @@ instance Ord1 Arithmetic where liftCompare = genericLiftCompare
 instance Show1 Arithmetic where liftShowsPrec = genericLiftShowsPrec
 
 -- TODO: Implement Eval instance for Arithmetic
-instance Evaluatable Arithmetic
-
+instance Evaluatable Arithmetic where
+  eval = traverse subtermValue >=> go where
+    go (Plus a b)      = liftNumeric2 (+) (+) a b
+    go (Minus a b)     = liftNumeric2 (-) (-) a b
+    go (Times a b)     = liftNumeric2 (*) (*) a b
+    go (DividedBy a b) = liftNumeric2 (/) div a b
+    go (Modulo a b)    = liftNumeric2 mod' mod a b
+    go (Power a b)     = liftNumeric2 (**) (^) a b
+    go (Negate a)      = liftNumeric negate a
 
 -- | Boolean operators.
 data Boolean a
@@ -66,9 +75,17 @@ instance Eq1 Boolean where liftEq = genericLiftEq
 instance Ord1 Boolean where liftCompare = genericLiftCompare
 instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Boolean
-instance Evaluatable Boolean
-
+instance Evaluatable Boolean where
+  -- N.B. we have to use Monad rather than Applicative/Traversable on 'And' and 'Or' so that we don't evaluate both operands
+  eval = go . fmap subtermValue where
+    go (And a b) = do
+      cond <- a
+      ifthenelse cond b (pure cond)
+    go (Or a b) = do
+      cond <- a
+      ifthenelse cond (pure cond) b
+    go (Not a) = a >>= toBool >>= boolean . not
+    go (XOr a b) = liftA2 (/=) (a >>= toBool) (b >>= toBool) >>= boolean
 
 -- | Javascript delete operator
 newtype Delete a = Delete a