picnoir/hnix
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Fix toJSON context handling and add test case

Browse source
This commit is contained in:
Doug Beardsley 2018-12-05 14:59:42 -05:00
parent 5c6b1ff285
commit 38147f81a9
4 changed files with 54 additions and 55 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

55
src/Nix/Builtins.hs
View file

@ -60,6 +60,7 @@ import qualified Data.HashMap.Lazy as M
import qualified Data.HashSet as HS
import Data.List
import Data.Maybe
import Data.Scientific
import Data.Set (Set)
import qualified Data.Set as S
import Data.String.Interpolate.IsString
@ -71,6 +72,7 @@ import qualified Data.Text.Lazy.Builder as Builder
import Data.These (fromThese)
import qualified Data.Time.Clock.POSIX as Time
import Data.Traversable (for, mapM)
import qualified Data.Vector as V
import Nix.Atoms
import Nix.Convert
import Nix.Effects
@ -260,9 +262,7 @@ builtinsList = sequence [
, add Normal "tail" tail_
, add0 Normal "true" (return $ nvConstant $ NBool True)
, add TopLevel "throw" throw_
, add' Normal "toJSON"
(arity1 $ principledMakeNixStringWithoutContext . decodeUtf8 . LBS.toStrict
. A.encodingToLazyByteString . toEncodingSorted)
, add Normal "toJSON" prim_toJSON
, add2 Normal "toFile" toFile
, add Normal "toPath" toPath
, add TopLevel "toString" toString
@ -1009,12 +1009,57 @@ readDir_ pathThunk = do
pure (Text.pack item, t)
toNix (M.fromList itemsWithTypes)
fromJSON :: MonadNix e m => m (NValue m) -> m (NValue m)
fromJSON :: forall e m. (MonadNix e m, Typeable m) => m (NValue m) -> m (NValue m)
fromJSON = fromValue >=> fromStringNoContext >=> \encoded ->
case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of
Left jsonError ->
throwError $ ErrorCall $ "builtins.fromJSON: " ++ jsonError
Right v -> toValue v
Right v -> jsonToNValue v
where
jsonToNValue = \case
A.Object m -> flip nvSet M.empty
<$> traverse (thunk . jsonToNValue) m
A.Array l -> nvList <$>
traverse (\x -> thunk . whileForcingThunk (CoercionFromJson @m x)
. jsonToNValue $ x) (V.toList l)
A.String s -> pure $ nvStr $ hackyMakeNixStringWithoutContext s
A.Number n -> pure $ nvConstant $ case floatingOrInteger n of
Left r -> NFloat r
Right i -> NInt i
A.Bool b -> pure $ nvConstant $ NBool b
A.Null -> pure $ nvConstant NNull
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
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)
toXML_ :: MonadNix e m => m (NValue m) -> m (NValue m)
toXML_ v = v >>= normalForm >>= \x ->

48
src/Nix/Convert.hs
View file

@ -27,23 +27,18 @@ module Nix.Convert where
import Control.Monad
import Control.Monad.Free
import Data.Aeson (toJSON)
import qualified Data.Aeson as A
import Data.ByteString
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Scientific
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import qualified Data.Vector as V
import Nix.Atoms
import Nix.Effects
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Frames
import Nix.String
import Nix.Normal
import Nix.Thunk
import Nix.Utils
import Nix.Value
@ -301,26 +296,6 @@ instance (MonadThunk (NValue m) (NThunk m) m, FromValue a m (NValue m))
fromValueMay = force ?? fromValueMay
fromValue = force ?? fromValue
instance (Convertible e m, MonadEffects m)
=> FromValue A.Value m (NValueNF m) where
fromValueMay = \case
Free (NVConstantF a) -> pure $ Just $ case a of
NInt n -> toJSON n
NFloat n -> toJSON n
NBool b -> toJSON b
NNull -> A.Null
Free (NVStrF ns) -> pure $ toJSON <$> hackyGetStringNoContext ns
Free (NVListF l) ->
fmap (A.Array . V.fromList) . sequence
<$> traverse fromValueMay l
Free (NVSetF m _) ->
fmap A.Object . sequence <$> traverse fromValueMay m
Free (NVPathF p) -> Just . toJSON . unStorePath <$> addPath p
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
_ -> throwError $ CoercionToJsonNF v
class ToValue a m v where
toValue :: a -> m v
@ -427,21 +402,6 @@ whileForcingThunk :: forall s e m r. (Framed e m, Exception s, Typeable m)
whileForcingThunk frame =
withFrame Debug (ForcingThunk @m) . withFrame Debug frame
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
=> ToValue A.Value m (NValue m) where
toValue = \case
A.Object m -> flip nvSet M.empty
<$> traverse (thunk . toValue @_ @_ @(NValue m)) m
A.Array l -> nvList <$>
traverse (\x -> thunk . whileForcingThunk (CoercionFromJson @m x)
. toValue $ x) (V.toList l)
A.String s -> pure $ nvStr $ hackyMakeNixStringWithoutContext s
A.Number n -> pure $ nvConstant $ case floatingOrInteger n of
Left r -> NFloat r
Right i -> NInt i
A.Bool b -> pure $ nvConstant $ NBool b
A.Null -> pure $ nvConstant NNull
class FromNix a m v where
fromNix :: v -> m a
default fromNix :: FromValue a m v => v -> m a
@ -491,13 +451,6 @@ instance (Convertible e m, FromValue a m (NValueNF m), Show a) => FromNix [a] m
instance Convertible e m => FromNix (HashMap Text (NValueNF m)) m (NValueNF m) where
instance Convertible e m => FromNix (HashMap Text (NValueNF m), HashMap Text SourcePos) m (NValueNF m) where
instance Convertible e m => FromNix (HashMap Text (NThunk m), HashMap Text SourcePos) m (NValue m) where
instance (Convertible e m, MonadEffects m, MonadThunk (NValue m) (NThunk m) m) => FromNix A.Value m (NValueNF m) where
instance (Convertible e m, MonadEffects m,
MonadThunk (NValue m) (NThunk m) m)
=> FromNix A.Value m (NValue m) where
fromNixMay = fromNixMay <=< normalForm
fromNix = fromNix <=< normalForm
instance (Monad m, FromNix a m v) => FromNix a m (m v) where
fromNixMay = (>>= fromNixMay)
@ -551,7 +504,6 @@ instance Applicative m => ToNix Path m (NValue m) where
instance Applicative m => ToNix (HashMap Text (NValueNF m)) m (NValueNF m) where
instance Applicative m => ToNix (HashMap Text (NValueNF m), HashMap Text SourcePos) m (NValueNF m) where
instance Applicative m => ToNix (HashMap Text (NThunk m), HashMap Text SourcePos) m (NValue m) where
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m) => ToNix A.Value m (NValue m) where
instance Applicative m => ToNix Bool m (NExprF r) where
instance Applicative m => ToNix () m (NExprF r) where

4
src/Nix/Render/Frame.hs
View file

@ -153,7 +153,9 @@ renderValueFrame level = fmap (:[]) . \case
desc | level <= Error = "Cannot coerce "
| otherwise = "While coercing "
CoercionToJsonNF _v -> pure "CoercionToJsonNF"
CoercionToJson v -> do
v' <- renderValue level "" "" v
pure $ "CoercionToJson " <> v'
CoercionFromJson _j -> pure "CoercionFromJson"
ExpectationNF _t _v -> pure "ExpectationNF"
Expectation t v -> do

2
src/Nix/Value.hs
View file

@ -355,7 +355,7 @@ data ValueFrame m
| Multiplication (NValue m) (NValue m)
| Division (NValue m) (NValue m)
| Coercion ValueType ValueType
| CoercionToJsonNF (NValueNF m)
| CoercionToJson (NValue m)
| CoercionFromJson A.Value
| ExpectationNF ValueType (NValueNF m)
| Expectation ValueType (NValue m)