diff --git a/src/Control/Abstract/Addressable.hs b/src/Control/Abstract/Addressable.hs index 03b9f6322..db6806814 100644 --- a/src/Control/Abstract/Addressable.hs +++ b/src/Control/Abstract/Addressable.hs @@ -1,17 +1,10 @@ -{-# LANGUAGE UndecidableInstances #-} module Control.Abstract.Addressable ( Allocatable(..) , Derefable(..) ) where -import Control.Abstract.Context import Control.Abstract.Evaluator -import Control.Abstract.Hole -import Data.Abstract.Address.Located -import Data.Abstract.Address.Monovariant -import Data.Abstract.Address.Precise import Data.Abstract.Name -import qualified Data.Set as Set import Prologue class (Ord address, Show address) => Allocatable address effects where @@ -21,44 +14,3 @@ class (Ord address, Show address) => Allocatable address effects where class (Ord address, Show address) => Derefable address effects where derefCell :: address -> Set value -> Evaluator address value effects (Maybe value) - - -instance Member Fresh effects => Allocatable Precise effects where - allocCell _ = Precise <$> fresh - - assignCell _ value _ = pure (Set.singleton value) - -instance Derefable Precise effects where - derefCell _ = pure . fmap fst . Set.minView - - -instance Allocatable Monovariant effects where - allocCell = pure . Monovariant - - assignCell _ value values = pure (Set.insert value values) - -instance Member NonDet effects => Derefable Monovariant effects where - derefCell _ = traverse (foldMapA pure) . nonEmpty . toList - - -instance (Allocatable address effects, Member (Reader ModuleInfo) effects, Member (Reader PackageInfo) effects, Member (Reader Span) effects) => Allocatable (Located address) effects where - allocCell name = relocate (Located <$> allocCell name <*> currentPackage <*> currentModule <*> pure name <*> ask) - - assignCell (Located loc _ _ _ _) value = relocate . assignCell loc value - -instance Derefable address effects => Derefable (Located address) effects where - derefCell (Located loc _ _ _ _) = relocate . derefCell loc - - -instance (Allocatable address effects, Ord context, Show context) => Allocatable (Hole context address) effects where - allocCell name = relocate (Total <$> allocCell name) - - assignCell (Total loc) value = relocate . assignCell loc value - assignCell (Partial _) _ = pure - -instance (Derefable address effects, Ord context, Show context) => Derefable (Hole context address) effects where - derefCell (Total loc) = relocate . derefCell loc - derefCell (Partial _) = const (pure Nothing) - -relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a -relocate = raiseEff . lowerEff diff --git a/src/Control/Abstract/Hole.hs b/src/Control/Abstract/Hole.hs index ccbb83eb6..eaf94e1c7 100644 --- a/src/Control/Abstract/Hole.hs +++ b/src/Control/Abstract/Hole.hs @@ -4,6 +4,8 @@ module Control.Abstract.Hole , toMaybe ) where +import Control.Abstract.Addressable +import Control.Abstract.Evaluator import Prologue class AbstractHole a where @@ -19,3 +21,17 @@ instance Lower context => AbstractHole (Hole context a) where toMaybe :: Hole context a -> Maybe a toMaybe (Partial _) = Nothing toMaybe (Total a) = Just a + + +instance (Allocatable address effects, Ord context, Show context) => Allocatable (Hole context address) effects where + allocCell name = relocate (Total <$> allocCell name) + + assignCell (Total loc) value = relocate . assignCell loc value + assignCell (Partial _) _ = pure + +instance (Derefable address effects, Ord context, Show context) => Derefable (Hole context address) effects where + derefCell (Total loc) = relocate . derefCell loc + derefCell (Partial _) = const (pure Nothing) + +relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a +relocate = raiseEff . lowerEff diff --git a/src/Data/Abstract/Address/Located.hs b/src/Data/Abstract/Address/Located.hs index 4e2d4e50f..26b4bc4ed 100644 --- a/src/Data/Abstract/Address/Located.hs +++ b/src/Data/Abstract/Address/Located.hs @@ -1,11 +1,14 @@ +{-# LANGUAGE UndecidableInstances #-} module Data.Abstract.Address.Located ( Located(..) ) where +import Control.Abstract.Addressable +import Control.Abstract.Context +import Control.Abstract.Evaluator import Data.Abstract.Module (ModuleInfo) import Data.Abstract.Name import Data.Abstract.Package (PackageInfo) -import Data.Span data Located address = Located { address :: address @@ -15,3 +18,16 @@ data Located address = Located , addressSpan :: Span } deriving (Eq, Ord, Show) + + +instance (Allocatable address effects, Member (Reader ModuleInfo) effects, Member (Reader PackageInfo) effects, Member (Reader Span) effects) => Allocatable (Located address) effects where + allocCell name = relocate (Located <$> allocCell name <*> currentPackage <*> currentModule <*> pure name <*> ask) + + assignCell (Located loc _ _ _ _) value = relocate . assignCell loc value + +instance Derefable address effects => Derefable (Located address) effects where + derefCell (Located loc _ _ _ _) = relocate . derefCell loc + + +relocate :: Evaluator address1 value effects a -> Evaluator address2 value effects a +relocate = raiseEff . lowerEff diff --git a/src/Data/Abstract/Address/Monovariant.hs b/src/Data/Abstract/Address/Monovariant.hs index 9d052c413..23e74cc77 100644 --- a/src/Data/Abstract/Address/Monovariant.hs +++ b/src/Data/Abstract/Address/Monovariant.hs @@ -1,8 +1,12 @@ +{-# LANGUAGE UndecidableInstances #-} module Data.Abstract.Address.Monovariant ( Monovariant(..) ) where +import Control.Abstract.Addressable +import Control.Monad.Effect.NonDet import Data.Abstract.Name +import qualified Data.Set as Set import Prologue -- | 'Monovariant' models using one address for a particular name. It trackes the set of values that a particular address takes and uses it's name to lookup in the store and only allocation if new. @@ -11,3 +15,12 @@ newtype Monovariant = Monovariant { unMonovariant :: Name } instance Show Monovariant where showsPrec d = showsUnaryWith showsPrec "Monovariant" d . unMonovariant + + +instance Allocatable Monovariant effects where + allocCell = pure . Monovariant + + assignCell _ value values = pure (Set.insert value values) + +instance Member NonDet effects => Derefable Monovariant effects where + derefCell _ = traverse (foldMapA pure) . nonEmpty . toList diff --git a/src/Data/Abstract/Address/Precise.hs b/src/Data/Abstract/Address/Precise.hs index c3cefd1ad..7aba1f0c2 100644 --- a/src/Data/Abstract/Address/Precise.hs +++ b/src/Data/Abstract/Address/Precise.hs @@ -1,7 +1,11 @@ +{-# LANGUAGE UndecidableInstances #-} module Data.Abstract.Address.Precise ( Precise(..) ) where +import Control.Abstract.Addressable +import Control.Monad.Effect.Fresh +import qualified Data.Set as Set import Prologue -- | 'Precise' models precise store semantics where only the 'Latest' value is taken. Everything gets it's own address (always makes a new allocation) which makes for a larger store. @@ -10,3 +14,12 @@ newtype Precise = Precise { unPrecise :: Int } instance Show Precise where showsPrec d = showsUnaryWith showsPrec "Precise" d . unPrecise + + +instance Member Fresh effects => Allocatable Precise effects where + allocCell _ = Precise <$> fresh + + assignCell _ value _ = pure (Set.singleton value) + +instance Derefable Precise effects where + derefCell _ = pure . fmap fst . Set.minView