{-# LANGUAGE AllowAmbiguousTypes #-} -- For ShowLetName
{-# 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 Data.String (String)
-- 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 end-users 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 'ShowLetName'
-- | Useful on golden unit tests because 'StableName'
-- change often when changing unrelated source code
-- or even changing basic GHC or executable flags.
class ShowLetName (showName::Bool) letName where
  showLetName :: letName -> String
-- | Like 'Show'.
instance Show letName => ShowLetName 'True letName where
  showLetName :: letName -> String
showLetName = letName -> String
forall letName. Show letName => letName -> String
show
-- | Always return @"<hidden>"@,
instance ShowLetName 'False letName where
  showLetName :: letName -> String
showLetName letName
_p = String
"<hidden>"

-- * 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