Use WithStringContext(T) for nvalueToJSON

main/Main.hs

@@ -13,7 +13,6 @@ import           Control.Monad
 import           Control.Monad.Catch
 import           Control.Monad.IO.Class
 -- import           Control.Monad.ST
-import qualified Data.Aeson.Encoding as A
 import qualified Data.Aeson.Text as A
 import qualified Data.HashMap.Lazy as M
 import qualified Data.Map as Map
@@ -22,7 +21,6 @@ import           Data.Maybe (fromJust)
 import           Data.Time
 import qualified Data.Text as Text
 import qualified Data.Text.IO as Text
-import qualified Data.Text.Lazy.Encoding as TL
 import qualified Data.Text.Lazy.IO as TL
 import           Data.Text.Prettyprint.Doc
 import           Data.Text.Prettyprint.Doc.Render.Text
@@ -142,12 +140,9 @@ main = do
             | xml opts =
               liftIO . putStrLn . Text.unpack . principledStringIgnoreContext . toXML <=< normalForm
             | json opts =
-              liftIO . TL.putStrLn
-                     . TL.decodeUtf8
-                     . A.encodingToLazyByteString
-                     . toEncodingSorted
-                     . snd
-                     <=< nvalueToJSON
+              liftIO . Text.putStrLn
+                     . principledStringIgnoreContext
+                     <=< nvalueToJSONNixString
             | strict opts =
               liftIO . print . prettyNValueNF <=< normalForm
             | values opts  =

src/Nix/Builtins.hs

@@ -45,14 +45,12 @@ import qualified "cryptohash-sha512" Crypto.Hash.SHA512 as SHA512
 #endif
 
 import qualified Data.Aeson as A
-import qualified Data.Aeson.Encoding as A
 import           Data.Align (alignWith)
 import           Data.Array
 import           Data.Bits
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as B
 import           Data.ByteString.Base16 as Base16
-import qualified Data.ByteString.Lazy as LBS
 import           Data.Char (isDigit)
 import           Data.Fix
 import           Data.Foldable (foldrM)
@@ -1033,10 +1031,7 @@ prim_toJSON
   :: MonadNix e m
   => m (NValue m)
   -> m (NValue m)
-prim_toJSON x = do
-  (ctx, v) <- nvalueToJSON =<< x
-  let t = decodeUtf8 $ LBS.toStrict $ A.encodingToLazyByteString $ toEncodingSorted v
-  pure $ nvStr $ principledMakeNixString t ctx
+prim_toJSON x = x >>= nvalueToJSONNixString >>= pure . nvStr
 
 toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m)
 toXML_ v = v >>= normalForm >>= pure . nvStr . toXML

src/Nix/Json.hs

@@ -1,10 +1,15 @@
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Nix.Json where
 
+import           Control.Monad
+import           Control.Monad.Trans
 import qualified Data.Aeson as A
-import qualified Data.HashSet as HS
+import qualified Data.Aeson.Encoding as A
 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
@@ -12,27 +17,29 @@ import           Nix.Exec
 import           Nix.Frames
 import           Nix.String
 import           Nix.Thunk
+import           Nix.Utils
 import           Nix.Value
 
-nvalueToJSON
-  :: MonadNix e m
-  => NValue m
-  -> m (HS.HashSet StringContext, A.Value)
-nvalueToJSON v = case v of
-    NVConstant a -> retEmpty $ case a of
-        NInt n   -> A.toJSON n
-        NFloat n -> A.toJSON n
-        NBool b  -> A.toJSON b
-        NNull    -> A.Null
-    NVStr ns  -> pure (principledGetContext ns, A.toJSON $ principledStringIgnoreContext ns)
-    NVList l  -> do
-        (ctxs, vals) <- unzip <$> traverse (`force` nvalueToJSON) l
-        return (HS.unions ctxs, A.Array $ V.fromList vals)
-    NVSet m _ ->
-        fmap A.Object . sequence <$> traverse (`force` nvalueToJSON) m
-    NVPath p  -> do
-      fp <- unStorePath <$> addPath p
-      return (HS.singleton $ StringContext (Text.pack fp) DirectPath, A.toJSON fp)
-    _ -> throwError $ CoercionToJson v
-  where
-    retEmpty a = pure (mempty, a)
+nvalueToJSONNixString :: MonadNix e m => NValue m -> m NixString
+nvalueToJSONNixString = runWithStringContextT
+  . fmap (TL.toStrict . TL.decodeUtf8 . A.encodingToLazyByteString . toEncodingSorted)
+  . nvalueToJSON
+
+nvalueToJSON :: MonadNix e m => NValue m -> WithStringContextT m A.Value
+nvalueToJSON = \case
+  NVConstant (NInt n) -> pure $ A.toJSON n
+  NVConstant (NFloat n) -> pure $ A.toJSON n
+  NVConstant (NBool b) -> pure $ A.toJSON b
+  NVConstant NNull -> pure $ A.Null
+  NVStr ns  -> do
+    addStringContext $ principledGetContext ns
+    return $ A.toJSON $ principledStringIgnoreContext ns
+  NVList l  ->
+    A.Array . V.fromList <$> traverse (join . lift . flip force (return . nvalueToJSON)) l
+  NVSet m _ ->
+    A.Object <$> traverse (join . lift . flip force (return . nvalueToJSON)) m
+  NVPath p  -> do
+    fp <- lift $ unStorePath <$> addPath p
+    addSingletonStringContext $ StringContext (Text.pack fp) DirectPath
+    return $ A.toJSON fp
+  v -> lift $ throwError $ CoercionToJson v

src/Nix/String.hs

@@ -23,11 +23,16 @@ module Nix.String (
   , principledStringMempty
   , principledStringMConcat
   , WithStringContext
+  , WithStringContextT
   , extractNixString
+  , addStringContext
+  , addSingletonStringContext
+  , runWithStringContextT
   , runWithStringContext
 ) where
 
 import           Control.Monad.Writer
+import           Data.Functor.Identity
 import qualified Data.HashSet as S
 import           Data.Hashable
 import           Data.Text (Text)
@@ -145,13 +150,27 @@ principledMakeNixString :: Text -> S.HashSet StringContext -> NixString
 principledMakeNixString s c = NixString s c
 
 -- | A monad for accumulating string context while producing a result string.
-newtype WithStringContext a = WithStringContext (Writer (S.HashSet StringContext) a)
-  deriving (Functor, Applicative, Monad, MonadWriter (S.HashSet StringContext))
+newtype WithStringContextT m a = WithStringContextT (WriterT (S.HashSet StringContext) m a)
+  deriving (Functor, Applicative, Monad, MonadTrans, MonadWriter (S.HashSet StringContext))
+
+type WithStringContext = WithStringContextT Identity
+
+-- | Add 'StringContext's into the resulting set.
+addStringContext :: Monad m => S.HashSet StringContext -> WithStringContextT m ()
+addStringContext = WithStringContextT . tell
+
+-- | Add a 'StringContext' into the resulting set.
+addSingletonStringContext :: Monad m => StringContext -> WithStringContextT m ()
+addSingletonStringContext = WithStringContextT . tell . S.singleton
 
 -- | Get the contents of a 'NixString' and write its context into the resulting set.
-extractNixString :: NixString -> WithStringContext Text
-extractNixString (NixString s c) = WithStringContext $ tell c >> return s
+extractNixString :: Monad m => NixString -> WithStringContextT m Text
+extractNixString (NixString s c) = WithStringContextT $ tell c >> return s
 
 -- | Run an action producing a string with a context and put those into a 'NixString'.
-runWithStringContext :: WithStringContext Text -> NixString
-runWithStringContext (WithStringContext m) = uncurry NixString $ runWriter m
+runWithStringContextT :: Monad m => WithStringContextT m Text -> m NixString
+runWithStringContextT (WithStringContextT m) = uncurry NixString <$> runWriterT m
+
+-- | Run an action producing a string with a context and put those into a 'NixString'.
+runWithStringContext :: WithStringContextT Identity Text -> NixString
+runWithStringContext = runIdentity . runWithStringContextT