{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}

-- | Code for normalization (reduction into a normal form) of Nix expressions.
-- Nix language allows recursion, so some expressions do not converge.
-- And so do not converge into a normal form.
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.String
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)

-- | Normalize the value as much as possible, leaving only detected cycles.
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)
-> (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))
-> 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)
-> (t -> (NValue t f m -> n r) -> 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)
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 (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
$ \NValue t f m -> m (StT (StateT (Set (ThunkId m))) (NValue t f m))
f -> NValue t f m -> m (NValue t f m, Set (ThunkId m))
NValue t f m -> m (StT (StateT (Set (ThunkId m))) (NValue t f m))
f (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) ((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

-- 2021-05-09: NOTE: This seems a bit excessive. If these functorial versions are not used for recursion schemes - just free from it.
-- | Normalization HOF (functorial) version of @normalizeValue@. Accepts the special thunk operating/forcing/nirmalizing function & internalizes it.
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)
-> (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))
-> 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)
-> (t -> (NValue t f m -> n r) -> 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)
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

-- | Normalize value.
-- Detect cycles.
-- If cycles were detected - put a stub on them.
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

-- | Monadic context of the result.
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

-- | Detect cycles & stub them.
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 =
  (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)
-> NValue t f m
-> NValue t f m
forall t (f :: * -> *) (m :: * -> *) r.
MonadDataContext f m =>
(t -> (NValue t f m -> r) -> r)
-> (NValue' t f m r -> r) -> NValue t f m -> r
iterNValue
    (\t
t NValue t f m -> NValue t f m
_ ->
      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
opaque

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)
-> (t -> (NValue t f m -> 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
-> m (NValue t f m)
forall (f :: * -> *) (m :: * -> *) (n :: * -> *) t r.
(MonadDataContext f m, Monad n) =>
(forall x. n x -> m x)
-> (t -> (NValue t f m -> n r) -> 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
    --  2021-02-25: NOTE: Please, unflip this up the stack
    (\ t
t NValue t f m -> m (NValue t f m)
f -> NValue t f m -> m (NValue t f m)
f (NValue t f m -> m (NValue t f m))
-> m (NValue t f m) -> m (NValue t f m)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m (NValue t f m) -> t -> m (NValue t f m)
forall t (m :: * -> *) a. MonadThunk t m a => m a -> t -> m a
queryM (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
opaque) t
t)
    ((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)

opaque :: Applicative f => NValue t f m
opaque :: NValue t f m
opaque = NixString -> NValue t f m
forall (f :: * -> *) t (m :: * -> *).
Applicative f =>
NixString -> NValue t f m
nvStr (NixString -> NValue t f m) -> NixString -> NValue t f m
forall a b. (a -> b) -> a -> b
$ Text -> NixString
makeNixStringWithoutContext Text
"<cycle>"

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)
forall t (m :: * -> *) (f :: * -> *).
(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))
-> (t -> m (NValue t f m)) -> t -> m (NValue t f m)
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
queryM (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
opaque)