{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
module Nix.Normal where
import Prelude hiding ( force )
import Nix.Utils
import Control.Monad.Free ( Free(..) )
import Data.Set ( member
, insert
)
import Nix.Cited
import Nix.Frames
import Nix.Thunk
import Nix.Value
newtype NormalLoop t f m = NormalLoop (NValue t f m)
deriving Int -> NormalLoop t f m -> ShowS
[NormalLoop t f m] -> ShowS
NormalLoop t f m -> String
(Int -> NormalLoop t f m -> ShowS)
-> (NormalLoop t f m -> String)
-> ([NormalLoop t f m] -> ShowS)
-> Show (NormalLoop t f m)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Show t) =>
Int -> NormalLoop t f m -> ShowS
forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Show t) =>
[NormalLoop t f m] -> ShowS
forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Show t) =>
NormalLoop t f m -> String
showList :: [NormalLoop t f m] -> ShowS
$cshowList :: forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Show t) =>
[NormalLoop t f m] -> ShowS
show :: NormalLoop t f m -> String
$cshow :: forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Show t) =>
NormalLoop t f m -> String
showsPrec :: Int -> NormalLoop t f m -> ShowS
$cshowsPrec :: forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Show t) =>
Int -> NormalLoop t f m -> ShowS
Show
instance MonadDataErrorContext t f m => Exception (NormalLoop t f m)
normalizeValue
:: forall e t m f
. ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m
-> m (NValue t f m)
normalizeValue :: NValue t f m -> m (NValue t f m)
normalizeValue NValue t f m
v = ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> m (NValue t f m)
forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> m (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> m (NValue t f m)
forall a b. (a -> b) -> a -> b
$ (forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r)
-> ((NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> t -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (NValue'
t f m (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall (f :: * -> *) (m :: * -> *) (n :: * -> *) t r.
(MonadDataContext f m, Monad n) =>
(forall x. n x -> m x)
-> ((NValue t f m -> n r) -> t -> n r)
-> (NValue' t f m (n r) -> n r)
-> NValue t f m
-> n r
iterNValueM forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run ((t
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> t
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip t
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
go) ((NValue' t f m (NValue t f m) -> NValue t f m)
-> ReaderT
Int (StateT (Set (ThunkId m)) m) (NValue' t f m (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NValue' t f m (NValue t f m) -> NValue t f m
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (ReaderT
Int (StateT (Set (ThunkId m)) m) (NValue' t f m (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (NValue'
t f m (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT
Int (StateT (Set (ThunkId m)) m) (NValue' t f m (NValue t f m)))
-> NValue'
t f m (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r)
-> NValue'
t f m (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT
Int (StateT (Set (ThunkId m)) m) (NValue' t f m (NValue t f m))
forall (n :: * -> *) (f :: * -> *) (m :: * -> *) t a.
(Functor n, Traversable f, Monad m, Applicative n) =>
(forall x. n x -> m x)
-> NValue' t f m (n a) -> n (NValue' t f m a)
sequenceNValue' forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run) NValue t f m
v
where
start :: Int
start = Int
0 :: Int
table :: Set (ThunkId m)
table = Set (ThunkId m)
forall a. Monoid a => a
mempty
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (StateT (Set (ThunkId m)) m r -> Set (ThunkId m) -> m r
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Set (ThunkId m)
table) (StateT (Set (ThunkId m)) m r -> m r)
-> (ReaderT Int (StateT (Set (ThunkId m)) m) r
-> StateT (Set (ThunkId m)) m r)
-> ReaderT Int (StateT (Set (ThunkId m)) m) r
-> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT Int (StateT (Set (ThunkId m)) m) r
-> Int -> StateT (Set (ThunkId m)) m r
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Int
start)
go
:: t
-> ( NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
go :: t
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
go t
t NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
k = do
Bool
b <- t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool
forall t (m :: * -> *) a (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadThunk t m a, MonadTrans t, MonadState (Set (ThunkId m)) m) =>
t -> t m Bool
seen t
t
ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> Bool
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall a. a -> a -> Bool -> a
bool
(do
Int
i <- ReaderT Int (StateT (Set (ThunkId m)) m) Int
forall r (m :: * -> *). MonadReader r m => m r
ask
Bool
-> ReaderT Int (StateT (Set (ThunkId m)) m) ()
-> ReaderT Int (StateT (Set (ThunkId m)) m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2000) (ReaderT Int (StateT (Set (ThunkId m)) m) ()
-> ReaderT Int (StateT (Set (ThunkId m)) m) ())
-> ReaderT Int (StateT (Set (ThunkId m)) m) ()
-> ReaderT Int (StateT (Set (ThunkId m)) m) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Int (StateT (Set (ThunkId m)) m) ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Exceeded maximum normalization depth of 2000 levels"
(((NValue t f m -> StateT (Set (ThunkId m)) m (NValue t f m))
-> StateT (Set (ThunkId m)) m (NValue t f m))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall (u :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTransControl u, Monad (u m), Monad m) =>
((a -> m (StT u b)) -> m (StT u b)) -> (a -> u m b) -> u m b
lifted (((NValue t f m -> StateT (Set (ThunkId m)) m (NValue t f m))
-> StateT (Set (ThunkId m)) m (NValue t f m))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (((NValue t f m -> m (NValue t f m, Set (ThunkId m)))
-> m (NValue t f m, Set (ThunkId m)))
-> (NValue t f m -> StateT (Set (ThunkId m)) m (NValue t f m))
-> StateT (Set (ThunkId m)) m (NValue t f m))
-> ((NValue t f m -> m (NValue t f m, Set (ThunkId m)))
-> m (NValue t f m, Set (ThunkId m)))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((NValue t f m -> m (NValue t f m, Set (ThunkId m)))
-> m (NValue t f m, Set (ThunkId m)))
-> (NValue t f m -> StateT (Set (ThunkId m)) m (NValue t f m))
-> StateT (Set (ThunkId m)) m (NValue t f m)
forall (u :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTransControl u, Monad (u m), Monad m) =>
((a -> m (StT u b)) -> m (StT u b)) -> (a -> u m b) -> u m b
lifted)
((NValue t f m -> m (NValue t f m, Set (ThunkId m)))
-> m (NValue t f m) -> m (NValue t f m, Set (ThunkId m))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< t -> m (NValue t f m)
forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force t
t)
((Int -> Int)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local Int -> Int
forall a. Enum a => a -> a
succ (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
k)
)
(NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall a b. (a -> b) -> a -> b
$ t -> NValue t f m
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t)
Bool
b
seen :: t -> t m Bool
seen t
t = do
let tid :: ThunkId m
tid = t -> ThunkId m
forall t (m :: * -> *) a. MonadThunk t m a => t -> ThunkId m
thunkId t
t
m Bool -> t m Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> t m Bool) -> m Bool -> t m Bool
forall a b. (a -> b) -> a -> b
$ do
Bool
res <- (Set (ThunkId m) -> Bool) -> m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Set (ThunkId m) -> Bool) -> m Bool)
-> (Set (ThunkId m) -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ThunkId m -> Set (ThunkId m) -> Bool
forall a. Ord a => a -> Set a -> Bool
member ThunkId m
tid
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
res (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (Set (ThunkId m) -> Set (ThunkId m)) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Set (ThunkId m) -> Set (ThunkId m)) -> m ())
-> (Set (ThunkId m) -> Set (ThunkId m)) -> m ()
forall a b. (a -> b) -> a -> b
$ ThunkId m -> Set (ThunkId m) -> Set (ThunkId m)
forall a. Ord a => a -> Set a -> Set a
insert ThunkId m
tid
pure Bool
res
normalizeValueF
:: forall e t m f
. ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> (forall r . t -> (NValue t f m -> m r) -> m r)
-> NValue t f m
-> m (NValue t f m)
normalizeValueF :: (forall r. t -> (NValue t f m -> m r) -> m r)
-> NValue t f m -> m (NValue t f m)
normalizeValueF forall r. t -> (NValue t f m -> m r) -> m r
f = ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> m (NValue t f m)
forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> m (NValue t f m))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> NValue t f m
-> m (NValue t f m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r)
-> ((NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> t -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (NValue'
t f m (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall (f :: * -> *) (m :: * -> *) (n :: * -> *) t r.
(MonadDataContext f m, Monad n) =>
(forall x. n x -> m x)
-> ((NValue t f m -> n r) -> t -> n r)
-> (NValue' t f m (n r) -> n r)
-> NValue t f m
-> n r
iterNValueM forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run ((t
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> t
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall a b c. (a -> b -> c) -> b -> a -> c
flip t
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
go) ((NValue' t f m (NValue t f m) -> NValue t f m)
-> ReaderT
Int (StateT (Set (ThunkId m)) m) (NValue' t f m (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NValue' t f m (NValue t f m) -> NValue t f m
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (ReaderT
Int (StateT (Set (ThunkId m)) m) (NValue' t f m (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (NValue'
t f m (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT
Int (StateT (Set (ThunkId m)) m) (NValue' t f m (NValue t f m)))
-> NValue'
t f m (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r)
-> NValue'
t f m (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT
Int (StateT (Set (ThunkId m)) m) (NValue' t f m (NValue t f m))
forall (n :: * -> *) (f :: * -> *) (m :: * -> *) t a.
(Functor n, Traversable f, Monad m, Applicative n) =>
(forall x. n x -> m x)
-> NValue' t f m (n a) -> n (NValue' t f m a)
sequenceNValue' forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run)
where
start :: Int
start = Int
0 :: Int
table :: Set (ThunkId m)
table = Set (ThunkId m)
forall a. Monoid a => a
mempty
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (StateT (Set (ThunkId m)) m r -> Set (ThunkId m) -> m r
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Set (ThunkId m)
table) (StateT (Set (ThunkId m)) m r -> m r)
-> (ReaderT Int (StateT (Set (ThunkId m)) m) r
-> StateT (Set (ThunkId m)) m r)
-> ReaderT Int (StateT (Set (ThunkId m)) m) r
-> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ReaderT Int (StateT (Set (ThunkId m)) m) r
-> Int -> StateT (Set (ThunkId m)) m r
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Int
start)
go
:: t
-> ( NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
go :: t
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
go t
t NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
k = do
Bool
b <- t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool
forall t (m :: * -> *) a (t :: (* -> *) -> * -> *) (m :: * -> *).
(MonadThunk t m a, MonadTrans t, MonadState (Set (ThunkId m)) m) =>
t -> t m Bool
seen t
t
ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> Bool
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall a. a -> a -> Bool -> a
bool
(do
Int
i <- ReaderT Int (StateT (Set (ThunkId m)) m) Int
forall r (m :: * -> *). MonadReader r m => m r
ask
Bool
-> ReaderT Int (StateT (Set (ThunkId m)) m) ()
-> ReaderT Int (StateT (Set (ThunkId m)) m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2000) (ReaderT Int (StateT (Set (ThunkId m)) m) ()
-> ReaderT Int (StateT (Set (ThunkId m)) m) ())
-> ReaderT Int (StateT (Set (ThunkId m)) m) ()
-> ReaderT Int (StateT (Set (ThunkId m)) m) ()
forall a b. (a -> b) -> a -> b
$ String -> ReaderT Int (StateT (Set (ThunkId m)) m) ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Exceeded maximum normalization depth of 2000 levels"
((NValue t f m
-> StateT (Set (ThunkId m)) m (StT (ReaderT Int) (NValue t f m)))
-> StateT (Set (ThunkId m)) m (StT (ReaderT Int) (NValue t f m)))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall (u :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTransControl u, Monad (u m), Monad m) =>
((a -> m (StT u b)) -> m (StT u b)) -> (a -> u m b) -> u m b
lifted (((NValue t f m
-> m (StT (StateT (Set (ThunkId m))) (NValue t f m)))
-> m (StT (StateT (Set (ThunkId m))) (NValue t f m)))
-> (NValue t f m -> StateT (Set (ThunkId m)) m (NValue t f m))
-> StateT (Set (ThunkId m)) m (NValue t f m)
forall (u :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTransControl u, Monad (u m), Monad m) =>
((a -> m (StT u b)) -> m (StT u b)) -> (a -> u m b) -> u m b
lifted (((NValue t f m
-> m (StT (StateT (Set (ThunkId m))) (NValue t f m)))
-> m (StT (StateT (Set (ThunkId m))) (NValue t f m)))
-> (NValue t f m -> StateT (Set (ThunkId m)) m (NValue t f m))
-> StateT (Set (ThunkId m)) m (NValue t f m))
-> ((NValue t f m
-> m (StT (StateT (Set (ThunkId m))) (NValue t f m)))
-> m (StT (StateT (Set (ThunkId m))) (NValue t f m)))
-> (NValue t f m -> StateT (Set (ThunkId m)) m (NValue t f m))
-> StateT (Set (ThunkId m)) m (NValue t f m)
forall a b. (a -> b) -> a -> b
$ t
-> (NValue t f m -> m (NValue t f m, Set (ThunkId m)))
-> m (NValue t f m, Set (ThunkId m))
forall r. t -> (NValue t f m -> m r) -> m r
f t
t) ((NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall a b. (a -> b) -> a -> b
$ (Int -> Int)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local Int -> Int
forall a. Enum a => a -> a
succ (ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
k
)
(NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m))
-> NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
forall a b. (a -> b) -> a -> b
$ t -> NValue t f m
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
t)
Bool
b
seen :: t -> t m Bool
seen t
t = do
let tid :: ThunkId m
tid = t -> ThunkId m
forall t (m :: * -> *) a. MonadThunk t m a => t -> ThunkId m
thunkId t
t
m Bool -> t m Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Bool -> t m Bool) -> m Bool -> t m Bool
forall a b. (a -> b) -> a -> b
$ do
Bool
res <- (Set (ThunkId m) -> Bool) -> m Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Set (ThunkId m) -> Bool) -> m Bool)
-> (Set (ThunkId m) -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ThunkId m -> Set (ThunkId m) -> Bool
forall a. Ord a => a -> Set a -> Bool
member ThunkId m
tid
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
res (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ (Set (ThunkId m) -> Set (ThunkId m)) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Set (ThunkId m) -> Set (ThunkId m)) -> m ())
-> (Set (ThunkId m) -> Set (ThunkId m)) -> m ()
forall a b. (a -> b) -> a -> b
$ ThunkId m -> Set (ThunkId m) -> Set (ThunkId m)
forall a. Ord a => a -> Set a -> Set a
insert ThunkId m
tid
pure Bool
res
normalForm
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
, Ord (ThunkId m)
)
=> NValue t f m
-> m (NValue t f m)
normalForm :: NValue t f m -> m (NValue t f m)
normalForm NValue t f m
t = NValue t f m -> NValue t f m
forall t (f :: * -> *) (m :: * -> *).
(MonadDataContext f m, HasCitations m (NValue t f m) t,
HasCitations1 m (NValue t f m) f) =>
NValue t f m -> NValue t f m
stubCycles (NValue t f m -> NValue t f m)
-> m (NValue t f m) -> m (NValue t f m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NValue t f m -> m (NValue t f m)
forall e t (m :: * -> *) (f :: * -> *).
(Framed e m, MonadThunk t m (NValue t f m),
MonadDataErrorContext t f m, Ord (ThunkId m)) =>
NValue t f m -> m (NValue t f m)
normalizeValue NValue t f m
t
normalForm_
:: ( Framed e m
, MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, Ord (ThunkId m)
)
=> NValue t f m
-> m ()
normalForm_ :: NValue t f m -> m ()
normalForm_ NValue t f m
t = m (NValue t f m) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (NValue t f m) -> m ()) -> m (NValue t f m) -> m ()
forall a b. (a -> b) -> a -> b
$ NValue t f m -> m (NValue t f m)
forall e t (m :: * -> *) (f :: * -> *).
(Framed e m, MonadThunk t m (NValue t f m),
MonadDataErrorContext t f m, Ord (ThunkId m)) =>
NValue t f m -> m (NValue t f m)
normalizeValue NValue t f m
t
opaqueVal :: Applicative f => NValue t f m
opaqueVal :: NValue t f m
opaqueVal = Text -> NValue t f m
forall (f :: * -> *) t (m :: * -> *).
Applicative f =>
Text -> NValue t f m
nvStrWithoutContext Text
"<cycle>"
stubCycles
:: forall t f m
. ( MonadDataContext f m
, HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
)
=> NValue t f m
-> NValue t f m
stubCycles :: NValue t f m -> NValue t f m
stubCycles =
((NValue t f m -> NValue t f m) -> t -> NValue t f m)
-> (NValue' t f m (NValue t f m) -> NValue t f m)
-> NValue t f m
-> NValue t f m
forall t (f :: * -> *) (m :: * -> *) r.
MonadDataContext f m =>
((Free (NValue' t f m) t -> r) -> t -> r)
-> (NValue' t f m r -> r) -> Free (NValue' t f m) t -> r
iterNValue
(\NValue t f m -> NValue t f m
_ t
t ->
NValue' t f m (NValue t f m) -> NValue t f m
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (NValue' t f m (NValue t f m) -> NValue t f m)
-> NValue' t f m (NValue t f m) -> NValue t f m
forall a b. (a -> b) -> a -> b
$
f (NValueF (NValue t f m) m (NValue t f m))
-> NValue' t f m (NValue t f m)
forall t (f :: * -> *) (m :: * -> *) a.
f (NValueF (NValue t f m) m a) -> NValue' t f m a
NValue' (f (NValueF (NValue t f m) m (NValue t f m))
-> NValue' t f m (NValue t f m))
-> f (NValueF (NValue t f m) m (NValue t f m))
-> NValue' t f m (NValue t f m)
forall a b. (a -> b) -> a -> b
$
(Provenance m (NValue t f m)
-> f (NValueF (NValue t f m) m (NValue t f m))
-> f (NValueF (NValue t f m) m (NValue t f m)))
-> f (NValueF (NValue t f m) m (NValue t f m))
-> [Provenance m (NValue t f m)]
-> f (NValueF (NValue t f m) m (NValue t f m))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(forall (f :: * -> *) a.
HasCitations1 m (NValue t f m) f =>
Provenance m (NValue t f m) -> f a -> f a
forall (m :: * -> *) v (f :: * -> *) a.
HasCitations1 m v f =>
Provenance m v -> f a -> f a
addProvenance1 @m @(NValue t f m))
f (NValueF (NValue t f m) m (NValue t f m))
forall a (m :: * -> *). f (NValueF (NValue a f m) m (NValue a f m))
cyc
([Provenance m (NValue t f m)] -> [Provenance m (NValue t f m)]
forall a. [a] -> [a]
reverse ([Provenance m (NValue t f m)] -> [Provenance m (NValue t f m)])
-> [Provenance m (NValue t f m)] -> [Provenance m (NValue t f m)]
forall a b. (a -> b) -> a -> b
$ t -> [Provenance m (NValue t f m)]
forall (m :: * -> *) v a.
HasCitations m v a =>
a -> [Provenance m v]
citations @m @(NValue t f m) t
t)
)
NValue' t f m (NValue t f m) -> NValue t f m
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free
where
Free (NValue' f (NValueF (NValue a f m) m (NValue a f m))
cyc) = NValue a f m
forall (f :: * -> *) t (m :: * -> *). Applicative f => NValue t f m
opaqueVal
thunkStubVal :: Applicative f => NValue t f m
thunkStubVal :: NValue t f m
thunkStubVal = Text -> NValue t f m
forall (f :: * -> *) t (m :: * -> *).
Applicative f =>
Text -> NValue t f m
nvStrWithoutContext Text
thunkStubText
bindComputedThunkOrStub
:: ( Applicative f
, MonadThunk t m (NValue t f m)
)
=> (NValue t f m -> m a)
-> t
-> m a
bindComputedThunkOrStub :: (NValue t f m -> m a) -> t -> m a
bindComputedThunkOrStub = ((NValue t f m -> m a) -> (t -> m (NValue t f m)) -> t -> m a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< m (NValue t f m) -> t -> m (NValue t f m)
forall t (m :: * -> *) a. MonadThunk t m a => m a -> t -> m a
query (NValue t f m -> m (NValue t f m)
forall (f :: * -> *) a. Applicative f => a -> f a
pure NValue t f m
forall (f :: * -> *) t (m :: * -> *). Applicative f => NValue t f m
thunkStubVal))
removeEffects
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> NValue t f m
-> m (NValue t f m)
removeEffects :: NValue t f m -> m (NValue t f m)
removeEffects =
(forall x. m x -> m x)
-> ((NValue t f m -> m (NValue t f m)) -> t -> m (NValue t f m))
-> (NValue' t f m (m (NValue t f m)) -> m (NValue t f m))
-> NValue t f m
-> m (NValue t f m)
forall (f :: * -> *) (m :: * -> *) (n :: * -> *) t r.
(MonadDataContext f m, Monad n) =>
(forall x. n x -> m x)
-> ((NValue t f m -> n r) -> t -> n r)
-> (NValue' t f m (n r) -> n r)
-> NValue t f m
-> n r
iterNValueM
forall a. a -> a
forall x. m x -> m x
id
(NValue t f m -> m (NValue t f m)) -> t -> m (NValue t f m)
forall (f :: * -> *) t (m :: * -> *) a.
(Applicative f, MonadThunk t m (NValue t f m)) =>
(NValue t f m -> m a) -> t -> m a
bindComputedThunkOrStub
((NValue' t f m (NValue t f m) -> NValue t f m)
-> m (NValue' t f m (NValue t f m)) -> m (NValue t f m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NValue' t f m (NValue t f m) -> NValue t f m
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free (m (NValue' t f m (NValue t f m)) -> m (NValue t f m))
-> (NValue' t f m (m (NValue t f m))
-> m (NValue' t f m (NValue t f m)))
-> NValue' t f m (m (NValue t f m))
-> m (NValue t f m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall x. m x -> m x)
-> NValue' t f m (m (NValue t f m))
-> m (NValue' t f m (NValue t f m))
forall (n :: * -> *) (f :: * -> *) (m :: * -> *) t a.
(Functor n, Traversable f, Monad m, Applicative n) =>
(forall x. n x -> m x)
-> NValue' t f m (n a) -> n (NValue' t f m a)
sequenceNValue' forall a. a -> a
forall x. m x -> m x
id)
dethunk
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> t
-> m (NValue t f m)
dethunk :: t -> m (NValue t f m)
dethunk = (NValue t f m -> m (NValue t f m)) -> t -> m (NValue t f m)
forall (f :: * -> *) t (m :: * -> *) a.
(Applicative f, MonadThunk t m (NValue t f m)) =>
(NValue t f m -> m a) -> t -> m a
bindComputedThunkOrStub NValue t f m -> m (NValue t f m)
forall t (m :: * -> *) (f :: * -> *).
(MonadThunk t m (NValue t f m), MonadDataContext f m) =>
NValue t f m -> m (NValue t f m)
removeEffects