-- For ShowLetName
{-# LANGUAGE AllowAmbiguousTypes #-}
-- For makeSharingName
{-# LANGUAGE BangPatterns #-}
-- For ShowLetName
{-# LANGUAGE DataKinds #-}
-- For SharingName
{-# LANGUAGE ExistentialQuantification #-}

-- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
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.Exts (Int(..))
-- import GHC.Prim (unsafeCoerce#)
import GHC.StableName (StableName (..), eqStableName, hashStableName, makeStableName)

-- import Numeric (showHex)

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'

-- | This class is not for end-users like usual symantic operators,
-- though it will have to be defined on end-users' interpreters.
class Referenceable letName sem where
  -- | @('ref' isRec letName)@ is a reference to @(letName)@.
  -- It is introduced by 'observeSharing'.
  -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
  -- ie. appears within its 'define'.
  --
  -- TODO: index 'letName' with 'a' to enable dependent-map
  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'

-- | This class is not for end-users like usual symantic operators.
-- There should be not need to use it outside this module,
-- because used 'define's are gathered in 'Letsable'.
class Definable letName sem where
  -- | @('define' letName sub)@ let-binds @(letName)@ to be equal to @(sub)@.
  -- This is a temporary node either replaced
  -- by 'ref' and an entry in 'lets''s 'LetBindings',
  -- or removed when no 'ref'erence is made to it.
  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'
class MakeLetName letName where
  makeLetName :: SharingName -> IO letName

-- * Type 'SharingName'

-- | Note that the observable sharing enabled by 'StableName'
-- is not perfect as it will not observe all the sharing explicitely done.
--
-- Note also that the observed sharing could be different between ghc and ghci.
data SharingName = forall a. SharingName (StableName a)

-- | @('makeSharingName' x)@ is like @('makeStableName' x)@ but it also forces
-- evaluation of @(x)@ to ensure that the 'StableName' is correct first time,
-- which avoids to produce a tree bigger than needed.
--
-- Note that this function uses 'unsafePerformIO' instead of returning in 'IO',
-- this is apparently required to avoid infinite loops due to unstable 'StableName'
-- in compiled code, and sometimes also in ghci.
--
-- Note that maybe [pseq should be used here](https://gitlab.haskell.org/ghc/ghc/-/issues/2916).
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

{-
instance Show SharingName where
  showsPrec _ (SharingName n) = showHex (I# (unsafeCoerce# n))
-}

-- * Type 'SharingObserver'
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)
  }

-- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
-- least once and/or recursively, in order to replace them
-- with the 'lets' and 'ref' combinators.
-- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
--
-- Beware not to apply 'observeSharing' more than once on the same term
-- otherwise some 'define' introduced by the first call
-- would be removed by the second call.
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 --trace (show refs) $
          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'
type WithSharing letName sem a =
  (sem a, HM.HashMap letName (SomeLet sem))

{-
-- * Type 'WithSharing'
data WithSharing letName sem a = WithSharing
  { lets :: HM.HashMap letName (SomeLet sem)
  , body :: sem a
  }
mapWithSharing ::
  (forall v. sem v -> sem v) ->
  WithSharing letName sem a ->
  WithSharing letName sem a
mapWithSharing f ws = WithSharing
  { lets = (\(SomeLet sem) -> SomeLet (f sem)) <$> lets ws
  , body = f (body ws)
  }
-}

-- ** Type 'SharingObserverState'
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 ->
            -- Compose is used to return (letName, seenBefore) along seen
            -- in the same HashMap lookup.
            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
      -- recursive reference to nodeName:
      -- update seen references
      -- and mark nodeName as recursive
      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
      -- non-recursive reference to nodeName:
      -- update seen references
      -- and recurse if the nodeName hasn't been seen before
      -- (would be in a preceding sibling branch, not in parentNames).
      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"

-- * Type 'SharingFinalizer'

-- | Remove 'define' when non-recursive or unused
-- or replace it by 'ref', moving 'define's to the top.
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
        -- This 'define' is 'ref'erenced: move it into the result,
        -- to put it in scope even when some 'ref' to it exists outside of 'body'
        -- (which can happen when a body-expression is shared),
        -- and replace it by a 'ref'.
        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 -- Remove this unreferenced 'define' node.
        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'
class Letsable letName sem where
  -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
  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

-- ** Type 'SomeLet'
data SomeLet sem = forall a. SomeLet (sem a)

-- ** Type 'LetBindings'
type LetBindings letName sem = HM.HashMap letName (SomeLet sem)

{-
-- | Not used but can be written nonetheless.
instance
  ( Letsable letName sem
  , Eq letName
  , Hashable letName
  , Show letName
  ) => Letsable letName (SharingFinalizer letName sem) where
  lets defs x = SharingFinalizer $ do
    ds <- traverse (\(SomeLet v) -> do
      r <- unFinalizeSharing v
      return (SomeLet r)
      ) defs
    MT.lift $ MT.tell ds
    unFinalizeSharing x
-}

-- ** Type 'OpenRecs'

-- | Mutually recursive terms, in open recursion style.
type OpenRecs letName a = LetRecs letName (OpenRec letName a)

-- | Mutually recursive term, in open recursion style.
-- The term is given a @final@ (aka. @self@) map
-- of other terms it can refer to (including itself).
type OpenRec letName a = LetRecs letName a -> a

-- | Recursive let bindings.
type LetRecs letName = HM.HashMap letName

-- | Least fixpoint combinator.
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

-- | Least fixpoint combinator of mutually recursive terms.
-- @('mutualFix' opens)@ takes a container of terms
-- in the open recursion style @(opens)@,
-- and return that container of terms with their knots tied-up.
--
-- Used to express mutual recursion and to transparently introduce memoization.
--
-- Here all mutually dependent functions are restricted to the same polymorphic type @(a)@.
-- See http://okmij.org/ftp/Computation/fixed-point-combinators.html#Poly-variadic
mutualFix :: forall recs a. Functor recs => recs ({-finals-} 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