Fix hnix-tests
This commit is contained in:
parent
676994ed82
commit
9405074cd8
|
@ -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 =
|
||||
|
|
|
@ -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),
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in New Issue