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

module Nix.Json where

import qualified Data.Aeson                    as A
import qualified Data.Aeson.Encoding           as A
import qualified Data.HashMap.Lazy             as HM
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
forall l s. LazyStrict l s => l -> s
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   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 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  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 NAtom
NNull      -> Value -> WithStringContextT m Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure   Value
A.Null
  NVStr      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 [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 NValue t f m -> WithStringContextT m Value
forall (m :: * -> *) t (f :: * -> *) e.
(Scoped (NValue t f m) m, MonadReader e m, Has e Frames,
 Has e SrcSpan, Has e Options, MonadFix m, MonadCatch m,
 Alternative m, MonadEffects t f m, MonadThunk t m (NValue t f m),
 Comonad f, Traversable f, HasCitations m (NValue t f m) t,
 HasCitations1 m (NValue t f m) f, MonadValue (NValue t f m) m,
 Applicative f, Show t, Typeable m, Typeable f, Typeable t) =>
NValue t f m -> WithStringContextT m Value
intoJson [NValue t f m]
l
  NVSet AttrSet (NValue t f m)
m AttrSet SourcePos
_ ->
    WithStringContextT m Value
-> (NValue t f m -> WithStringContextT m Value)
-> Maybe (NValue t f m)
-> WithStringContextT m Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
      (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 NValue t f m -> WithStringContextT m Value
forall (m :: * -> *) t (f :: * -> *) e.
(Scoped (NValue t f m) m, MonadReader e m, Has e Frames,
 Has e SrcSpan, Has e Options, MonadFix m, MonadCatch m,
 Alternative m, MonadEffects t f m, MonadThunk t m (NValue t f m),
 Comonad f, Traversable f, HasCitations m (NValue t f m) t,
 HasCitations1 m (NValue t f m) f, MonadValue (NValue t f m) m,
 Applicative f, Show t, Typeable m, Typeable f, Typeable t) =>
NValue t f m -> WithStringContextT m Value
intoJson AttrSet (NValue t f m)
m)
      NValue t f m -> WithStringContextT m Value
forall (m :: * -> *) t (f :: * -> *) e.
(Scoped (NValue t f m) m, MonadReader e m, Has e Frames,
 Has e SrcSpan, Has e Options, MonadFix m, MonadCatch m,
 Alternative m, MonadEffects t f m, MonadThunk t m (NValue t f m),
 Comonad f, Traversable f, HasCitations m (NValue t f m) t,
 HasCitations1 m (NValue t f m) f, MonadValue (NValue t f m) m,
 Applicative f, Show t, Typeable m, Typeable f, Typeable t) =>
NValue t f m -> WithStringContextT m Value
intoJson
      (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 Text
"outPath" AttrSet (NValue t f m)
m)
  NVPath 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
forall a. ToText a => a -> Text
toText FilePath
fp) ContextFlavor
DirectPath
      pure $ FilePath -> Value
forall a. ToJSON a => a -> Value
A.toJSON FilePath
fp
  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

 where
  intoJson :: NValue t f m -> WithStringContextT m Value
intoJson NValue t f m
nv = 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 -> 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 -> WithStringContextT m Value)
-> m (NValue t f m) -> m (WithStringContextT m Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NValue t f m -> m (NValue t f m)
forall v (m :: * -> *). MonadValue v m => v -> m v
demand NValue t f m
nv