Use WithStringContext(T) for nvalueToJSON
This commit is contained in:
parent
e360468c20
commit
ad0d2d2bf8
11
main/Main.hs
11
main/Main.hs
|
@ -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 =
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue