github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-01 09:15:01 +03:00
Code Issues Projects Releases Wiki Activity

Parameterize Function by the effects list.

Browse Source
This commit is contained in:
Rob Rix 2018-05-23 16:02:14 -04:00
parent 7da70e5983
commit 145ce59a54
1 changed files with 19 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
src/Control/Abstract/Value.hs
View File

@ -50,14 +50,14 @@ class AbstractHole value where
hole :: value hole :: value
lambda :: (Effectful m, Member (Function (m effects) value) effects) => [Name] -> Set Name -> m effects value -> m effects value lambda :: (Effectful m, Member (Function effects value) effects) => [Name] -> Set Name -> m effects value -> m effects value
lambda paramNames fvs body = send (Lambda paramNames fvs body) lambda paramNames fvs body = send (Lambda paramNames fvs (lowerEff body))
call' :: (Effectful m, Member (Function (m effects) value) effects) => value -> [m effects value] -> m effects value call' :: (Effectful m, Member (Function effects value) effects) => value -> [m effects value] -> m effects value
call' fn params = send (Call fn params) call' fn params = send (Call fn (map lowerEff params))
lambda' :: (Effectful m, Members '[Fresh, Function (m effects) value] effects, Monad (m effects)) lambda' :: (Effectful m, Members '[Fresh, Function effects value] effects, Monad (m effects))
=> (Name -> m effects value) => (Name -> m effects value)
-> m effects value -> m effects value
lambda' body = do lambda' body = do
@ -93,7 +93,7 @@ runHeapType = runState Map.empty
prog :: ( Effectful m prog :: ( Effectful m
, Members '[ Boolean value , Members '[ Boolean value
, Fresh , Fresh
, Function (m effects) value , Function effects value
, Unit value , Unit value
, Variable value , Variable value
] effects ] effects
@ -112,8 +112,8 @@ deriving instance Member NonDet effects => Alternative (Eval location effects)
data Embed effect effects return where data Embed effect effects return where
Embed :: (effect \\ effects') effects => Eff effects' a -> Embed effect effects a Embed :: (effect \\ effects') effects => Eff effects' a -> Embed effect effects a
runType :: ( effects ~ (Function (Eval Name effects) Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) runType :: ( effects ~ (Function effects Type ': Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest)
, (Function (Eval Name effects) Type \\ effects) effects' , (Function effects Type \\ effects) effects'
, effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , effects' ~ (Unit Type ': Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest)
, (Unit Type \\ effects') effects'' , (Unit Type \\ effects') effects''
, effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest) , effects'' ~ (Boolean Type ': Variable Type ': State (Map Name (Set Type)) ': Reader (Map Name Name) ': Fail ': NonDet ': rest)
@ -127,18 +127,18 @@ runType :: ( effects ~ (Function (Eval Name effects) Type ': Unit Type ': Boolea
runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType allocType assignType runType = runNonDetA . runFail . runEnv . runHeapType . runVariable derefType . runBooleanType . runUnitType . runFunctionType allocType assignType
builtinId :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) builtinId :: (Effectful m, Members '[Fresh, Function effects value, Variable value] effects, Monad (m effects))
=> m effects value => m effects value
builtinId = lambda' variable' builtinId = lambda' variable'
builtinConst :: (Effectful m, Members '[Fresh, Function (m effects) value, Variable value] effects, Monad (m effects)) builtinConst :: (Effectful m, Members '[Fresh, Function effects value, Variable value] effects, Monad (m effects))
=> m effects value => m effects value
builtinConst = lambda' (\ name -> lambda' (const (variable' name))) builtinConst = lambda' (\ name -> lambda' (const (variable' name)))
data Function m value return where data Function effects value return where
Lambda :: [Name] -> Set Name -> m value -> Function m value value Lambda :: [Name] -> Set Name -> Eff effects value -> Function effects value value
Call :: value -> [m value] -> Function m value value Call :: value -> [Eff effects value] -> Function effects value value
variable' :: (Effectful m, Member (Variable value) effects) => Name -> m effects value variable' :: (Effectful m, Member (Variable value) effects) => Name -> m effects value
variable' = send . Variable variable' = send . Variable
@ -208,7 +208,7 @@ runFunctionValue :: forall m location effects effects' a
] effects' ] effects'
, Monad (m location effects) , Monad (m location effects)
, Monad (m location effects') , Monad (m location effects')
, (Function (m location effects) (Value (m location effects) location) \\ effects) effects' , (Function effects (Value (m location effects) location) \\ effects) effects'
) )
=> (Name -> m location effects location) => (Name -> m location effects location)
-> (location -> Value (m location effects) location -> m location effects ()) -> (location -> Value (m location effects) location -> m location effects ())
@ -221,14 +221,14 @@ runFunctionValue alloc assign = go
packageInfo <- currentPackage packageInfo <- currentPackage
moduleInfo <- currentModule moduleInfo <- currentModule
env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask env <- Map.filterWithKey (fmap (`Set.member` fvs) . const) <$> ask
let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo body) let body' = withCurrentPackage packageInfo (withCurrentModule moduleInfo (raiseEff body))
pure (Closure params body' env) pure (Closure params body' env)
Call (Closure paramNames body env) params -> go $ do Call (Closure paramNames body env) params -> go $ do
bindings <- foldr (\ (name, param) rest -> do bindings <- foldr (\ (name, param) rest -> do
v <- param v <- param
a <- alloc name a <- alloc name
assign a v assign a v
Map.insert name a <$> rest) (pure env) (zip paramNames params) Map.insert name a <$> rest) (pure env) (zip paramNames (map raiseEff params))
local (Map.unionWith const bindings) body local (Map.unionWith const bindings) body
runUnitValue :: ( Applicative (m location effects') runUnitValue :: ( Applicative (m location effects')
@ -268,7 +268,7 @@ runFunctionType :: forall m location effects effects' a
] effects ] effects
, Monad (m location effects) , Monad (m location effects)
, Monad (m location effects') , Monad (m location effects')
, (Function (m location effects) Type \\ effects) effects' , (Function effects Type \\ effects) effects'
) )
=> (Name -> m location effects location) => (Name -> m location effects location)
-> (location -> Type -> m location effects ()) -> (location -> Type -> m location effects ())
@ -283,9 +283,9 @@ runFunctionType alloc assign = go
tvar <- TVar <$> fresh tvar <- TVar <$> fresh
assign a tvar assign a tvar
bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params bimap (Map.insert name a) (tvar :) <$> rest) (pure (Map.empty, [])) params
(Product tvars :->) <$> local (Map.unionWith const bindings) body (Product tvars :->) <$> local (Map.unionWith const bindings) (raiseEff body)
Call fn params -> go $ do Call fn params -> go $ do
paramTypes <- sequenceA params paramTypes <- traverse raiseEff params
case fn of case fn of
Product argTypes :-> ret -> do Product argTypes :-> ret -> do
guard (and (zipWith (==) paramTypes argTypes)) guard (and (zipWith (==) paramTypes argTypes))