{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
module Symantic.Semantics.SharingObserver where
import Control.Applicative (Applicative (..))
import Control.Monad (Monad (..))
import Data.Bool
import Data.Eq (Eq (..))
import Data.Function (($), (.))
import Data.Functor (Functor, (<$>))
import Data.Functor.Compose (Compose (..))
import Data.HashMap.Strict (HashMap)
import Data.HashSet (HashSet)
import Data.Hashable (Hashable, hash, hashWithSalt)
import Data.Int (Int)
import Data.Maybe (Maybe (..), isNothing)
import Data.Monoid (Monoid (..))
import Data.Ord (Ord (..))
import GHC.StableName (StableName (..), eqStableName, hashStableName, makeStableName)
import Control.Monad.Trans.Class qualified as MT
import Control.Monad.Trans.Reader qualified as MT
import Control.Monad.Trans.State qualified as MT
import Control.Monad.Trans.Writer qualified as MT
import Data.HashMap.Strict qualified as HM
import Data.HashSet qualified as HS
import System.IO (IO)
import System.IO.Unsafe (unsafePerformIO)
import Text.Show (Show (..))
import Prelude (error, (+))
import Symantic.Syntaxes.Derive
class Referenceable letName sem where
ref :: Bool -> letName -> sem a
ref Bool
isRec letName
name = Derived sem a -> sem a
forall (sem :: Semantic) a.
LiftDerived sem =>
Derived sem a -> sem a
liftDerived (Bool -> letName -> Derived sem a
forall letName (sem :: Semantic) a.
Referenceable letName sem =>
Bool -> letName -> sem a
ref Bool
isRec letName
name)
default ref ::
FromDerived (Referenceable letName) sem =>
Bool ->
letName ->
sem a
class Definable letName sem where
define :: letName -> sem a -> sem a
define letName
name = (Derived sem a -> Derived sem a) -> sem a -> sem a
forall (sem :: Semantic) a b.
LiftDerived1 sem =>
(Derived sem a -> Derived sem b) -> sem a -> sem b
liftDerived1 (letName -> Derived sem a -> Derived sem a
forall letName (sem :: Semantic) a.
Definable letName sem =>
letName -> sem a -> sem a
define letName
name)
default define ::
FromDerived1 (Definable letName) sem =>
letName ->
sem a ->
sem a
class MakeLetName letName where
makeLetName :: SharingName -> IO letName
data SharingName = forall a. SharingName (StableName a)
makeSharingName :: a -> SharingName
makeSharingName :: forall a. a -> SharingName
makeSharingName !a
x = StableName a -> SharingName
forall a. StableName a -> SharingName
SharingName (StableName a -> SharingName) -> StableName a -> SharingName
forall a b. (a -> b) -> a -> b
$ IO (StableName a) -> StableName a
forall a. IO a -> a
unsafePerformIO (IO (StableName a) -> StableName a)
-> IO (StableName a) -> StableName a
forall a b. (a -> b) -> a -> b
$ a -> IO (StableName a)
forall a. a -> IO (StableName a)
makeStableName a
x
instance Eq SharingName where
SharingName StableName a
x == :: SharingName -> SharingName -> Bool
== SharingName StableName a
y = StableName a -> StableName a -> Bool
forall a b. StableName a -> StableName b -> Bool
eqStableName StableName a
x StableName a
y
instance Hashable SharingName where
hash :: SharingName -> Int
hash (SharingName StableName a
n) = StableName a -> Int
forall a. StableName a -> Int
hashStableName StableName a
n
hashWithSalt :: Int -> SharingName -> Int
hashWithSalt Int
salt (SharingName StableName a
n) = Int -> StableName a -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt StableName a
n
newtype SharingObserver letName sem a = SharingObserver
{ forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver ::
MT.ReaderT
(HashSet SharingName)
(MT.State (SharingObserverState letName))
(SharingFinalizer letName sem a)
}
observeSharing ::
Eq letName =>
Hashable letName =>
Show letName =>
SharingObserver letName sem a ->
WithSharing letName sem a
observeSharing :: forall letName (sem :: Semantic) a.
(Eq letName, Hashable letName, Show letName) =>
SharingObserver letName sem a -> WithSharing letName sem a
observeSharing (SharingObserver ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
m) =
let (SharingFinalizer letName sem a
fs, SharingObserverState letName
st) =
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> HashSet SharingName
-> State
(SharingObserverState letName) (SharingFinalizer letName sem a)
forall r (m :: Semantic) a. ReaderT r m a -> r -> m a
MT.runReaderT ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
m HashSet SharingName
forall a. Monoid a => a
mempty
State
(SharingObserverState letName) (SharingFinalizer letName sem a)
-> SharingObserverState letName
-> (SharingFinalizer letName sem a, SharingObserverState letName)
forall s a. State s a -> s -> (a, s)
`MT.runState` SharingObserverState :: forall letName.
HashMap SharingName (letName, Int)
-> HashSet SharingName -> SharingObserverState letName
SharingObserverState
{ oss_refs :: HashMap SharingName (letName, Int)
oss_refs = HashMap SharingName (letName, Int)
forall k v. HashMap k v
HM.empty
, oss_recs :: HashSet SharingName
oss_recs = HashSet SharingName
forall a. HashSet a
HS.empty
}
in let refs :: HashSet letName
refs =
[letName] -> HashSet letName
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList
[ letName
letName
| (letName
letName, Int
refCount) <- HashMap SharingName (letName, Int) -> [(letName, Int)]
forall k v. HashMap k v -> [v]
HM.elems (SharingObserverState letName -> HashMap SharingName (letName, Int)
forall letName.
SharingObserverState letName -> HashMap SharingName (letName, Int)
oss_refs SharingObserverState letName
st)
, Int
refCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
]
in
Writer (LetBindings letName sem) (sem a)
-> (sem a, LetBindings letName sem)
forall w a. Writer w a -> (a, w)
MT.runWriter (Writer (LetBindings letName sem) (sem a)
-> (sem a, LetBindings letName sem))
-> Writer (LetBindings letName sem) (sem a)
-> (sem a, LetBindings letName sem)
forall a b. (a -> b) -> a -> b
$
(ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> HashSet letName -> Writer (LetBindings letName sem) (sem a)
forall r (m :: Semantic) a. ReaderT r m a -> r -> m a
`MT.runReaderT` HashSet letName
refs) (ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> Writer (LetBindings letName sem) (sem a))
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> Writer (LetBindings letName sem) (sem a)
forall a b. (a -> b) -> a -> b
$
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem a
fs
type WithSharing letName sem a =
(sem a, HM.HashMap letName (SomeLet sem))
data SharingObserverState letName = SharingObserverState
{ forall letName.
SharingObserverState letName -> HashMap SharingName (letName, Int)
oss_refs :: HashMap SharingName (letName, Int)
, forall letName. SharingObserverState letName -> HashSet SharingName
oss_recs :: HashSet SharingName
}
observeSharingNode ::
Eq letName =>
Hashable letName =>
Show letName =>
Referenceable letName sem =>
MakeLetName letName =>
SharingObserver letName sem a ->
SharingObserver letName sem a
observeSharingNode :: forall letName (sem :: Semantic) a.
(Eq letName, Hashable letName, Show letName,
Referenceable letName sem, MakeLetName letName) =>
SharingObserver letName sem a -> SharingObserver letName sem a
observeSharingNode (SharingObserver ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
m) = ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a
forall letName (sem :: Semantic) a.
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a
SharingObserver (ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a
forall a b. (a -> b) -> a -> b
$ do
let nodeName :: SharingName
nodeName = ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingName
forall a. a -> SharingName
makeSharingName ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
m
SharingObserverState letName
st <- StateT
(SharingObserverState letName)
Identity
(SharingObserverState letName)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingObserverState letName)
forall (t :: Semantic -> Semantic) (m :: Semantic) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift StateT
(SharingObserverState letName)
Identity
(SharingObserverState letName)
forall (m :: Semantic) s. Monad m => StateT s m s
MT.get
((letName
letName, Maybe (letName, Int)
seenBefore), HashMap SharingName (letName, Int)
seen) <-
Compose
(ReaderT
(HashSet SharingName) (State (SharingObserverState letName)))
((,) (letName, Maybe (letName, Int)))
(HashMap SharingName (letName, Int))
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
((letName, Maybe (letName, Int)),
HashMap SharingName (letName, Int))
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose
(ReaderT
(HashSet SharingName) (State (SharingObserverState letName)))
((,) (letName, Maybe (letName, Int)))
(HashMap SharingName (letName, Int))
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
((letName, Maybe (letName, Int)),
HashMap SharingName (letName, Int)))
-> Compose
(ReaderT
(HashSet SharingName) (State (SharingObserverState letName)))
((,) (letName, Maybe (letName, Int)))
(HashMap SharingName (letName, Int))
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
((letName, Maybe (letName, Int)),
HashMap SharingName (letName, Int))
forall a b. (a -> b) -> a -> b
$
(Maybe (letName, Int)
-> Compose
(ReaderT
(HashSet SharingName) (State (SharingObserverState letName)))
((,) (letName, Maybe (letName, Int)))
(Maybe (letName, Int)))
-> SharingName
-> HashMap SharingName (letName, Int)
-> Compose
(ReaderT
(HashSet SharingName) (State (SharingObserverState letName)))
((,) (letName, Maybe (letName, Int)))
(HashMap SharingName (letName, Int))
forall (f :: Semantic) k v.
(Functor f, Eq k, Hashable k) =>
(Maybe v -> f (Maybe v)) -> k -> HashMap k v -> f (HashMap k v)
HM.alterF
( \Maybe (letName, Int)
seenBefore ->
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> Compose
(ReaderT
(HashSet SharingName) (State (SharingObserverState letName)))
((,) (letName, Maybe (letName, Int)))
(Maybe (letName, Int))
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> Compose
(ReaderT
(HashSet SharingName) (State (SharingObserverState letName)))
((,) (letName, Maybe (letName, Int)))
(Maybe (letName, Int)))
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> Compose
(ReaderT
(HashSet SharingName) (State (SharingObserverState letName)))
((,) (letName, Maybe (letName, Int)))
(Maybe (letName, Int))
forall a b. (a -> b) -> a -> b
$
((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
((letName, Maybe (letName, Int)), Maybe (letName, Int))
forall (m :: Semantic) a. Monad m => a -> m a
return (((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
((letName, Maybe (letName, Int)), Maybe (letName, Int)))
-> ((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
((letName, Maybe (letName, Int)), Maybe (letName, Int))
forall a b. (a -> b) -> a -> b
$ case Maybe (letName, Int)
seenBefore of
Maybe (letName, Int)
Nothing ->
((letName
letName, Maybe (letName, Int)
seenBefore), (letName, Int) -> Maybe (letName, Int)
forall a. a -> Maybe a
Just (letName
letName, Int
0))
where
letName :: letName
letName = IO letName -> letName
forall a. IO a -> a
unsafePerformIO (IO letName -> letName) -> IO letName -> letName
forall a b. (a -> b) -> a -> b
$ SharingName -> IO letName
forall letName. MakeLetName letName => SharingName -> IO letName
makeLetName SharingName
nodeName
Just (letName
letName, Int
refCount) ->
((letName
letName, Maybe (letName, Int)
seenBefore), (letName, Int) -> Maybe (letName, Int)
forall a. a -> Maybe a
Just (letName
letName, Int
refCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
)
SharingName
nodeName
(SharingObserverState letName -> HashMap SharingName (letName, Int)
forall letName.
SharingObserverState letName -> HashMap SharingName (letName, Int)
oss_refs SharingObserverState letName
st)
HashSet SharingName
parentNames <- ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(HashSet SharingName)
forall (m :: Semantic) r. Monad m => ReaderT r m r
MT.ask
if SharingName
nodeName SharingName -> HashSet SharingName -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet SharingName
parentNames
then do
StateT (SharingObserverState letName) Identity ()
-> ReaderT
(HashSet SharingName) (State (SharingObserverState letName)) ()
forall (t :: Semantic -> Semantic) (m :: Semantic) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (StateT (SharingObserverState letName) Identity ()
-> ReaderT
(HashSet SharingName) (State (SharingObserverState letName)) ())
-> StateT (SharingObserverState letName) Identity ()
-> ReaderT
(HashSet SharingName) (State (SharingObserverState letName)) ()
forall a b. (a -> b) -> a -> b
$
SharingObserverState letName
-> StateT (SharingObserverState letName) Identity ()
forall (m :: Semantic) s. Monad m => s -> StateT s m ()
MT.put
SharingObserverState letName
st
{ oss_refs :: HashMap SharingName (letName, Int)
oss_refs = HashMap SharingName (letName, Int)
seen
, oss_recs :: HashSet SharingName
oss_recs = SharingName -> HashSet SharingName -> HashSet SharingName
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert SharingName
nodeName (SharingObserverState letName -> HashSet SharingName
forall letName. SharingObserverState letName -> HashSet SharingName
oss_recs SharingObserverState letName
st)
}
SharingFinalizer letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall (m :: Semantic) a. Monad m => a -> m a
return (SharingFinalizer letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a))
-> SharingFinalizer letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall a b. (a -> b) -> a -> b
$ Bool -> letName -> SharingFinalizer letName sem a
forall letName (sem :: Semantic) a.
Referenceable letName sem =>
Bool -> letName -> sem a
ref Bool
True letName
letName
else do
StateT (SharingObserverState letName) Identity ()
-> ReaderT
(HashSet SharingName) (State (SharingObserverState letName)) ()
forall (t :: Semantic -> Semantic) (m :: Semantic) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (StateT (SharingObserverState letName) Identity ()
-> ReaderT
(HashSet SharingName) (State (SharingObserverState letName)) ())
-> StateT (SharingObserverState letName) Identity ()
-> ReaderT
(HashSet SharingName) (State (SharingObserverState letName)) ()
forall a b. (a -> b) -> a -> b
$ SharingObserverState letName
-> StateT (SharingObserverState letName) Identity ()
forall (m :: Semantic) s. Monad m => s -> StateT s m ()
MT.put SharingObserverState letName
st{oss_refs :: HashMap SharingName (letName, Int)
oss_refs = HashMap SharingName (letName, Int)
seen}
if Maybe (letName, Int) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (letName, Int)
seenBefore
then (HashSet SharingName -> HashSet SharingName)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall r (m :: Semantic) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
MT.local (SharingName -> HashSet SharingName -> HashSet SharingName
forall a. (Eq a, Hashable a) => a -> HashSet a -> HashSet a
HS.insert SharingName
nodeName) (letName
-> SharingFinalizer letName sem a -> SharingFinalizer letName sem a
forall letName (sem :: Semantic) a.
Definable letName sem =>
letName -> sem a -> sem a
define letName
letName (SharingFinalizer letName sem a -> SharingFinalizer letName sem a)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
m)
else SharingFinalizer letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall (m :: Semantic) a. Monad m => a -> m a
return (SharingFinalizer letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a))
-> SharingFinalizer letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall a b. (a -> b) -> a -> b
$ Bool -> letName -> SharingFinalizer letName sem a
forall letName (sem :: Semantic) a.
Referenceable letName sem =>
Bool -> letName -> sem a
ref Bool
False letName
letName
type instance Derived (SharingObserver letName sem) = SharingFinalizer letName sem
instance
( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
) =>
LiftDerived (SharingObserver letName sem)
where
liftDerived :: forall a.
Derived (SharingObserver letName sem) a
-> SharingObserver letName sem a
liftDerived = SharingObserver letName sem a -> SharingObserver letName sem a
forall letName (sem :: Semantic) a.
(Eq letName, Hashable letName, Show letName,
Referenceable letName sem, MakeLetName letName) =>
SharingObserver letName sem a -> SharingObserver letName sem a
observeSharingNode (SharingObserver letName sem a -> SharingObserver letName sem a)
-> (SharingFinalizer letName sem a
-> SharingObserver letName sem a)
-> SharingFinalizer letName sem a
-> SharingObserver letName sem a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a
forall letName (sem :: Semantic) a.
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a
SharingObserver (ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a)
-> (SharingFinalizer letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a))
-> SharingFinalizer letName sem a
-> SharingObserver letName sem a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SharingFinalizer letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall (m :: Semantic) a. Monad m => a -> m a
return
instance
( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
) =>
LiftDerived1 (SharingObserver letName sem)
where
liftDerived1 :: forall a b.
(Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b)
-> SharingObserver letName sem a -> SharingObserver letName sem b
liftDerived1 Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
f SharingObserver letName sem a
a =
SharingObserver letName sem b -> SharingObserver letName sem b
forall letName (sem :: Semantic) a.
(Eq letName, Hashable letName, Show letName,
Referenceable letName sem, MakeLetName letName) =>
SharingObserver letName sem a -> SharingObserver letName sem a
observeSharingNode (SharingObserver letName sem b -> SharingObserver letName sem b)
-> SharingObserver letName sem b -> SharingObserver letName sem b
forall a b. (a -> b) -> a -> b
$
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
-> SharingObserver letName sem b
forall letName (sem :: Semantic) a.
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a
SharingObserver (ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
-> SharingObserver letName sem b)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
-> SharingObserver letName sem b
forall a b. (a -> b) -> a -> b
$
Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
SharingFinalizer letName sem a -> SharingFinalizer letName sem b
f (SharingFinalizer letName sem a -> SharingFinalizer letName sem b)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem a
a
instance
( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
) =>
LiftDerived2 (SharingObserver letName sem)
where
liftDerived2 :: forall a b c.
(Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
-> Derived (SharingObserver letName sem) c)
-> SharingObserver letName sem a
-> SharingObserver letName sem b
-> SharingObserver letName sem c
liftDerived2 Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
-> Derived (SharingObserver letName sem) c
f SharingObserver letName sem a
a SharingObserver letName sem b
b =
SharingObserver letName sem c -> SharingObserver letName sem c
forall letName (sem :: Semantic) a.
(Eq letName, Hashable letName, Show letName,
Referenceable letName sem, MakeLetName letName) =>
SharingObserver letName sem a -> SharingObserver letName sem a
observeSharingNode (SharingObserver letName sem c -> SharingObserver letName sem c)
-> SharingObserver letName sem c -> SharingObserver letName sem c
forall a b. (a -> b) -> a -> b
$
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c)
-> SharingObserver letName sem c
forall letName (sem :: Semantic) a.
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a
SharingObserver (ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c)
-> SharingObserver letName sem c)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c)
-> SharingObserver letName sem c
forall a b. (a -> b) -> a -> b
$
Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
-> Derived (SharingObserver letName sem) c
SharingFinalizer letName sem a
-> SharingFinalizer letName sem b -> SharingFinalizer letName sem c
f (SharingFinalizer letName sem a
-> SharingFinalizer letName sem b
-> SharingFinalizer letName sem c)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b -> SharingFinalizer letName sem c)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem a
a
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b -> SharingFinalizer letName sem c)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingObserver letName sem b
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem b
b
instance
( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
) =>
LiftDerived3 (SharingObserver letName sem)
where
liftDerived3 :: forall a b c d.
(Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
-> Derived (SharingObserver letName sem) c
-> Derived (SharingObserver letName sem) d)
-> SharingObserver letName sem a
-> SharingObserver letName sem b
-> SharingObserver letName sem c
-> SharingObserver letName sem d
liftDerived3 Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
-> Derived (SharingObserver letName sem) c
-> Derived (SharingObserver letName sem) d
f SharingObserver letName sem a
a SharingObserver letName sem b
b SharingObserver letName sem c
c =
SharingObserver letName sem d -> SharingObserver letName sem d
forall letName (sem :: Semantic) a.
(Eq letName, Hashable letName, Show letName,
Referenceable letName sem, MakeLetName letName) =>
SharingObserver letName sem a -> SharingObserver letName sem a
observeSharingNode (SharingObserver letName sem d -> SharingObserver letName sem d)
-> SharingObserver letName sem d -> SharingObserver letName sem d
forall a b. (a -> b) -> a -> b
$
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem d)
-> SharingObserver letName sem d
forall letName (sem :: Semantic) a.
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a
SharingObserver (ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem d)
-> SharingObserver letName sem d)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem d)
-> SharingObserver letName sem d
forall a b. (a -> b) -> a -> b
$
Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
-> Derived (SharingObserver letName sem) c
-> Derived (SharingObserver letName sem) d
SharingFinalizer letName sem a
-> SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d
f (SharingFinalizer letName sem a
-> SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem a
a
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c -> SharingFinalizer letName sem d)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingObserver letName sem b
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem b
b
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c -> SharingFinalizer letName sem d)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem d)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingObserver letName sem c
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem c
c
instance
( Referenceable letName sem
, MakeLetName letName
, Eq letName
, Hashable letName
, Show letName
) =>
LiftDerived4 (SharingObserver letName sem)
where
liftDerived4 :: forall a b c d e.
(Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
-> Derived (SharingObserver letName sem) c
-> Derived (SharingObserver letName sem) d
-> Derived (SharingObserver letName sem) e)
-> SharingObserver letName sem a
-> SharingObserver letName sem b
-> SharingObserver letName sem c
-> SharingObserver letName sem d
-> SharingObserver letName sem e
liftDerived4 Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
-> Derived (SharingObserver letName sem) c
-> Derived (SharingObserver letName sem) d
-> Derived (SharingObserver letName sem) e
f SharingObserver letName sem a
a SharingObserver letName sem b
b SharingObserver letName sem c
c SharingObserver letName sem d
d =
SharingObserver letName sem e -> SharingObserver letName sem e
forall letName (sem :: Semantic) a.
(Eq letName, Hashable letName, Show letName,
Referenceable letName sem, MakeLetName letName) =>
SharingObserver letName sem a -> SharingObserver letName sem a
observeSharingNode (SharingObserver letName sem e -> SharingObserver letName sem e)
-> SharingObserver letName sem e -> SharingObserver letName sem e
forall a b. (a -> b) -> a -> b
$
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem e)
-> SharingObserver letName sem e
forall letName (sem :: Semantic) a.
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> SharingObserver letName sem a
SharingObserver (ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem e)
-> SharingObserver letName sem e)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem e)
-> SharingObserver letName sem e
forall a b. (a -> b) -> a -> b
$
Derived (SharingObserver letName sem) a
-> Derived (SharingObserver letName sem) b
-> Derived (SharingObserver letName sem) c
-> Derived (SharingObserver letName sem) d
-> Derived (SharingObserver letName sem) e
SharingFinalizer letName sem a
-> SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d
-> SharingFinalizer letName sem e
f (SharingFinalizer letName sem a
-> SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d
-> SharingFinalizer letName sem e)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d
-> SharingFinalizer letName sem e)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem a
a
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d
-> SharingFinalizer letName sem e)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c
-> SharingFinalizer letName sem d
-> SharingFinalizer letName sem e)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingObserver letName sem b
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem b)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem b
b
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c
-> SharingFinalizer letName sem d
-> SharingFinalizer letName sem e)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem d -> SharingFinalizer letName sem e)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingObserver letName sem c
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem c)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem c
c
ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem d -> SharingFinalizer letName sem e)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem d)
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem e)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingObserver letName sem d
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem d)
forall letName (sem :: Semantic) a.
SharingObserver letName sem a
-> ReaderT
(HashSet SharingName)
(State (SharingObserverState letName))
(SharingFinalizer letName sem a)
unSharingObserver SharingObserver letName sem d
d
instance Referenceable letName (SharingObserver letName sem) where
ref :: forall a. Bool -> letName -> SharingObserver letName sem a
ref = [Char] -> Bool -> letName -> SharingObserver letName sem a
forall a. HasCallStack => [Char] -> a
error [Char]
"[BUG]: observeSharing MUST NOT be applied twice"
instance Definable letName (SharingObserver letName sem) where
define :: forall a.
letName
-> SharingObserver letName sem a -> SharingObserver letName sem a
define = [Char]
-> letName
-> SharingObserver letName sem a
-> SharingObserver letName sem a
forall a. HasCallStack => [Char] -> a
error [Char]
"[BUG]: observeSharing MUST NOT be applied twice"
instance Letsable letName (SharingObserver letName sem) where
lets :: forall a.
LetBindings letName (SharingObserver letName sem)
-> SharingObserver letName sem a -> SharingObserver letName sem a
lets = [Char]
-> LetBindings letName (SharingObserver letName sem)
-> SharingObserver letName sem a
-> SharingObserver letName sem a
forall a. HasCallStack => [Char] -> a
error [Char]
"[BUG]: observeSharing MUST NOT be applied twice"
newtype SharingFinalizer letName sem a = SharingFinalizer
{ forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing ::
MT.ReaderT
(HS.HashSet letName)
(MT.Writer (LetBindings letName sem))
(sem a)
}
type instance Derived (SharingFinalizer _letName sem) = sem
instance
(Eq letName, Hashable letName) =>
LiftDerived (SharingFinalizer letName sem)
where
liftDerived :: forall a.
Derived (SharingFinalizer letName sem) a
-> SharingFinalizer letName sem a
liftDerived = ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a
forall letName (sem :: Semantic) a.
ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a
SharingFinalizer (ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a)
-> (sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a))
-> sem a
-> SharingFinalizer letName sem a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall (f :: Semantic) a. Applicative f => a -> f a
pure
instance
(Eq letName, Hashable letName) =>
LiftDerived1 (SharingFinalizer letName sem)
where
liftDerived1 :: forall a b.
(Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b)
-> SharingFinalizer letName sem a -> SharingFinalizer letName sem b
liftDerived1 Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
f SharingFinalizer letName sem a
a = ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
-> SharingFinalizer letName sem b
forall letName (sem :: Semantic) a.
ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a
SharingFinalizer (ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
-> SharingFinalizer letName sem b)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
-> SharingFinalizer letName sem b
forall a b. (a -> b) -> a -> b
$ sem a -> sem b
Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
f (sem a -> sem b)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem a
a
instance
(Eq letName, Hashable letName) =>
LiftDerived2 (SharingFinalizer letName sem)
where
liftDerived2 :: forall a b c.
(Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
-> Derived (SharingFinalizer letName sem) c)
-> SharingFinalizer letName sem a
-> SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
liftDerived2 Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
-> Derived (SharingFinalizer letName sem) c
f SharingFinalizer letName sem a
a SharingFinalizer letName sem b
b =
ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem c)
-> SharingFinalizer letName sem c
forall letName (sem :: Semantic) a.
ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a
SharingFinalizer (ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem c)
-> SharingFinalizer letName sem c)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem c)
-> SharingFinalizer letName sem c
forall a b. (a -> b) -> a -> b
$
sem a -> sem b -> sem c
Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
-> Derived (SharingFinalizer letName sem) c
f (sem a -> sem b -> sem c)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem b -> sem c)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem a
a
ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem b -> sem c)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem c)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingFinalizer letName sem b
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem b
b
instance
(Eq letName, Hashable letName) =>
LiftDerived3 (SharingFinalizer letName sem)
where
liftDerived3 :: forall a b c d.
(Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
-> Derived (SharingFinalizer letName sem) c
-> Derived (SharingFinalizer letName sem) d)
-> SharingFinalizer letName sem a
-> SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d
liftDerived3 Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
-> Derived (SharingFinalizer letName sem) c
-> Derived (SharingFinalizer letName sem) d
f SharingFinalizer letName sem a
a SharingFinalizer letName sem b
b SharingFinalizer letName sem c
c =
ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem d)
-> SharingFinalizer letName sem d
forall letName (sem :: Semantic) a.
ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a
SharingFinalizer (ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem d)
-> SharingFinalizer letName sem d)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem d)
-> SharingFinalizer letName sem d
forall a b. (a -> b) -> a -> b
$
sem a -> sem b -> sem c -> sem d
Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
-> Derived (SharingFinalizer letName sem) c
-> Derived (SharingFinalizer letName sem) d
f (sem a -> sem b -> sem c -> sem d)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem b -> sem c -> sem d)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem a
a
ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem b -> sem c -> sem d)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
-> ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem c -> sem d)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingFinalizer letName sem b
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem b
b
ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem c -> sem d)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem c)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem d)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingFinalizer letName sem c
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem c)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem c
c
instance
(Eq letName, Hashable letName) =>
LiftDerived4 (SharingFinalizer letName sem)
where
liftDerived4 :: forall a b c d e.
(Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
-> Derived (SharingFinalizer letName sem) c
-> Derived (SharingFinalizer letName sem) d
-> Derived (SharingFinalizer letName sem) e)
-> SharingFinalizer letName sem a
-> SharingFinalizer letName sem b
-> SharingFinalizer letName sem c
-> SharingFinalizer letName sem d
-> SharingFinalizer letName sem e
liftDerived4 Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
-> Derived (SharingFinalizer letName sem) c
-> Derived (SharingFinalizer letName sem) d
-> Derived (SharingFinalizer letName sem) e
f SharingFinalizer letName sem a
a SharingFinalizer letName sem b
b SharingFinalizer letName sem c
c SharingFinalizer letName sem d
d =
ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem e)
-> SharingFinalizer letName sem e
forall letName (sem :: Semantic) a.
ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a
SharingFinalizer (ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem e)
-> SharingFinalizer letName sem e)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem e)
-> SharingFinalizer letName sem e
forall a b. (a -> b) -> a -> b
$
sem a -> sem b -> sem c -> sem d -> sem e
Derived (SharingFinalizer letName sem) a
-> Derived (SharingFinalizer letName sem) b
-> Derived (SharingFinalizer letName sem) c
-> Derived (SharingFinalizer letName sem) d
-> Derived (SharingFinalizer letName sem) e
f (sem a -> sem b -> sem c -> sem d -> sem e)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem b -> sem c -> sem d -> sem e)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem a
a
ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem b -> sem c -> sem d -> sem e)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
-> ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem c -> sem d -> sem e)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingFinalizer letName sem b
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem b)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem b
b
ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem c -> sem d -> sem e)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem c)
-> ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem d -> sem e)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingFinalizer letName sem c
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem c)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem c
c
ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(sem d -> sem e)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem d)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem e)
forall (f :: Semantic) a b.
Applicative f =>
f (a -> b) -> f a -> f b
<*> SharingFinalizer letName sem d
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem d)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem d
d
instance
( Referenceable letName sem
, Eq letName
, Hashable letName
, Show letName
) =>
Referenceable letName (SharingFinalizer letName sem)
where
ref :: forall a. Bool -> letName -> SharingFinalizer letName sem a
ref Bool
isRec = sem a -> SharingFinalizer letName sem a
forall (sem :: Semantic) a.
LiftDerived sem =>
Derived sem a -> sem a
liftDerived (sem a -> SharingFinalizer letName sem a)
-> (letName -> sem a) -> letName -> SharingFinalizer letName sem a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> letName -> sem a
forall letName (sem :: Semantic) a.
Referenceable letName sem =>
Bool -> letName -> sem a
ref Bool
isRec
instance
( Referenceable letName sem
, Eq letName
, Hashable letName
, Show letName
) =>
Definable letName (SharingFinalizer letName sem)
where
define :: forall a.
letName
-> SharingFinalizer letName sem a -> SharingFinalizer letName sem a
define letName
name SharingFinalizer letName sem a
body = ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a
forall letName (sem :: Semantic) a.
ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a
SharingFinalizer (ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a)
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> SharingFinalizer letName sem a
forall a b. (a -> b) -> a -> b
$ do
HashSet letName
refs <- ReaderT
(HashSet letName)
(Writer (LetBindings letName sem))
(HashSet letName)
forall (m :: Semantic) r. Monad m => ReaderT r m r
MT.ask
let (sem a
sem, LetBindings letName sem
defs) =
Writer (LetBindings letName sem) (sem a)
-> (sem a, LetBindings letName sem)
forall w a. Writer w a -> (a, w)
MT.runWriter (Writer (LetBindings letName sem) (sem a)
-> (sem a, LetBindings letName sem))
-> Writer (LetBindings letName sem) (sem a)
-> (sem a, LetBindings letName sem)
forall a b. (a -> b) -> a -> b
$ ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
-> HashSet letName -> Writer (LetBindings letName sem) (sem a)
forall r (m :: Semantic) a. ReaderT r m a -> r -> m a
MT.runReaderT (SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem a
body) HashSet letName
refs
if letName
name letName -> HashSet letName -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet letName
refs
then do
WriterT (LetBindings letName sem) Identity ()
-> ReaderT (HashSet letName) (Writer (LetBindings letName sem)) ()
forall (t :: Semantic -> Semantic) (m :: Semantic) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (WriterT (LetBindings letName sem) Identity ()
-> ReaderT (HashSet letName) (Writer (LetBindings letName sem)) ())
-> WriterT (LetBindings letName sem) Identity ()
-> ReaderT (HashSet letName) (Writer (LetBindings letName sem)) ()
forall a b. (a -> b) -> a -> b
$ LetBindings letName sem
-> WriterT (LetBindings letName sem) Identity ()
forall (m :: Semantic) w. Monad m => w -> WriterT w m ()
MT.tell (LetBindings letName sem
-> WriterT (LetBindings letName sem) Identity ())
-> LetBindings letName sem
-> WriterT (LetBindings letName sem) Identity ()
forall a b. (a -> b) -> a -> b
$ letName
-> SomeLet sem
-> LetBindings letName sem
-> LetBindings letName sem
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert letName
name (sem a -> SomeLet sem
forall (sem :: Semantic) a. sem a -> SomeLet sem
SomeLet sem a
sem) LetBindings letName sem
defs
sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall (m :: Semantic) a. Monad m => a -> m a
return (sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a))
-> sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall a b. (a -> b) -> a -> b
$ Bool -> letName -> sem a
forall letName (sem :: Semantic) a.
Referenceable letName sem =>
Bool -> letName -> sem a
ref Bool
False letName
name
else
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
forall letName (sem :: Semantic) a.
SharingFinalizer letName sem a
-> ReaderT
(HashSet letName) (Writer (LetBindings letName sem)) (sem a)
unFinalizeSharing SharingFinalizer letName sem a
body
class Letsable letName sem where
lets :: LetBindings letName sem -> sem a -> sem a
lets LetBindings letName sem
defs = (Derived sem a -> Derived sem a) -> sem a -> sem a
forall (sem :: Semantic) a b.
LiftDerived1 sem =>
(Derived sem a -> Derived sem b) -> sem a -> sem b
liftDerived1 (LetBindings letName (Derived sem) -> Derived sem a -> Derived sem a
forall letName (sem :: Semantic) a.
Letsable letName sem =>
LetBindings letName sem -> sem a -> sem a
lets ((\(SomeLet sem a
val) -> Derived sem a -> SomeLet (Derived sem)
forall (sem :: Semantic) a. sem a -> SomeLet sem
SomeLet (sem a -> Derived sem a
forall (sem :: Semantic) a. Derivable sem => sem a -> Derived sem a
derive sem a
val)) (SomeLet sem -> SomeLet (Derived sem))
-> LetBindings letName sem -> LetBindings letName (Derived sem)
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> LetBindings letName sem
defs))
default lets ::
Derivable sem =>
FromDerived1 (Letsable letName) sem =>
LetBindings letName sem ->
sem a ->
sem a
data SomeLet sem = forall a. SomeLet (sem a)
type LetBindings letName sem = HM.HashMap letName (SomeLet sem)
type OpenRecs letName a = LetRecs letName (OpenRec letName a)
type OpenRec letName a = LetRecs letName a -> a
type LetRecs letName = HM.HashMap letName
fix :: (a -> a) -> a
fix :: forall a. (a -> a) -> a
fix a -> a
f = a
final where final :: a
final = a -> a
f a
final
mutualFix :: forall recs a. Functor recs => recs ( recs a -> a) -> recs a
mutualFix :: forall (recs :: Semantic) a.
Functor recs =>
recs (recs a -> a) -> recs a
mutualFix recs (recs a -> a)
opens = (recs a -> recs a) -> recs a
forall a. (a -> a) -> a
fix recs a -> recs a
f
where
f :: recs a -> recs a
f :: recs a -> recs a
f recs a
recs = ((recs a -> a) -> recs a -> a
forall a b. (a -> b) -> a -> b
$ recs a
recs) ((recs a -> a) -> a) -> recs (recs a -> a) -> recs a
forall (f :: Semantic) a b. Functor f => (a -> b) -> f a -> f b
<$> recs (recs a -> a)
opens