{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}

module Nix.Json where

import           Control.Monad
import           Control.Monad.Trans
import qualified Data.Aeson                    as A
import qualified Data.Aeson.Encoding           as A
import qualified Data.HashMap.Lazy             as HM
import qualified Data.Text                     as Text
import qualified Data.Text.Lazy                as TL
import qualified Data.Text.Lazy.Encoding       as TL
import qualified Data.Vector                   as V
import           Nix.Atoms
import           Nix.Effects
import           Nix.Exec
import           Nix.Frames
import           Nix.String
import           Nix.Utils
import           Nix.Value
import           Nix.Value.Monad

nvalueToJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString
nvalueToJSONNixString :: NValue t f m -> m NixString
nvalueToJSONNixString =
  WithStringContextT m Text -> m NixString
forall (m :: * -> *).
Monad m =>
WithStringContextT m Text -> m NixString
runWithStringContextT
    (WithStringContextT m Text -> m NixString)
-> (NValue t f m -> WithStringContextT m Text)
-> NValue t f m
-> m NixString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> Text)
-> WithStringContextT m Value -> WithStringContextT m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        ( Text -> Text
TL.toStrict
        (Text -> Text) -> (Value -> Text) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8
        (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding' Value -> ByteString
forall a. Encoding' a -> ByteString
A.encodingToLazyByteString
        (Encoding' Value -> ByteString)
-> (Value -> Encoding' Value) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Encoding' Value
toEncodingSorted
        )
    (WithStringContextT m Value -> WithStringContextT m Text)
-> (NValue t f m -> WithStringContextT m Value)
-> NValue t f m
-> WithStringContextT m Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NValue t f m -> WithStringContextT m Value
forall e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
NValue t f m -> WithStringContextT m Value
nvalueToJSON

nvalueToJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value
nvalueToJSON :: NValue t f m -> WithStringContextT m Value
nvalueToJSON = \case
  NVConstant (NInt   n :: Integer
n) -> Value -> WithStringContextT m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> WithStringContextT m Value)
-> Value -> WithStringContextT m Value
forall a b. (a -> b) -> a -> b
$ Integer -> Value
forall a. ToJSON a => a -> Value
A.toJSON Integer
n
  NVConstant (NFloat n :: Float
n) -> Value -> WithStringContextT m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> WithStringContextT m Value)
-> Value -> WithStringContextT m Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
forall a. ToJSON a => a -> Value
A.toJSON Float
n
  NVConstant (NBool  b :: Bool
b) -> Value -> WithStringContextT m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> WithStringContextT m Value)
-> Value -> WithStringContextT m Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
forall a. ToJSON a => a -> Value
A.toJSON Bool
b
  NVConstant NNull      -> Value -> WithStringContextT m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> WithStringContextT m Value)
-> Value -> WithStringContextT m Value
forall a b. (a -> b) -> a -> b
$ Value
A.Null
  NVStr      ns :: NixString
ns         -> Text -> Value
forall a. ToJSON a => a -> Value
A.toJSON (Text -> Value)
-> WithStringContextT m Text -> WithStringContextT m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NixString -> WithStringContextT m Text
forall (m :: * -> *).
Monad m =>
NixString -> WithStringContextT m Text
extractNixString NixString
ns
  NVList l :: [NValue t f m]
l ->
    Array -> Value
A.Array
      (Array -> Value) -> ([Value] -> Array) -> [Value] -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   [Value] -> Array
forall a. [a] -> Vector a
V.fromList
      ([Value] -> Value)
-> WithStringContextT m [Value] -> WithStringContextT m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NValue t f m -> WithStringContextT m Value)
-> [NValue t f m] -> WithStringContextT m [Value]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (WithStringContextT m (WithStringContextT m Value)
-> WithStringContextT m Value
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (WithStringContextT m (WithStringContextT m Value)
 -> WithStringContextT m Value)
-> (NValue t f m
    -> WithStringContextT m (WithStringContextT m Value))
-> NValue t f m
-> WithStringContextT m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (WithStringContextT m Value)
-> WithStringContextT m (WithStringContextT m Value)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (WithStringContextT m Value)
 -> WithStringContextT m (WithStringContextT m Value))
-> (NValue t f m -> m (WithStringContextT m Value))
-> NValue t f m
-> WithStringContextT m (WithStringContextT m Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NValue t f m
 -> (NValue t f m -> m (WithStringContextT m Value))
 -> m (WithStringContextT m Value))
-> (NValue t f m -> m (WithStringContextT m Value))
-> NValue t f m
-> m (WithStringContextT m Value)
forall a b c. (a -> b -> c) -> b -> a -> c
flip NValue t f m
-> (NValue t f m -> m (WithStringContextT m Value))
-> m (WithStringContextT m Value)
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand (WithStringContextT m Value -> m (WithStringContextT m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithStringContextT m Value -> m (WithStringContextT m Value))
-> (NValue t f m -> WithStringContextT m Value)
-> NValue t f m
-> m (WithStringContextT m Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NValue t f m -> WithStringContextT m Value
forall e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
NValue t f m -> WithStringContextT m Value
nvalueToJSON)) [NValue t f m]
l
  NVSet m :: AttrSet (NValue t f m)
m _ -> case Text -> AttrSet (NValue t f m) -> Maybe (NValue t f m)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup "outPath" AttrSet (NValue t f m)
m of
    Nothing ->
      Object -> Value
A.Object
        (Object -> Value)
-> WithStringContextT m Object -> WithStringContextT m Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NValue t f m -> WithStringContextT m Value)
-> AttrSet (NValue t f m) -> WithStringContextT m Object
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (WithStringContextT m (WithStringContextT m Value)
-> WithStringContextT m Value
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (WithStringContextT m (WithStringContextT m Value)
 -> WithStringContextT m Value)
-> (NValue t f m
    -> WithStringContextT m (WithStringContextT m Value))
-> NValue t f m
-> WithStringContextT m Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m (WithStringContextT m Value)
-> WithStringContextT m (WithStringContextT m Value)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (WithStringContextT m Value)
 -> WithStringContextT m (WithStringContextT m Value))
-> (NValue t f m -> m (WithStringContextT m Value))
-> NValue t f m
-> WithStringContextT m (WithStringContextT m Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NValue t f m
 -> (NValue t f m -> m (WithStringContextT m Value))
 -> m (WithStringContextT m Value))
-> (NValue t f m -> m (WithStringContextT m Value))
-> NValue t f m
-> m (WithStringContextT m Value)
forall a b c. (a -> b -> c) -> b -> a -> c
flip NValue t f m
-> (NValue t f m -> m (WithStringContextT m Value))
-> m (WithStringContextT m Value)
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand (WithStringContextT m Value -> m (WithStringContextT m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithStringContextT m Value -> m (WithStringContextT m Value))
-> (NValue t f m -> WithStringContextT m Value)
-> NValue t f m
-> m (WithStringContextT m Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NValue t f m -> WithStringContextT m Value
forall e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
NValue t f m -> WithStringContextT m Value
nvalueToJSON)) AttrSet (NValue t f m)
m
    Just outPath :: NValue t f m
outPath -> WithStringContextT m (WithStringContextT m Value)
-> WithStringContextT m Value
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (WithStringContextT m (WithStringContextT m Value)
 -> WithStringContextT m Value)
-> WithStringContextT m (WithStringContextT m Value)
-> WithStringContextT m Value
forall a b. (a -> b) -> a -> b
$ m (WithStringContextT m Value)
-> WithStringContextT m (WithStringContextT m Value)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (WithStringContextT m Value)
 -> WithStringContextT m (WithStringContextT m Value))
-> m (WithStringContextT m Value)
-> WithStringContextT m (WithStringContextT m Value)
forall a b. (a -> b) -> a -> b
$ NValue t f m
-> (NValue t f m -> m (WithStringContextT m Value))
-> m (WithStringContextT m Value)
forall v (m :: * -> *) r. MonadValue v m => v -> (v -> m r) -> m r
demand NValue t f m
outPath (WithStringContextT m Value -> m (WithStringContextT m Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithStringContextT m Value -> m (WithStringContextT m Value))
-> (NValue t f m -> WithStringContextT m Value)
-> NValue t f m
-> m (WithStringContextT m Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NValue t f m -> WithStringContextT m Value
forall e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
NValue t f m -> WithStringContextT m Value
nvalueToJSON)
  NVPath p :: FilePath
p -> do
    FilePath
fp <- m FilePath -> WithStringContextT m FilePath
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m FilePath -> WithStringContextT m FilePath)
-> m FilePath -> WithStringContextT m FilePath
forall a b. (a -> b) -> a -> b
$ StorePath -> FilePath
unStorePath (StorePath -> FilePath) -> m StorePath -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> m StorePath
forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
FilePath -> m StorePath
addPath FilePath
p
    StringContext -> WithStringContextT m ()
forall (m :: * -> *).
Monad m =>
StringContext -> WithStringContextT m ()
addSingletonStringContext (StringContext -> WithStringContextT m ())
-> StringContext -> WithStringContextT m ()
forall a b. (a -> b) -> a -> b
$ Text -> ContextFlavor -> StringContext
StringContext (FilePath -> Text
Text.pack FilePath
fp) ContextFlavor
DirectPath
    Value -> WithStringContextT m Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> WithStringContextT m Value)
-> Value -> WithStringContextT m Value
forall a b. (a -> b) -> a -> b
$ FilePath -> Value
forall a. ToJSON a => a -> Value
A.toJSON FilePath
fp
  v :: NValue t f m
v -> m Value -> WithStringContextT m Value
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Value -> WithStringContextT m Value)
-> m Value -> WithStringContextT m Value
forall a b. (a -> b) -> a -> b
$ ValueFrame t f m -> m Value
forall s e (m :: * -> *) a.
(Framed e m, Exception s, MonadThrow m) =>
s -> m a
throwError (ValueFrame t f m -> m Value) -> ValueFrame t f m -> m Value
forall a b. (a -> b) -> a -> b
$ NValue t f m -> ValueFrame t f m
forall t (f :: * -> *) (m :: * -> *).
NValue t f m -> ValueFrame t f m
CoercionToJson NValue t f m
v