diff --git a/src/Analysis/Abstract/Evaluating.hs b/src/Analysis/Abstract/Evaluating.hs index 40435eb72..466ed2c6d 100644 --- a/src/Analysis/Abstract/Evaluating.hs +++ b/src/Analysis/Abstract/Evaluating.hs @@ -19,31 +19,6 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.Map as Map import System.FilePath.Posix --- -- | Require/import another term/file and return an Effect. --- -- --- -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. --- require :: forall v es. --- ( Members (Evaluating v) es --- , AbstractEnvironmentFor v --- ) --- => ModuleName -> Eff es (EnvironmentFor v) --- require name = get @(Linker (EnvironmentFor v)) >>= maybe (load name) pure . linkerLookup name --- --- -- | Load another term/file and return an Effect. --- -- --- -- Always loads/evaluates. --- load :: forall v es. --- ( Members (Evaluating v) es --- , AbstractEnvironmentFor v --- ) --- => ModuleName -> Eff es (EnvironmentFor v) --- load name = ask @(Linker (Evaluator v)) >>= maybe notFound evalAndCache . linkerLookup name --- where notFound = fail ("cannot find " <> show name) --- evalAndCache e = do --- v <- raiseEmbedded (runEvaluator e) --- let env = environment v --- modify @(Linker (EnvironmentFor v)) (linkerInsert name env) --- pure env -- | The effects necessary for concrete interpretation. type EvaluationEffects t v diff --git a/src/Control/Abstract/Value.hs b/src/Control/Abstract/Value.hs index 874deb506..159bda073 100644 --- a/src/Control/Abstract/Value.hs +++ b/src/Control/Abstract/Value.hs @@ -37,6 +37,11 @@ class (MonadEvaluator t v m) => MonadValue t v m where -- | Evaluate an application (like a function call). apply :: v -> [Subterm t (m v)] -> m v + -- | Extract the environment from an interface value. + environment :: v -> m (EnvironmentFor v) + + interface :: v -> m v + -- | Construct a 'Value' wrapping the value arguments (if any). instance ( FreeVariables t , MonadAddressable location (Value location t) m @@ -51,6 +56,7 @@ instance ( FreeVariables t integer = pure . inj . Integer boolean = pure . inj . Boolean string = pure . inj . Value.String + interface v = inj . Value.Interface v <$> getGlobalEnv ifthenelse cond if' else' | Just (Boolean b) <- prj cond = if b then if' else else' @@ -67,6 +73,10 @@ instance ( FreeVariables t envInsert name a <$> rest) (pure env) (zip names params) localEnv (mappend bindings) (evaluateTerm body) + environment v + | Just (Interface _ env) <- prj v = pure env + | otherwise = pure mempty + -- | Discard the value arguments (if any), constructing a 'Type.Type' instead. instance (Alternative m, MonadEvaluator t Type m, MonadFresh m) => MonadValue t Type m where abstract names (Subterm _ body) = do @@ -83,6 +93,8 @@ instance (Alternative m, MonadEvaluator t Type m, MonadFresh m) => MonadValue t integer _ = pure Int boolean _ = pure Bool string _ = pure Type.String + -- TODO + interface = undefined ifthenelse cond if' else' = unify cond Bool *> (if' <|> else') @@ -91,3 +103,6 @@ instance (Alternative m, MonadEvaluator t Type m, MonadFresh m) => MonadValue t paramTypes <- traverse subtermValue params _ :-> ret <- op `unify` (Product paramTypes :-> Var tvar) pure ret + + -- TODO + environment = undefined diff --git a/src/Data/Abstract/Evaluatable.hs b/src/Data/Abstract/Evaluatable.hs index 54e8bb19b..543bfad5e 100644 --- a/src/Data/Abstract/Evaluatable.hs +++ b/src/Data/Abstract/Evaluatable.hs @@ -21,7 +21,6 @@ import Data.Abstract.FreeVariables as FreeVariables import Data.Abstract.Linker import Data.Abstract.Value import Data.Algebra -import qualified Data.ByteString.Char8 as BC import Data.Functor.Classes import Data.Proxy import Data.Semigroup @@ -80,7 +79,7 @@ instance Evaluatable [] where -- Looks up the term's name in the cache of evaluated modules first, returns a value if found, otherwise loads/evaluates the module. require :: ( MonadAnalysis term v m , MonadEvaluator term v m - , AbstractEnvironmentFor v + , MonadValue term v m ) => ModuleName -> m (EnvironmentFor v) @@ -91,7 +90,7 @@ require name = getModuleTable >>= maybe (load name) pure . linkerLookup name -- Always loads/evaluates. load :: ( MonadAnalysis term v m , MonadEvaluator term v m - , AbstractEnvironmentFor v + , MonadValue term v m ) => ModuleName -> m (EnvironmentFor v) @@ -99,10 +98,6 @@ load name = askModuleTable >>= maybe notFound evalAndCache . linkerLookup name where notFound = fail ("cannot find " <> show name) evalAndCache e = do v <- evaluateTerm e - let env = environment v + env <- environment v modifyModuleTable (linkerInsert name env) pure env - --- | Get a module name from a term (expects single free variables). -moduleName :: FreeVariables term => term -> Prelude.String -moduleName term = let [n] = toList (freeVariables term) in BC.unpack n diff --git a/src/Data/Abstract/Value.hs b/src/Data/Abstract/Value.hs index 442d67199..d3162827b 100644 --- a/src/Data/Abstract/Value.hs +++ b/src/Data/Abstract/Value.hs @@ -86,16 +86,6 @@ type family LocationFor value :: * where LocationFor (Value location term) = location LocationFor Type.Type = Monovariant - -type AbstractEnvironmentFor v = AbstractEnvironment (LocationFor v) v -class AbstractEnvironment l v | v -> l where - environment :: v -> EnvironmentFor v - -instance AbstractEnvironment l (Value l t) where - environment v - | Just (Interface _ env) <- prj v = env - | otherwise = mempty - -- | Value types, e.g. closures, which can root a set of addresses. class ValueRoots l v | v -> l where -- | Compute the set of addresses rooted by a given value. diff --git a/src/Data/Syntax.hs b/src/Data/Syntax.hs index 927f1aa77..5af16ad5b 100644 --- a/src/Data/Syntax.hs +++ b/src/Data/Syntax.hs @@ -1,13 +1,11 @@ -{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables, TypeApplications #-} +{-# LANGUAGE DeriveAnyClass, GADTs, TypeOperators, MultiParamTypeClasses, UndecidableInstances, ScopedTypeVariables #-} module Data.Syntax where -import qualified Assigning.Assignment as Assignment import Control.Monad.Fail import Data.Abstract.Environment import Data.Abstract.Evaluatable import Data.AST import Data.ByteString.Char8 (unpack) -import qualified Data.Error as Error import Data.Range import Data.Record import Data.Span @@ -15,6 +13,8 @@ import Data.Term import Diffing.Algorithm hiding (Empty) import Prelude hiding (fail) import Prologue +import qualified Assigning.Assignment as Assignment +import qualified Data.Error as Error -- Combinators @@ -139,15 +139,12 @@ instance Show1 Program where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Program where eval (Program xs) = eval' xs where - -- interface val = inj . Value.Interface val <$> get @(EnvironmentFor (Value l t)) - interface val = pure val -- inj . Value.Interface val <$> askLocalEnv - eval' [] = unit >>= interface eval' [x] = subtermValue x >>= interface eval' (x:xs) = do _ <- subtermValue x env <- getGlobalEnv - localEnv (envUnion env) (eval' xs) + localEnv (const env) (eval' xs) -- | An accessibility modifier, e.g. private, public, protected, etc. newtype AccessibilityModifier a = AccessibilityModifier ByteString diff --git a/src/Data/Syntax/Declaration.hs b/src/Data/Syntax/Declaration.hs index 6e6c73f20..f6928ba04 100644 --- a/src/Data/Syntax/Declaration.hs +++ b/src/Data/Syntax/Declaration.hs @@ -5,6 +5,7 @@ import Prologue import Data.Abstract.Environment import Data.Abstract.Evaluatable import Diffing.Algorithm +import qualified Data.Map as Map data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a } deriving (Eq, Foldable, Functor, GAlign, Generic1, Mergeable, Ord, Show, Traversable, FreeVariables1) @@ -215,7 +216,8 @@ instance Ord1 Import where liftCompare = genericLiftCompare instance Show1 Import where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import where - eval (Import from _ _) = undefined -- let n = qualifiedName (subterm from) in require n *> unit + eval (Import from _ _) = require name *> unit + where name = qualifiedName (subterm from) data Import2 a = Import2 { import2From :: !a, import2Alias :: !a, import2Symbols :: ![(Name, Name)] } @@ -226,41 +228,24 @@ instance Ord1 Import2 where liftCompare = genericLiftCompare instance Show1 Import2 where liftShowsPrec = genericLiftShowsPrec instance Evaluatable Import2 where - -- TODO: - eval (Import2 from alias xs) = undefined-- require (qualifiedName (subterm from)) >> pure unit + eval (Import2 from alias xs) = do + env <- getGlobalEnv + putGlobalEnv mempty + importedEnv <- require name + env' <- Map.foldrWithKey (\k v rest -> do + if Map.null symbols + -- Copy over all symbols in the environment under their qualified names. + then envInsert (prefix <> k) v <$> rest + -- Only copy over specified symbols, possibly aliasing them. + else maybe rest (\symAlias -> envInsert symAlias v <$> rest) (Map.lookup k symbols) + ) (pure env) (unEnvironment importedEnv) --- instance ( Members (Evaluating v) es --- , Evaluatable es t v (Base t) --- , Recursive t --- , FreeVariables t --- , AbstractValue v --- , AbstractEnvironmentFor v --- ) --- => Evaluatable es t v Import2 where --- eval (Import2 from alias xs) = do --- -- Capture current global environment --- env <- get @(EnvironmentFor v) --- --- -- TODO: We may or may not want to clear the globalEnv before requiring. --- put @(EnvironmentFor v) mempty --- --- -- Evaluate the import to get it's environment. --- -- (requiring will have also have potentially updated the global environment) --- importedEnv <- require @v (qualifiedName (subterm from)) --- --- -- Restore previous global environment, adding the imported env --- let symbols = Map.fromList xs --- let prefix = qualifiedName (subterm alias) <> "." --- env' <- Map.foldrWithKey (\k v rest -> do --- if Map.null symbols --- -- Copy over all symbols in the environment under their qualified names. --- then envInsert (prefix <> k) v <$> rest --- -- Only copy over specified symbols, possibly aliasing them. --- else maybe rest (\symAlias -> envInsert symAlias v <$> rest) (Map.lookup k symbols) --- ) (pure env) (unEnvironment importedEnv) --- --- modify (const env') --- pure unit + modifyGlobalEnv (const env') + unit + where + name = qualifiedName (subterm from) + symbols = Map.fromList xs + prefix = qualifiedName (subterm alias) <> "." -- | A wildcard import @@ -271,21 +256,10 @@ instance Eq1 WildcardImport where liftEq = genericLiftEq instance Ord1 WildcardImport where liftCompare = genericLiftCompare instance Show1 WildcardImport where liftShowsPrec = genericLiftShowsPrec --- instance ( Members (Evaluating v) es --- , FreeVariables t --- , AbstractEnvironmentFor v --- , AbstractValue v --- ) --- => Evaluatable es t v WildcardImport where --- eval (WildcardImport from _) = put @(EnvironmentFor v) mempty --- >> require @v (qualifiedName (subterm from)) --- >> pure unit - instance Evaluatable WildcardImport where - eval (WildcardImport from _) = undefined - -- putGlobalEnv mempty - -- >> require (qualifiedName (subterm from)) - -- >> pure unit + eval (WildcardImport from _) = putGlobalEnv mempty *> require name *> unit + where name = qualifiedName (subterm from) + -- | An imported symbol data ImportSymbol a = ImportSymbol { importSymbolName :: !a, importSymbolAlias :: !a }