{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, TemplateHaskell, Trustworthy #-}
module Polysemy.Fresh
  (-- * Effect
    Fresh(..)

    -- * Actions
  , fresh

    -- * Interpretations
  , freshToIO

    -- * Unsafe Interpretations
  , runFreshEnumUnsafe
  , runFreshUnsafePerformIO
  ) where

import Data.Unique

import Polysemy.Internal
import Polysemy.Internal.Union
import System.IO.Unsafe (unsafePerformIO)
import Polysemy
import Polysemy.State

-----------------------------------------------------------------------------
-- | An effect for creating unique objects which may be used as references,
-- a la 'Unique'. Polymorphic code making use of 'Fresh' is expected
-- to place constraints upon @uniq@ as necessary.
--
-- Any interpreter for 'Fresh' has the responsibilty of ensuring
-- that any call to 'fresh' produces an object that /never/
-- compares equal to an object produced by a previous call to 'fresh'.
data Fresh uniq m a where
  Fresh :: Fresh uniq m uniq

makeSem ''Fresh

-----------------------------------------------------------------------------
-- | Runs a 'Fresh' effect through generating 'Unique's using 'IO'.
freshToIO :: Member (Embed IO) r
          => Sem (Fresh Unique ': r) a
          -> Sem r a
freshToIO :: Sem (Fresh Unique : r) a -> Sem r a
freshToIO = (forall (rInitial :: EffectRow) x.
 Fresh Unique (Sem rInitial) x -> Sem r x)
-> Sem (Fresh Unique : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  Fresh Unique (Sem rInitial) x -> Sem r x)
 -> Sem (Fresh Unique : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    Fresh Unique (Sem rInitial) x -> Sem r x)
-> Sem (Fresh Unique : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \Fresh Unique (Sem rInitial) x
Fresh -> IO Unique -> Sem r Unique
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed IO Unique
newUnique
{-# INLINE freshToIO #-}

-----------------------------------------------------------------------------
-- | Run a 'Fresh' effect purely by specifying an 'Enum' to be used as the
-- type of unique objects.
--
-- __Beware:__ This is safe only if:
--
--   1. This is run after all interpreters which may revert local state
--      or produce multiple, inconsistent instances of local state.
--      This includes interpreters that may backtrack or produce multiple results
--      (such as 'Polysemy.Error.runError' or 'Polysemy.NonDet.runNonDet').
--
--   2. You don't use any interpreter which may cause the final monad
--      to revert local state or produce multiple, inconsistent instances of local
--      state. This includes certain 'Polysemy.Final.Final'/@lower-@ interpeters
--      such as 'Polysemy.Error.lowerError' or 'Polysemy.Final.MTL.errorToFinal',
--      as well as interpreters for 'Polysemy.Async.Async'.
--
-- Prefer 'freshToIO' whenever possible.
-- If you can't use 'runFreshEnumUnsafe' safely, nor use 'freshToIO', consider
-- 'runFreshUnsafePerformIO'.
runFreshEnumUnsafe :: forall n a r
                    . Enum n
                   => Sem (Fresh n ': r) a
                   -> Sem r a
runFreshEnumUnsafe :: Sem (Fresh n : r) a -> Sem r a
runFreshEnumUnsafe =
    (((n, a) -> a) -> Sem r (n, a) -> Sem r a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (n, a) -> a
forall a b. (a, b) -> b
snd (Sem r (n, a) -> Sem r a)
-> (Sem (Fresh n : r) a -> Sem r (n, a))
-> Sem (Fresh n : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
  ((Sem (Fresh n : r) a -> Sem r (n, a))
 -> Sem (Fresh n : r) a -> Sem r a)
-> (Sem (Fresh n : r) a -> Sem r (n, a))
-> Sem (Fresh n : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ (n -> Sem (State n : r) a -> Sem r (n, a)
forall s (r :: EffectRow) a.
s -> Sem (State s : r) a -> Sem r (s, a)
runState @n (Int -> n
forall a. Enum a => Int -> a
toEnum Int
0) (Sem (State n : r) a -> Sem r (n, a))
-> (Sem (Fresh n : r) a -> Sem (State n : r) a)
-> Sem (Fresh n : r) a
-> Sem r (n, a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
  ((Sem (Fresh n : r) a -> Sem (State n : r) a)
 -> Sem (Fresh n : r) a -> Sem r (n, a))
-> (Sem (Fresh n : r) a -> Sem (State n : r) a)
-> Sem (Fresh n : r) a
-> Sem r (n, a)
forall a b. (a -> b) -> a -> b
$ (forall (rInitial :: EffectRow) x.
 Fresh n (Sem rInitial) x -> Sem (State n : r) x)
-> Sem (Fresh n : r) a -> Sem (State n : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: EffectRow) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: EffectRow) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
reinterpret
  ((forall (rInitial :: EffectRow) x.
  Fresh n (Sem rInitial) x -> Sem (State n : r) x)
 -> Sem (Fresh n : r) a -> Sem (State n : r) a)
-> (forall (rInitial :: EffectRow) x.
    Fresh n (Sem rInitial) x -> Sem (State n : r) x)
-> Sem (Fresh n : r) a
-> Sem (State n : r) a
forall a b. (a -> b) -> a -> b
$ \Fresh n (Sem rInitial) x
Fresh -> do
    x
s <- Sem (State n : r) x
forall s (r :: EffectRow). Member (State s) r => Sem r s
get
    x -> Sem (State n : r) ()
forall s (r :: EffectRow). Member (State s) r => s -> Sem r ()
put (x -> Sem (State n : r) ()) -> x -> Sem (State n : r) ()
forall a b. (a -> b) -> a -> b
$! x -> x
forall a. Enum a => a -> a
succ x
s
    x -> Sem (State n : r) x
forall (m :: * -> *) a. Monad m => a -> m a
return x
s
{-# INLINE runFreshEnumUnsafe #-}

-----------------------------------------------------------------------------
-- | Runs a 'Fresh' effect through generating 'Unique's using
-- 'unsafePerformIO'.
--
-- Ironically, despite the fact that this uses 'unsafePerformIO', and
-- 'runFreshUnsafe' uses no unsafe operations whatsoever, this is still
-- typically safer to use than 'runFreshUnsafe', although 'runFreshUnsafe'
-- is perhaps more efficient.
--
-- The worst thing that this particular use of 'unsafePerformIO' could result
-- in is the loss of referential transparency, as rerunning an interpreter stack
-- using 'runFreshUnsafePerformIO' will create different 'Unique's. This should
-- never matter.
--
-- This could be potentially be less efficient than 'runFreshUnsafe'.
--
-- If you ever observe that multiple invocations of 'fresh' produce the same
-- 'Unique' under 'runFreshUnsafePerformIO', then open an issue over at the
-- GitHub repository.
runFreshUnsafePerformIO :: Sem (Fresh Unique ': r) a
                        -> Sem r a
runFreshUnsafePerformIO :: Sem (Fresh Unique : r) a -> Sem r a
runFreshUnsafePerformIO = (forall x.
 Union (Fresh Unique : r) (Sem (Fresh Unique : r)) x -> Sem r x)
-> Sem (Fresh Unique : r) a -> Sem r a
forall (m :: * -> *) (r :: EffectRow) a.
Monad m =>
(forall x. Union r (Sem r) x -> m x) -> Sem r a -> m a
usingSem ((forall x.
  Union (Fresh Unique : r) (Sem (Fresh Unique : r)) x -> Sem r x)
 -> Sem (Fresh Unique : r) a -> Sem r a)
-> (forall x.
    Union (Fresh Unique : r) (Sem (Fresh Unique : r)) x -> Sem r x)
-> Sem (Fresh Unique : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \Union (Fresh Unique : r) (Sem (Fresh Unique : r)) x
u ->
  case Union (Fresh Unique : r) (Sem (Fresh Unique : r)) x
-> Either
     (Union r (Sem (Fresh Unique : r)) x)
     (Weaving (Fresh Unique) (Sem (Fresh Unique : r)) x)
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) (m :: * -> *) a.
Union (e : r) m a -> Either (Union r m a) (Weaving e m a)
decomp Union (Fresh Unique : r) (Sem (Fresh Unique : r)) x
u of
    Right (Weaving Fresh Unique (Sem rInitial) a
Fresh f ()
s forall x. f (Sem rInitial x) -> Sem (Fresh Unique : r) (f x)
_ f a -> x
ex forall x. f x -> Maybe x
_) -> do
      let !uniq :: Unique
uniq = IO Unique -> Unique
forall a. IO a -> a
unsafePerformIO (Union (Fresh Unique : r) (Sem (Fresh Unique : r)) x -> IO Unique
forall (r :: EffectRow) a.
Union (Fresh Unique : r) (Sem (Fresh Unique : r)) a -> IO Unique
newUnique' Union (Fresh Unique : r) (Sem (Fresh Unique : r)) x
u)
          {-# NOINLINE uniq #-}
      x -> Sem r x
forall (f :: * -> *) a. Applicative f => a -> f a
pure (x -> Sem r x) -> x -> Sem r x
forall a b. (a -> b) -> a -> b
$ f a -> x
ex (Unique
uniq Unique -> f () -> f Unique
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f ()
s)
    Left Union r (Sem (Fresh Unique : r)) x
g -> Union r (Sem r) x -> Sem r x
forall (r :: EffectRow) a. Union r (Sem r) a -> Sem r a
liftSem ((forall x. Sem (Fresh Unique : r) x -> Sem r x)
-> Union r (Sem (Fresh Unique : r)) x -> Union r (Sem r) x
forall (m :: * -> *) (n :: * -> *) (r :: EffectRow) a.
(forall x. m x -> n x) -> Union r m a -> Union r n a
hoist forall (r :: EffectRow) a. Sem (Fresh Unique : r) a -> Sem r a
forall x. Sem (Fresh Unique : r) x -> Sem r x
runFreshUnsafePerformIO Union r (Sem (Fresh Unique : r)) x
g)
-- KingoftheHomeless: I've tried very hard to prevent optimizations from
-- sharing the call to 'unsafePerformIO'.
-- The inlining of 'interpret' is so that I can give
-- 'u' to 'newUnique'', and thus prevent 'uniq' from floating outside the
-- lambda. This interpreter might even be safe to INLINE, but I'm not taking
-- any chances.
{-# NOINLINE runFreshUnsafePerformIO #-}

newUnique' :: Union (Fresh Unique ': r) (Sem (Fresh Unique ': r)) a -> IO Unique
newUnique' :: Union (Fresh Unique : r) (Sem (Fresh Unique : r)) a -> IO Unique
newUnique' (Union ElemOf e (Fresh Unique : r)
_ Weaving e (Sem (Fresh Unique : r)) a
_) = IO Unique
newUnique
{-# NOINLINE newUnique' #-}