github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-28 10:15:55 +03:00
Code Issues Projects Releases Wiki Activity

Specialize runStore.

Browse Source
This commit is contained in:
Rob Rix 2018-05-31 08:50:57 -04:00
parent 42540a1e20
commit b491750f94
1 changed files with 4 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
src/Control/Abstract/Heap.hs
View File

@ -22,7 +22,6 @@ module Control.Abstract.Heap
import Control.Abstract.Addressable
import Control.Abstract.Environment
import Control.Abstract.Evaluator
import Control.Monad.Effect.Internal
import Data.Abstract.Heap
import Data.Abstract.Name
import Data.Semigroup.Reducer
@ -113,10 +112,10 @@ data Store address value return where
Alloc :: Name -> Store address value address
Deref :: address -> Store address value value
runStore :: (Addressable address effects, Effectful (m address value), Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => m address value (Store address value ': effects) a -> m address value effects a
runStore = raiseHandler (interpret (\ eff -> case eff of
Alloc name -> lowerEff $ allocCell name
Deref addr -> lowerEff $ heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr))))
runStore :: (Addressable address effects, Member (Resumable (AddressError address value)) effects, Member (State (Heap address (Cell address) value)) effects) => Evaluator address value (Store address value ': effects) a -> Evaluator address value effects a
runStore = interpret (\ eff -> case eff of
Alloc name -> allocCell name
Deref addr -> heapLookup addr <$> get >>= maybeM (throwResumable (UnallocatedAddress addr)) >>= derefCell addr >>= maybeM (throwResumable (UninitializedAddress addr)))
data AddressError address value resume where