{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ExistentialQuantification #-} -- For SharingName
-- {-# LANGUAGE MagicHash #-} -- For unsafeCoerce#
module Symantic.Univariant.Letable where

import Control.Applicative (Applicative(..))
import Control.Monad (Monad(..))
import Data.Bool (Bool(..))
import Data.Eq (Eq(..))
import Data.Foldable (foldMap)
import Data.Function (($), (.))
import Data.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 ((+))
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 Data.HashMap.Strict as HM
import qualified Data.HashSet as HS

import Symantic.Univariant.Trans

-- import Debug.Trace (trace)

-- * Class 'Letable'
-- | This class is not for manual usage like usual symantic operators,
-- here 'def' and 'ref' are introduced by 'observeSharing'.
class Letable letName repr where
  -- | @('def' letName x)@ let-binds @(letName)@ to be equal to @(x)@.
  def :: letName -> repr a -> repr a
  -- | @('ref' isRec letName)@ is a reference to @(letName)@.
  -- @(isRec)@ is 'True' iif. this 'ref'erence is recursive,
  -- ie. is reachable within its 'def'inition.
  ref :: Bool -> letName -> repr a
  default def ::
    Liftable1 repr => Letable letName (Output repr) =>
    letName -> repr a -> repr a
  default ref ::
    Liftable repr => Letable letName (Output repr) =>
    Bool -> letName -> repr a
  def letName
n = (Output repr a -> Output repr a) -> repr a -> repr a
forall (repr :: * -> *) a b.
Liftable1 repr =>
(Output repr a -> Output repr b) -> repr a -> repr b
lift1 (letName -> Output repr a -> Output repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
letName -> repr a -> repr a
def letName
n)
  ref Bool
r letName
n = Output repr a -> repr a
forall (repr :: * -> *) a. Liftable repr => Output repr a -> repr a
lift (Bool -> letName -> Output repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
Bool -> letName -> repr a
ref Bool
r letName
n)

-- * 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 'ObserveSharing'
-- | Interpreter detecting some (Haskell embedded) @let@ definitions used at
-- least once and/or recursively, in order to replace them
-- with the 'def' and 'ref' combinators.
-- See [Type-safe observable sharing in Haskell](https://doi.org/10.1145/1596638.1596653)
newtype ObserveSharing letName repr a = ObserveSharing { forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing ::
  MT.ReaderT (HashSet SharingName)
             (MT.State (ObserveSharingState letName))
             (CleanDefs letName repr a) }

observeSharing ::
  Eq letName =>
  Hashable letName =>
  ObserveSharing letName repr a -> repr a
observeSharing :: forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName) =>
ObserveSharing letName repr a -> repr a
observeSharing (ObserveSharing ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
m) = do
  let (CleanDefs letName repr a
a, ObserveSharingState letName
st) = ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> HashSet SharingName
-> State (ObserveSharingState letName) (CleanDefs letName repr a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
MT.runReaderT ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
m HashSet SharingName
forall a. Monoid a => a
mempty State (ObserveSharingState letName) (CleanDefs letName repr a)
-> ObserveSharingState letName
-> (CleanDefs letName repr a, ObserveSharingState letName)
forall s a. State s a -> s -> (a, s)
`MT.runState`
        ObserveSharingState :: forall letName.
HashMap SharingName (letName, Int)
-> HashSet SharingName -> ObserveSharingState letName
ObserveSharingState
          { 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
          }
  let refs :: HashSet letName
refs = [letName] -> HashSet letName
forall a. (Eq a, Hashable a) => [a] -> HashSet a
HS.fromList ([letName] -> HashSet letName) -> [letName] -> HashSet letName
forall a b. (a -> b) -> a -> b
$
        (((letName, Int) -> [letName])
-> HashMap SharingName (letName, Int) -> [letName]
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
`foldMap` ObserveSharingState letName -> HashMap SharingName (letName, Int)
forall letName.
ObserveSharingState letName -> HashMap SharingName (letName, Int)
oss_refs ObserveSharingState letName
st) (((letName, Int) -> [letName]) -> [letName])
-> ((letName, Int) -> [letName]) -> [letName]
forall a b. (a -> b) -> a -> b
$ (\(letName
letName, Int
refCount) ->
          if Int
refCount Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then [letName
letName] else [])
  -- trace (show refs) $
  CleanDefs letName repr a -> HashSet letName -> repr a
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr a
a HashSet letName
refs

-- ** Type 'ObserveSharingState'
data ObserveSharingState letName = ObserveSharingState
  { forall letName.
ObserveSharingState letName -> HashMap SharingName (letName, Int)
oss_refs :: HashMap SharingName (letName, Int)
  , forall letName. ObserveSharingState letName -> HashSet SharingName
oss_recs :: HashSet SharingName
    -- ^ TODO: unused so far, will it be useful somewhere at a later stage?
  }

observeSharingNode ::
  Eq letName =>
  Hashable letName =>
  Letable letName repr =>
  MakeLetName letName =>
  ObserveSharing letName repr a -> ObserveSharing letName repr a
observeSharingNode :: forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Letable letName repr,
 MakeLetName letName) =>
ObserveSharing letName repr a -> ObserveSharing letName repr a
observeSharingNode (ObserveSharing ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
m) = ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> ObserveSharing letName repr a
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> ObserveSharing letName repr a
ObserveSharing (ReaderT
   (HashSet SharingName)
   (State (ObserveSharingState letName))
   (CleanDefs letName repr a)
 -> ObserveSharing letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
-> ObserveSharing letName repr a
forall a b. (a -> b) -> a -> b
$ do
  let nodeName :: SharingName
nodeName = ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> SharingName
forall a. a -> SharingName
makeSharingName ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
m
  ObserveSharingState letName
st <- StateT
  (ObserveSharingState letName)
  Identity
  (ObserveSharingState letName)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (ObserveSharingState letName)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift StateT
  (ObserveSharingState letName)
  Identity
  (ObserveSharingState letName)
forall (m :: * -> *) s. Monad m => StateT s m s
MT.get
  ((letName
letName, Maybe (letName, Int)
before), HashMap SharingName (letName, Int)
preds) <- Compose
  (ReaderT
     (HashSet SharingName) (State (ObserveSharingState letName)))
  ((,) (letName, Maybe (letName, Int)))
  (HashMap SharingName (letName, Int))
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState 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 (ObserveSharingState letName)))
   ((,) (letName, Maybe (letName, Int)))
   (HashMap SharingName (letName, Int))
 -> ReaderT
      (HashSet SharingName)
      (State (ObserveSharingState letName))
      ((letName, Maybe (letName, Int)),
       HashMap SharingName (letName, Int)))
-> Compose
     (ReaderT
        (HashSet SharingName) (State (ObserveSharingState letName)))
     ((,) (letName, Maybe (letName, Int)))
     (HashMap SharingName (letName, Int))
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     ((letName, Maybe (letName, Int)),
      HashMap SharingName (letName, Int))
forall a b. (a -> b) -> a -> b
$ (Maybe (letName, Int)
 -> Compose
      (ReaderT
         (HashSet SharingName) (State (ObserveSharingState letName)))
      ((,) (letName, Maybe (letName, Int)))
      (Maybe (letName, Int)))
-> SharingName
-> HashMap SharingName (letName, Int)
-> Compose
     (ReaderT
        (HashSet SharingName) (State (ObserveSharingState 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)
before ->
    ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  ((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> Compose
     (ReaderT
        (HashSet SharingName) (State (ObserveSharingState 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 (ObserveSharingState letName))
   ((letName, Maybe (letName, Int)), Maybe (letName, Int))
 -> Compose
      (ReaderT
         (HashSet SharingName) (State (ObserveSharingState letName)))
      ((,) (letName, Maybe (letName, Int)))
      (Maybe (letName, Int)))
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     ((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> Compose
     (ReaderT
        (HashSet SharingName) (State (ObserveSharingState letName)))
     ((,) (letName, Maybe (letName, Int)))
     (Maybe (letName, Int))
forall a b. (a -> b) -> a -> b
$ case Maybe (letName, Int)
before of
      Maybe (letName, Int)
Nothing -> do
        let 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
        ((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     ((letName, Maybe (letName, Int)), Maybe (letName, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return ((letName
letName, Maybe (letName, Int)
before), (letName, Int) -> Maybe (letName, Int)
forall a. a -> Maybe a
Just (letName
letName, Int
0))
      Just (letName
letName, Int
refCount) -> do
        ((letName, Maybe (letName, Int)), Maybe (letName, Int))
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     ((letName, Maybe (letName, Int)), Maybe (letName, Int))
forall (m :: * -> *) a. Monad m => a -> m a
return ((letName
letName, Maybe (letName, Int)
before), (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 (ObserveSharingState letName -> HashMap SharingName (letName, Int)
forall letName.
ObserveSharingState letName -> HashMap SharingName (letName, Int)
oss_refs ObserveSharingState letName
st)
  HashSet SharingName
parentNames <- ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState 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
    StateT (ObserveSharingState letName) Identity ()
-> ReaderT
     (HashSet SharingName) (State (ObserveSharingState letName)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (StateT (ObserveSharingState letName) Identity ()
 -> ReaderT
      (HashSet SharingName) (State (ObserveSharingState letName)) ())
-> StateT (ObserveSharingState letName) Identity ()
-> ReaderT
     (HashSet SharingName) (State (ObserveSharingState letName)) ()
forall a b. (a -> b) -> a -> b
$ ObserveSharingState letName
-> StateT (ObserveSharingState letName) Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MT.put ObserveSharingState letName
st
      { oss_refs :: HashMap SharingName (letName, Int)
oss_refs = HashMap SharingName (letName, Int)
preds
      , 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 (ObserveSharingState letName -> HashSet SharingName
forall letName. ObserveSharingState letName -> HashSet SharingName
oss_recs ObserveSharingState letName
st)
      }
    CleanDefs letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CleanDefs letName repr a
 -> ReaderT
      (HashSet SharingName)
      (State (ObserveSharingState letName))
      (CleanDefs letName repr a))
-> CleanDefs letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall a b. (a -> b) -> a -> b
$ Bool -> letName -> CleanDefs letName repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
Bool -> letName -> repr a
ref Bool
True letName
letName
  else do
    StateT (ObserveSharingState letName) Identity ()
-> ReaderT
     (HashSet SharingName) (State (ObserveSharingState letName)) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
MT.lift (StateT (ObserveSharingState letName) Identity ()
 -> ReaderT
      (HashSet SharingName) (State (ObserveSharingState letName)) ())
-> StateT (ObserveSharingState letName) Identity ()
-> ReaderT
     (HashSet SharingName) (State (ObserveSharingState letName)) ()
forall a b. (a -> b) -> a -> b
$ ObserveSharingState letName
-> StateT (ObserveSharingState letName) Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MT.put ObserveSharingState letName
st{ oss_refs :: HashMap SharingName (letName, Int)
oss_refs = HashMap SharingName (letName, Int)
preds }
    if Maybe (letName, Int) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (letName, Int)
before
      then (HashSet SharingName -> HashSet SharingName)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs 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 -> CleanDefs letName repr a -> CleanDefs letName repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
letName -> repr a -> repr a
def letName
letName (CleanDefs letName repr a -> CleanDefs letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
m)
      else CleanDefs letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (CleanDefs letName repr a
 -> ReaderT
      (HashSet SharingName)
      (State (ObserveSharingState letName))
      (CleanDefs letName repr a))
-> CleanDefs letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall a b. (a -> b) -> a -> b
$ Bool -> letName -> CleanDefs letName repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
Bool -> letName -> repr a
ref Bool
False letName
letName

type instance Output (ObserveSharing letName repr) = CleanDefs letName repr
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  ) => Trans (CleanDefs letName repr) (ObserveSharing letName repr) where
  trans :: forall a. CleanDefs letName repr a -> ObserveSharing letName repr a
trans = ObserveSharing letName repr a -> ObserveSharing letName repr a
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Letable letName repr,
 MakeLetName letName) =>
ObserveSharing letName repr a -> ObserveSharing letName repr a
observeSharingNode (ObserveSharing letName repr a -> ObserveSharing letName repr a)
-> (CleanDefs letName repr a -> ObserveSharing letName repr a)
-> CleanDefs letName repr a
-> ObserveSharing letName repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> ObserveSharing letName repr a
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> ObserveSharing letName repr a
ObserveSharing (ReaderT
   (HashSet SharingName)
   (State (ObserveSharingState letName))
   (CleanDefs letName repr a)
 -> ObserveSharing letName repr a)
-> (CleanDefs letName repr a
    -> ReaderT
         (HashSet SharingName)
         (State (ObserveSharingState letName))
         (CleanDefs letName repr a))
-> CleanDefs letName repr a
-> ObserveSharing letName repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CleanDefs letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall (m :: * -> *) a. Monad m => a -> m a
return
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  ) => Trans1 (CleanDefs letName repr) (ObserveSharing letName repr) where
  trans1 :: forall a b.
(CleanDefs letName repr a -> CleanDefs letName repr b)
-> ObserveSharing letName repr a -> ObserveSharing letName repr b
trans1 CleanDefs letName repr a -> CleanDefs letName repr b
f ObserveSharing letName repr a
x = ObserveSharing letName repr b -> ObserveSharing letName repr b
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Letable letName repr,
 MakeLetName letName) =>
ObserveSharing letName repr a -> ObserveSharing letName repr a
observeSharingNode (ObserveSharing letName repr b -> ObserveSharing letName repr b)
-> ObserveSharing letName repr b -> ObserveSharing letName repr b
forall a b. (a -> b) -> a -> b
$ ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr b)
-> ObserveSharing letName repr b
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> ObserveSharing letName repr a
ObserveSharing (ReaderT
   (HashSet SharingName)
   (State (ObserveSharingState letName))
   (CleanDefs letName repr b)
 -> ObserveSharing letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
-> ObserveSharing letName repr b
forall a b. (a -> b) -> a -> b
$
    CleanDefs letName repr a -> CleanDefs letName repr b
f (CleanDefs letName repr a -> CleanDefs letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing ObserveSharing letName repr a
x
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  ) => Trans2 (CleanDefs letName repr) (ObserveSharing letName repr) where
  trans2 :: forall a b c.
(CleanDefs letName repr a
 -> CleanDefs letName repr b -> CleanDefs letName repr c)
-> ObserveSharing letName repr a
-> ObserveSharing letName repr b
-> ObserveSharing letName repr c
trans2 CleanDefs letName repr a
-> CleanDefs letName repr b -> CleanDefs letName repr c
f ObserveSharing letName repr a
x ObserveSharing letName repr b
y = ObserveSharing letName repr c -> ObserveSharing letName repr c
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Letable letName repr,
 MakeLetName letName) =>
ObserveSharing letName repr a -> ObserveSharing letName repr a
observeSharingNode (ObserveSharing letName repr c -> ObserveSharing letName repr c)
-> ObserveSharing letName repr c -> ObserveSharing letName repr c
forall a b. (a -> b) -> a -> b
$ ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr c)
-> ObserveSharing letName repr c
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> ObserveSharing letName repr a
ObserveSharing (ReaderT
   (HashSet SharingName)
   (State (ObserveSharingState letName))
   (CleanDefs letName repr c)
 -> ObserveSharing letName repr c)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr c)
-> ObserveSharing letName repr c
forall a b. (a -> b) -> a -> b
$
    CleanDefs letName repr a
-> CleanDefs letName repr b -> CleanDefs letName repr c
f (CleanDefs letName repr a
 -> CleanDefs letName repr b -> CleanDefs letName repr c)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b -> CleanDefs letName repr c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing ObserveSharing letName repr a
x
      ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr b -> CleanDefs letName repr c)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr c)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ObserveSharing letName repr b
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing ObserveSharing letName repr b
y
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  ) => Trans3 (CleanDefs letName repr) (ObserveSharing letName repr) where
  trans3 :: forall a b c d.
(CleanDefs letName repr a
 -> CleanDefs letName repr b
 -> CleanDefs letName repr c
 -> CleanDefs letName repr d)
-> ObserveSharing letName repr a
-> ObserveSharing letName repr b
-> ObserveSharing letName repr c
-> ObserveSharing letName repr d
trans3 CleanDefs letName repr a
-> CleanDefs letName repr b
-> CleanDefs letName repr c
-> CleanDefs letName repr d
f ObserveSharing letName repr a
x ObserveSharing letName repr b
y ObserveSharing letName repr c
z = ObserveSharing letName repr d -> ObserveSharing letName repr d
forall letName (repr :: * -> *) a.
(Eq letName, Hashable letName, Letable letName repr,
 MakeLetName letName) =>
ObserveSharing letName repr a -> ObserveSharing letName repr a
observeSharingNode (ObserveSharing letName repr d -> ObserveSharing letName repr d)
-> ObserveSharing letName repr d -> ObserveSharing letName repr d
forall a b. (a -> b) -> a -> b
$ ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr d)
-> ObserveSharing letName repr d
forall letName (repr :: * -> *) a.
ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr a)
-> ObserveSharing letName repr a
ObserveSharing (ReaderT
   (HashSet SharingName)
   (State (ObserveSharingState letName))
   (CleanDefs letName repr d)
 -> ObserveSharing letName repr d)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr d)
-> ObserveSharing letName repr d
forall a b. (a -> b) -> a -> b
$
    CleanDefs letName repr a
-> CleanDefs letName repr b
-> CleanDefs letName repr c
-> CleanDefs letName repr d
f (CleanDefs letName repr a
 -> CleanDefs letName repr b
 -> CleanDefs letName repr c
 -> CleanDefs letName repr d)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b
      -> CleanDefs letName repr c -> CleanDefs letName repr d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing ObserveSharing letName repr a
x
      ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr b
   -> CleanDefs letName repr c -> CleanDefs letName repr d)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr c -> CleanDefs letName repr d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ObserveSharing letName repr b
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr b)
forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing ObserveSharing letName repr b
y
      ReaderT
  (HashSet SharingName)
  (State (ObserveSharingState letName))
  (CleanDefs letName repr c -> CleanDefs letName repr d)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr c)
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ObserveSharing letName repr c
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr c)
forall letName (repr :: * -> *) a.
ObserveSharing letName repr a
-> ReaderT
     (HashSet SharingName)
     (State (ObserveSharingState letName))
     (CleanDefs letName repr a)
unObserveSharing ObserveSharing letName repr c
z
instance
  ( Letable letName repr
  , MakeLetName letName
  , Eq letName
  , Hashable letName
  ) => Letable letName (ObserveSharing letName repr)

-- * Type 'CleanDefs'
-- | Remove 'def' when non-recursive or unused.
newtype CleanDefs letName repr a = CleanDefs { forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs ::
  HS.HashSet letName -> repr a }

type instance Output (CleanDefs _letName repr) = repr
instance Trans repr (CleanDefs letName repr) where
  trans :: forall a. repr a -> CleanDefs letName repr a
trans = (HashSet letName -> repr a) -> CleanDefs letName repr a
forall letName (repr :: * -> *) a.
(HashSet letName -> repr a) -> CleanDefs letName repr a
CleanDefs ((HashSet letName -> repr a) -> CleanDefs letName repr a)
-> (repr a -> HashSet letName -> repr a)
-> repr a
-> CleanDefs letName repr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. repr a -> HashSet letName -> repr a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance Trans1 repr (CleanDefs letName repr) where
  trans1 :: forall a b.
(repr a -> repr b)
-> CleanDefs letName repr a -> CleanDefs letName repr b
trans1 repr a -> repr b
f CleanDefs letName repr a
x = (HashSet letName -> repr b) -> CleanDefs letName repr b
forall letName (repr :: * -> *) a.
(HashSet letName -> repr a) -> CleanDefs letName repr a
CleanDefs ((HashSet letName -> repr b) -> CleanDefs letName repr b)
-> (HashSet letName -> repr b) -> CleanDefs letName repr b
forall a b. (a -> b) -> a -> b
$ repr a -> repr b
f (repr a -> repr b)
-> (HashSet letName -> repr a) -> HashSet letName -> repr b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CleanDefs letName repr a -> HashSet letName -> repr a
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr a
x
instance Trans2 repr (CleanDefs letName repr) where
  trans2 :: forall a b c.
(repr a -> repr b -> repr c)
-> CleanDefs letName repr a
-> CleanDefs letName repr b
-> CleanDefs letName repr c
trans2 repr a -> repr b -> repr c
f CleanDefs letName repr a
x CleanDefs letName repr b
y = (HashSet letName -> repr c) -> CleanDefs letName repr c
forall letName (repr :: * -> *) a.
(HashSet letName -> repr a) -> CleanDefs letName repr a
CleanDefs ((HashSet letName -> repr c) -> CleanDefs letName repr c)
-> (HashSet letName -> repr c) -> CleanDefs letName repr c
forall a b. (a -> b) -> a -> b
$
    repr a -> repr b -> repr c
f (repr a -> repr b -> repr c)
-> (HashSet letName -> repr a)
-> HashSet letName
-> repr b
-> repr c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CleanDefs letName repr a -> HashSet letName -> repr a
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr a
x
      (HashSet letName -> repr b -> repr c)
-> (HashSet letName -> repr b) -> HashSet letName -> repr c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CleanDefs letName repr b -> HashSet letName -> repr b
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr b
y
instance Trans3 repr (CleanDefs letName repr) where
  trans3 :: forall a b c d.
(repr a -> repr b -> repr c -> repr d)
-> CleanDefs letName repr a
-> CleanDefs letName repr b
-> CleanDefs letName repr c
-> CleanDefs letName repr d
trans3 repr a -> repr b -> repr c -> repr d
f CleanDefs letName repr a
x CleanDefs letName repr b
y CleanDefs letName repr c
z = (HashSet letName -> repr d) -> CleanDefs letName repr d
forall letName (repr :: * -> *) a.
(HashSet letName -> repr a) -> CleanDefs letName repr a
CleanDefs ((HashSet letName -> repr d) -> CleanDefs letName repr d)
-> (HashSet letName -> repr d) -> CleanDefs letName repr d
forall a b. (a -> b) -> a -> b
$
    repr a -> repr b -> repr c -> repr d
f (repr a -> repr b -> repr c -> repr d)
-> (HashSet letName -> repr a)
-> HashSet letName
-> repr b
-> repr c
-> repr d
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CleanDefs letName repr a -> HashSet letName -> repr a
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr a
x
      (HashSet letName -> repr b -> repr c -> repr d)
-> (HashSet letName -> repr b)
-> HashSet letName
-> repr c
-> repr d
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CleanDefs letName repr b -> HashSet letName -> repr b
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr b
y
      (HashSet letName -> repr c -> repr d)
-> (HashSet letName -> repr c) -> HashSet letName -> repr d
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> CleanDefs letName repr c -> HashSet letName -> repr c
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr c
z
instance
  ( Letable letName repr
  , Eq letName
  , Hashable letName
  ) => Letable letName (CleanDefs letName repr) where
  def :: forall a.
letName -> CleanDefs letName repr a -> CleanDefs letName repr a
def letName
name CleanDefs letName repr a
x = (HashSet letName -> repr a) -> CleanDefs letName repr a
forall letName (repr :: * -> *) a.
(HashSet letName -> repr a) -> CleanDefs letName repr a
CleanDefs ((HashSet letName -> repr a) -> CleanDefs letName repr a)
-> (HashSet letName -> repr a) -> CleanDefs letName repr a
forall a b. (a -> b) -> a -> b
$ \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 -- Perserve 'def'
      letName -> repr a -> repr a
forall letName (repr :: * -> *) a.
Letable letName repr =>
letName -> repr a -> repr a
def letName
name (repr a -> repr a) -> repr a -> repr a
forall a b. (a -> b) -> a -> b
$ CleanDefs letName repr a -> HashSet letName -> repr a
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr a
x HashSet letName
refs
    else -- Remove 'def'
      CleanDefs letName repr a -> HashSet letName -> repr a
forall letName (repr :: * -> *) a.
CleanDefs letName repr a -> HashSet letName -> repr a
unCleanDefs CleanDefs letName repr a
x HashSet letName
refs