diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index bc3880337..df68ebe98 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/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 diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index e4eb18913..6299fda65 100644 --- a/src/Control/Abstract/Value.hs +++ b/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) diff --git a/src/Data/Abstract/Address.hs b/src/Data/Abstract/Address.hs index 511c424ae..0ebc3c08a 100644 --- a/src/Data/Abstract/Address.hs +++ b/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 diff --git a/src/Data/Abstract/Environment.hs b/src/Data/Abstract/Environment.hs index dcd25dba4..8f143399f 100644 --- a/src/Data/Abstract/Environment.hs +++ b/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 diff --git a/src/Data/Abstract/Heap.hs b/src/Data/Abstract/Heap.hs index 8f02ce79f..12a766a3f 100644 --- a/src/Data/Abstract/Heap.hs +++ b/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 diff --git a/src/Data/Syntax/Expression.hs b/src/Data/Syntax/Expression.hs index 758e79a2b..d0ddd213f 100644 --- a/src/Data/Syntax/Expression.hs +++ b/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 diff --git a/test/Doctests.hs b/test/Doctests.hs index 55d024d7d..f55bdeef8 100644 --- a/test/Doctests.hs +++ b/test/Doctests.hs @@ -26,5 +26,5 @@ extensions = sources :: [String] sources = - [ "src/Data/Semiring.hs" + [ "src/Data/Abstract/Environment.hs" ]