Initial implementation of genericClosure

src/Nix/Builtins.hs

@@ -43,6 +43,8 @@ import qualified Data.HashMap.Lazy as M
 import           Data.List
 import           Data.Maybe
 import           Data.Semigroup
+import           Data.Set (Set)
+import qualified Data.Set as S
 import           Data.Text (Text)
 import qualified Data.Text as Text
 import           Data.Text.Encoding
@@ -141,6 +143,7 @@ builtinsList = sequence [
     , add  Normal   "fromJSON"                   fromJSON
     , add  Normal   "functionArgs"               functionArgs
     , add2 Normal   "genList"                    genList
+    , add  Normal   "genericClosure"             genericClosure
     , add2 Normal   "getAttr"                    getAttr
     , add  Normal   "getEnv"                     getEnv_
     , add2 Normal   "hasAttr"                    hasAttr
@@ -515,6 +518,42 @@ genList generator = fromValue @Integer >=> \n ->
     else throwError @String $ "builtins.genList: Expected a non-negative number, got "
              ++ show n
 
+genericClosure :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
+genericClosure = fromValue @(AttrSet (NThunk m)) >=> \s ->
+    case (M.lookup "startSet" s, M.lookup "operator" s) of
+      (Nothing, Nothing) ->
+          throwError
+              ("builtins.genericClosure: Attributes 'startSet' and 'operator' required"
+                   :: String)
+      (Nothing, Just _) ->
+          throwError
+              ("builtins.genericClosure: Attribute 'startSet' required"
+                   :: String)
+      (Just _, Nothing) ->
+          throwError
+              ("builtins.genericClosure: Attribute 'operator' required"
+                   :: String)
+      (Just startSet, Just operator) ->
+          fromValue @[NThunk m] startSet >>= \ss ->
+          force operator $ \op ->
+              toValue @[NThunk m] =<< (ss ++) . snd <$> go op ss S.empty
+  where
+    go :: NValue m -> [NThunk m] -> Set (NValue m)
+       -> m (Set (NValue m), [NThunk m])
+    go _ [] ks = pure (ks, [])
+    go op (t:ts) ks = force t $ \v -> fromValue @(AttrSet (NThunk m)) t >>= \s ->
+        case M.lookup "key" s of
+            Nothing ->
+                throwError
+                    ("builtins.genericClosure: Attribute 'key' required" :: String)
+            Just k -> force k $ \k' ->
+                if S.member k' ks
+                    then go op ts ks
+                    else do
+                        ys <- fromValue @[NThunk m] =<< (op `callFunc` pure v)
+                        (ks'', zs) <- go op ts (S.insert k' ks)
+                        fmap ((zs ++) . (ys ++)) <$> go op ys ks''
+
 replaceStrings :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m) -> m (NValue m)
 replaceStrings tfrom tto ts =
     fromNix tfrom >>= \(from :: [Text]) ->

src/Nix/Value.hs

@@ -24,6 +24,7 @@
 module Nix.Value where
 
 import           Control.Monad
+import           Control.Monad.Catch
 import           Control.Monad.Trans.Class
 import           Control.Monad.Trans.Except
 import qualified Data.Aeson as A
@@ -163,6 +164,35 @@ instance Show (NValueF m (Fix (NValueF m))) where
               . showString " "
               . showsPrec 11 b
 
+instance Eq (NValue m) where
+    NVConstant (NFloat x) == NVConstant (NInt y)   = x == fromInteger y
+    NVConstant (NInt x)   == NVConstant (NFloat y) = fromInteger x == y
+    NVConstant (NInt x)   == NVConstant (NInt y)   = x == y
+    NVConstant (NFloat x) == NVConstant (NFloat y) = x == y
+    NVStr x _ == NVStr y _ = x < y
+    NVPath x  == NVPath y  = x < y
+    _         == _         = False
+
+instance Ord (NValue m) where
+    NVConstant (NFloat x) <= NVConstant (NInt y)   = x <= fromInteger y
+    NVConstant (NInt x)   <= NVConstant (NFloat y) = fromInteger x <= y
+    NVConstant (NInt x)   <= NVConstant (NInt y)   = x <= y
+    NVConstant (NFloat x) <= NVConstant (NFloat y) = x <= y
+    NVStr x _ <= NVStr y _ = x < y
+    NVPath x  <= NVPath y  = x < y
+    _         <= _         = False
+
+checkComparable :: (Framed e m, MonadThrow m, Typeable m)
+                => NValue m -> NValue m -> m ()
+checkComparable x y = case (x, y) of
+    (NVConstant (NFloat _), NVConstant (NInt _))   -> pure ()
+    (NVConstant (NInt _),   NVConstant (NFloat _)) -> pure ()
+    (NVConstant (NInt _),   NVConstant (NInt _))   -> pure ()
+    (NVConstant (NFloat _), NVConstant (NFloat _)) -> pure ()
+    (NVStr _ _, NVStr _ _) -> pure ()
+    (NVPath _, NVPath _)   -> pure ()
+    _ -> throwError $ Comparison x y
+
 builtin :: Monad m
         => String -> (m (NValue m) -> m (NValue m)) -> m (NValue m)
 builtin name f = return $ nvBuiltin name f
@@ -286,6 +316,7 @@ instance Show (NThunk m) where
 data ValueFrame m
     = ForcingThunk
     | ConcerningValue (NValue m)
+    | Comparison (NValue m) (NValue m)
     | Coercion ValueType ValueType
     | CoercionToJsonNF (NValueNF m)
     | CoercionFromJson A.Value