Use WithStringContext(T) for nvalueToJSON

This commit is contained in:
Ken Micklas 2018-12-12 18:54:17 -05:00
parent e360468c20
commit ad0d2d2bf8
4 changed files with 59 additions and 43 deletions

View file

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

View file

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

View file

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

View file

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