{-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName
{-# LANGUAGE BangPatterns #-} -- For makeSharingName
{-# LANGUAGE DataKinds #-} -- For ShowLetName
{-# LANGUAGE ExistentialQuantification #-} -- For SharingName
-- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
module Symantic.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, hashWithSalt, hash)
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(..), makeStableName, hashStableName, eqStableName)
-- import Numeric (showHex)
import Prelude ((+), error)
import System.IO (IO)
import System.IO.Unsafe (unsafePerformIO)
import Text.Show (Show(..))
import qualified Control.Monad.Trans.Class as MT
import qualified Control.Monad.Trans.Reader as MT
import qualified Control.Monad.Trans.State as MT
import qualified Control.Monad.Trans.Writer as MT
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS

import Symantic.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 repr 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 -> repr a
  ref Bool
isRec letName
name = Derived repr a -> repr a
forall (repr :: * -> *) a.
LiftDerived repr =>
Derived repr a -> repr a
liftDerived (Bool -> letName -> Derived repr a
forall letName (repr :: * -> *) a.
Referenceable letName repr =>
Bool -> letName -> repr a
ref Bool
isRec letName
name)
  default ref ::
    FromDerived (Referenceable letName) repr =>
    Bool -> letName -> repr 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 repr 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 -> repr a -> repr a
  define letName
name = (Derived repr a -> Derived repr a) -> repr a -> repr a
forall (repr :: * -> *) a b.
LiftDerived1 repr =>
(Derived repr a -> Derived repr b) -> repr a -> repr b
liftDerived1 (letName -> Derived repr a -> Derived repr a
forall letName (repr :: * -> *) a.
Definable letName repr =>
letName -> repr a -> repr a
define letName
name)
  default define ::
    FromDerived1 (Definable letName) repr =>
    letName -> repr a -> repr 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 :: 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 repr a = SharingObserver { SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver ::
  MT.ReaderT (HashSet SharingName)
             (MT.State (SharingObserverState letName))
             (SharingFinalizer letName repr 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 repr a ->
  WithSharing letName repr a
observeSharing :: SharingObserver letName repr a -> WithSharing letName repr a
observeSharing (SharingObserver ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
m) =
  let (SharingFinalizer letName repr a
fs, SharingObserverState letName
st) = ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> HashSet SharingName
-> State
     (SharingObserverState letName) (SharingFinalizer letName repr a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
MT.runReaderT ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
m HashSet SharingName
forall a. Monoid a => a
mempty State
  (SharingObserverState letName) (SharingFinalizer letName repr a)
-> SharingObserverState letName
-> (SharingFinalizer letName repr 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 repr) (repr a)
-> WithSharing letName repr a
forall w a. Writer w a -> (a, w)
MT.runWriter (Writer (LetBindings letName repr) (repr a)
 -> WithSharing letName repr a)
-> Writer (LetBindings letName repr) (repr a)
-> WithSharing letName repr a
forall a b. (a -> b) -> a -> b
$
  (ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> HashSet letName -> Writer (LetBindings letName repr) (repr a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`MT.runReaderT` HashSet letName
refs) (ReaderT
   (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
 -> Writer (LetBindings letName repr) (repr a))
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> Writer (LetBindings letName repr) (repr a)
forall a b. (a -> b) -> a -> b
$
  SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr a
fs

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

-- ** Type 'SharingObserverState'
data SharingObserverState letName = SharingObserverState
  { SharingObserverState letName -> HashMap SharingName (letName, Int)
oss_refs :: HashMap SharingName (letName, Int)
  , SharingObserverState letName -> HashSet SharingName
oss_recs :: HashSet SharingName
  }

observeSharingNode ::
  Eq letName =>
  Hashable letName =>
  Show letName =>
  Referenceable letName repr =>
  MakeLetName letName =>
  SharingObserver letName repr a ->
  SharingObserver letName repr a
observeSharingNode :: SharingObserver letName repr a -> SharingObserver letName repr a
observeSharingNode (SharingObserver ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
m) = ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> SharingObserver letName repr a
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> SharingObserver letName repr a
SharingObserver (ReaderT
   (HashSet SharingName)
   (State (SharingObserverState letName))
   (SharingFinalizer letName repr a)
 -> SharingObserver letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
-> SharingObserver letName repr a
forall a b. (a -> b) -> a -> b
$ do
  let nodeName :: SharingName
nodeName = ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> SharingName
forall a. a -> SharingName
makeSharingName ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
m
  SharingObserverState letName
st <- StateT
  (SharingObserverState letName)
  Identity
  (SharingObserverState letName)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingObserverState letName)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift StateT
  (SharingObserverState letName)
  Identity
  (SharingObserverState letName)
forall (m :: * -> *) 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 (f :: k1 -> *) k2 (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 :: * -> *) 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 :: * -> *) 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 :: * -> *) 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 :: (* -> *) -> * -> *) (m :: * -> *) 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 :: * -> *) 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 repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SharingFinalizer letName repr a
 -> ReaderT
      (HashSet SharingName)
      (State (SharingObserverState letName))
      (SharingFinalizer letName repr a))
-> SharingFinalizer letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall a b. (a -> b) -> a -> b
$ Bool -> letName -> SharingFinalizer letName repr a
forall letName (repr :: * -> *) a.
Referenceable letName repr =>
Bool -> letName -> repr 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 :: (* -> *) -> * -> *) (m :: * -> *) 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 :: * -> *) 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 repr a)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall r (m :: * -> *) 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 repr a
-> SharingFinalizer letName repr a
forall letName (repr :: * -> *) a.
Definable letName repr =>
letName -> repr a -> repr a
define letName
letName (SharingFinalizer letName repr a
 -> SharingFinalizer letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
m)
      else SharingFinalizer letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (SharingFinalizer letName repr a
 -> ReaderT
      (HashSet SharingName)
      (State (SharingObserverState letName))
      (SharingFinalizer letName repr a))
-> SharingFinalizer letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall a b. (a -> b) -> a -> b
$ Bool -> letName -> SharingFinalizer letName repr a
forall letName (repr :: * -> *) a.
Referenceable letName repr =>
Bool -> letName -> repr a
ref Bool
False letName
letName

type instance Derived (SharingObserver letName repr) = SharingFinalizer letName repr
instance
  ( Referenceable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Show letName
  ) => LiftDerived (SharingObserver letName repr) where
  liftDerived :: Derived (SharingObserver letName repr) a
-> SharingObserver letName repr a
liftDerived = SharingObserver letName repr a -> SharingObserver letName repr a
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Show letName,
 Referenceable letName repr, MakeLetName letName) =>
SharingObserver letName repr a -> SharingObserver letName repr a
observeSharingNode (SharingObserver letName repr a -> SharingObserver letName repr a)
-> (SharingFinalizer letName repr a
    -> SharingObserver letName repr a)
-> SharingFinalizer letName repr a
-> SharingObserver letName repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> SharingObserver letName repr a
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> SharingObserver letName repr a
SharingObserver (ReaderT
   (HashSet SharingName)
   (State (SharingObserverState letName))
   (SharingFinalizer letName repr a)
 -> SharingObserver letName repr a)
-> (SharingFinalizer letName repr a
    -> ReaderT
         (HashSet SharingName)
         (State (SharingObserverState letName))
         (SharingFinalizer letName repr a))
-> SharingFinalizer letName repr a
-> SharingObserver letName repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SharingFinalizer letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall (m :: * -> *) a. Monad m => a -> m a
return
instance
  ( Referenceable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Show letName
  ) => LiftDerived1 (SharingObserver letName repr) where
  liftDerived1 :: (Derived (SharingObserver letName repr) a
 -> Derived (SharingObserver letName repr) b)
-> SharingObserver letName repr a -> SharingObserver letName repr b
liftDerived1 Derived (SharingObserver letName repr) a
-> Derived (SharingObserver letName repr) b
f SharingObserver letName repr a
a = SharingObserver letName repr b -> SharingObserver letName repr b
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Show letName,
 Referenceable letName repr, MakeLetName letName) =>
SharingObserver letName repr a -> SharingObserver letName repr a
observeSharingNode (SharingObserver letName repr b -> SharingObserver letName repr b)
-> SharingObserver letName repr b -> SharingObserver letName repr b
forall a b. (a -> b) -> a -> b
$ ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr b)
-> SharingObserver letName repr b
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> SharingObserver letName repr a
SharingObserver (ReaderT
   (HashSet SharingName)
   (State (SharingObserverState letName))
   (SharingFinalizer letName repr b)
 -> SharingObserver letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b)
-> SharingObserver letName repr b
forall a b. (a -> b) -> a -> b
$
    Derived (SharingObserver letName repr) a
-> Derived (SharingObserver letName repr) b
SharingFinalizer letName repr a -> SharingFinalizer letName repr b
f (SharingFinalizer letName repr a
 -> SharingFinalizer letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr a
a
instance
  ( Referenceable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Show letName
  ) => LiftDerived2 (SharingObserver letName repr) where
  liftDerived2 :: (Derived (SharingObserver letName repr) a
 -> Derived (SharingObserver letName repr) b
 -> Derived (SharingObserver letName repr) c)
-> SharingObserver letName repr a
-> SharingObserver letName repr b
-> SharingObserver letName repr c
liftDerived2 Derived (SharingObserver letName repr) a
-> Derived (SharingObserver letName repr) b
-> Derived (SharingObserver letName repr) c
f SharingObserver letName repr a
a SharingObserver letName repr b
b = SharingObserver letName repr c -> SharingObserver letName repr c
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Show letName,
 Referenceable letName repr, MakeLetName letName) =>
SharingObserver letName repr a -> SharingObserver letName repr a
observeSharingNode (SharingObserver letName repr c -> SharingObserver letName repr c)
-> SharingObserver letName repr c -> SharingObserver letName repr c
forall a b. (a -> b) -> a -> b
$ ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr c)
-> SharingObserver letName repr c
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> SharingObserver letName repr a
SharingObserver (ReaderT
   (HashSet SharingName)
   (State (SharingObserverState letName))
   (SharingFinalizer letName repr c)
 -> SharingObserver letName repr c)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr c)
-> SharingObserver letName repr c
forall a b. (a -> b) -> a -> b
$
    Derived (SharingObserver letName repr) a
-> Derived (SharingObserver letName repr) b
-> Derived (SharingObserver letName repr) c
SharingFinalizer letName repr a
-> SharingFinalizer letName repr b
-> SharingFinalizer letName repr c
f (SharingFinalizer letName repr a
 -> SharingFinalizer letName repr b
 -> SharingFinalizer letName repr c)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b
      -> SharingFinalizer letName repr c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr a
a
      ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr b
   -> SharingFinalizer letName repr c)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingObserver letName repr b
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr b
b
instance
  ( Referenceable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Show letName
  ) => LiftDerived3 (SharingObserver letName repr) where
  liftDerived3 :: (Derived (SharingObserver letName repr) a
 -> Derived (SharingObserver letName repr) b
 -> Derived (SharingObserver letName repr) c
 -> Derived (SharingObserver letName repr) d)
-> SharingObserver letName repr a
-> SharingObserver letName repr b
-> SharingObserver letName repr c
-> SharingObserver letName repr d
liftDerived3 Derived (SharingObserver letName repr) a
-> Derived (SharingObserver letName repr) b
-> Derived (SharingObserver letName repr) c
-> Derived (SharingObserver letName repr) d
f SharingObserver letName repr a
a SharingObserver letName repr b
b SharingObserver letName repr c
c = SharingObserver letName repr d -> SharingObserver letName repr d
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Show letName,
 Referenceable letName repr, MakeLetName letName) =>
SharingObserver letName repr a -> SharingObserver letName repr a
observeSharingNode (SharingObserver letName repr d -> SharingObserver letName repr d)
-> SharingObserver letName repr d -> SharingObserver letName repr d
forall a b. (a -> b) -> a -> b
$ ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr d)
-> SharingObserver letName repr d
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> SharingObserver letName repr a
SharingObserver (ReaderT
   (HashSet SharingName)
   (State (SharingObserverState letName))
   (SharingFinalizer letName repr d)
 -> SharingObserver letName repr d)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr d)
-> SharingObserver letName repr d
forall a b. (a -> b) -> a -> b
$
    Derived (SharingObserver letName repr) a
-> Derived (SharingObserver letName repr) b
-> Derived (SharingObserver letName repr) c
-> Derived (SharingObserver letName repr) d
SharingFinalizer letName repr a
-> SharingFinalizer letName repr b
-> SharingFinalizer letName repr c
-> SharingFinalizer letName repr d
f (SharingFinalizer letName repr a
 -> SharingFinalizer letName repr b
 -> SharingFinalizer letName repr c
 -> SharingFinalizer letName repr d)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b
      -> SharingFinalizer letName repr c
      -> SharingFinalizer letName repr d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr a
a
      ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr b
   -> SharingFinalizer letName repr c
   -> SharingFinalizer letName repr d)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr c
      -> SharingFinalizer letName repr d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingObserver letName repr b
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr b
b
      ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr c
   -> SharingFinalizer letName repr d)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr c)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingObserver letName repr c
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr c)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr c
c
instance
  ( Referenceable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  , Show letName
  ) => LiftDerived4 (SharingObserver letName repr) where
  liftDerived4 :: (Derived (SharingObserver letName repr) a
 -> Derived (SharingObserver letName repr) b
 -> Derived (SharingObserver letName repr) c
 -> Derived (SharingObserver letName repr) d
 -> Derived (SharingObserver letName repr) e)
-> SharingObserver letName repr a
-> SharingObserver letName repr b
-> SharingObserver letName repr c
-> SharingObserver letName repr d
-> SharingObserver letName repr e
liftDerived4 Derived (SharingObserver letName repr) a
-> Derived (SharingObserver letName repr) b
-> Derived (SharingObserver letName repr) c
-> Derived (SharingObserver letName repr) d
-> Derived (SharingObserver letName repr) e
f SharingObserver letName repr a
a SharingObserver letName repr b
b SharingObserver letName repr c
c SharingObserver letName repr d
d = SharingObserver letName repr e -> SharingObserver letName repr e
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Show letName,
 Referenceable letName repr, MakeLetName letName) =>
SharingObserver letName repr a -> SharingObserver letName repr a
observeSharingNode (SharingObserver letName repr e -> SharingObserver letName repr e)
-> SharingObserver letName repr e -> SharingObserver letName repr e
forall a b. (a -> b) -> a -> b
$ ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr e)
-> SharingObserver letName repr e
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr a)
-> SharingObserver letName repr a
SharingObserver (ReaderT
   (HashSet SharingName)
   (State (SharingObserverState letName))
   (SharingFinalizer letName repr e)
 -> SharingObserver letName repr e)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr e)
-> SharingObserver letName repr e
forall a b. (a -> b) -> a -> b
$
    Derived (SharingObserver letName repr) a
-> Derived (SharingObserver letName repr) b
-> Derived (SharingObserver letName repr) c
-> Derived (SharingObserver letName repr) d
-> Derived (SharingObserver letName repr) e
SharingFinalizer letName repr a
-> SharingFinalizer letName repr b
-> SharingFinalizer letName repr c
-> SharingFinalizer letName repr d
-> SharingFinalizer letName repr e
f (SharingFinalizer letName repr a
 -> SharingFinalizer letName repr b
 -> SharingFinalizer letName repr c
 -> SharingFinalizer letName repr d
 -> SharingFinalizer letName repr e)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b
      -> SharingFinalizer letName repr c
      -> SharingFinalizer letName repr d
      -> SharingFinalizer letName repr e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr a
a
      ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr b
   -> SharingFinalizer letName repr c
   -> SharingFinalizer letName repr d
   -> SharingFinalizer letName repr e)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr c
      -> SharingFinalizer letName repr d
      -> SharingFinalizer letName repr e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingObserver letName repr b
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr b)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr b
b
      ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr c
   -> SharingFinalizer letName repr d
   -> SharingFinalizer letName repr e)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr c)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr d
      -> SharingFinalizer letName repr e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingObserver letName repr c
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr c)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr c
c
      ReaderT
  (HashSet SharingName)
  (State (SharingObserverState letName))
  (SharingFinalizer letName repr d
   -> SharingFinalizer letName repr e)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr d)
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingObserver letName repr d
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr d)
forall letName (repr :: * -> *) a.
SharingObserver letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (SharingObserverState letName))
     (SharingFinalizer letName repr a)
unSharingObserver SharingObserver letName repr d
d
instance Referenceable letName (SharingObserver letName repr) where
  ref :: Bool -> letName -> SharingObserver letName repr a
ref = [Char] -> Bool -> letName -> SharingObserver letName repr a
forall a. HasCallStack => [Char] -> a
error [Char]
"[BUG]: observeSharing MUST NOT be applied twice"
instance Definable letName (SharingObserver letName repr) where
  define :: letName
-> SharingObserver letName repr a -> SharingObserver letName repr a
define = [Char]
-> letName
-> SharingObserver letName repr a
-> SharingObserver letName repr a
forall a. HasCallStack => [Char] -> a
error [Char]
"[BUG]: observeSharing MUST NOT be applied twice"
instance Letsable letName (SharingObserver letName repr) where
  lets :: LetBindings letName (SharingObserver letName repr)
-> SharingObserver letName repr a -> SharingObserver letName repr a
lets = [Char]
-> LetBindings letName (SharingObserver letName repr)
-> SharingObserver letName repr a
-> SharingObserver letName repr 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 repr a = SharingFinalizer { SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing ::
  MT.ReaderT (HS.HashSet letName)
    (MT.Writer (LetBindings letName repr))
      (repr a) }

type instance Derived (SharingFinalizer _letName repr) = repr
instance (Eq letName, Hashable letName) =>
  LiftDerived (SharingFinalizer letName repr) where
  liftDerived :: Derived (SharingFinalizer letName repr) a
-> SharingFinalizer letName repr a
liftDerived = ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> SharingFinalizer letName repr a
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> SharingFinalizer letName repr a
SharingFinalizer (ReaderT
   (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
 -> SharingFinalizer letName repr a)
-> (repr a
    -> ReaderT
         (HashSet letName) (Writer (LetBindings letName repr)) (repr a))
-> repr a
-> SharingFinalizer letName repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance (Eq letName, Hashable letName) =>
  LiftDerived1 (SharingFinalizer letName repr) where
  liftDerived1 :: (Derived (SharingFinalizer letName repr) a
 -> Derived (SharingFinalizer letName repr) b)
-> SharingFinalizer letName repr a
-> SharingFinalizer letName repr b
liftDerived1 Derived (SharingFinalizer letName repr) a
-> Derived (SharingFinalizer letName repr) b
f SharingFinalizer letName repr a
a = ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
-> SharingFinalizer letName repr b
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> SharingFinalizer letName repr a
SharingFinalizer (ReaderT
   (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
 -> SharingFinalizer letName repr b)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
-> SharingFinalizer letName repr b
forall a b. (a -> b) -> a -> b
$ repr a -> repr b
Derived (SharingFinalizer letName repr) a
-> Derived (SharingFinalizer letName repr) b
f (repr a -> repr b)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr a
a
instance (Eq letName, Hashable letName) =>
  LiftDerived2 (SharingFinalizer letName repr) where
  liftDerived2 :: (Derived (SharingFinalizer letName repr) a
 -> Derived (SharingFinalizer letName repr) b
 -> Derived (SharingFinalizer letName repr) c)
-> SharingFinalizer letName repr a
-> SharingFinalizer letName repr b
-> SharingFinalizer letName repr c
liftDerived2 Derived (SharingFinalizer letName repr) a
-> Derived (SharingFinalizer letName repr) b
-> Derived (SharingFinalizer letName repr) c
f SharingFinalizer letName repr a
a SharingFinalizer letName repr b
b = ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr c)
-> SharingFinalizer letName repr c
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> SharingFinalizer letName repr a
SharingFinalizer (ReaderT
   (HashSet letName) (Writer (LetBindings letName repr)) (repr c)
 -> SharingFinalizer letName repr c)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr c)
-> SharingFinalizer letName repr c
forall a b. (a -> b) -> a -> b
$
    repr a -> repr b -> repr c
Derived (SharingFinalizer letName repr) a
-> Derived (SharingFinalizer letName repr) b
-> Derived (SharingFinalizer letName repr) c
f (repr a -> repr b -> repr c)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> ReaderT
     (HashSet letName)
     (Writer (LetBindings letName repr))
     (repr b -> repr c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr a
a
      ReaderT
  (HashSet letName)
  (Writer (LetBindings letName repr))
  (repr b -> repr c)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingFinalizer letName repr b
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr b
b
instance (Eq letName, Hashable letName) =>
  LiftDerived3 (SharingFinalizer letName repr) where
  liftDerived3 :: (Derived (SharingFinalizer letName repr) a
 -> Derived (SharingFinalizer letName repr) b
 -> Derived (SharingFinalizer letName repr) c
 -> Derived (SharingFinalizer letName repr) d)
-> SharingFinalizer letName repr a
-> SharingFinalizer letName repr b
-> SharingFinalizer letName repr c
-> SharingFinalizer letName repr d
liftDerived3 Derived (SharingFinalizer letName repr) a
-> Derived (SharingFinalizer letName repr) b
-> Derived (SharingFinalizer letName repr) c
-> Derived (SharingFinalizer letName repr) d
f SharingFinalizer letName repr a
a SharingFinalizer letName repr b
b SharingFinalizer letName repr c
c = ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr d)
-> SharingFinalizer letName repr d
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> SharingFinalizer letName repr a
SharingFinalizer (ReaderT
   (HashSet letName) (Writer (LetBindings letName repr)) (repr d)
 -> SharingFinalizer letName repr d)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr d)
-> SharingFinalizer letName repr d
forall a b. (a -> b) -> a -> b
$
    repr a -> repr b -> repr c -> repr d
Derived (SharingFinalizer letName repr) a
-> Derived (SharingFinalizer letName repr) b
-> Derived (SharingFinalizer letName repr) c
-> Derived (SharingFinalizer letName repr) d
f (repr a -> repr b -> repr c -> repr d)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> ReaderT
     (HashSet letName)
     (Writer (LetBindings letName repr))
     (repr b -> repr c -> repr d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr a
a
      ReaderT
  (HashSet letName)
  (Writer (LetBindings letName repr))
  (repr b -> repr c -> repr d)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
-> ReaderT
     (HashSet letName)
     (Writer (LetBindings letName repr))
     (repr c -> repr d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingFinalizer letName repr b
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr b
b
      ReaderT
  (HashSet letName)
  (Writer (LetBindings letName repr))
  (repr c -> repr d)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr c)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingFinalizer letName repr c
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr c)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr c
c
instance (Eq letName, Hashable letName) =>
  LiftDerived4 (SharingFinalizer letName repr) where
  liftDerived4 :: (Derived (SharingFinalizer letName repr) a
 -> Derived (SharingFinalizer letName repr) b
 -> Derived (SharingFinalizer letName repr) c
 -> Derived (SharingFinalizer letName repr) d
 -> Derived (SharingFinalizer letName repr) e)
-> SharingFinalizer letName repr a
-> SharingFinalizer letName repr b
-> SharingFinalizer letName repr c
-> SharingFinalizer letName repr d
-> SharingFinalizer letName repr e
liftDerived4 Derived (SharingFinalizer letName repr) a
-> Derived (SharingFinalizer letName repr) b
-> Derived (SharingFinalizer letName repr) c
-> Derived (SharingFinalizer letName repr) d
-> Derived (SharingFinalizer letName repr) e
f SharingFinalizer letName repr a
a SharingFinalizer letName repr b
b SharingFinalizer letName repr c
c SharingFinalizer letName repr d
d = ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr e)
-> SharingFinalizer letName repr e
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> SharingFinalizer letName repr a
SharingFinalizer (ReaderT
   (HashSet letName) (Writer (LetBindings letName repr)) (repr e)
 -> SharingFinalizer letName repr e)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr e)
-> SharingFinalizer letName repr e
forall a b. (a -> b) -> a -> b
$
    repr a -> repr b -> repr c -> repr d -> repr e
Derived (SharingFinalizer letName repr) a
-> Derived (SharingFinalizer letName repr) b
-> Derived (SharingFinalizer letName repr) c
-> Derived (SharingFinalizer letName repr) d
-> Derived (SharingFinalizer letName repr) e
f (repr a -> repr b -> repr c -> repr d -> repr e)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> ReaderT
     (HashSet letName)
     (Writer (LetBindings letName repr))
     (repr b -> repr c -> repr d -> repr e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr a
a
      ReaderT
  (HashSet letName)
  (Writer (LetBindings letName repr))
  (repr b -> repr c -> repr d -> repr e)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
-> ReaderT
     (HashSet letName)
     (Writer (LetBindings letName repr))
     (repr c -> repr d -> repr e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingFinalizer letName repr b
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr b)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr b
b
      ReaderT
  (HashSet letName)
  (Writer (LetBindings letName repr))
  (repr c -> repr d -> repr e)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr c)
-> ReaderT
     (HashSet letName)
     (Writer (LetBindings letName repr))
     (repr d -> repr e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingFinalizer letName repr c
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr c)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr c
c
      ReaderT
  (HashSet letName)
  (Writer (LetBindings letName repr))
  (repr d -> repr e)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr d)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SharingFinalizer letName repr d
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr d)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr d
d
instance
  ( Referenceable letName repr
  , Eq letName
  , Hashable letName
  , Show letName
  ) => Referenceable letName (SharingFinalizer letName repr) where
  ref :: Bool -> letName -> SharingFinalizer letName repr a
ref Bool
isRec = repr a -> SharingFinalizer letName repr a
forall (repr :: * -> *) a.
LiftDerived repr =>
Derived repr a -> repr a
liftDerived (repr a -> SharingFinalizer letName repr a)
-> (letName -> repr a)
-> letName
-> SharingFinalizer letName repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> letName -> repr a
forall letName (repr :: * -> *) a.
Referenceable letName repr =>
Bool -> letName -> repr a
ref Bool
isRec
instance
  ( Referenceable letName repr
  , Eq letName
  , Hashable letName
  , Show letName
  ) => Definable letName (SharingFinalizer letName repr) where
  define :: letName
-> SharingFinalizer letName repr a
-> SharingFinalizer letName repr a
define letName
name SharingFinalizer letName repr a
body = ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> SharingFinalizer letName repr a
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> SharingFinalizer letName repr a
SharingFinalizer (ReaderT
   (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
 -> SharingFinalizer letName repr a)
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> SharingFinalizer letName repr a
forall a b. (a -> b) -> a -> b
$ do
    HashSet letName
refs <- ReaderT
  (HashSet letName)
  (Writer (LetBindings letName repr))
  (HashSet letName)
forall (m :: * -> *) r. Monad m => ReaderT r m r
MT.ask
    let (repr a
repr, LetBindings letName repr
defs) =
          Writer (LetBindings letName repr) (repr a)
-> (repr a, LetBindings letName repr)
forall w a. Writer w a -> (a, w)
MT.runWriter (Writer (LetBindings letName repr) (repr a)
 -> (repr a, LetBindings letName repr))
-> Writer (LetBindings letName repr) (repr a)
-> (repr a, LetBindings letName repr)
forall a b. (a -> b) -> a -> b
$ ReaderT
  (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
-> HashSet letName -> Writer (LetBindings letName repr) (repr a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
MT.runReaderT (SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr 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 repr) Identity ()
-> ReaderT (HashSet letName) (Writer (LetBindings letName repr)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (WriterT (LetBindings letName repr) Identity ()
 -> ReaderT
      (HashSet letName) (Writer (LetBindings letName repr)) ())
-> WriterT (LetBindings letName repr) Identity ()
-> ReaderT (HashSet letName) (Writer (LetBindings letName repr)) ()
forall a b. (a -> b) -> a -> b
$ LetBindings letName repr
-> WriterT (LetBindings letName repr) Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
MT.tell (LetBindings letName repr
 -> WriterT (LetBindings letName repr) Identity ())
-> LetBindings letName repr
-> WriterT (LetBindings letName repr) Identity ()
forall a b. (a -> b) -> a -> b
$ letName
-> SomeLet repr
-> LetBindings letName repr
-> LetBindings letName repr
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert letName
name (repr a -> SomeLet repr
forall (repr :: * -> *) a. repr a -> SomeLet repr
SomeLet repr a
repr) LetBindings letName repr
defs
        repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (repr a
 -> ReaderT
      (HashSet letName) (Writer (LetBindings letName repr)) (repr a))
-> repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall a b. (a -> b) -> a -> b
$ Bool -> letName -> repr a
forall letName (repr :: * -> *) a.
Referenceable letName repr =>
Bool -> letName -> repr a
ref Bool
False letName
name
      else
        -- Remove this unreferenced 'define' node.
        SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
forall letName (repr :: * -> *) a.
SharingFinalizer letName repr a
-> ReaderT
     (HashSet letName) (Writer (LetBindings letName repr)) (repr a)
unFinalizeSharing SharingFinalizer letName repr a
body

-- * Class 'Letsable'
class Letsable letName repr where
  -- | @('lets' defs x)@ let-binds @(defs)@ in @(x)@.
  lets :: LetBindings letName repr -> repr a -> repr a
  lets LetBindings letName repr
defs = (Derived repr a -> Derived repr a) -> repr a -> repr a
forall (repr :: * -> *) a b.
LiftDerived1 repr =>
(Derived repr a -> Derived repr b) -> repr a -> repr b
liftDerived1 (LetBindings letName (Derived repr)
-> Derived repr a -> Derived repr a
forall letName (repr :: * -> *) a.
Letsable letName repr =>
LetBindings letName repr -> repr a -> repr a
lets ((\(SomeLet repr a
val) -> Derived repr a -> SomeLet (Derived repr)
forall (repr :: * -> *) a. repr a -> SomeLet repr
SomeLet (repr a -> Derived repr a
forall (repr :: * -> *) a.
Derivable repr =>
repr a -> Derived repr a
derive repr a
val)) (SomeLet repr -> SomeLet (Derived repr))
-> LetBindings letName repr -> LetBindings letName (Derived repr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LetBindings letName repr
defs))
  default lets ::
    Derivable repr =>
    FromDerived1 (Letsable letName) repr =>
    LetBindings letName repr -> repr a -> repr a

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

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

{-
-- | Not used but can be written nonetheless.
instance
  ( Letsable letName repr
  , Eq letName
  , Hashable letName
  , Show letName
  ) => Letsable letName (SharingFinalizer letName repr) 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 :: (a -> a) -> a
fix a -> a
f = a
final where final :: a
final = a -> a
f a
final

-- | Lest 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,
-- between observed sharing ('defLet', 'call', 'jump')
-- and also between join points ('defJoin', 'refJoin').
--
-- 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 :: 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 :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> recs (recs a -> a)
opens