{-# language CPP #-}

module Nix.Json where

import           Nix.Prelude
import qualified Data.Aeson                    as A
import qualified Data.Aeson.Encoding           as A
import qualified Data.Vector                   as V
import qualified Data.HashMap.Strict           as HM
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.Key                as AKM
import qualified Data.Aeson.KeyMap             as AKM
#endif
import           Nix.Atoms
import           Nix.Effects
import           Nix.Exec
import           Nix.Frames
import           Nix.String
import           Nix.Value
import           Nix.Value.Monad
import           Nix.Expr.Types

-- This was moved from Utils.
toEncodingSorted :: A.Value -> A.Encoding
toEncodingSorted :: Value -> Encoding
toEncodingSorted = \case
  A.Object Object
m ->
    Series -> Encoding
A.pairs
      (Series -> Encoding)
-> ([(Key, Value)] -> Series) -> [(Key, Value)] -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
      ([Series] -> Series)
-> ([(Key, Value)] -> [Series]) -> [(Key, Value)] -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((\(Key
k, Value
v) -> Key -> Encoding -> Series
A.pair Key
k (Encoding -> Series) -> Encoding -> Series
forall a b. (a -> b) -> a -> b
$ Value -> Encoding
toEncodingSorted Value
v) ((Key, Value) -> Series) -> [(Key, Value)] -> [Series]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
      ([(Key, Value)] -> [Series])
-> ([(Key, Value)] -> [(Key, Value)]) -> [(Key, Value)] -> [Series]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Key, Value) -> Key) -> [(Key, Value)] -> [(Key, Value)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortWith (Key, Value) -> Key
forall a b. (a, b) -> a
fst ([(Key, Value)] -> Encoding) -> [(Key, Value)] -> Encoding
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_aeson(2,0,0)
          Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
AKM.toList
#else
          HM.toList
#endif
            Object
m
  A.Array Array
l -> (Value -> Encoding) -> [Value] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
A.list Value -> Encoding
toEncodingSorted ([Value] -> Encoding) -> [Value] -> Encoding
forall a b. (a -> b) -> a -> b
$ Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
l
  Value
v         -> Value -> Encoding
forall a. ToJSON a => a -> Encoding
A.toEncoding Value
v

toJSONNixString :: MonadNix e t f m => NValue t f m -> m NixString
toJSONNixString :: NValue t f m -> m NixString
toJSONNixString =
  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
      ( ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8
      -- This is completely not optimal, but seems we do not have better encoding analog (except for @unsafe*@), Aeson gatekeeps through this.
      (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding -> ByteString
forall a. Encoding' a -> ByteString
A.encodingToLazyByteString
      (Encoding -> ByteString)
-> (Value -> Encoding) -> Value -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Encoding
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
toJSON

toJSON :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value
toJSON :: NValue t f m -> WithStringContextT m Value
toJSON = \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 e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
NValue t f m -> WithStringContextT m Value
intoJson [NValue t f m]
l
  NVSet PositionSet
_ AttrSet (NValue t f m)
m ->
    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)
-> KeyMap (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 e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
NValue t f m -> WithStringContextT m Value
intoJson KeyMap (NValue t f m)
kmap)
      NValue t f m -> WithStringContextT m Value
forall e t (f :: * -> *) (m :: * -> *).
MonadNix e t f m =>
NValue t f m -> WithStringContextT m Value
intoJson
      (Key -> KeyMap (NValue t f m) -> Maybe (NValue t f m)
forall v. Key -> KeyMap v -> Maybe v
lkup Key
"outPath" KeyMap (NValue t f m)
kmap)
   where
#if MIN_VERSION_aeson(2,0,0)
    lkup :: Key -> KeyMap v -> Maybe v
lkup = Key -> KeyMap v -> Maybe v
forall v. Key -> KeyMap v -> Maybe v
AKM.lookup
    kmap :: KeyMap (NValue t f m)
kmap = HashMap Key (NValue t f m) -> KeyMap (NValue t f m)
forall v. HashMap Key v -> KeyMap v
AKM.fromHashMap (HashMap Key (NValue t f m) -> KeyMap (NValue t f m))
-> HashMap Key (NValue t f m) -> KeyMap (NValue t f m)
forall a b. (a -> b) -> a -> b
$ (VarName -> Key)
-> AttrSet (NValue t f m) -> HashMap Key (NValue t f m)
forall k2 k1 v.
(Eq k2, Hashable k2) =>
(k1 -> k2) -> HashMap k1 v -> HashMap k2 v
HM.mapKeys (Text -> Key
AKM.fromText (Text -> Key) -> (VarName -> Text) -> VarName -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VarName -> Text
coerce) AttrSet (NValue t f m)
m
#else
    lkup = HM.lookup
    kmap = HM.mapKeys (coerce @VarName @Text) m
#endif
  NVPath Path
p ->
    do
      String
fp <- m String -> WithStringContextT m String
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m String -> WithStringContextT m String)
-> m String -> WithStringContextT m String
forall a b. (a -> b) -> a -> b
$ StorePath -> String
coerce (StorePath -> String) -> m StorePath -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path -> m StorePath
forall e (m :: * -> *).
(Framed e m, MonadStore m) =>
Path -> m StorePath
addPath Path
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
$ ContextFlavor -> VarName -> StringContext
StringContext ContextFlavor
DirectPath (VarName -> StringContext) -> VarName -> StringContext
forall a b. (a -> b) -> a -> b
$ String -> VarName
forall a. IsString a => String -> a
fromString String
fp
      pure $ String -> Value
forall a. ToJSON a => a -> Value
A.toJSON String
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 :: MonadNix e t f m => NValue t f m -> WithStringContextT m A.Value
  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
toJSON (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