{-# language AllowAmbiguousTypes #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# language TypeFamilies #-}
{-# language RankNTypes #-}
module Nix.Normal where
import Nix.Prelude
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Applicative f, Show t) =>
Int -> NormalLoop t f m -> ShowS
forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Applicative f, Show t) =>
[NormalLoop t f m] -> ShowS
forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Applicative f, Show t) =>
NormalLoop t f m -> String
showList :: [NormalLoop t f m] -> ShowS
$cshowList :: forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Applicative f, Show t) =>
[NormalLoop t f m] -> ShowS
show :: NormalLoop t f m -> String
$cshow :: forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Applicative f, Show t) =>
NormalLoop t f m -> String
showsPrec :: Int -> NormalLoop t f m -> ShowS
$cshowsPrec :: forall t (f :: * -> *) (m :: * -> *).
(Comonad f, Applicative 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 :: 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
v = forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run forall a b. (a -> b) -> a -> b
$ 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 (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)
go (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
maxDepth :: Int
maxDepth = Int
2000
table :: Set (ThunkId m)
table = forall a. Monoid a => a
mempty
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run :: forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Set (ThunkId m)
table) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Int
start)
go
:: ( 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)
go :: (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)
go NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
k t
tnk =
forall a. a -> a -> Bool -> a
bool
(do
Int
i <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i forall a. Ord a => a -> a -> Bool
> Int
maxDepth) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Exceeded maximum normalization depth of " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Int
maxDepth forall a. Semigroup a => a -> a -> a
<> String
" levels."
(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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
(forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall t (m :: * -> *) a. MonadThunk t m a => t -> m a
force t
tnk)
(forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a. Num a => a -> a -> a
+Int
1) 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)
)
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure t
tnk)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool
seen t
tnk
where
seen :: t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool
seen :: t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool
seen t
t =
do
let tnkid :: ThunkId m
tnkid = forall t (m :: * -> *) a. MonadThunk t m a => t -> ThunkId m
thunkId t
t
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
do
Bool
thunkWasVisited <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
member ThunkId m
tnkid
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
thunkWasVisited) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
insert ThunkId m
tnkid
pure Bool
thunkWasVisited
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 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
f = forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (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)
go (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
maxDepth :: Int
maxDepth = Int
2000
table :: Set (ThunkId m)
table = forall a. Monoid a => a
mempty
run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run :: forall r. ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
run = (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
`evalStateT` Set (ThunkId m)
table) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` Int
start)
go
:: ( 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)
go :: (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)
go NValue t f m
-> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
k t
tnk =
forall a. a -> a -> Bool -> a
bool
(do
Int
i <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
i forall a. Ord a => a -> a -> Bool
> Int
maxDepth) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Exceeded maximum normalization depth of " forall a. Semigroup a => a -> a -> a
<> forall b a. (Show a, IsString b) => a -> b
show Int
maxDepth forall a. Semigroup a => a -> a -> a
<> String
" levels."
(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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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)
(forall r. t -> (NValue t f m -> m r) -> m r
f t
tnk)
(forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (forall a. Num a => a -> a -> a
+Int
1) 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)
)
(forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure t
tnk)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool
seen t
tnk
where
seen :: t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool
seen :: t -> ReaderT Int (StateT (Set (ThunkId m)) m) Bool
seen t
t =
do
let tnkid :: ThunkId m
tnkid = forall t (m :: * -> *) a. MonadThunk t m a => t -> ThunkId m
thunkId t
t
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
do
Bool
thunkWasVisited <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Bool
member ThunkId m
tnkid
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
thunkWasVisited) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> Set a -> Set a
insert ThunkId m
tnkid
pure Bool
thunkWasVisited
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 :: forall e (m :: * -> *) t (f :: * -> *).
(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
t = 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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_ :: forall e (m :: * -> *) t (f :: * -> *).
(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
t = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 :: NVConstraint f => NValue t f m
opaqueVal :: forall (f :: * -> *) t (m :: * -> *).
NVConstraint f =>
NValue t f m
opaqueVal = forall (f :: * -> *) t (m :: * -> *).
NVConstraint f =>
Text -> NValue t f m
mkNVStrWithoutContext 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 :: 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 =
forall t (f :: * -> *) (m :: * -> *) r.
MonadDataContext f m =>
((NValue t f m -> r) -> t -> r)
-> (NValue' t f m r -> r) -> NValue t f m -> r
iterNValue
(\NValue t f m -> NValue t f m
_ t
t ->
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall a b. (a -> b) -> a -> b
$
forall t (f :: * -> *) (m :: * -> *) a.
f (NValueF (NValue t f m) m a) -> NValue' t f m a
NValue' forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
(forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) v (f :: * -> *) a.
HasCitations1 m v f =>
Provenance m v -> f a -> f a
addProvenance1 @m @(NValue t f m))
forall {t} {m :: * -> *}.
f (NValueF (NValue t f m) m (NValue t f m))
cyc
(forall (m :: * -> *) v a.
HasCitations m v a =>
a -> [Provenance m v]
citations @m @(NValue t f m) t
t)
)
forall (f :: * -> *) a. f (Free f a) -> Free f a
Free
where
Free (NValue' f (NValueF (NValue t f m) m (NValue t f m))
cyc) = forall (f :: * -> *) t (m :: * -> *).
NVConstraint f =>
NValue t f m
opaqueVal
thunkStubVal :: NVConstraint f => NValue t f m
thunkStubVal :: forall (f :: * -> *) t (m :: * -> *).
NVConstraint f =>
NValue t f m
thunkStubVal = forall (f :: * -> *) t (m :: * -> *).
NVConstraint f =>
Text -> NValue t f m
mkNVStrWithoutContext Text
thunkStubText
bindComputedThunkOrStub
:: ( NVConstraint f
, MonadThunk t m (NValue t f m)
)
=> (NValue t f m -> m a)
-> t
-> m a
bindComputedThunkOrStub :: forall (f :: * -> *) t (m :: * -> *) a.
(NVConstraint f, MonadThunk t m (NValue t f m)) =>
(NValue t f m -> m a) -> t -> m a
bindComputedThunkOrStub = (forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall t (m :: * -> *) a. MonadThunk t m a => m a -> t -> m a
query (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) t (m :: * -> *).
NVConstraint 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 :: forall t (m :: * -> *) (f :: * -> *).
(MonadThunk t m (NValue t f m), MonadDataContext f m) =>
NValue t f m -> m (NValue t f m)
removeEffects =
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
id
forall (f :: * -> *) t (m :: * -> *) a.
(NVConstraint f, MonadThunk t m (NValue t f m)) =>
(NValue t f m -> m a) -> t -> m a
bindComputedThunkOrStub
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. f (Free f a) -> Free f a
Free forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
id)
dethunk
:: (MonadThunk t m (NValue t f m), MonadDataContext f m)
=> t
-> m (NValue t f m)
dethunk :: forall t (m :: * -> *) (f :: * -> *).
(MonadThunk t m (NValue t f m), MonadDataContext f m) =>
t -> m (NValue t f m)
dethunk = forall (f :: * -> *) t (m :: * -> *) a.
(NVConstraint f, MonadThunk t m (NValue t f m)) =>
(NValue t f m -> m a) -> t -> m a
bindComputedThunkOrStub forall t (m :: * -> *) (f :: * -> *).
(MonadThunk t m (NValue t f m), MonadDataContext f m) =>
NValue t f m -> m (NValue t f m)
removeEffects