Merge remote-tracking branch 'origin/vs-context-primops'

2019-03-17 15:35:17 -07:00 · 2019-03-17 15:35:17 -07:00 · 895f4e721f
parent 1e2b67e488 bda79c984b
commit 895f4e721f
5 changed files with 221 additions and 104 deletions
--- a/src/Nix/Builtins.hs
+++ b/src/Nix/Builtins.hs
@ -281,6 +281,8 @@ builtinsList = sequence
  , add  Normal   "tryEval"          tryEval
  , add  Normal   "typeOf"           typeOf
  , add  Normal   "valueSize"        getRecursiveSize
+  , add  Normal   "getContext"                 getContext
+  , add2 Normal   "appendContext"              appendContext

  , add2 Normal   "unsafeGetAttrPos"           unsafeGetAttrPos
  , add  Normal   "unsafeDiscardStringContext" unsafeDiscardStringContext
@ -402,10 +404,7 @@ unsafeGetAttrPos x y = x >>= \x' -> y >>= \y' -> case (x', y') of
 -- This function is a bit special in that it doesn't care about the contents
 -- of the list.
 length_
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 length_ = toValue . (length :: [t] -> Int) <=< fromValue

 add_
@ -584,10 +583,7 @@ splitDrvName s =
    (Text.intercalate sep namePieces, Text.intercalate sep versionPieces)

 parseDrvName
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 parseDrvName = fromValue >=> fromStringNoContext >=> \s -> do
  let (name :: Text, version :: Text) = splitDrvName s
  -- jww (2018-04-15): There should be an easier way to write this.
@ -615,8 +611,10 @@ match_ pat str = fromValue pat >>= fromStringNoContext >>= \p ->
    let s  = principledStringIgnoreContext ns

    let re = makeRegex (encodeUtf8 p) :: Regex
-    let mkMatch t | Text.null t = toValue () -- Shorthand for Null
-                  | otherwise   = toValue $ principledMakeNixStringWithoutContext t
+    let mkMatch t
+          | Text.null t = toValue ()
+          | -- Shorthand for Null
+            otherwise   = toValue $ principledMakeNixStringWithoutContext t
    case matchOnceText re (encodeUtf8 s) of
      Just ("", sarr, "") -> do
        let s = map fst (elems sarr)
@ -666,8 +664,7 @@ splitMatches numDropped (((_, (start, len)) : captures) : mts) haystack =
 thunkStr s =
  valueThunk (nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s)))

-substring
-  :: MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString
+substring :: MonadNix e t f m => Int -> Int -> NixString -> Prim m NixString
 substring start len str = Prim $ if start < 0 --NOTE: negative values of 'len' are OK
  then
    throwError
@ -677,10 +674,7 @@ substring start len str = Prim $ if start < 0 --NOTE: negative values of 'len' a
  else pure $ principledModifyNixContents (Text.take len . Text.drop start) str

 attrNames
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 attrNames =
  fromValue @(AttrSet t)
    >=> toNix
@ -689,10 +683,7 @@ attrNames =
    .   M.keys

 attrValues
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 attrValues =
  fromValue @(AttrSet t)
    >=> toValue
@ -740,7 +731,10 @@ filter_
  -> m (NValue t f m)
  -> m (NValue t f m)
 filter_ fun xs = fun >>= \f ->
-  toValue <=< filterM (fromValue <=< callFunc f . force') <=< fromValue @[t] $ xs
+  toValue
+    <=< filterM (fromValue <=< callFunc f . force')
+    <=< fromValue @[t]
+    $   xs

 catAttrs
  :: forall e t f m
@ -752,7 +746,8 @@ catAttrs attrName xs = fromValue attrName >>= fromStringNoContext >>= \n ->
  fromValue @[t] xs >>= \l ->
    fmap (nvList . catMaybes)
      $ forM l
-      $ fmap (M.lookup n) . flip force fromValue
+      $ fmap (M.lookup n)
+      . flip force fromValue

 baseNameOf :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 baseNameOf x = do
@ -873,30 +868,31 @@ genList generator = fromValue @Integer >=> \n -> if n >= 0
 newtype WValue t f m a = WValue (NValue' t f m a)

 instance Comonad f => Eq (WValue t f m a) where
-  WValue (NVConstant (NFloat x)) == WValue (NVConstant (NInt y))   = x == fromInteger y
-  WValue (NVConstant (NInt x))   == WValue (NVConstant (NFloat y)) = fromInteger x == y
+  WValue (NVConstant (NFloat x)) == WValue (NVConstant (NInt y)) =
+    x == fromInteger y
+  WValue (NVConstant (NInt x)) == WValue (NVConstant (NFloat y)) =
+    fromInteger x == y
  WValue (NVConstant (NInt   x)) == WValue (NVConstant (NInt   y)) = x == y
  WValue (NVConstant (NFloat x)) == WValue (NVConstant (NFloat y)) = x == y
-  WValue (NVPath x)              == WValue (NVPath y)              = x == y
-  WValue (NVStr x)               == WValue (NVStr y) =
-    hackyStringIgnoreContext x   == hackyStringIgnoreContext y
+  WValue (NVPath     x         ) == WValue (NVPath     y         ) = x == y
+  WValue (NVStr x) == WValue (NVStr y) =
+    hackyStringIgnoreContext x == hackyStringIgnoreContext y
  _ == _ = False

 instance Comonad f => Ord (WValue t f m a) where
-  WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NInt y))   = x <= fromInteger y
-  WValue (NVConstant (NInt x))   <= WValue (NVConstant (NFloat y)) = fromInteger x <= y
+  WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NInt y)) =
+    x <= fromInteger y
+  WValue (NVConstant (NInt x)) <= WValue (NVConstant (NFloat y)) =
+    fromInteger x <= y
  WValue (NVConstant (NInt   x)) <= WValue (NVConstant (NInt   y)) = x <= y
  WValue (NVConstant (NFloat x)) <= WValue (NVConstant (NFloat y)) = x <= y
-  WValue (NVPath x)              <= WValue (NVPath y)              = x <= y
-  WValue (NVStr x)               <= WValue (NVStr y) =
-    hackyStringIgnoreContext x   <= hackyStringIgnoreContext y
+  WValue (NVPath     x         ) <= WValue (NVPath     y         ) = x <= y
+  WValue (NVStr x) <= WValue (NVStr y) =
+    hackyStringIgnoreContext x <= hackyStringIgnoreContext y
  _ <= _ = False

 genericClosure
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 genericClosure = fromValue @(AttrSet t) >=> \s ->
  case (M.lookup "startSet" s, M.lookup "operator" s) of
    (Nothing, Nothing) ->
@ -1009,10 +1005,7 @@ intersectAttrs set1 set2 =
      return $ nvSet (s2 `M.intersection` s1) (p2 `M.intersection` p1)

 functionArgs
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 functionArgs fun = fun >>= \case
  NVClosure p _ ->
    toValue @(AttrSet t) $ valueThunk . nvConstant . NBool <$> case p of
@ -1064,52 +1057,31 @@ hasKind = fromValueMay >=> toNix . \case
  _             -> False

 isAttrs
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 isAttrs = hasKind @(AttrSet t)

 isList
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 isList = hasKind @[t]

 isString
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 isString = hasKind @NixString

 isInt
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 isInt = hasKind @Int

 isFloat
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 isFloat = hasKind @Float

 isBool
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 isBool = hasKind @Bool

 isNull
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 isNull = hasKind @()

 isFunction :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
@ -1123,10 +1095,7 @@ throw_ mnv = do
  throwError . ErrorCall . Text.unpack $ principledStringIgnoreContext ns

 import_
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 import_ = scopedImport (pure (nvSet M.empty M.empty))

 scopedImport
@ -1202,20 +1171,15 @@ lessThan ta tb = ta >>= \va -> tb >>= \vb -> do
    _ -> badType

 concatLists
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 concatLists =
  fromValue @[t]
    >=> mapM (flip force $ fromValue @[t] >=> pure)
-    >=> toValue . concat
+    >=> toValue
+    .   concat

 listToAttrs
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 listToAttrs = fromValue @[t] >=> \l ->
  fmap (flip nvSet M.empty . M.fromList . reverse)
    $   forM l
@ -1338,10 +1302,7 @@ instance Convertible e t f m => ToNix FileType m (NValue t f m) where
    FileTypeUnknown   -> "unknown"

 readDir_
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 readDir_ pathThunk = do
  path           <- absolutePathFromValue =<< pathThunk
  items          <- listDirectory path
@ -1356,10 +1317,7 @@ readDir_ pathThunk = do
  toNix (M.fromList itemsWithTypes)

 fromJSON
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 fromJSON = fromValue >=> fromStringNoContext >=> \encoded ->
  case A.eitherDecodeStrict' @A.Value $ encodeUtf8 encoded of
    Left jsonError ->
@ -1405,10 +1363,7 @@ typeOf v = v >>= toNix . principledMakeNixStringWithoutContext . \case
  _             -> error "Pattern synonyms obscure complete patterns"

 tryEval
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 tryEval e = catch (onSuccess <$> e) (pure . onError)
 where
  onSuccess v = flip nvSet M.empty $ M.fromList
@ -1443,10 +1398,7 @@ addErrorContext
 addErrorContext _ action = action

 exec_
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 exec_ xs = do
  ls <- fromValue @[t] xs
  xs <- traverse (coerceToString DontCopyToStore CoerceStringy <=< force') ls
@ -1456,10 +1408,7 @@ exec_ xs = do
  exec (map (Text.unpack . hackyStringIgnoreContext) xs)

 fetchurl
-  :: forall e t f m
-   . MonadNix e t f m
-  => m (NValue t f m)
-  -> m (NValue t f m)
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 fetchurl v = v >>= \case
  NVSet s _ -> attrsetGet "url" s >>= force ?? (go (M.lookup "sha256" s))
  v@NVStr{} -> go Nothing v
@ -1510,10 +1459,65 @@ currentTime_ = do
  opts :: Options <- asks (view hasLens)
  toNix @Integer $ round $ Time.utcTimeToPOSIXSeconds (currentTime opts)

-derivationStrict_
-  :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
+derivationStrict_ :: MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
 derivationStrict_ = (>>= derivationStrict)

+getContext
+  :: forall e t f m . MonadNix e t f m => m (NValue t f m) -> m (NValue t f m)
+getContext x = x >>= \x' -> case x' of
+  (NVStr ns) -> do
+    let context =
+          getNixLikeContext $ toNixLikeContext $ principledGetContext ns
+    valued :: M.HashMap Text (NValue t f m) <- sequenceA $ M.map toValue context
+    pure $ flip nvSet M.empty $ M.map wrapValue valued
+  x ->
+    throwError $ ErrorCall $ "Invalid type for builtins.getContext: " ++ show x
+
+appendContext
+  :: forall e t f m
+   . MonadNix e t f m
+  => m (NValue t f m)
+  -> m (NValue t f m)
+  -> m (NValue t f m)
+appendContext x y = x >>= \x' -> y >>= \y' -> case (x', y') of
+  (NVStr ns, NVSet attrs _) -> do
+    newContextValues <- forM attrs $ force' >=> \case
+      NVSet attrs _ -> do
+        -- TODO: Fail for unexpected keys.
+        path <- maybe (return False) (force ?? fromValue)
+          $ M.lookup "path" attrs
+        allOutputs <- maybe (return False) (force ?? fromValue)
+          $ M.lookup "allOutputs" attrs
+        outputs <- case M.lookup "outputs" attrs of
+          Nothing -> return []
+          Just os -> force' os >>= \case
+            NVList vs ->
+              forM vs $ fmap principledStringIgnoreContext . fromNix . force'
+            x ->
+              throwError
+                $ ErrorCall
+                $ "Invalid types for context value outputs in builtins.appendContext: "
+                ++ show x
+        return $ NixLikeContextValue path allOutputs outputs
+      x ->
+        throwError
+          $  ErrorCall
+          $  "Invalid types for context value in builtins.appendContext: "
+          ++ show x
+    toValue
+      $ principledMakeNixString (principledStringIgnoreContext ns)
+      $ fromNixLikeContext
+      $ NixLikeContext
+      $ M.unionWith (<>) newContextValues
+      $ getNixLikeContext
+      $ toNixLikeContext
+      $ principledGetContext ns
+  (x, y) ->
+    throwError
+      $  ErrorCall
+      $  "Invalid types for builtins.appendContext: "
+      ++ show (x, y)
+
 newtype Prim m a = Prim { runPrim :: m a }

 -- | Types that support conversion to nix in a particular monad
@ -1530,4 +1534,3 @@ instance ( MonadNix e t f m
      => ToBuiltin t f m (a -> b) where
  toBuiltin name f =
    return $ nvBuiltin name (fromNix >=> fmap wrapValue . toBuiltin name . f)
-
--- a/src/Nix/Convert.hs
+++ b/src/Nix/Convert.hs
@ -28,9 +28,11 @@
 module Nix.Convert where

 import           Control.Monad
+import           Control.Monad.Catch
 import           Data.ByteString
 import           Data.HashMap.Lazy              ( HashMap )
 import qualified Data.HashMap.Lazy             as M
+import           Data.Maybe
 import           Data.Text                      ( Text )
 import qualified Data.Text                     as Text
 import           Data.Text.Encoding             ( encodeUtf8
@ -384,6 +386,30 @@ instance Convertible e t f m => ToValue Bool m (NExprF r) where
 instance Convertible e t f m => ToValue () m (NExprF r) where
  toValue _ = pure . NConstant $ NNull

+instance ( MonadThunk t m (NValue t f m)
+         , MonadDataErrorContext t f m
+         , Framed e m
+         )
+    => ToValue NixLikeContextValue m (NValue t f m) where
+  toValue nlcv = do
+    path <- if nlcvPath nlcv then Just <$> toValue True else return Nothing
+    allOutputs <- if nlcvAllOutputs nlcv
+      then Just <$> toValue True
+      else return Nothing
+    outputs <- do
+      let outputs =
+            fmap principledMakeNixStringWithoutContext $ nlcvOutputs nlcv
+      outputsM :: [NValue t f m] <- traverse toValue outputs
+      let ts :: [t] = fmap wrapValue outputsM
+      case ts of
+        [] -> return Nothing
+        _  -> Just <$> toValue ts
+    pure $ flip nvSet M.empty $ M.fromList $ catMaybes
+      [ (\p -> ("path", wrapValue p)) <$> path
+      , (\ao -> ("allOutputs", wrapValue ao)) <$> allOutputs
+      , (\os -> ("outputs", wrapValue os)) <$> outputs
+      ]
+
 whileForcingThunk
  :: forall t f m s e r . (Exception s, Convertible e t f m) => s -> m r -> m r
 whileForcingThunk frame =
--- a/src/Nix/String.hs
+++ b/src/Nix/String.hs
@ -9,6 +9,10 @@ module Nix.String
  , principledMempty
  , StringContext(..)
  , ContextFlavor(..)
+  , NixLikeContext(..)
+  , NixLikeContextValue(..)
+  , toNixLikeContext
+  , fromNixLikeContext
  , stringHasContext
  , principledIntercalateNixString
  , hackyGetStringNoContext
@ -34,6 +38,7 @@ where

 import           Control.Monad.Writer
 import           Data.Functor.Identity
+import qualified Data.HashMap.Lazy             as M
 import qualified Data.HashSet                  as S
 import           Data.Hashable
 import           Data.Text                      ( Text )
@ -45,6 +50,7 @@ import           GHC.Generics
 -- | A 'ContextFlavor' describes the sum of possible derivations for string contexts
 data ContextFlavor =
    DirectPath
+  | AllOutputs
  | DerivationOutput !Text
  deriving (Show, Eq, Ord, Generic)

@ -65,6 +71,53 @@ data NixString = NixString

 instance Hashable NixString

+newtype NixLikeContext = NixLikeContext
+  { getNixLikeContext :: M.HashMap Text NixLikeContextValue
+  } deriving (Eq, Ord, Show, Generic)
+
+data NixLikeContextValue = NixLikeContextValue
+  { nlcvPath :: !Bool
+  , nlcvAllOutputs :: !Bool
+  , nlcvOutputs :: ![Text]
+  } deriving (Show, Eq, Ord, Generic)
+
+instance Semigroup NixLikeContextValue where
+  a <> b = NixLikeContextValue
+    { nlcvPath = nlcvPath a || nlcvPath b
+    , nlcvAllOutputs = nlcvAllOutputs a || nlcvAllOutputs b
+    , nlcvOutputs = nlcvOutputs a <> nlcvOutputs b
+    }
+
+instance Monoid NixLikeContextValue where
+  mempty = NixLikeContextValue False False []
+
+toStringContexts :: (Text, NixLikeContextValue) -> [StringContext]
+toStringContexts (path, nlcv) = case nlcv of
+  NixLikeContextValue True _ _ ->
+    StringContext path DirectPath:toStringContexts (path, nlcv { nlcvPath = False })
+  NixLikeContextValue _ True _ ->
+    StringContext path AllOutputs:toStringContexts (path, nlcv { nlcvAllOutputs = False })
+  NixLikeContextValue _ _ ls | not (null ls) ->
+    map (StringContext path . DerivationOutput) ls
+  _ -> []
+
+toNixLikeContextValue :: StringContext -> (Text, NixLikeContextValue)
+toNixLikeContextValue sc = (,) (scPath sc) $ case scFlavor sc of
+  DirectPath -> NixLikeContextValue True False []
+  AllOutputs -> NixLikeContextValue False True []
+  DerivationOutput t -> NixLikeContextValue False False [t]
+
+toNixLikeContext :: S.HashSet StringContext -> NixLikeContext
+toNixLikeContext stringContext = NixLikeContext $ S.foldr go mempty stringContext
+  where
+    go sc hm = let
+      (t, nlcv) = toNixLikeContextValue sc
+      in M.insertWith (<>) t nlcv hm
+
+fromNixLikeContext :: NixLikeContext -> S.HashSet StringContext
+fromNixLikeContext =
+  S.fromList . join . map toStringContexts . M.toList . getNixLikeContext
+
 principledGetContext :: NixString -> S.HashSet StringContext
 principledGetContext = nsContext

--- a/tests/eval-compare/builtins.appendContext.nix
+++ b/tests/eval-compare/builtins.appendContext.nix
@ -0,0 +1,28 @@
+let
+  drv = derivation {
+    name = "fail";
+    builder = "/bin/false";
+    system = "x86_64-linux";
+    outputs = [ "out" "foo" ];
+  };
+
+  path = "${./builtins.appendContext.nix}";
+
+  desired-context = {
+    "${builtins.unsafeDiscardStringContext path}" = {
+      path = true;
+    };
+    "${builtins.unsafeDiscardStringContext drv.drvPath}" = {
+      outputs = [ "foo" "out" ];
+      allOutputs = true;
+    };
+  };
+
+  # TODO: Remove builtins.attrValues here once store hash is correct.
+  legit-context = builtins.attrValues (builtins.getContext "${path}${drv.outPath}${drv.foo.outPath}${drv.drvPath}");
+
+  constructed-context = builtins.attrValues (builtins.getContext (builtins.appendContext "" desired-context));
+in [ (builtins.appendContext "foo" {})
+     (legit-context == constructed-context)
+     constructed-context
+   ]
--- a/tests/eval-compare/builtins.getContext.nix
+++ b/tests/eval-compare/builtins.getContext.nix
@ -0,0 +1,7 @@
+with builtins;
+
+[ (getContext "foo")
+  (attrValues (getContext (toFile "foo" "foo contents")))
+  # TODO: Re-enable this once output hash is correct.
+  # (getContext (toFile "foo" "foo contents"))
+]