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

Change NValueNF to use Free instead of Fix 

This allows us to detect and report cycles during normalization.

See #348
This commit is contained in:
John Wiegley 2018-08-09 22:09:00 -04:00
parent 266793a287
commit f0b6b6b223
No known key found for this signature in database
GPG Key ID: C144D8F4F19FE630
9 changed files with 162 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
hnix.cabal
View File

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 6d8b6df867ed451ea735063f46d5ff612f0f9f8433b6bed92ff64d66ab9f2558
-- hash: 3ca81d4efceb654f9c796b7812fa26a3604be30b5891e92a1b617b24f82ca9af
name: hnix
version: 0.5.2
@ -497,6 +497,7 @@ library
, directory
, exceptions
, filepath
, free
, hashing
, http-client
, http-client-tls

1
package.yaml
View File

@ -103,6 +103,7 @@ library:
- binary
- deriving-compat >= 0.3 && < 0.6
- directory
- free
- http-types
- http-client
- http-client-tls

3
src/Nix.hs
View File

@ -23,6 +23,7 @@ module Nix (module Nix.Cache,
import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Free
import Control.Monad.Reader
import Data.Fix
import qualified Data.HashMap.Lazy as M
@ -94,7 +95,7 @@ evaluateExpression mpath evaluator handler expr = do
eval' = (normalForm =<<) . nixEvalExpr mpath
argmap args = embed $ Fix $ NVSetF (M.fromList args) mempty
argmap args = embed $ Free $ NVSetF (M.fromList args) mempty
compute ev x args p = do
f <- ev mpath x

83
src/Nix/Convert.hs
View File

@ -26,10 +26,10 @@
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.Fix
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Scientific
@ -55,7 +55,7 @@ type Convertible e m = (Framed e m, MonadVar m, Typeable m)
instance Convertible e m => FromValue () m (NValueNF m) where
fromValueMay = \case
Fix (NVConstantF NNull) -> pure $ Just ()
Free (NVConstantF NNull) -> pure $ Just ()
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -73,7 +73,7 @@ instance Convertible e m
instance Convertible e m
=> FromValue Bool m (NValueNF m) where
fromValueMay = \case
Fix (NVConstantF (NBool b)) -> pure $ Just b
Free (NVConstantF (NBool b)) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -91,7 +91,7 @@ instance Convertible e m
instance Convertible e m
=> FromValue Int m (NValueNF m) where
fromValueMay = \case
Fix (NVConstantF (NInt b)) -> pure $ Just (fromInteger b)
Free (NVConstantF (NInt b)) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -109,7 +109,7 @@ instance Convertible e m
instance Convertible e m
=> FromValue Integer m (NValueNF m) where
fromValueMay = \case
Fix (NVConstantF (NInt b)) -> pure $ Just b
Free (NVConstantF (NInt b)) -> pure $ Just b
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -127,8 +127,8 @@ instance Convertible e m
instance Convertible e m
=> FromValue Float m (NValueNF m) where
fromValueMay = \case
Fix (NVConstantF (NFloat b)) -> pure $ Just b
Fix (NVConstantF (NInt i)) -> pure $ Just (fromInteger i)
Free (NVConstantF (NFloat b)) -> pure $ Just b
Free (NVConstantF (NInt i)) -> pure $ Just (fromInteger i)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -147,9 +147,9 @@ instance Convertible e m
instance (Convertible e m, MonadEffects m)
=> FromValue Text m (NValueNF m) where
fromValueMay = \case
Fix (NVStrF t _) -> pure $ Just t
Fix (NVPathF p) -> Just . Text.pack . unStorePath <$> addPath p
Fix (NVSetF s _) -> case M.lookup "outPath" s of
Free (NVStrF t _) -> pure $ Just t
Free (NVPathF p) -> Just . Text.pack . unStorePath <$> addPath p
Free (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Text p
_ -> pure Nothing
@ -173,9 +173,9 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
instance (Convertible e m, MonadEffects m)
=> FromValue (Text, DList Text) m (NValueNF m) where
fromValueMay = \case
Fix (NVStrF t d) -> pure $ Just (t, d)
Fix (NVPathF p) -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
Fix (NVSetF s _) -> case M.lookup "outPath" s of
Free (NVStrF t d) -> pure $ Just (t, d)
Free (NVPathF p) -> Just . (,mempty) . Text.pack . unStorePath <$> addPath p
Free (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fmap (,mempty) <$> fromValueMay @Text p
_ -> pure Nothing
@ -199,7 +199,7 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
instance Convertible e m
=> FromValue ByteString m (NValueNF m) where
fromValueMay = \case
Fix (NVStrF t _) -> pure $ Just (encodeUtf8 t)
Free (NVStrF t _) -> pure $ Just (encodeUtf8 t)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -219,9 +219,9 @@ newtype Path = Path { getPath :: FilePath }
instance Convertible e m => FromValue Path m (NValueNF m) where
fromValueMay = \case
Fix (NVPathF p) -> pure $ Just (Path p)
Fix (NVStrF s _) -> pure $ Just (Path (Text.unpack s))
Fix (NVSetF s _) -> case M.lookup "outPath" s of
Free (NVPathF p) -> pure $ Just (Path p)
Free (NVStrF s _) -> pure $ Just (Path (Text.unpack s))
Free (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
_ -> pure Nothing
@ -245,7 +245,7 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
instance (Convertible e m, FromValue a m (NValueNF m), Show a)
=> FromValue [a] m (NValueNF m) where
fromValueMay = \case
Fix (NVListF l) -> sequence <$> traverse fromValueMay l
Free (NVListF l) -> sequence <$> traverse fromValueMay l
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -262,7 +262,7 @@ instance Convertible e m => FromValue [NThunk m] m (NValue m) where
instance Convertible e m
=> FromValue (HashMap Text (NValueNF m)) m (NValueNF m) where
fromValueMay = \case
Fix (NVSetF s _) -> pure $ Just s
Free (NVSetF s _) -> pure $ Just s
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -281,7 +281,7 @@ instance Convertible e m
=> FromValue (HashMap Text (NValueNF m),
HashMap Text SourcePos) m (NValueNF m) where
fromValueMay = \case
Fix (NVSetF s p) -> pure $ Just (s, p)
Free (NVSetF s p) -> pure $ Just (s, p)
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -316,18 +316,19 @@ instance (MonadThunk (NValue m) (NThunk m) m, FromValue a m (NValue m))
instance (Convertible e m, MonadEffects m)
=> FromValue A.Value m (NValueNF m) where
fromValueMay = \case
Fix (NVConstantF a) -> pure $ Just $ case a of
Free (NVConstantF a) -> pure $ Just $ case a of
NInt n -> toJSON n
NFloat n -> toJSON n
NBool b -> toJSON b
NNull -> A.Null
Fix (NVStrF s _) -> pure $ Just $ toJSON s
Fix (NVListF l) -> fmap (A.Array . V.fromList) . sequence
<$> traverse fromValueMay l
Fix (NVSetF m _) -> fmap A.Object . sequence <$> traverse fromValueMay m
Fix NVClosureF {} -> pure Nothing
Fix (NVPathF p) -> Just . toJSON . unStorePath <$> addPath p
Fix (NVBuiltinF _ _) -> pure Nothing
Free (NVStrF s _) -> pure $ Just $ toJSON s
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
@ -336,55 +337,55 @@ class ToValue a m v where
toValue :: a -> m v
instance Applicative m => ToValue () m (NValueNF m) where
toValue _ = pure . Fix . NVConstantF $ NNull
toValue _ = pure . Free . NVConstantF $ NNull
instance Applicative m => ToValue () m (NValue m) where
toValue _ = pure . nvConstant $ NNull
instance Applicative m => ToValue Bool m (NValueNF m) where
toValue = pure . Fix . NVConstantF . NBool
toValue = pure . Free . NVConstantF . NBool
instance Applicative m => ToValue Bool m (NValue m) where
toValue = pure . nvConstant . NBool
instance Applicative m => ToValue Int m (NValueNF m) where
toValue = pure . Fix . NVConstantF . NInt . toInteger
toValue = pure . Free . NVConstantF . NInt . toInteger
instance Applicative m => ToValue Int m (NValue m) where
toValue = pure . nvConstant . NInt . toInteger
instance Applicative m => ToValue Integer m (NValueNF m) where
toValue = pure . Fix . NVConstantF . NInt
toValue = pure . Free . NVConstantF . NInt
instance Applicative m => ToValue Integer m (NValue m) where
toValue = pure . nvConstant . NInt
instance Applicative m => ToValue Float m (NValueNF m) where
toValue = pure . Fix . NVConstantF . NFloat
toValue = pure . Free . NVConstantF . NFloat
instance Applicative m => ToValue Float m (NValue m) where
toValue = pure . nvConstant . NFloat
instance Applicative m => ToValue Text m (NValueNF m) where
toValue = pure . Fix . flip NVStrF mempty
toValue = pure . Free . flip NVStrF mempty
instance Applicative m => ToValue Text m (NValue m) where
toValue = pure . flip nvStr mempty
instance Applicative m => ToValue (Text, DList Text) m (NValueNF m) where
toValue = pure . Fix . uncurry NVStrF
toValue = pure . Free . uncurry NVStrF
instance Applicative m => ToValue (Text, DList Text) m (NValue m) where
toValue = pure . uncurry nvStr
instance Applicative m => ToValue ByteString m (NValueNF m) where
toValue = pure . Fix . flip NVStrF mempty . decodeUtf8
toValue = pure . Free . flip NVStrF mempty . decodeUtf8
instance Applicative m => ToValue ByteString m (NValue m) where
toValue = pure . flip nvStr mempty . decodeUtf8
instance Applicative m => ToValue Path m (NValueNF m) where
toValue = pure . Fix . NVPathF . getPath
toValue = pure . Free . NVPathF . getPath
instance Applicative m => ToValue Path m (NValue m) where
toValue = pure . nvPath . getPath
@ -403,21 +404,21 @@ instance MonadThunk (NValue m) (NThunk m) m
instance (ToValue a m (NValueNF m), Applicative m)
=> ToValue [a] m (NValueNF m) where
toValue = fmap (Fix . NVListF) . traverse toValue
toValue = fmap (Free . NVListF) . traverse toValue
instance Applicative m => ToValue [NThunk m] m (NValue m) where
toValue = pure . nvList
instance Applicative m
=> ToValue (HashMap Text (NValueNF m)) m (NValueNF m) where
toValue = pure . Fix . flip NVSetF M.empty
toValue = pure . Free . flip NVSetF M.empty
instance Applicative m => ToValue (HashMap Text (NThunk m)) m (NValue m) where
toValue = pure . flip nvSet M.empty
instance Applicative m => ToValue (HashMap Text (NValueNF m),
HashMap Text SourcePos) m (NValueNF m) where
toValue (s, p) = pure $ Fix $ NVSetF s p
toValue (s, p) = pure $ Free $ NVSetF s p
instance Applicative m => ToValue (HashMap Text (NThunk m),
HashMap Text SourcePos) m (NValue m) where
@ -574,7 +575,7 @@ instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
toNix = thunk . toNix
instance (Applicative m, ToNix a m (NValueNF m)) => ToNix [a] m (NValueNF m) where
toNix = fmap (Fix . NVListF) . traverse toNix
toNix = fmap (Free . NVListF) . traverse toNix
instance MonadThunk (NValue m) (NThunk m) m => ToNix (NThunk m) m (NValue m) where
toNix = force ?? pure

5
src/Nix/Eval.hs
View File

@ -308,9 +308,8 @@ evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v) -> m (Maybe Text)
evalSetterKeyName = \case
StaticKey k -> pure (Just k)
DynamicKey k -> runAntiquoted "\n" assembleString (>>= fromValueMay) k
<&> \case Just (t, _) -> Just t
_ -> Nothing
DynamicKey k ->
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&> fmap fst
assembleString :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NString (m v) -> m (Maybe (Text, DList Text))

30
src/Nix/Normal.hs
View File

@ -13,7 +13,7 @@
module Nix.Normal where
import Control.Monad
import Data.Fix
import Control.Monad.Free
import qualified Data.HashMap.Lazy as M
import Data.Text (Text)
import qualified Data.Text as Text
@ -39,22 +39,22 @@ normalFormBy
normalFormBy k n v = do
-- doc <- prettyNValue v
-- traceM $ show n ++ ": normalFormBy: " ++ show doc
unless (n < 2000) $
throwError $ NormalLoop v
case v of
NVConstant a -> return $ Fix $ NVConstantF a
NVStr t s -> return $ Fix $ NVStrF t s
if n > 2000
then return $ Pure v
else case v of
NVConstant a -> return $ Free $ NVConstantF a
NVStr t s -> return $ Free $ NVStrF t s
NVList l ->
fmap (Fix . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
fmap (Free . NVListF) $ forM (zip [0..] l) $ \(i :: Int, t) -> do
traceM $ show n ++ ": normalFormBy: List[" ++ show i ++ "]"
t `k` normalFormBy k (succ n)
NVSet s p ->
fmap (Fix . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \ky t -> do
fmap (Free . flip NVSetF p) $ sequence $ flip M.mapWithKey s $ \ky t -> do
traceM $ show n ++ ": normalFormBy: Set{" ++ show ky ++ "}"
t `k` normalFormBy k (succ n)
NVClosure p f -> return $ Fix $ NVClosureF p f
NVPath fp -> return $ Fix $ NVPathF fp
NVBuiltin name f -> return $ Fix $ NVBuiltinF name f
NVClosure p f -> return $ Free $ NVClosureF p f
NVPath fp -> return $ Free $ NVPathF fp
NVBuiltin name f -> return $ Free $ NVBuiltinF name f
_ -> error "Pattern synonyms mask complete matches"
normalForm :: (Framed e m, MonadVar m, Typeable m,
@ -64,7 +64,8 @@ normalForm = normalFormBy force 0
embed :: forall m. (MonadThunk (NValue m) (NThunk m) m)
=> NValueNF m -> m (NValue m)
embed (Fix x) = case x of
embed (Pure v) = return v
embed (Free x) = case x of
NVConstantF a -> return $ nvConstant a
NVStrF t s -> return $ nvStr t s
NVListF l -> nvList . fmap (value @_ @_ @m) <$> traverse embed l
@ -75,8 +76,11 @@ embed (Fix x) = case x of
valueText :: forall e m. (Framed e m, MonadEffects m, Typeable m)
=> Bool -> NValueNF m -> m (Text, DList Text)
valueText addPathsToStore = cata phi
valueText addPathsToStore = iter phi . check
where
check :: NValueNF m -> Free (NValueF m) (m (Text, DList Text))
check = fmap (const $ pure ("<CYCLE>", mempty))
phi :: NValueF m (m (Text, DList Text)) -> m (Text, DList Text)
phi (NVConstantF a) = pure (atomText a, mempty)
phi (NVStrF t c) = pure (t, c)

69
src/Nix/Pretty.hs
View File

@ -13,6 +13,7 @@
module Nix.Pretty where
import Control.Monad
import Control.Monad.Free
import Data.Fix
import Data.HashMap.Lazy (toList)
import qualified Data.HashMap.Lazy as M
@ -234,42 +235,56 @@ exprFNixDoc = \case
where
recPrefix = text "rec" <> space
fixate :: Functor f => (a -> f (Fix f)) -> Free f a -> Fix f
fixate g = Fix . go
where
go (Pure a) = g a
go (Free f) = fmap (Fix . go) f
prettyNValueNF :: Functor m => NValueNF m -> Doc
prettyNValueNF = prettyNix . valueToExpr
where valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = transport go
where
check :: NValueNF m -> Fix (NValueF m)
check = fixate (const (NVStrF "<CYCLE>" mempty))
go (NVConstantF a) = NConstant a
go (NVStrF t _) = NStr (DoubleQuoted [Plain t])
go (NVListF l) = NList l
go (NVSetF s p) = NSet
[ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p))
| (k, v) <- toList s ]
go (NVClosureF _ _) = NSym . pack $ "<closure>"
go (NVPathF p) = NLiteralPath p
go (NVBuiltinF name _) = NSym $ Text.pack $ "builtins." ++ name
valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = transport go . check
go (NVConstantF a) = NConstant a
go (NVStrF t _) = NStr (DoubleQuoted [Plain t])
go (NVListF l) = NList l
go (NVSetF s p) = NSet
[ NamedVar (StaticKey k :| []) v (fromMaybe nullPos (M.lookup k p))
| (k, v) <- toList s ]
go (NVClosureF _ _) = NSym . pack $ "<closure>"
go (NVPathF p) = NLiteralPath p
go (NVBuiltinF name _) = NSym $ Text.pack $ "builtins." ++ name
printNix :: Functor m => NValueNF m -> String
printNix = cata phi
where phi :: NValueF m String -> String
phi (NVConstantF a) = unpack $ atomText a
phi (NVStrF t _) = show t
phi (NVListF l) = "[ " ++ unwords l ++ " ]"
phi (NVSetF s _) =
"{ " ++ concat [ unpack k ++ " = " ++ v ++ "; "
| (k, v) <- sort $ toList s ] ++ "}"
phi NVClosureF {} = "<<lambda>>"
phi (NVPathF fp) = fp
phi (NVBuiltinF name _) = "<<builtin " ++ name ++ ">>"
printNix = iter phi . check
where
check :: NValueNF m -> Free (NValueF m) String
check = fmap (const "<CYCLE>")
phi :: NValueF m String -> String
phi (NVConstantF a) = unpack $ atomText a
phi (NVStrF t _) = show t
phi (NVListF l) = "[ " ++ unwords l ++ " ]"
phi (NVSetF s _) =
"{ " ++ concat [ unpack k ++ " = " ++ v ++ "; "
| (k, v) <- sort $ toList s ] ++ "}"
phi NVClosureF {} = "<<lambda>>"
phi (NVPathF fp) = fp
phi (NVBuiltinF name _) = "<<builtin " ++ name ++ ">>"
removeEffects :: Functor m => NValueF m (NThunk m) -> NValueNF m
removeEffects = Fix . fmap dethunk
removeEffects = Free . fmap dethunk
where
dethunk (NThunk _ (Value v)) = removeEffects (_baseValue v)
dethunk (NThunk _ _) = Fix $ NVStrF "<thunk>" mempty
dethunk (NThunk _ _) = Free $ NVStrF "<thunk>" mempty
removeEffectsM :: MonadVar m => NValueF m (NThunk m) -> m (NValueNF m)
removeEffectsM = fmap Fix . traverse dethunk
removeEffectsM = fmap Free . traverse dethunk
prettyNValueF :: MonadVar m => NValueF m (NThunk m) -> m Doc
prettyNValueF = fmap prettyNValueNF . removeEffectsM
@ -298,9 +313,9 @@ dethunk = \case
NThunk _ (Thunk _ active ref) -> do
nowActive <- atomicModifyVar active (True,)
if nowActive
then pure $ Fix $ NVStrF "<thunk>" mempty
then pure $ Free $ NVStrF "<thunk>" mempty
else do
eres <- readVar ref
case eres of
Computed v -> removeEffectsM (_baseValue v)
_ -> pure $ Fix $ NVStrF "<thunk>" mempty
_ -> pure $ Free $ NVStrF "<thunk>" mempty

27
src/Nix/Value.hs
View File

@ -1,6 +1,7 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
@ -15,6 +16,7 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
@ -26,11 +28,13 @@ module Nix.Value where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Free
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import qualified Data.Aeson as A
import Data.Align
import Data.Fix
import Data.Functor.Classes
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.Hashable
@ -85,8 +89,11 @@ data NValueF m r
-- has yet to be performed. An 'NThunk m' is either a pending evaluation, or
-- a value in head normal form. A 'NThunkSet' is a set of mappings from keys
-- to thunks.
--
-- The 'Free' structure is used here to represent the possibility that
-- cycles may appear during normalization.
type NValueNF m = Fix (NValueF m) -- normal form
type NValueNF m = Free (NValueF m) (NValue m)
type ValueSet m = AttrSet (NThunk m)
data Provenance m = Provenance
@ -214,7 +221,7 @@ builtin3 name f =
builtin name $ \a -> builtin name $ \b -> builtin name $ \c -> f a b c
isClosureNF :: Monad m => NValueNF m -> Bool
isClosureNF (Fix NVClosureF {}) = True
isClosureNF (Free NVClosureF {}) = True
isClosureNF _ = False
thunkEq :: MonadThunk (NValue m) (NThunk m) m
@ -315,6 +322,22 @@ instance Show (NThunk m) where
show (NThunk _ (Value v)) = show v
show (NThunk _ _) = "<thunk>"
instance Eq1 (NValueF m) where
liftEq _ (NVConstantF x) (NVConstantF y) = x == y
liftEq _ (NVStrF x _) (NVStrF y _) = x == y
liftEq _ (NVPathF x) (NVPathF y) = x == y
liftEq _ _ _ = False
instance Show1 (NValueF m) where
liftShowsPrec sp sl p = \case
NVConstantF atom -> showsUnaryWith showsPrec "NVConstantF" p atom
NVStrF txt _ -> showsUnaryWith showsPrec "NVStrF" p txt
NVListF lst -> showsUnaryWith (liftShowsPrec sp sl) "NVListF" p lst
NVSetF attrs _ -> showsUnaryWith (liftShowsPrec sp sl) "NVSetF" p attrs
NVClosureF c _ -> showsUnaryWith showsPrec "NVClosureF" p c
NVPathF path -> showsUnaryWith showsPrec "NVPathF" p path
NVBuiltinF name _ -> showsUnaryWith showsPrec "NVBuiltinF" p name
data ValueFrame m
= ForcingThunk
| ConcerningValue (NValue m)

51
src/Nix/XML.hs
View File

@ -2,7 +2,7 @@
module Nix.XML where
import Data.Fix
import Control.Monad.Free
import qualified Data.HashMap.Lazy as M
import Data.List
import Data.Ord
@ -13,30 +13,37 @@ import Nix.Value
import Text.XML.Light
toXML :: Functor m => NValueNF m -> String
toXML = (.) ((++ "\n") .
("<?xml version='1.0' encoding='utf-8'?>\n" ++) .
ppElement .
(\e -> Element (unqual "expr") [] [Elem e] Nothing))
$ cata
$ \case
NVConstantF a -> case a of
NInt n -> mkElem "int" "value" (show n)
NFloat f -> mkElem "float" "value" (show f)
NBool b -> mkElem "bool" "value" (if b then "true" else "false")
NNull -> Element (unqual "null") [] [] Nothing
toXML = ("<?xml version='1.0' encoding='utf-8'?>\n" ++)
. (++ "\n")
. ppElement
. (\e -> Element (unqual "expr") [] [Elem e] Nothing)
. iter phi
. check
where
check :: NValueNF m -> Free (NValueF m) Element
check = fmap (const (mkElem "cycle" "value" ""))
NVStrF t _ -> mkElem "string" "value" (Text.unpack t)
NVListF l -> Element (unqual "list") [] (Elem <$> l) Nothing
phi :: NValueF m Element -> Element
phi = \case
NVConstantF a -> case a of
NInt n -> mkElem "int" "value" (show n)
NFloat f -> mkElem "float" "value" (show f)
NBool b -> mkElem "bool" "value" (if b then "true" else "false")
NNull -> Element (unqual "null") [] [] Nothing
NVSetF s _ -> Element (unqual "attrs") []
(map (\(k, v) -> Elem (Element (unqual "attr")
[Attr (unqual "name") (Text.unpack k)]
[Elem v] Nothing))
(sortBy (comparing fst) $ M.toList s)) Nothing
NVStrF t _ -> mkElem "string" "value" (Text.unpack t)
NVListF l -> Element (unqual "list") [] (Elem <$> l) Nothing
NVClosureF p _ -> Element (unqual "function") [] (paramsXML p) Nothing
NVPathF fp -> mkElem "path" "value" fp
NVBuiltinF name _ -> mkElem "function" "name" name
NVSetF s _ -> Element (unqual "attrs") []
(map (\(k, v) ->
Elem (Element (unqual "attr")
[Attr (unqual "name") (Text.unpack k)]
[Elem v] Nothing))
(sortBy (comparing fst) $ M.toList s)) Nothing
NVClosureF p _ -> Element (unqual "function") [] (paramsXML p) Nothing
NVPathF fp -> mkElem "path" "value" fp
NVBuiltinF name _ -> mkElem "function" "name" name
mkElem :: String -> String -> String -> Element
mkElem n a v = Element (unqual n) [Attr (unqual a) v] [] Nothing