From 9405074cd82fd5ac233a169b51d8a1d74f5cf4e3 Mon Sep 17 00:00:00 2001
From: John Wiegley <johnw@newartisans.com>
Date: Sat, 16 Mar 2019 14:41:25 -0700
Subject: [PATCH] Fix hnix-tests

---
 src/Nix/Builtins.hs    | 12 ++++--
 src/Nix/Normal.hs      |  7 ++--
 src/Nix/Thunk.hs       |  2 +-
 src/Nix/Thunk/Basic.hs |  4 +-
 src/Nix/Value.hs       | 87 ++++++++++++++++++++++++++++++------------
 tests/EvalTests.hs     |  8 ++--
 6 files changed, 81 insertions(+), 39 deletions(-)

diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs
index a5a9d7c..ccd8468 100644
--- a/src/Nix/Builtins.hs
+++ b/src/Nix/Builtins.hs
@@ -475,7 +475,11 @@ splitVersion s = case Text.uncons s of
       | h `elem` versionComponentSeparators -> splitVersion t
       | isDigit h ->
           let (digits, rest) = Text.span isDigit s
-          in VersionComponent_Number (fromMaybe (error $ "splitVersion: couldn't parse " <> show digits) $ readMaybe $ Text.unpack digits) : splitVersion rest
+          in VersionComponent_Number
+              (fromMaybe (error $ "splitVersion: couldn't parse " <> show digits)
+                   $ readMaybe
+                   $ Text.unpack digits)
+              : splitVersion rest
       | otherwise ->
           let (chars, rest) = Text.span (\c -> not $ isDigit c || c `elem` versionComponentSeparators) s
               thisComponent = case chars of
@@ -485,8 +489,10 @@ splitVersion s = case Text.uncons s of
 
 splitVersion_ :: MonadBuiltins e t f m => m (NValue t f m) -> m (NValue t f m)
 splitVersion_ = fromValue >=> fromStringNoContext >=> \s ->
-  return $ nvList $ flip map (splitVersion s) $ \c ->
-    valueThunk $ nvStr $ principledMakeNixStringWithoutContext $ versionComponentToString c
+  return $ nvList $ flip map (splitVersion s) $
+    valueThunk . nvStr
+               . principledMakeNixStringWithoutContext
+               . versionComponentToString
 
 compareVersions :: Text -> Text -> Ordering
 compareVersions s1 s2 =
diff --git a/src/Nix/Normal.hs b/src/Nix/Normal.hs
index 09fd8cb..15bb58d 100644
--- a/src/Nix/Normal.hs
+++ b/src/Nix/Normal.hs
@@ -60,12 +60,13 @@ normalForm' f = run . nValueToNFM run go
         lift $ put s'
         return res
 
-    seen t = do
-        let tid = thunkId t
-        lift $ do
+    seen t = case thunkId t of
+        Just tid -> lift $ do
             res <- gets (member tid)
             unless res $ modify (insert tid)
             return res
+        Nothing ->
+            return False
 
 normalForm :: (Framed e m,
               MonadThunk t m (NValue t f m),
diff --git a/src/Nix/Thunk.hs b/src/Nix/Thunk.hs
index bfd3cf4..f4578ca 100644
--- a/src/Nix/Thunk.hs
+++ b/src/Nix/Thunk.hs
@@ -10,7 +10,7 @@ import Data.Typeable (Typeable)
 
 class Monad m => MonadThunk t m v | t -> m, t -> v where
     thunk :: m v -> m t
-    thunkId :: t -> Int
+    thunkId :: t -> Maybe Int
     query :: t -> r -> (v -> r) -> r
     queryM :: t -> m r -> (v -> m r) -> m r
     force :: t -> (v -> m r) -> m r
diff --git a/src/Nix/Thunk/Basic.hs b/src/Nix/Thunk/Basic.hs
index 56c4330..98d14d5 100644
--- a/src/Nix/Thunk/Basic.hs
+++ b/src/Nix/Thunk/Basic.hs
@@ -45,8 +45,8 @@ instance (MonadBasicThunk m, MonadCatch m)
   => MonadThunk (NThunkF m v) m v where
     thunk     = buildThunk
     thunkId   = \case
-        Value _     -> -1
-        Thunk n _ _ -> n
+        Value _     -> Nothing
+        Thunk n _ _ -> Just n
     query     = queryValue
     queryM    = queryThunk
     force     = forceThunk
diff --git a/src/Nix/Value.hs b/src/Nix/Value.hs
index 1f11a39..61e0126 100644
--- a/src/Nix/Value.hs
+++ b/src/Nix/Value.hs
@@ -402,35 +402,72 @@ alignEqM eq fa fb = fmap (either (const False) (const True)) $ runExceptT $ do
         _ -> throwE ()
     forM_ pairs $ \(a, b) -> guard =<< lift (eq a b)
 
-isDerivation :: (MonadThunk t m (NValue t f m), Comonad f)
-             => AttrSet t -> m Bool
-isDerivation m = case M.lookup "type" m of
+isDerivation :: Monad m
+             => (t -> m (Maybe NixString)) -> AttrSet t
+             -> m Bool
+isDerivation f m = case M.lookup "type" m of
     Nothing -> pure False
-    Just t -> force t $ \case
-      -- We should probably really make sure the context is empty here but the
-      -- C++ implementation ignores it.
-      NVStr s -> pure $ principledStringIgnoreContext s == "derivation"
-      _ -> pure False
+    Just t -> do
+        mres <- f t
+        case mres of
+            -- We should probably really make sure the context is empty here
+            -- but the C++ implementation ignores it.
+            Just s -> pure $ principledStringIgnoreContext s == "derivation"
+            Nothing -> pure False
+
+valueFEq :: Monad m
+         => (AttrSet a -> AttrSet a -> m Bool)
+         -> (a -> a -> m Bool)
+         -> NValueF p m a
+         -> NValueF p m a
+         -> m Bool
+valueFEq attrsEq eq = curry $ \case
+    (NVConstantF lc, NVConstantF rc) -> pure $ lc == rc
+    (NVStrF ls, NVStrF rs) ->
+        pure $ principledStringIgnoreContext ls
+            == principledStringIgnoreContext rs
+    (NVListF ls, NVListF rs)   -> alignEqM eq ls rs
+    (NVSetF lm _, NVSetF rm _) -> attrsEq lm rm
+    (NVPathF lp, NVPathF rp)   -> pure $ lp == rp
+    _ -> pure False
+
+compareAttrSets :: Monad m
+                => (t -> m (Maybe NixString))
+                -> (t -> t -> m Bool)
+                -> AttrSet t
+                -> AttrSet t
+                -> m Bool
+compareAttrSets f eq lm rm = do
+    isDerivation f lm >>= \case
+        True -> isDerivation f rm >>= \case
+            True | Just lp <- M.lookup "outPath" lm
+                 , Just rp <- M.lookup "outPath" rm
+                   -> eq lp rp
+            _ -> compareAttrs
+        _ -> compareAttrs
+  where
+    compareAttrs = alignEqM eq lm rm
 
 valueEq :: (MonadThunk t m (NValue t f m), Comonad f)
         => NValue t f m -> NValue t f m -> m Bool
-valueEq = curry $ \case
-    (NVConstant lc, NVConstant rc) -> pure $ lc == rc
-    (NVStr ls, NVStr rs) ->
-        pure $ principledStringIgnoreContext ls
-            == principledStringIgnoreContext rs
-    (NVList ls, NVList rs) -> alignEqM thunkEq ls rs
-    (NVSet lm _, NVSet rm _) -> do
-        let compareAttrs = alignEqM thunkEq lm rm
-        isDerivation lm >>= \case
-            True -> isDerivation rm >>= \case
-                True | Just lp <- M.lookup "outPath" lm
-                     , Just rp <- M.lookup "outPath" rm
-                       -> thunkEq lp rp
-                _ -> compareAttrs
-            _ -> compareAttrs
-    (NVPath lp, NVPath rp) -> pure $ lp == rp
-    _ -> pure False
+valueEq (NValue (extract -> x)) (NValue (extract -> y)) =
+    valueFEq (compareAttrSets f thunkEq) thunkEq x y
+  where
+    f t = force t $ \case
+        NVStr s -> pure $ Just s
+        _ -> pure Nothing
+
+valueNFEq :: (Comonad f, Monad m)
+          => NValueNF t f m -> NValueNF t f m -> m Bool
+valueNFEq (Pure _) (Pure _) = pure False
+valueNFEq (Pure _) (Free _) = pure False
+valueNFEq (Free _) (Pure _) = pure False
+valueNFEq (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
+    valueFEq (compareAttrSets f valueNFEq) valueNFEq x y
+  where
+    f (Pure (NVStr s)) = pure $ Just s
+    f (Free (NVStr s)) = pure $ Just s
+    f _ = pure Nothing
 
 data TStringContext = NoContext | HasContext
   deriving Show
diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs
index bd9aef1..f173c19 100644
--- a/tests/EvalTests.hs
+++ b/tests/EvalTests.hs
@@ -436,11 +436,9 @@ constantEqual a b = do
     let opts = defaultOptions time
     -- putStrLn =<< lint (stripAnnotation a)
     res <- runStdLazyM opts $ do
-        a' <- nixEvalExprLoc Nothing a
-        b' <- nixEvalExprLoc Nothing b
-        iterNValue forceEff (const (return ())) a'
-        iterNValue forceEff (const (return ())) b'
-        valueEq a' b'
+        a' <- normalForm =<< nixEvalExprLoc Nothing a
+        b' <- normalForm =<< nixEvalExprLoc Nothing b
+        valueNFEq a' b'
     assertBool "" res
 
 constantEqualText' :: Text -> Text -> Assertion