Merge remote-tracking branch 'origin/master' into pending
This commit is contained in:
John Wiegley
commit
833851392d
|
|
@ -70,7 +70,7 @@ import qualified Data.Text.Lazy as LazyText
|
|||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
import Data.These (fromThese)
|
||||
import qualified Data.Time.Clock.POSIX as Time
|
||||
import Data.Traversable (mapM)
|
||||
import Data.Traversable (for, mapM)
|
||||
import Nix.Atoms
|
||||
import Nix.Convert
|
||||
import Nix.Effects
|
||||
|
|
@ -234,6 +234,7 @@ builtinsList = sequence [
|
|||
, add2 Normal "lessThan" lessThan
|
||||
, add Normal "listToAttrs" listToAttrs
|
||||
, add2 TopLevel "map" map_
|
||||
, add2 TopLevel "mapAttrs" mapAttrs_
|
||||
, add2 Normal "match" match_
|
||||
, add2 Normal "mul" mul_
|
||||
, add0 Normal "null" (return $ nvConstant NNull)
|
||||
|
|
@ -292,27 +293,32 @@ builtinsList = sequence [
|
|||
-- Primops
|
||||
|
||||
foldNixPath :: forall e m r. MonadNix e m
|
||||
=> (FilePath -> Maybe String -> r -> m r) -> r -> m r
|
||||
=> (FilePath -> Maybe String -> NixPathEntryType -> r -> m r) -> r -> m r
|
||||
foldNixPath f z = do
|
||||
mres <- lookupVar @_ @(NThunk m) "__includes"
|
||||
dirs <- case mres of
|
||||
Nothing -> return []
|
||||
Just v -> fromNix @[Text] v
|
||||
menv <- getEnvVar "NIX_PATH"
|
||||
foldrM go z $ dirs ++ case menv of
|
||||
foldrM go z $ map fromInclude dirs ++ case menv of
|
||||
Nothing -> []
|
||||
Just str -> Text.splitOn ":" (Text.pack str)
|
||||
Just str -> uriAwareSplit (Text.pack str)
|
||||
where
|
||||
go x rest = case Text.splitOn "=" x of
|
||||
[p] -> f (Text.unpack p) Nothing rest
|
||||
[n, p] -> f (Text.unpack p) (Just (Text.unpack n)) rest
|
||||
fromInclude x
|
||||
| "://" `Text.isInfixOf` x = (x, PathEntryURI)
|
||||
| otherwise = (x, PathEntryPath)
|
||||
go (x, ty) rest = case Text.splitOn "=" x of
|
||||
[p] -> f (Text.unpack p) Nothing ty rest
|
||||
[n, p] -> f (Text.unpack p) (Just (Text.unpack n)) ty rest
|
||||
_ -> throwError $ ErrorCall $ "Unexpected entry in NIX_PATH: " ++ show x
|
||||
|
||||
nixPath :: MonadNix e m => m (NValue m)
|
||||
nixPath = fmap nvList $ flip foldNixPath [] $ \p mn rest ->
|
||||
nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest ->
|
||||
pure $ valueThunk
|
||||
(flip nvSet mempty $ M.fromList
|
||||
[ ("path", valueThunk $ nvPath p)
|
||||
[ case ty of
|
||||
PathEntryPath -> ("path", valueThunk $ nvPath p)
|
||||
PathEntryURI -> ("uri", valueThunk $ nvStr (Text.pack p) mempty)
|
||||
, ("prefix", valueThunk $
|
||||
nvStr (Text.pack (fromMaybe "" mn)) mempty) ]) : rest
|
||||
|
||||
|
|
@ -569,6 +575,17 @@ map_ fun xs = fun >>= \f ->
|
|||
. (f `callFunc`) . force')
|
||||
<=< fromValue @[NThunk m] $ xs
|
||||
|
||||
mapAttrs_ :: forall e m. MonadNix e m
|
||||
=> m (NValue m) -> m (NValue m) -> m (NValue m)
|
||||
mapAttrs_ fun xs = fun >>= \f ->
|
||||
fromValue @(AttrSet (NThunk m)) xs >>= \aset -> do
|
||||
let pairs = M.toList aset
|
||||
values <- for pairs $ \(key, value) ->
|
||||
thunk $
|
||||
withFrame Debug (ErrorCall "While applying f in mapAttrs:\n") $
|
||||
callFunc ?? force' value =<< callFunc f (pure (nvStr key mempty))
|
||||
toNix . M.fromList . zip (map fst pairs) $ values
|
||||
|
||||
filter_ :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
|
||||
filter_ fun xs = fun >>= \f ->
|
||||
toNix <=< filterM (fromValue <=< callFunc f . force')
|
||||
|
|
@ -1011,43 +1028,6 @@ exec_ xs = do
|
|||
xs <- traverse (fromValue @Text . force') ls
|
||||
exec (map Text.unpack xs)
|
||||
|
||||
fetchTarball :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
|
||||
fetchTarball v = v >>= \case
|
||||
NVSet s _ -> case M.lookup "url" s of
|
||||
Nothing -> throwError $ ErrorCall
|
||||
"builtins.fetchTarball: Missing url attribute"
|
||||
Just url -> force url $ go (M.lookup "sha256" s)
|
||||
v@NVStr {} -> go Nothing v
|
||||
v -> throwError $ ErrorCall $
|
||||
"builtins.fetchTarball: Expected URI or set, got " ++ show v
|
||||
where
|
||||
go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
|
||||
go msha = \case
|
||||
NVStr uri _ -> fetch uri msha
|
||||
v -> throwError $ ErrorCall $
|
||||
"builtins.fetchTarball: Expected URI or string, got " ++ show v
|
||||
|
||||
{- jww (2018-04-11): This should be written using pipes in another module
|
||||
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
|
||||
fetch uri msha = case takeExtension (Text.unpack uri) of
|
||||
".tgz" -> undefined
|
||||
".gz" -> undefined
|
||||
".bz2" -> undefined
|
||||
".xz" -> undefined
|
||||
".tar" -> undefined
|
||||
ext -> throwError $ ErrorCall $ "builtins.fetchTarball: Unsupported extension '"
|
||||
++ ext ++ "'"
|
||||
-}
|
||||
|
||||
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
|
||||
fetch uri Nothing =
|
||||
nixInstantiateExpr $ "builtins.fetchTarball \"" ++
|
||||
Text.unpack uri ++ "\""
|
||||
fetch url (Just m) = fromValue m >>= \sha ->
|
||||
nixInstantiateExpr $ "builtins.fetchTarball { "
|
||||
++ "url = \"" ++ Text.unpack url ++ "\"; "
|
||||
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
|
||||
|
||||
fetchurl :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
|
||||
fetchurl v = v >>= \case
|
||||
NVSet s _ -> attrsetGet "url" s >>= force ?? (go (M.lookup "sha256" s))
|
||||
|
|
|
|||
|
|
@ -715,23 +715,28 @@ findPathBy finder l name = do
|
|||
go :: Maybe FilePath -> NThunk m -> m (Maybe FilePath)
|
||||
go p@(Just _) _ = pure p
|
||||
go Nothing l = force l $ fromValue >=>
|
||||
\(s :: HashMap Text (NThunk m)) ->
|
||||
case M.lookup "path" s of
|
||||
Just p -> force p $ fromValue >=> \(Path path) ->
|
||||
case M.lookup "prefix" s of
|
||||
Nothing -> tryPath path Nothing
|
||||
Just pf -> force pf $ fromValueMay >=> \case
|
||||
Just (pfx :: Text) | not (Text.null pfx) ->
|
||||
tryPath path (Just (Text.unpack pfx))
|
||||
_ -> tryPath path Nothing
|
||||
Nothing ->
|
||||
throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
|
||||
++ " with 'path' elements, but saw: " ++ show s
|
||||
\(s :: HashMap Text (NThunk m)) -> do
|
||||
p <- resolvePath s
|
||||
force p $ fromValue >=> \(Path path) ->
|
||||
case M.lookup "prefix" s of
|
||||
Nothing -> tryPath path Nothing
|
||||
Just pf -> force pf $ fromValueMay >=> \case
|
||||
Just (pfx :: Text) | not (Text.null pfx) ->
|
||||
tryPath path (Just (Text.unpack pfx))
|
||||
_ -> tryPath path Nothing
|
||||
|
||||
tryPath p (Just n) | n':ns <- splitDirectories name, n == n' =
|
||||
finder $ p <///> joinPath ns
|
||||
tryPath p _ = finder $ p <///> name
|
||||
|
||||
resolvePath s = case M.lookup "path" s of
|
||||
Just t -> return t
|
||||
Nothing -> case M.lookup "uri" s of
|
||||
Just ut -> thunk $ fetchTarball (force ut pure)
|
||||
Nothing ->
|
||||
throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
|
||||
++ " with 'path' elements, but saw: " ++ show s
|
||||
|
||||
findPathM :: forall e m. (MonadNix e m, MonadIO m) =>
|
||||
[NThunk m] -> FilePath -> m FilePath
|
||||
findPathM l name = findPathBy path l name
|
||||
|
|
@ -799,3 +804,40 @@ evalExprLoc expr = do
|
|||
where
|
||||
phi = Eval.eval @_ @(NValue m) @(NThunk m) @m . annotated . getCompose
|
||||
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
|
||||
|
||||
fetchTarball :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m)
|
||||
fetchTarball v = v >>= \case
|
||||
NVSet s _ -> case M.lookup "url" s of
|
||||
Nothing -> throwError $ ErrorCall
|
||||
"builtins.fetchTarball: Missing url attribute"
|
||||
Just url -> force url $ go (M.lookup "sha256" s)
|
||||
v@NVStr {} -> go Nothing v
|
||||
v -> throwError $ ErrorCall $
|
||||
"builtins.fetchTarball: Expected URI or set, got " ++ show v
|
||||
where
|
||||
go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
|
||||
go msha = \case
|
||||
NVStr uri _ -> fetch uri msha
|
||||
v -> throwError $ ErrorCall $
|
||||
"builtins.fetchTarball: Expected URI or string, got " ++ show v
|
||||
|
||||
{- jww (2018-04-11): This should be written using pipes in another module
|
||||
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
|
||||
fetch uri msha = case takeExtension (Text.unpack uri) of
|
||||
".tgz" -> undefined
|
||||
".gz" -> undefined
|
||||
".bz2" -> undefined
|
||||
".xz" -> undefined
|
||||
".tar" -> undefined
|
||||
ext -> throwError $ ErrorCall $ "builtins.fetchTarball: Unsupported extension '"
|
||||
++ ext ++ "'"
|
||||
-}
|
||||
|
||||
fetch :: Text -> Maybe (NThunk m) -> m (NValue m)
|
||||
fetch uri Nothing =
|
||||
nixInstantiateExpr $ "builtins.fetchTarball \"" ++
|
||||
Text.unpack uri ++ "\""
|
||||
fetch url (Just m) = fromValue m >>= \sha ->
|
||||
nixInstantiateExpr $ "builtins.fetchTarball { "
|
||||
++ "url = \"" ++ Text.unpack url ++ "\"; "
|
||||
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
|
||||
|
|
|
|||
|
|
@ -203,10 +203,11 @@ exprFNixDoc = \case
|
|||
NUnary op r1 ->
|
||||
mkNixDoc (text (unpack (operatorName opInfo)) <> wrapParens opInfo r1) opInfo
|
||||
where opInfo = getUnaryOperator op
|
||||
NSelect r attr o ->
|
||||
NSelect r' attr o ->
|
||||
(if isJust o then leastPrecedence else flip mkNixDoc selectOp) $
|
||||
wrapPath selectOp r <> dot <> prettySelector attr <> ordoc
|
||||
where
|
||||
r = flip mkNixDoc selectOp $ wrapParens appOpNonAssoc r'
|
||||
ordoc = maybe empty (((space <> text "or") <+>) . wrapParens appOpNonAssoc) o
|
||||
NHasAttr r attr ->
|
||||
mkNixDoc (wrapParens hasAttrOp r <+> text "?" <+> prettySelector attr) hasAttrOp
|
||||
|
|
|
|||
|
|
@ -175,7 +175,7 @@ renderExecFrame level = \case
|
|||
renderThunkLoop :: (MonadReader e m, Has e Options, MonadFile m)
|
||||
=> NixLevel -> ThunkLoop -> m [Doc]
|
||||
renderThunkLoop _level = pure . (:[]) . \case
|
||||
ThunkLoop Nothing -> text "<<loop>>"
|
||||
ThunkLoop Nothing -> text "<<thunk loop>>"
|
||||
ThunkLoop (Just n) ->
|
||||
text $ "<<loop forcing thunk #" ++ show n ++ ">>"
|
||||
|
||||
|
|
|
|||
|
|
@ -17,8 +17,9 @@ import Data.Fix
|
|||
import Data.HashMap.Lazy (HashMap)
|
||||
import qualified Data.HashMap.Lazy as M
|
||||
import Data.List (sortOn)
|
||||
import Data.Monoid (Endo)
|
||||
import Data.Monoid (Endo, (<>))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Vector as V
|
||||
import Lens.Family2 as X
|
||||
import Lens.Family2.Stock (_1, _2)
|
||||
|
|
@ -108,3 +109,17 @@ toEncodingSorted = \case
|
|||
$ M.toList m
|
||||
A.Array l -> A.list toEncodingSorted $ V.toList l
|
||||
v -> A.toEncoding v
|
||||
|
||||
data NixPathEntryType = PathEntryPath | PathEntryURI deriving (Show, Eq)
|
||||
|
||||
-- | @NIX_PATH@ is colon-separated, but can also contain URLs, which have a colon
|
||||
-- (i.e. @https://...@)
|
||||
uriAwareSplit :: Text -> [(Text, NixPathEntryType)]
|
||||
uriAwareSplit = go where
|
||||
go str = case Text.break (== ':') str of
|
||||
(e1, e2)
|
||||
| Text.null e2 -> [(e1, PathEntryPath)]
|
||||
| Text.pack "://" `Text.isPrefixOf` e2 ->
|
||||
let ((suffix, _):path) = go (Text.drop 3 e2)
|
||||
in (e1 <> Text.pack "://" <> suffix, PathEntryURI) : path
|
||||
| otherwise -> (e1, PathEntryPath) : go (Text.drop 1 e2)
|
||||
|
|
|
|||
|
|
@ -323,7 +323,13 @@ case_fixed_points_attrsets =
|
|||
-- constantEqualText "true" "[(x: x)] == [(x: x)]"
|
||||
|
||||
case_function_equals3 =
|
||||
constantEqualText "false" "(x: x) == (x: x)"
|
||||
constantEqualText "false" "(let a = (x: x); in a == a)"
|
||||
|
||||
case_function_equals4 =
|
||||
constantEqualText "true" "(let a = {f = x: x;}; in a == a)"
|
||||
|
||||
case_function_equals5 =
|
||||
constantEqualText "true" "(let a = [(x: x)]; in a == a)"
|
||||
|
||||
case_directory_pathexists =
|
||||
constantEqualText "false" "builtins.pathExists \"/bin/sh/invalid-directory\""
|
||||
|
|
@ -338,6 +344,14 @@ case_rec_path_attr =
|
|||
constantEqualText "10"
|
||||
"let src = 10; x = rec { passthru.src = src; }; in x.passthru.src"
|
||||
|
||||
case_mapattrs_builtin =
|
||||
constantEqualText' "{ a = \"afoo\"; b = \"bbar\"; }" [i|
|
||||
(builtins.mapAttrs (x: y: x + y) {
|
||||
a = "foo";
|
||||
b = "bar";
|
||||
})
|
||||
|]
|
||||
|
||||
-----------------------
|
||||
|
||||
tests :: TestTree
|
||||
|
|
|
|||
Loading…
Reference in a new issue