parent
fb0466769d
commit
7f6a64da04
|
@ -36,7 +36,7 @@ import Data.ByteString.Base16 as Base16
|
||||||
import qualified Data.ByteString.Lazy as LBS
|
import qualified Data.ByteString.Lazy as LBS
|
||||||
import Data.Char (isDigit)
|
import Data.Char (isDigit)
|
||||||
import Data.Coerce
|
import Data.Coerce
|
||||||
import Data.Foldable (foldlM)
|
import Data.Foldable (foldlM, foldrM)
|
||||||
import qualified Data.HashMap.Lazy as M
|
import qualified Data.HashMap.Lazy as M
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
|
@ -224,13 +224,35 @@ call2 f arg1 arg2 = force f $ \f' ->
|
||||||
|
|
||||||
-- Primops
|
-- Primops
|
||||||
|
|
||||||
|
foldNixPath :: forall e m r.
|
||||||
|
(Scoped e (NThunk m) m, MonadEffects m,
|
||||||
|
Framed e m, MonadThrow m, MonadVar m, MonadFile m)
|
||||||
|
=> (FilePath -> Maybe String -> r -> m r) -> r -> m r
|
||||||
|
foldNixPath f z = do
|
||||||
|
mres <- lookupVar @_ @(NThunk m) "__includes"
|
||||||
|
dirs <- case mres of
|
||||||
|
Nothing -> return []
|
||||||
|
Just v -> force v $ \case
|
||||||
|
NVList xs -> forM xs $ flip force $ \case
|
||||||
|
NVStr s _ -> pure s
|
||||||
|
_ -> error "impossible"
|
||||||
|
_ -> error "impossible"
|
||||||
|
menv <- getEnvVar "NIX_PATH"
|
||||||
|
foldrM go z $ dirs ++ case menv of
|
||||||
|
Nothing -> []
|
||||||
|
Just str -> Text.splitOn ":" (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
|
||||||
|
_ -> throwError $ "Unexpected entry in NIX_PATH: " ++ show x
|
||||||
|
|
||||||
nixPath :: MonadBuiltins e m => m (NValue m)
|
nixPath :: MonadBuiltins e m => m (NValue m)
|
||||||
nixPath = fmap NVList $ foldNixPath [] $ \acc p mn -> pure $
|
nixPath = fmap NVList $ flip foldNixPath [] $ \p mn rest -> pure $
|
||||||
(valueThunk . flip NVSet M.empty . M.fromList $
|
(valueThunk . flip NVSet M.empty . M.fromList $
|
||||||
[ ("path", valueThunk $ NVPath p)
|
[ ("path", valueThunk $ NVPath p)
|
||||||
, ("prefix", valueThunk $
|
, ("prefix", valueThunk $
|
||||||
NVStr (Text.pack (fromMaybe "" mn)) mempty) ])
|
NVStr (Text.pack (fromMaybe "" mn)) mempty) ]) : rest
|
||||||
: acc
|
|
||||||
|
|
||||||
toString :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
toString :: MonadBuiltins e m => NThunk m -> m (NValue m)
|
||||||
toString str = do
|
toString str = do
|
||||||
|
|
115
src/Nix/Exec.hs
115
src/Nix/Exec.hs
|
@ -17,6 +17,7 @@
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE TypeSynonymInstances #-}
|
{-# LANGUAGE TypeSynonymInstances #-}
|
||||||
{-# LANGUAGE UndecidableInstances #-}
|
{-# LANGUAGE UndecidableInstances #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
|
||||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
||||||
{-# OPTIONS_GHC -Wno-orphans #-}
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
||||||
|
@ -88,12 +89,16 @@ instance ConvertValue (NValue m) Float where
|
||||||
|
|
||||||
instance ConvertValue (NValue m) Text where
|
instance ConvertValue (NValue m) Text where
|
||||||
ofVal = flip NVStr mempty
|
ofVal = flip NVStr mempty
|
||||||
wantVal = \case NVStr t _ -> Just t; _ -> Nothing
|
wantVal = \case
|
||||||
|
NVStr t _ -> Just t
|
||||||
|
NVPath p -> Just (Text.pack p)
|
||||||
|
_ -> Nothing
|
||||||
|
|
||||||
instance ConvertValue (NValue m) (Maybe Text) where
|
instance ConvertValue (NValue m) (Maybe Text) where
|
||||||
ofVal (Just s) = NVStr s mempty
|
ofVal (Just s) = NVStr s mempty
|
||||||
ofVal Nothing = NVConstant NNull
|
ofVal Nothing = NVConstant NNull
|
||||||
wantVal (NVStr s _) = Just (Just s)
|
wantVal (NVStr s _) = Just (Just s)
|
||||||
|
wantVal (NVPath s) = Just (Just (Text.pack s))
|
||||||
wantVal (NVConstant NNull) = Just Nothing
|
wantVal (NVConstant NNull) = Just Nothing
|
||||||
wantVal _ = Nothing
|
wantVal _ = Nothing
|
||||||
|
|
||||||
|
@ -379,28 +384,51 @@ instance (MonadFix m, MonadThrow m, MonadIO m) => MonadEffects (Lazy m) where
|
||||||
++ " __cur_file is in scope,"
|
++ " __cur_file is in scope,"
|
||||||
++ " but is not a path; it is: "
|
++ " but is not a path; it is: "
|
||||||
++ show v
|
++ show v
|
||||||
pure $ cwd </> origPath
|
pure $ cwd <///> origPath
|
||||||
liftIO $ removeDotDotIndirections <$> canonicalizePath absPath
|
liftIO $ removeDotDotIndirections <$> canonicalizePath absPath
|
||||||
|
|
||||||
findEnvPath name = foldNixPath Nothing go >>= \case
|
findEnvPath name = do
|
||||||
Nothing -> throwError $ "file '" ++ name
|
mres <- lookupVar @_ @(NThunk (Lazy m)) "__nixPath"
|
||||||
++ "' was not found in the Nix search path"
|
mpath <- case mres of
|
||||||
++ " (add it using $NIX_PATH or -I)"
|
Nothing -> error "impossible"
|
||||||
Just path -> return path
|
Just x -> force x $ \case
|
||||||
|
NVList l -> foldM go Nothing l
|
||||||
|
v -> throwError $
|
||||||
|
"__nixPath must be a list of attr sets, but saw: "
|
||||||
|
++ show v
|
||||||
|
case mpath of
|
||||||
|
Nothing ->
|
||||||
|
throwError $ "file '" ++ name
|
||||||
|
++ "' was not found in the Nix search path"
|
||||||
|
++ " (add it using $NIX_PATH or -I)"
|
||||||
|
Just path -> return path
|
||||||
where
|
where
|
||||||
go p@(Just _) _ _ = pure p
|
-- jww (2018-04-13): Introduce abstractions to make working with Nix
|
||||||
go Nothing p Nothing = do
|
-- values like this within Haskell much easier!
|
||||||
traceM $ "[p] = " ++ p
|
go :: Maybe FilePath -> NThunk (Lazy m) -> Lazy m (Maybe FilePath)
|
||||||
traceM $ "name = " ++ name
|
go p@(Just _) _ = pure p
|
||||||
traceM $ "cand = " ++ p </> name
|
go Nothing l = force l $ \case
|
||||||
nixFilePath $ p </> name
|
v@(NVSet s _) -> case M.lookup "path" s of
|
||||||
go Nothing p (Just n)
|
Just p -> force p $ \p' -> case wantVal p' of
|
||||||
| n':ns <- splitDirectories name, n == n' = do
|
Just (path :: Text) -> case M.lookup "prefix" s of
|
||||||
traceM $ "[n, p] = " ++ n ++ ", " ++ p
|
Nothing -> tryPath (Text.unpack path) Nothing
|
||||||
traceM $ "name = " ++ name
|
Just pf -> force pf $ \pf' -> case wantVal pf' of
|
||||||
traceM $ "cand = " ++ p </> joinPath ns
|
Just (pfx :: Text) | not (Text.null pfx) ->
|
||||||
nixFilePath $ p </> joinPath ns
|
tryPath (Text.unpack path)
|
||||||
go _ _ _ = return Nothing
|
(Just (Text.unpack pfx))
|
||||||
|
_ -> tryPath (Text.unpack path) Nothing
|
||||||
|
_ -> throwError $ "__nixPath must be a list of attr sets"
|
||||||
|
++ " with textual 'path' elements, but saw: " ++ show v
|
||||||
|
Nothing ->
|
||||||
|
throwError $ "__nixPath must be a list of attr sets"
|
||||||
|
++ " with 'path' elements, but saw: "
|
||||||
|
++ show v
|
||||||
|
v -> throwError $ "__nixPath must be a list of attr sets"
|
||||||
|
++ " with textual 'path' elements, but saw: " ++ show v
|
||||||
|
|
||||||
|
tryPath p (Just n) | n':ns <- splitDirectories name, n == n' =
|
||||||
|
nixFilePath $ p <///> joinPath ns
|
||||||
|
tryPath p _ = nixFilePath $ p <///> name
|
||||||
|
|
||||||
pathExists = liftIO . fileExist
|
pathExists = liftIO . fileExist
|
||||||
|
|
||||||
|
@ -480,44 +508,23 @@ removeDotDotIndirections = intercalate "/" . go [] . splitOn "/"
|
||||||
pathToDefaultNixFile :: FilePath -> IO FilePath
|
pathToDefaultNixFile :: FilePath -> IO FilePath
|
||||||
pathToDefaultNixFile p = do
|
pathToDefaultNixFile p = do
|
||||||
isDir <- doesDirectoryExist p
|
isDir <- doesDirectoryExist p
|
||||||
pure $ if isDir
|
pure $ if isDir then p </> "default.nix" else p
|
||||||
then p </> "default.nix"
|
|
||||||
else p
|
infixr 9 <///>
|
||||||
|
(<///>) :: FilePath -> FilePath -> FilePath
|
||||||
|
x <///> y | isAbsolute y || "." `isPrefixOf` y = x </> y
|
||||||
|
| otherwise = joinByLargestOverlap x y
|
||||||
|
where
|
||||||
|
joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) =
|
||||||
|
joinPath $ head [ xs ++ drop (length tx) ys
|
||||||
|
| tx <- tails xs, tx `elem` inits ys ]
|
||||||
|
|
||||||
nixFilePath :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath)
|
nixFilePath :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath)
|
||||||
nixFilePath path = do
|
nixFilePath path = do
|
||||||
path <- makeAbsolutePath path
|
path <- makeAbsolutePath path
|
||||||
traceM $ "path = " ++ path
|
|
||||||
exists <- liftIO $ doesDirectoryExist path
|
exists <- liftIO $ doesDirectoryExist path
|
||||||
traceM $ "exists = " ++ show exists
|
path' <- if exists
|
||||||
path' <-
|
then makeAbsolutePath $ path </> "default.nix"
|
||||||
if exists
|
else return path
|
||||||
then makeAbsolutePath $ path </> "default.nix"
|
|
||||||
else return path
|
|
||||||
traceM $ "path' = " ++ path'
|
|
||||||
exists <- liftIO $ doesFileExist path'
|
exists <- liftIO $ doesFileExist path'
|
||||||
traceM $ "exists = " ++ show exists
|
|
||||||
return $ if exists then Just path' else Nothing
|
return $ if exists then Just path' else Nothing
|
||||||
|
|
||||||
foldNixPath :: forall e m r.
|
|
||||||
(Scoped e (NThunk m) m, MonadEffects m,
|
|
||||||
Framed e m, MonadThrow m, MonadVar m, MonadFile m)
|
|
||||||
=> r -> (r -> FilePath -> Maybe String -> m r) -> m r
|
|
||||||
foldNixPath z f = do
|
|
||||||
mres <- lookupVar @_ @(NThunk m) "__includes"
|
|
||||||
dirs <- case mres of
|
|
||||||
Nothing -> return []
|
|
||||||
Just v -> force v $ \case
|
|
||||||
NVList xs -> forM xs $ flip force $ \case
|
|
||||||
NVStr s _ -> pure s
|
|
||||||
_ -> error "impossible"
|
|
||||||
_ -> error "impossible"
|
|
||||||
menv <- getEnvVar "NIX_PATH"
|
|
||||||
foldM go z $ dirs ++ case menv of
|
|
||||||
Nothing -> []
|
|
||||||
Just str -> Text.splitOn ":" (Text.pack str)
|
|
||||||
where
|
|
||||||
go acc x = case Text.splitOn "=" x of
|
|
||||||
[p] -> f acc (Text.unpack p) Nothing
|
|
||||||
[n, p] -> f acc (Text.unpack p) (Just (Text.unpack n))
|
|
||||||
_ -> throwError $ "Unexpected entry in NIX_PATH: " ++ show x
|
|
||||||
|
|
|
@ -125,8 +125,9 @@ assertEval files = catch go $ \case
|
||||||
-- used, then apply those arguments after evaluation (see
|
-- used, then apply those arguments after evaluation (see
|
||||||
-- Main.hs).
|
-- Main.hs).
|
||||||
assertLangOk name
|
assertLangOk name
|
||||||
("nix=../../../../data/nix/corepkgs" :
|
(include opts ++
|
||||||
"dir4" : include opts)
|
[ "nix=../../../../data/nix/corepkgs"
|
||||||
|
, "lang/dir4" ])
|
||||||
Opts.CompletionInvoked _ -> error "unused"
|
Opts.CompletionInvoked _ -> error "unused"
|
||||||
_ -> assertFailure $ "Unknown test type " ++ show files
|
_ -> assertFailure $ "Unknown test type " ++ show files
|
||||||
where
|
where
|
||||||
|
|
Loading…
Reference in a new issue