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

Define a Carrier instance for HeapC.

Browse Source
This commit is contained in:
Rob Rix 2019-11-04 13:15:49 -05:00
parent a17a6825d3
commit 8f50312be3
No known key found for this signature in database
GPG Key ID: F188A01508EA1CF7
1 changed files with 19 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
semantic-analysis/src/Analysis/Carrier/Heap/Monovariant.hs
View File

@ -1,20 +1,32 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}
module Analysis.Carrier.Heap.Monovariant
( -- * Heap carrier
runHeap
, HeapC(..)
HeapC(..)
-- * Heap effect
, module Analysis.Effect.Heap
) where
import Analysis.Effect.Heap
import Control.Applicative (Alternative)
import Control.Effect.Carrier
import Control.Effect.State.Strict
import Control.Monad ((>=>))
import qualified Control.Monad.Fail as Fail
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map as Map
import Data.Monoid (Alt(..))
import qualified Data.Set as Set
runHeap :: HeapC addr value m a -> m (Map.Map addr (Set.Set value), a)
runHeap (HeapC m) = runState Map.empty m
newtype HeapC addr value m a = HeapC { runHeap :: m a }
deriving (Alternative, Applicative, Functor, Monad, Fail.MonadFail)
newtype HeapC addr value m a = HeapC (StateC (Map.Map addr (Set.Set value)) m a)
deriving (Applicative, Functor, Monad, Fail.MonadFail)
instance ( Alternative m
, Carrier sig m
, Member (State (Map.Map addr (Set.Set value))) sig
, Ord addr
, Ord value
)
=> Carrier (Heap addr value :+: sig) (HeapC addr value m) where
eff (L (Deref addr k)) = gets (Map.lookup addr >=> nonEmpty . Set.toList) >>= maybe (pure Nothing) (getAlt . foldMap (Alt . pure . Just)) >>= k
eff (L (Assign addr value k)) = modify (Map.insertWith (<>) addr (Set.singleton value)) >> k
eff (R other) = HeapC (eff (handleCoercible other))