implement Evaluatable for member access, add doctests, and fix Latest

src/Control/Abstract/Addressable.hs

@@ -46,9 +46,10 @@ letrec name body = do
 
 -- | 'Precise' locations are always 'alloc'ated a fresh 'Address', and 'deref'erence to the 'Latest' value written.
 instance (MonadFail m, LocationFor value ~ Precise, MonadHeap value m) => MonadAddressable Precise value m where
-  deref = derefWith (pure . unLatest)
-  alloc _ = fmap (Address . Precise . heapSize) getHeap
-
+  deref = derefWith (maybeM uninitializedAddress . unLatest)
+  alloc _ = do
+    addr <- fmap (Address . Precise . heapSize) getHeap
+    addr <$ modifyHeap (heapInit addr mempty)
 
 -- | 'Monovariant' locations 'alloc'ate one 'Address' per unique variable name, and 'deref'erence once per stored value, nondeterministically.
 instance (Alternative m, LocationFor value ~ Monovariant, MonadFail m, MonadHeap value m, Ord value) => MonadAddressable Monovariant value m where

src/Control/Abstract/Value.hs

@@ -85,6 +85,8 @@ class (Monad m, Show value) => MonadValue value m where
 
   klass :: Name -> EnvironmentFor value -> m value
 
+  objectEnvironment :: value -> m (EnvironmentFor value)
+
   -- | Evaluate an abstraction (a binder like a lambda or method definition).
   abstract :: (FreeVariables term, MonadControl term m) => [Name] -> Subterm term (m value) -> m value
   -- | Evaluate an application (like a function call).
@@ -151,6 +153,10 @@ instance ( Monad m
 
   klass n  = pure . injValue . Class n
 
+  objectEnvironment o
+    | Just (Class _ env) <- prjValue o = pure env
+    | otherwise = fail ("non-object type passed to objectEnvironment: " <> show o)
+
   ifthenelse cond if' else'
     | Just (Boolean b) <- prjValue cond = if b then if' else else'
     | otherwise = fail ("not defined for non-boolean conditions: " <> show cond)

src/Data/Abstract/Address.hs

@@ -30,16 +30,20 @@ type family Cell l = res | res -> l where
 
 
 -- | A cell holding a single value. Writes will replace any prior value.
-newtype Latest a = Latest { unLatest :: a }
+newtype Latest a = Latest { unLatest :: Maybe a }
   deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
 
 instance Semigroup (Latest a) where
-  _ <> a = a
+  a <> Latest Nothing = a
+  _ <> b              = b
+
+-- | 'Option' semantics rather than that of 'Maybe', which is broken.
+instance Monoid (Latest a) where
+  mappend = (<>)
+  mempty  = Latest Nothing
 
 instance Reducer a (Latest a) where
-  unit = Latest
-  cons _ = id
-  snoc _ = unit
+  unit = Latest . Just
 
 instance Eq1 Latest where liftEq = genericLiftEq
 instance Ord1 Latest where liftCompare = genericLiftCompare

src/Data/Abstract/Environment.hs

@@ -26,6 +26,10 @@ import qualified Data.Set as Set
 import           GHC.Exts (IsList (..))
 import           Prologue
 
+-- $setup
+-- >>> let bright = push (insert (name "foo") (Address (Precise 0)) mempty)
+-- >>> let shadowed = insert (name "foo") (Address (Precise 1)) bright
+
 -- | A map of names to addresses that represents the evaluation environment.
 newtype Environment l a = Environment { unEnvironment :: NonEmpty (Map.Map Name (Address l a)) }
   deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
@@ -42,6 +46,7 @@ instance IsList (Environment l a) where
   fromList xs                   = Environment (Map.fromList xs :| [])
   toList (Environment (x :| _)) = Map.toList x
 
+-- TODO: property-check me
 instance Semigroup (Environment l a) where
   Environment (a :| as) <> Environment (b :| bs) =
     Environment ((a <> b) :| alignWith (mergeThese (<>)) as bs)
@@ -64,11 +69,17 @@ pop (Environment (_ :| a : as)) = Environment (a :| as)
 head :: Environment l a -> Environment l a
 head (Environment (a :| _)) = Environment (a :| [])
 
--- TODO: Test the flattening behavior
+-- | Extract an association list of bindings from an 'Environment'. This displays frontmost-biased shadowing behavior, to wit:
+--
+-- >>> pairs shadowed
+-- [("foo" :| [],Address {unAddress = Precise {unPrecise = 1}})]
 pairs :: Environment l a -> [(Name, Address l a)]
 pairs = Map.toList . fold . unEnvironment
 
 -- | Lookup a 'Name' in the environment.
+--
+-- >>> lookup (name "foo") shadowed
+-- Just (Address {unAddress = Precise {unPrecise = 1}})
 lookup :: Name -> Environment l a -> Maybe (Address l a)
 lookup k = foldMapA (Map.lookup k) . unEnvironment
 
@@ -76,8 +87,16 @@ lookup k = foldMapA (Map.lookup k) . unEnvironment
 insert :: Name -> Address l a -> Environment l a -> Environment l a
 insert name value (Environment (a :| as)) = Environment (Map.insert name value a :| as)
 
+-- | Remove a 'Name' from the environment.
+--
+-- >>> delete (name "foo") shadowed
+-- Environment {unEnvironment = fromList [] :| []}
 delete :: Name -> Environment l a -> Environment l a
-delete name = Environment . fmap (Map.delete name) . unEnvironment
+delete name = trim . Environment . fmap (Map.delete name) . unEnvironment
+
+trim :: Environment l a -> Environment l a
+trim (Environment (a :| as)) = Environment (a :| filtered)
+  where filtered = filter (not . Map.null) as
 
 bindEnv :: (Ord l, Foldable t) => t Name -> Environment l a -> Environment l a
 bindEnv names env = foldMap envForName names

src/Data/Abstract/Heap.hs

@@ -36,6 +36,10 @@ heapLookupAll address = fmap toList . heapLookup address
 heapInsert :: (Ord l, Reducer a (Cell l a)) => Address l a -> a -> Heap l a -> Heap l a
 heapInsert (Address address) value = flip snoc (address, value)
 
+-- | Manually insert a cell into the heap at a given address.
+heapInit :: Ord l => Address l a -> Cell l a -> Heap l a -> Heap l a
+heapInit (Address address) cell (Heap h) = Heap (Monoidal.insert address cell h)
+
 -- | The number of addresses extant in a 'Heap'.
 heapSize :: Heap l a -> Int
 heapSize = Monoidal.size . unStore

src/Data/Syntax/Expression.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}
+{-# LANGUAGE DeriveAnyClass, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances, ViewPatterns #-}
 module Data.Syntax.Expression where
 
 import Data.Abstract.Evaluatable
@@ -179,8 +179,10 @@ instance Eq1 MemberAccess where liftEq = genericLiftEq
 instance Ord1 MemberAccess where liftCompare = genericLiftCompare
 instance Show1 MemberAccess where liftShowsPrec = genericLiftShowsPrec
 
--- TODO: Implement Eval instance for MemberAccess
-instance Evaluatable MemberAccess
+instance Evaluatable MemberAccess where
+  eval (fmap subtermValue -> MemberAccess mem acc) = do
+    lhs <- mem >>= objectEnvironment
+    localEnv (mappend lhs) acc
 
 -- | Subscript (e.g a[1])
 data Subscript a

test/Doctests.hs

@@ -26,5 +26,5 @@ extensions =
 
 sources :: [String]
 sources =
-  [ "src/Data/Semiring.hs"
+  [ "src/Data/Abstract/Environment.hs"
   ]