github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-22 14:21:31 +03:00
Code Issues Projects Releases Wiki Activity

Abstract application into AbstractFunction.

Browse Source
This commit is contained in:
Rob Rix 2018-02-27 17:17:06 -05:00
parent 7a648c1625
commit 1a795af3b6
1 changed files with 21 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
src/Control/Monad/Effect/Evaluatable.hs
View File

@ -15,6 +15,7 @@ import Control.Monad.Effect.Internal
import Control.Monad.Effect.NonDetEff import Control.Monad.Effect.NonDetEff
import Control.Monad.Effect.Reader import Control.Monad.Effect.Reader
import Control.Monad.Effect.State import Control.Monad.Effect.State
import Data.Abstract.Address
import Data.Abstract.Environment import Data.Abstract.Environment
import Data.Abstract.FreeVariables import Data.Abstract.FreeVariables
import Data.Abstract.Type as Type import Data.Abstract.Type as Type
@ -23,6 +24,7 @@ import Data.Algebra
import Data.Functor.Classes import Data.Functor.Classes
import Data.Functor.Foldable (Base, Recursive(..), project) import Data.Functor.Foldable (Base, Recursive(..), project)
import Data.Proxy import Data.Proxy
import Data.Semigroup
import Data.Term import Data.Term
import Data.Union (Apply) import Data.Union (Apply)
import Prelude hiding (fail) import Prelude hiding (fail)
@ -75,12 +77,22 @@ instance ( Ord (LocationFor v)
class AbstractValue v => AbstractFunction effects t v | v -> t where class AbstractValue v => AbstractFunction effects t v | v -> t where
abstract :: [Name] -> Subterm t (Eff effects v) -> Eff effects v abstract :: [Name] -> Subterm t (Eff effects v) -> Eff effects v
apply :: v -> [Subterm t (Eff effects v)] -> Eff effects v
instance Reader (EnvironmentFor (Value location t)) :< effects => AbstractFunction effects t (Value location t) where instance (Addressable location effects, Semigroup (Cell location (Value location t)), Members '[Fail, Reader (EnvironmentFor (Value location t)), State (StoreFor (Value location t))] effects, Recursive t, Evaluatable effects t (Value location t) (Base t), FreeVariables t) => AbstractFunction effects t (Value location t) where
-- FIXME: Can we store the action evaluating the body in the Value instead of the body term itself? -- FIXME: Can we store the action evaluating the body in the Value instead of the body term itself
abstract names (Subterm body _) = inj . Closure names body <$> ask @(EnvironmentFor (Value location t)) abstract names (Subterm body _) = inj . Closure names body <$> ask @(EnvironmentFor (Value location t))
instance Members '[Fresh, NonDetEff, Reader (EnvironmentFor (Type t)), State (StoreFor (Type t))] effects => AbstractFunction effects t (Type t) where apply op params = do
Closure names body env <- maybe (fail "expected a closure") pure (prj op :: Maybe (Closure location t))
bindings <- foldr (\ (name, param) rest -> do
v <- subtermValue param
a <- alloc name
assign a v
envInsert name a <$> rest) (pure env) (zip names params)
local (mappend bindings) (foldSubterms eval body)
instance Members '[Fail, Fresh, NonDetEff, Reader (EnvironmentFor (Type t)), State (StoreFor (Type t))] effects => AbstractFunction effects t (Type t) where
abstract names (Subterm _ body) = do abstract names (Subterm _ body) = do
(env, tvars) <- foldr (\ name rest -> do (env, tvars) <- foldr (\ name rest -> do
a <- alloc name a <- alloc name
@ -90,3 +102,9 @@ instance Members '[Fresh, NonDetEff, Reader (EnvironmentFor (Type t)), State (St
pure (envInsert name a env, tvar : tvars)) (pure mempty) names pure (envInsert name a env, tvar : tvars)) (pure mempty) names
ret <- local (mappend env) body ret <- local (mappend env) body
pure (Type.Product tvars :-> ret) pure (Type.Product tvars :-> ret)
apply op params = do
tvar <- fresh
paramTypes <- traverse subtermValue params
_ :-> ret <- op `unify` (Type.Product paramTypes :-> Var tvar)
pure ret