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

Specialize the Type handlers to Eval.

Browse Source
This commit is contained in:
Rob Rix 2018-05-24 09:54:28 -04:00
parent 6b874d19d7
commit 8bc9178a31
1 changed files with 14 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -235,23 +235,21 @@ data Type
| BoolT | BoolT
deriving (Eq, Ord, Show) deriving (Eq, Ord, Show)
runFunctionType :: forall m location opaque effects effects' a runFunctionType :: forall location opaque effects effects' a
. ( Alternative (m location Type opaque effects) . ( Members '[ Fresh
, Effectful (m location Type opaque) , NonDet
, Members '[ Fresh
, Reader (Map Name location) , Reader (Map Name location)
, Reader ModuleInfo , Reader ModuleInfo
, Reader PackageInfo , Reader PackageInfo
] effects ] effects
, Monad (m location Type opaque effects)
, (Function Type effects \\ effects) effects' , (Function Type effects \\ effects) effects'
) )
=> (Name -> m location Type opaque effects location) => (Name -> Eval location Type opaque effects location)
-> (location -> Type -> m location Type opaque effects ()) -> (location -> Type -> Eval location Type opaque effects ())
-> m location Type opaque effects a -> Eval location Type opaque effects a
-> m location Type opaque effects' a -> Eval location Type opaque effects' a
runFunctionType alloc assign = go runFunctionType alloc assign = go
where go :: forall a . m location Type opaque effects a -> m location Type opaque effects' a where go :: forall a . Eval location Type opaque effects a -> Eval location Type opaque effects' a
go = interpretAny $ \ eff -> case eff of go = interpretAny $ \ eff -> case eff of
Lambda params _ body -> go $ do Lambda params _ body -> go $ do
(bindings, tvars) <- foldr (\ name rest -> do (bindings, tvars) <- foldr (\ name rest -> do
@ -268,20 +266,16 @@ runFunctionType alloc assign = go
pure ret pure ret
_ -> empty _ -> empty
runUnitType :: ( Applicative (m location Type opaque effects') runUnitType :: (Unit Type \\ effects) effects'
, Effectful (m location Type opaque) => Eval location Type opaque effects a
, (Unit Type \\ effects) effects' -> Eval location Type opaque effects' a
)
=> m location Type opaque effects a
-> m location Type opaque effects' a
runUnitType = interpretAny (\ Unit -> pure (Product [])) runUnitType = interpretAny (\ Unit -> pure (Product []))
runBooleanType :: ( Alternative (m location Type opaque effects') runBooleanType :: ( Member NonDet effects'
, Effectful (m location Type opaque)
, (Boolean Type \\ effects) effects' , (Boolean Type \\ effects) effects'
) )
=> m location Type opaque effects a => Eval location Type opaque effects a
-> m location Type opaque effects' a -> Eval location Type opaque effects' a
runBooleanType = interpretAny (\ eff -> case eff of runBooleanType = interpretAny (\ eff -> case eff of
Bool _ -> pure BoolT Bool _ -> pure BoolT
AsBool BoolT -> pure True <|> pure False) AsBool BoolT -> pure True <|> pure False)