{-# language AllowAmbiguousTypes #-}
{-# language ConstraintKinds #-}
{-# language DataKinds #-}
{-# 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           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)

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

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

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

-- | 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_ :: 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>"

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

-- | Check if thunk @t@ is computed,
-- then bind it into first arg.
-- else bind the thunk stub val.
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