Merge remote-tracking branch 'origin/if-evaluation' into environment-scoping

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

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

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

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.

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

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 }