Merge branch 'master' into decompose-monad-evaluator

src/Control/Abstract/Value.hs

@@ -16,6 +16,7 @@ import Prologue
 --   This allows us to abstract the choice of whether to evaluate under binders for different value types.
 class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   -- | Construct an abstract unit value.
+  --   TODO: This might be the same as the empty tuple for some value types
   unit :: m value
 
   -- | Construct an abstract integral value.
@@ -30,6 +31,9 @@ class (MonadAnalysis term value m, Show value) => MonadValue term value m where
   -- | Construct a floating-point value.
   float :: Scientific -> m value
 
+  -- | Construct an N-ary tuple of multiple (possibly-disjoint) values
+  multiple :: [value] -> m value
+
   -- | Construct an abstract interface value.
   interface :: value -> m value
 
@@ -52,21 +56,24 @@ instance ( MonadAddressable location (Value location term) m
          )
          => MonadValue term (Value location term) m where
 
-  unit    = pure $ inj Value.Unit
-  integer = pure . inj . Integer
-  boolean = pure . inj . Boolean
-  string  = pure . inj . Value.String
-  float   = pure . inj . Value.Float
-  interface v = inj . Value.Interface v <$> getGlobalEnv
+  unit    = pure . injValue $ Value.Unit
+  integer = pure . injValue . Integer
+  boolean = pure . injValue . Boolean
+  string  = pure . injValue . Value.String
+  float   = pure . injValue . Value.Float
+  multiple vals =
+    pure . injValue $ Value.Tuple vals
+
+  interface v = injValue . Value.Interface v <$> getGlobalEnv
 
   ifthenelse cond if' else'
-    | Just (Boolean b) <- prj cond = if b then if' else else'
-    | otherwise = fail ("not defined for non-boolean condition: " <> show cond)
+    | Just (Boolean b) <- prjValue cond = if b then if' else else'
+    | otherwise = fail ("not defined for non-boolean conditions: " <> show cond)
 
-  abstract names (Subterm body _) = inj . Closure names body <$> askLocalEnv
+  abstract names (Subterm body _) = injValue . Closure names body <$> askLocalEnv
 
   apply op params = do
-    Closure names body env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prj op)
+    Closure names body env <- maybe (fail ("expected a closure, got: " <> show op)) pure (prjValue op)
     bindings <- foldr (\ (name, param) rest -> do
       v <- subtermValue param
       a <- alloc name
@@ -75,8 +82,8 @@ instance ( MonadAddressable location (Value location term) m
     localEnv (mappend bindings) (evaluateTerm body)
 
   environment v
-    | Just (Interface _ env) <- prj v = pure env
-    | otherwise                       = pure mempty
+    | Just (Interface _ env) <- prjValue v = pure env
+    | otherwise                            = pure mempty
 
 -- | Discard the value arguments (if any), constructing a 'Type.Type' instead.
 instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue term Type m where
@@ -95,6 +102,7 @@ instance (Alternative m, MonadAnalysis term Type m, MonadFresh m) => MonadValue
   boolean _ = pure Bool
   string _  = pure Type.String
   float _   = pure Type.Float
+  multiple  = pure . Type.Product
   -- TODO
   interface = undefined
 

src/Data/Abstract/Value.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
+{-# LANGUAGE ConstraintKinds, DataKinds, FunctionalDependencies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
 module Data.Abstract.Value where
 
 import Data.Abstract.Address
@@ -13,32 +13,42 @@ import Prologue
 import Prelude hiding (Float, Integer, String, fail)
 import qualified Prelude
 
-type ValueConstructors location
-  = '[Closure location
+type ValueConstructors location term
+  = '[Closure location term
     , Interface location
     , Unit
     , Boolean
     , Float
     , Integer
     , String
+    , Tuple
     ]
 
 -- | Open union of primitive values that terms can be evaluated to.
-type Value location = Union (ValueConstructors location)
+--   Fix by another name.
+newtype Value location term = Value { deValue :: Union (ValueConstructors location term) (Value location term) }
+  deriving (Eq, Show, Ord)
+
+-- | Identical to 'inj', but wraps the resulting sub-entity in a 'Value'.
+injValue :: (f :< ValueConstructors location term) => f (Value location term) -> Value location term
+injValue = Value . inj
+
+-- | Identical to 'prj', but unwraps the argument out of its 'Value' wrapper.
+prjValue :: (f :< ValueConstructors location term) => Value location term -> Maybe (f (Value location term))
+prjValue = prj . deValue
 
 -- TODO: Parameterize Value by the set of constructors s.t. each language can have a distinct value union.
--- TODO: Wrap the Value union in a newtype to differentiate from (eventual) à la carte Types.
 
 -- | A function value consisting of a list of parameters, the body of the function, and an environment of bindings captured by the body.
-data Closure location term = Closure [Name] term (Environment location (Value location term))
+data Closure location term value = Closure [Name] term (Environment location value)
   deriving (Eq, Generic1, Ord, Show)
 
-instance (Eq location) => Eq1 (Closure location) where liftEq = genericLiftEq
-instance (Ord location) => Ord1 (Closure location) where liftCompare = genericLiftCompare
-instance (Show location) => Show1 (Closure location) where liftShowsPrec = genericLiftShowsPrec
+instance (Eq location, Eq term) => Eq1 (Closure location term) where liftEq = genericLiftEq
+instance (Ord location, Ord term) => Ord1 (Closure location term) where liftCompare = genericLiftCompare
+instance (Show location, Show term) => Show1 (Closure location term) where liftShowsPrec = genericLiftShowsPrec
 
 -- | A program value consisting of the value of the program and it's enviornment of bindings.
-data Interface location term = Interface (Value location term) (Environment location (Value location term))
+data Interface location value = Interface value (Environment location value)
   deriving (Eq, Generic1, Ord, Show)
 
 instance (Eq location) => Eq1 (Interface location) where liftEq = genericLiftEq
@@ -46,7 +56,7 @@ instance (Ord location) => Ord1 (Interface location) where liftCompare = generic
 instance (Show location) => Show1 (Interface location) where liftShowsPrec = genericLiftShowsPrec
 
 -- | The unit value. Typically used to represent the result of imperative statements.
-data Unit term = Unit
+data Unit value = Unit
   deriving (Eq, Generic1, Ord, Show)
 
 instance Eq1 Unit where liftEq = genericLiftEq
@@ -54,7 +64,7 @@ instance Ord1 Unit where liftCompare = genericLiftCompare
 instance Show1 Unit where liftShowsPrec = genericLiftShowsPrec
 
 -- | Boolean values.
-newtype Boolean term = Boolean Prelude.Bool
+newtype Boolean value = Boolean Prelude.Bool
   deriving (Eq, Generic1, Ord, Show)
 
 instance Eq1 Boolean where liftEq = genericLiftEq
@@ -62,7 +72,7 @@ instance Ord1 Boolean where liftCompare = genericLiftCompare
 instance Show1 Boolean where liftShowsPrec = genericLiftShowsPrec
 
 -- | Arbitrary-width integral values.
-newtype Integer term = Integer Prelude.Integer
+newtype Integer value = Integer Prelude.Integer
   deriving (Eq, Generic1, Ord, Show)
 
 instance Eq1 Integer where liftEq = genericLiftEq
@@ -70,7 +80,7 @@ instance Ord1 Integer where liftCompare = genericLiftCompare
 instance Show1 Integer where liftShowsPrec = genericLiftShowsPrec
 
 -- | String values.
-newtype String term = String ByteString
+newtype String value = String ByteString
   deriving (Eq, Generic1, Ord, Show)
 
 instance Eq1 String where liftEq = genericLiftEq
@@ -78,13 +88,24 @@ instance Ord1 String where liftCompare = genericLiftCompare
 instance Show1 String where liftShowsPrec = genericLiftShowsPrec
 
 -- | Float values.
-newtype Float term = Float Scientific
+newtype Float value = Float Scientific
   deriving (Eq, Generic1, Ord, Show)
 
 instance Eq1 Float where liftEq = genericLiftEq
 instance Ord1 Float where liftCompare = genericLiftCompare
 instance Show1 Float where liftShowsPrec = genericLiftShowsPrec
 
+-- Zero or more values.
+-- TODO: Investigate whether we should use Vector for this.
+-- TODO: Should we have a Some type over a nonemmpty list? Or does this merit one?
+
+newtype Tuple value = Tuple [value]
+  deriving (Eq, Generic1, Ord, Show)
+
+instance Eq1 Tuple where liftEq = genericLiftEq
+instance Ord1 Tuple where liftCompare = genericLiftCompare
+instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
+
 -- | The environment for an abstract value type.
 type EnvironmentFor v = Environment (LocationFor v) v
 
@@ -106,8 +127,8 @@ class ValueRoots l v | v -> l where
 
 instance (FreeVariables term, Ord location) => ValueRoots location (Value location term) where
   valueRoots v
-    | Just (Closure names body env) <- prj v = envRoots env (foldr Set.delete (freeVariables body) names)
-    | otherwise                              = mempty
+    | Just (Closure names body env) <- prjValue v = envRoots env (foldr Set.delete (freeVariables (body :: term)) names)
+    | otherwise                                   = mempty
 
 instance ValueRoots Monovariant Type.Type where
   valueRoots _ = mempty

src/Data/Syntax/Declaration.hs

@@ -1,11 +1,11 @@
 {-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
 module Data.Syntax.Declaration where
 
-import Prologue
 import Data.Abstract.Environment
 import Data.Abstract.Evaluatable
 import Diffing.Algorithm
 import qualified Data.Map as Map
+import Prologue
 
 data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
   deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@@ -88,7 +88,7 @@ instance Evaluatable OptionalParameter
 
 -- TODO: Should we replace this with Function and differentiate by context?
 -- TODO: How should we distinguish class/instance methods?
-
+-- TODO: It would be really nice to have a more meaningful type contained in here than [a]
 -- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript.
 newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] }
   deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)
@@ -97,9 +97,9 @@ instance Eq1 VariableDeclaration where liftEq = genericLiftEq
 instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
 instance Show1 VariableDeclaration where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for VariableDeclaration
-instance Evaluatable VariableDeclaration
-
+instance Evaluatable VariableDeclaration where
+  eval (VariableDeclaration [])   = unit
+  eval (VariableDeclaration decs) = multiple =<< traverse subtermValue decs
 
 -- | A TypeScript/Java style interface declaration to implement.
 data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationBody :: !a }

src/Data/Syntax/Literal.hs

@@ -236,9 +236,8 @@ instance Eq1 Tuple where liftEq = genericLiftEq
 instance Ord1 Tuple where liftCompare = genericLiftCompare
 instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for Tuple
-instance Evaluatable Tuple
-
+instance Evaluatable Tuple where
+  eval (Tuple cs) = multiple =<< traverse subtermValue cs
 
 newtype Set a = Set { setElements :: [a] }
   deriving (Diffable, Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1)

src/Language/TypeScript/Syntax.hs

@@ -85,6 +85,8 @@ newtype Tuple a = Tuple { _tupleElements :: [a] }
 instance Eq1 Tuple where liftEq = genericLiftEq
 instance Ord1 Tuple where liftCompare = genericLiftCompare
 instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
+
+-- This is a tuple type, not a tuple value, so we can't lean on the shared Tuple value
 instance Evaluatable Tuple
 
 data Constructor a = Constructor { _constructorTypeParameters :: !a, _constructorFormalParameters :: ![a], _constructorType :: !a }