From f0b6b6b223fa2f7ccec478b02119d9852d6799fe Mon Sep 17 00:00:00 2001 From: John Wiegley Date: Thu, 9 Aug 2018 22:09:00 -0400 Subject: [PATCH] Change NValueNF to use Free instead of Fix This allows us to detect and report cycles during normalization. See #348 --- hnix.cabal | 3 +- package.yaml | 1 + src/Nix.hs | 3 +- src/Nix/Convert.hs | 83 +++++++++++++++++++++++----------------------- src/Nix/Eval.hs | 5 ++- src/Nix/Normal.hs | 30 +++++++++-------- src/Nix/Pretty.hs | 69 +++++++++++++++++++++++--------------- src/Nix/Value.hs | 27 +++++++++++++-- src/Nix/XML.hs | 51 ++++++++++++++++------------ 9 files changed, 162 insertions(+), 110 deletions(-) diff --git a/hnix.cabal b/hnix.cabal index e7790d7..0fb4c2b 100644 --- a/hnix.cabal +++ b/hnix.cabal @@ -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 diff --git a/package.yaml b/package.yaml index 774eda5..4d04cd1 100644 --- a/package.yaml +++ b/package.yaml @@ -103,6 +103,7 @@ library: - binary - deriving-compat >= 0.3 && < 0.6 - directory + - free - http-types - http-client - http-client-tls diff --git a/src/Nix.hs b/src/Nix.hs index 19ff760..3e9c128 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -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 diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs index e88bb29..b21746c 100644 --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -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 diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index 5177d41..832be22 100644 --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -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)) diff --git a/src/Nix/Normal.hs b/src/Nix/Normal.hs index c13e627..9f4bbc1 100644 --- a/src/Nix/Normal.hs +++ b/src/Nix/Normal.hs @@ -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 ("", 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) diff --git a/src/Nix/Pretty.hs b/src/Nix/Pretty.hs index a3c1609..e608ed4 100644 --- a/src/Nix/Pretty.hs +++ b/src/Nix/Pretty.hs @@ -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 "" 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 $ "" - 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 $ "" + 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 {} = "<>" - phi (NVPathF fp) = fp - phi (NVBuiltinF name _) = "<>" +printNix = iter phi . check + where + check :: NValueNF m -> Free (NValueF m) String + check = fmap (const "") + + 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 {} = "<>" + phi (NVPathF fp) = fp + phi (NVBuiltinF 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 "" mempty + dethunk (NThunk _ _) = Free $ NVStrF "" 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 "" mempty + then pure $ Free $ NVStrF "" mempty else do eres <- readVar ref case eres of Computed v -> removeEffectsM (_baseValue v) - _ -> pure $ Fix $ NVStrF "" mempty + _ -> pure $ Free $ NVStrF "" mempty diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs index 5a9d9de..c148414 100644 --- a/src/Nix/Value.hs +++ b/src/Nix/Value.hs @@ -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 _ _) = "" +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) diff --git a/src/Nix/XML.hs b/src/Nix/XML.hs index 990a7ef..7672897 100644 --- a/src/Nix/XML.hs +++ b/src/Nix/XML.hs @@ -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") . - ("\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 = ("\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