diff --git a/hnix.cabal b/hnix.cabal index 74913bc0e..1715d3fd5 100644 --- a/hnix.cabal +++ b/hnix.cabal @@ -341,6 +341,7 @@ library Nix.Convert Nix.Effects Nix.Effects.Basic + Nix.Effects.Derivation Nix.Eval Nix.Exec Nix.Expr @@ -401,8 +402,9 @@ library , gitrev >= 1.1.0 && < 1.4 , hashable >= 1.2.5 && < 1.4 , hashing >= 0.1.0 && < 0.2 - , hnix-store-core >= 0.1.0 && < 0.3 - , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.8 + , hnix-store-core + , hnix-store-remote + , http-client >= 0.5.14 && < 0.6 || >= 0.6.4 && < 0.7 , http-client-tls >= 0.3.5 && < 0.4 , http-types >= 0.12.2 && < 0.13 , lens-family >= 1.2.2 && < 2.2 diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs index f74b6f71f..78c15bb35 100644 --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -24,6 +24,7 @@ module Nix.Builtins (withNixContext, builtins) where +import Control.Arrow ( (&&&) ) import Control.Comonad import Control.Monad import Control.Monad.Catch @@ -45,6 +46,7 @@ import Data.Char ( isDigit ) import Data.Fix ( foldFix ) import Data.Foldable ( foldrM ) import qualified Data.HashMap.Lazy as M +import qualified Data.HashSet as HS import Data.List import Data.Maybe import Data.Scientific @@ -145,18 +147,19 @@ builtinsList = sequence version <- toValue (5 :: Int) pure $ Builtin Normal ("langVersion", version) - , add0 Normal "nixPath" nixPath , add TopLevel "abort" throw_ -- for now , add2 Normal "add" add_ , add2 Normal "addErrorContext" addErrorContext , add2 Normal "all" all_ , add2 Normal "any" any_ + , add2 Normal "appendContext" appendContext , add Normal "attrNames" attrNames , add Normal "attrValues" attrValues , add TopLevel "baseNameOf" baseNameOf , add2 Normal "bitAnd" bitAnd , add2 Normal "bitOr" bitOr , add2 Normal "bitXor" bitXor + , add0 Normal "builtins" builtinsBuiltin , add2 Normal "catAttrs" catAttrs , add2 Normal "compareVersions" compareVersions_ , add Normal "concatLists" concatLists @@ -235,6 +238,7 @@ builtinsList = sequence , add2 TopLevel "map" map_ , add2 TopLevel "mapAttrs" mapAttrs_ , add2 Normal "match" match_ + , add0 Normal "nixPath" nixPath , add2 Normal "mul" mul_ , add0 Normal "null" (pure $ nvConstant NNull) , add Normal "parseDrvName" parseDrvName @@ -244,6 +248,16 @@ builtinsList = sequence , add Normal "readDir" readDir_ , add Normal "readFile" readFile_ , add2 Normal "findFile" findFile_ + {- + , add Normal "fetchGit" fetchGit + , add Normal "fetchMercurial" fetchMercurial + , add Normal "filterSource" filterSource + , add Normal "fromTOML" fromTOML + -} + , add Normal "getContext" getContext + --, add Normal "hashFile" hashFile + , add Normal "isPath" isPath + , add Normal "path" path , add2 TopLevel "removeAttrs" removeAttrs , add3 Normal "replaceStrings" replaceStrings , add2 TopLevel "scopedImport" scopedImport @@ -252,9 +266,12 @@ builtinsList = sequence , add2 Normal "split" split_ , add Normal "splitVersion" splitVersion_ , add0 Normal "storeDir" (pure $ nvStr $ principledMakeNixStringWithoutContext "/nix/store") + {- + , add Normal "storePath" storePath + -} , add' Normal "stringLength" (arity1 $ Text.length . principledStringIgnoreContext) , add' Normal "sub" (arity2 ((-) @Integer)) - , add' Normal "substring" (substring @e @t @f @m) + , add' Normal "substring" substring , add Normal "tail" tail_ , add0 Normal "true" (pure $ nvConstant $ NBool True) , add TopLevel "throw" throw_ @@ -266,12 +283,11 @@ builtinsList = sequence , add2 TopLevel "trace" trace_ , add Normal "tryEval" tryEval , add Normal "typeOf" typeOf + , add2 Normal "unsafeGetAttrPos" unsafeGetAttrPos + , add Normal "unsafeDiscardStringContext" unsafeDiscardStringContext + , add Normal "unsafeDiscardOutputDependency" unsafeDiscardOutputDependency , add Normal "valueSize" getRecursiveSize - , add Normal "getContext" getContext - , add2 Normal "appendContext" appendContext - , add2 Normal "unsafeGetAttrPos" unsafeGetAttrPos - , add Normal "unsafeDiscardStringContext" unsafeDiscardStringContext ] where wrap :: BuiltinType -> Text -> v -> Builtin v @@ -652,13 +668,13 @@ splitMatches numDropped (((_, (start, len)) : captures) : mts) haystack = thunkStr s = nvStr (hackyMakeNixStringWithoutContext (decodeUtf8 s)) substring :: forall e t f m. 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 - $ ErrorCall - $ "builtins.substring: negative start position: " - ++ show start - else pure $ principledModifyNixContents (Text.take len . Text.drop start) str +substring start len str = Prim $ + if start < 0 + then throwError $ ErrorCall $ "builtins.substring: negative start position: " ++ show start + else pure $ principledModifyNixContents (take . Text.drop start) str + where + --NOTE: negative values of 'len' are OK, and mean "take everything" + take = if len < 0 then id else Text.take len attrNames :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) @@ -766,6 +782,12 @@ bitXor bitXor x y = fromValue @Integer x >>= \a -> fromValue @Integer y >>= \b -> toValue (a `xor` b) +builtinsBuiltin + :: forall e t f m + . MonadNix e t f m + => m (NValue t f m) +builtinsBuiltin = (throwError $ ErrorCall "HNix does not provide builtins.builtins at the moment. Using builtins directly should be preferred") + dirOf :: MonadNix e t f m => NValue t f m -> m (NValue t f m) dirOf x = demand x $ \case NVStr ns -> pure $ nvStr @@ -774,7 +796,6 @@ dirOf x = demand x $ \case v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v --- jww (2018-04-28): This should only be a string argument, and not coerced? unsafeDiscardStringContext :: MonadNix e t f m => NValue t f m -> m (NValue t f m) unsafeDiscardStringContext mnv = do @@ -782,6 +803,15 @@ unsafeDiscardStringContext mnv = do toValue $ principledMakeNixStringWithoutContext $ principledStringIgnoreContext ns +unsafeDiscardOutputDependency + :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +unsafeDiscardOutputDependency mnv = do + (ns, nc) <- (principledStringIgnoreContext &&& principledGetContext) <$> fromValue mnv + toValue $ principledMakeNixString ns $ HS.map discard nc + where + discard (StringContext a AllOutputs) = StringContext a DirectPath + discard x = x + seq_ :: MonadNix e t f m => NValue t f m @@ -957,6 +987,49 @@ replaceStrings tfrom tto ts = fromValue (Deeper tfrom) >>= \(nsFrom :: [NixStrin $ go (principledStringIgnoreContext ns) mempty $ principledGetContext ns +attrGetOr' :: forall e t f m v a. (MonadNix e t f m, FromValue v m (NValue' t f m (NValue t f m))) + => (AttrSet (NValue t f m)) -> Text -> m a -> (v -> m a) -> m a +attrGetOr' attrs n d f = case M.lookup n attrs of + Nothing -> d + Just v -> fromValue v >>= f + +attrGetOr attrs name fallback fun = attrGetOr' attrs name (return fallback) fun +-- attrGet attrs name = attrGetOr' attrs name (throwError $ ErrorCall $ "Required attribute '" ++ show name ++ "' not found.") + +path :: forall e t f m. MonadNix e t f m => NValue t f m -> m (NValue t f m) +path arg = fromValue @(AttrSet (NValue t f m)) arg >>= \attrs -> do + path <- fromStringNoContext =<< coerceToPath =<< attrsetGet "path" attrs + let filter = maybe (\_p _pt -> pure True) evalFilter $ M.lookup "filter" attrs + + -- TODO: Fail on extra args + -- XXX: This is a very common pattern, we could factor it out + name <- attrGetOr attrs "name" (fileName path) (fromStringNoContext) + sha256 <- attrGetOr attrs "sha256" ("") (fromStringNoContext) + recursive <- attrGetOr attrs "recursive" (True) (return) + + s <- Text.pack . unStorePath <$> addToStore name (Text.unpack path) filter recursive False + -- TODO: Ensure that s matches sha256 when not empty + pure $ nvStr $ principledMakeNixStringWithSingletonContext s (StringContext s DirectPath) + + where + pathToStr = nvStr . principledMakeNixStringWithoutContext . Text.pack + fileName = Text.pack . takeFileName . Text.unpack + + coerceToPath = coerceToString callFunc DontCopyToStore CoerceAny + + evalFilter :: (NValue t f m) -> FilePath -> PathType -> m Bool + evalFilter fun p pt = do + fun' <- fun `callFunc` (pathToStr p) + res <- fun' `callFunc` (pathTypeStr pt) + fromValue res + + pathTypeStr :: PathType -> (NValue t f m) + pathTypeStr = nvStr . principledMakeNixStringWithoutContext . \case + Regular -> "regular" + Directory -> "directory" + Symlink -> "symlink" + Unknown -> "unknown" + removeAttrs :: forall e t f m . MonadNix e t f m @@ -1040,10 +1113,6 @@ isList :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) isList = hasKind @[NValue t f m] -isString - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -isString = hasKind @NixString - isInt :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) isInt = hasKind @Int @@ -1060,6 +1129,16 @@ isNull :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) isNull = hasKind @() +isPath + :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) +isPath = hasKind @Path + +-- isString cannot use `hasKind` because it coerces derivations to strings. +isString :: MonadNix e t f m => NValue t f m -> m (NValue t f m) +isString v = demand v $ \case + NVStr{} -> toValue True + _ -> toValue False + isFunction :: MonadNix e t f m => NValue t f m -> m (NValue t f m) isFunction func = demand func $ \case NVClosure{} -> toValue True diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs index 2989e3771..9973810a1 100644 --- a/src/Nix/Convert.hs +++ b/src/Nix/Convert.hs @@ -151,7 +151,7 @@ instance ( Convertible e t f m NVStr' ns -> pure $ Just ns NVPath' p -> Just - . hackyMakeNixStringWithoutContext + . (\s -> principledMakeNixStringWithSingletonContext s (StringContext s DirectPath)) . Text.pack . unStorePath <$> addPath p diff --git a/src/Nix/Effects.hs b/src/Nix/Effects.hs index 9c0ad883a..aad2a0a9b 100644 --- a/src/Nix/Effects.hs +++ b/src/Nix/Effects.hs @@ -7,8 +7,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} -module Nix.Effects where +module Nix.Effects ( + module Nix.Effects + , Store.PathType (..) + ) where import Prelude hiding ( putStr , putStrLn @@ -17,24 +22,31 @@ import Prelude hiding ( putStr import qualified Prelude import Control.Monad.Trans +import qualified Data.HashSet as HS import Data.Text ( Text ) import qualified Data.Text as T -import Network.HTTP.Client hiding ( path ) +import qualified Data.Text.Encoding as T +import Network.HTTP.Client hiding ( path, Proxy ) import Network.HTTP.Client.TLS import Network.HTTP.Types import Nix.Expr -import Nix.Frames +import Nix.Frames hiding ( Proxy ) import Nix.Parser import Nix.Render import Nix.Utils import Nix.Value import qualified Paths_hnix -import qualified System.Directory as S import System.Environment import System.Exit +import System.FilePath ( takeFileName ) import qualified System.Info import System.Process +import qualified System.Nix.Hash as Store +import qualified System.Nix.Store.Remote as Store +import qualified System.Nix.Store.Remote.Types as Store +import qualified System.Nix.StorePath as Store + -- | A path into the nix store newtype StorePath = StorePath { unStorePath :: FilePath } @@ -145,7 +157,7 @@ instance MonadInstantiate IO where ++ err pathExists :: MonadFile m => FilePath -> m Bool -pathExists = doesFileExist +pathExists = doesPathExist class Monad m => MonadEnv m where getEnvVar :: String -> m (Maybe String) @@ -226,36 +238,36 @@ print = putStrLn . show instance MonadPutStr IO where putStr = Prelude.putStr -class Monad m => MonadStore m where - -- | Import a path into the nix store, and return the resulting path - addPath' :: FilePath -> m (Either ErrorCall StorePath) - -- | Add a file with the given name and contents to the nix store - toFile_' :: FilePath -> String -> m (Either ErrorCall StorePath) +type RecursiveFlag = Bool +type RepairFlag = Bool +type StorePathName = Text +type FilePathFilter m = FilePath -> Store.PathType -> m Bool +type StorePathSet = HS.HashSet StorePath + +class (MonadIO m, Store.MonadRemoteStore m) => MonadStore m where + + -- | Add a path to the store, with bells and whistles + addToStore :: StorePathName -> FilePath -> FilePathFilter m -> RecursiveFlag -> RepairFlag -> m StorePath + default addToStore :: StorePathName -> FilePath -> FilePathFilter m -> RecursiveFlag -> RepairFlag -> m StorePath + addToStore name path filter recursive repair = do + -- TODO: replace this error call by something smarter. throwE ? throwError ? + pathName <- either error return $ Store.makeStorePathName name + convertStorePath <$> Store.addToStore @'Store.SHA256 pathName path recursive filter repair + + addTextToStore :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath + default addTextToStore :: StorePathName -> Text -> Store.StorePathSet -> RepairFlag -> m StorePath + addTextToStore name text references repair = + convertStorePath <$> Store.addTextToStore name text references repair -instance MonadStore IO where - addPath' path = do - (exitCode, out, _) <- readProcessWithExitCode "nix-store" ["--add", path] "" - case exitCode of - ExitSuccess -> do - let dropTrailingLinefeed p = take (length p - 1) p - pure $ Right $ StorePath $ dropTrailingLinefeed out - _ -> - pure - $ Left - $ ErrorCall - $ "addPath: failed: nix-store --add " - ++ show path - --TODO: Use a temp directory so we don't overwrite anything important - toFile_' filepath content = do - writeFile filepath content - storepath <- addPath' filepath - S.removeFile filepath - pure storepath +-- XXX (layus) relying on show is not ideal, but way more concise. +-- Bound to disappear anyway if we unify StorePath representation across hnix* projects +convertStorePath :: Store.StorePath -> StorePath +convertStorePath = StorePath . show -addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath -addPath p = either throwError pure =<< addPath' p +toFile_ :: MonadStore m => FilePath -> String -> m StorePath +toFile_ p contents = addTextToStore (T.pack p) (T.pack contents) HS.empty False -toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath -toFile_ p contents = either throwError pure =<< toFile_' p contents +addPath :: (MonadStore m) => FilePath -> m StorePath +addPath p = addToStore (T.pack $ takeFileName p) p (\_p _pt -> pure True) True False diff --git a/src/Nix/Effects/Basic.hs b/src/Nix/Effects/Basic.hs index 25bd631d2..44535e85b 100644 --- a/src/Nix/Effects/Basic.hs +++ b/src/Nix/Effects/Basic.hs @@ -8,10 +8,6 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wno-missing-signatures #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - module Nix.Effects.Basic where import Control.Monad @@ -20,30 +16,24 @@ import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M import Data.List import Data.List.Split -import Data.Maybe ( maybeToList ) import Data.Text ( Text ) import qualified Data.Text as Text -import Nix.Atoms +import Data.Text.Prettyprint.Doc import Nix.Convert import Nix.Effects import Nix.Exec ( MonadNix - , callFunc , evalExprLoc , nixInstantiateExpr ) import Nix.Expr import Nix.Frames -import Nix.Normal import Nix.Parser -import Nix.Pretty import Nix.Render import Nix.Scope import Nix.String -import Nix.String.Coerce import Nix.Utils import Nix.Value import Nix.Value.Monad -import Prettyprinter import System.FilePath #ifdef MIN_VERSION_ghc_datasize @@ -64,13 +54,13 @@ defaultMakeAbsolutePath origPath = do Nothing -> getCurrentDirectory Just v -> demand v $ \case NVPath s -> pure $ takeDirectory s - v -> + val -> throwError $ ErrorCall $ "when resolving relative path," ++ " __cur_file is in scope," ++ " but is not a path; it is: " - ++ show v + ++ show val pure $ cwd origPathExpanded removeDotDotIndirections <$> canonicalizePath absPath @@ -111,13 +101,13 @@ findEnvPathM name = do where nixFilePath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) nixFilePath path = do - path <- makeAbsolutePath @t @f path - exists <- doesDirectoryExist path - path' <- if exists - then makeAbsolutePath @t @f $ path "default.nix" - else pure path - exists <- doesFileExist path' - pure $ if exists then Just path' else Nothing + absPath <- makeAbsolutePath @t @f path + isDir <- doesDirectoryExist absPath + absFile <- if isDir + then makeAbsolutePath @t @f $ absPath "default.nix" + else return absPath + exists <- doesFileExist absFile + pure $ if exists then Just absFile else Nothing findPathBy :: forall e t f m @@ -126,8 +116,8 @@ findPathBy -> [NValue t f m] -> FilePath -> m FilePath -findPathBy finder l name = do - mpath <- foldM go Nothing l +findPathBy finder ls name = do + mpath <- foldM go Nothing ls case mpath of Nothing -> throwError @@ -226,22 +216,22 @@ findPathM => [NValue t f m] -> FilePath -> m FilePath -findPathM = findPathBy path +findPathM = findPathBy existingPath where - path :: MonadEffects t f m => FilePath -> m (Maybe FilePath) - path path = do - path <- makeAbsolutePath @t @f path - exists <- doesPathExist path - pure $ if exists then Just path else Nothing + existingPath :: MonadEffects t f m => FilePath -> m (Maybe FilePath) + existingPath path = do + apath <- makeAbsolutePath @t @f path + exists <- doesPathExist apath + pure $ if exists then Just apath else Nothing defaultImportPath - :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc) m) + :: (MonadNix e t f m, MonadState (HashMap FilePath NExprLoc, b) m) => FilePath -> m (NValue t f m) defaultImportPath path = do traceM $ "Importing file " ++ path withFrame Info (ErrorCall $ "While importing file " ++ show path) $ do - imports <- get + imports <- gets fst evalExprLoc =<< case M.lookup path imports of Just expr -> pure expr Nothing -> do @@ -252,7 +242,7 @@ defaultImportPath path = do $ ErrorCall . show $ fillSep ["Parse during import failed:", err] Success expr -> do - modify (M.insert path expr) + modify (\(a, b) -> (M.insert path expr a, b)) pure expr defaultPathToDefaultNix :: MonadNix e t f m => FilePath -> m FilePath @@ -264,38 +254,5 @@ pathToDefaultNixFile p = do isDir <- doesDirectoryExist p pure $ if isDir then p "default.nix" else p -defaultDerivationStrict - :: forall e t f m . MonadNix e t f m => NValue t f m -> m (NValue t f m) -defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do - nn <- maybe (pure False) (demand ?? fromValue) (M.lookup "__ignoreNulls" s) - s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s) - v' <- normalForm =<< toValue @(AttrSet (NValue t f m)) @_ @(NValue t f m) s' - nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValue v') - where - mapMaybeM :: (a -> m (Maybe b)) -> [a] -> m [b] - mapMaybeM op = foldr f (pure []) - where f x xs = op x >>= (<$> xs) . (++) . maybeToList - - handleEntry :: Bool -> (Text, NValue t f m) -> m (Maybe (Text, NValue t f m)) - handleEntry ignoreNulls (k, v) = fmap (k, ) <$> case k of - -- The `args' attribute is special: it supplies the command-line - -- arguments to the builder. - -- TODO This use of coerceToString is probably not right and may - -- not have the right arguments. - "args" -> demand v $ fmap Just . coerceNixList - "__ignoreNulls" -> pure Nothing - _ -> demand v $ \case - NVConstant NNull | ignoreNulls -> pure Nothing - v' -> Just <$> coerceNix v' - where - coerceNix :: NValue t f m -> m (NValue t f m) - coerceNix = toValue <=< coerceToString callFunc CopyToStore CoerceAny - - coerceNixList :: NValue t f m -> m (NValue t f m) - coerceNixList v = do - xs <- fromValue @[NValue t f m] v - ys <- traverse (`demand` coerceNix) xs - toValue @[NValue t f m] ys - defaultTraceEffect :: MonadPutStr m => String -> m () defaultTraceEffect = Nix.Effects.putStrLn diff --git a/src/Nix/Effects/Derivation.hs b/src/Nix/Effects/Derivation.hs new file mode 100644 index 000000000..6a4e15c6e --- /dev/null +++ b/src/Nix/Effects/Derivation.hs @@ -0,0 +1,396 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + + +module Nix.Effects.Derivation ( defaultDerivationStrict ) where + +import Prelude hiding ( readFile ) + +import Control.Arrow ( first, second ) +import Control.Monad ( (>=>), forM, when ) +import Control.Monad.Writer ( join, lift ) +import Control.Monad.State ( MonadState, gets, modify ) + +import Data.Char ( isAscii, isAlphaNum ) +import qualified Data.HashMap.Lazy as M +import qualified Data.HashMap.Strict as MS +import qualified Data.HashSet as S +import Data.List +import qualified Data.Map.Strict as Map +import Data.Map.Strict ( Map ) +import qualified Data.Set as Set +import Data.Set ( Set ) +import Data.Text ( Text ) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text + +import Nix.Atoms +import Nix.Convert +import Nix.Effects +import Nix.Exec ( MonadNix , callFunc) +import Nix.Frames +import Nix.Json ( nvalueToJSONNixString ) +import Nix.Parser +import Nix.Render +import Nix.String +import Nix.String.Coerce +import Nix.Utils hiding ( readFile ) +import Nix.Value +import Nix.Value.Monad + +import qualified System.Nix.ReadonlyStore as Store +import qualified System.Nix.Hash as Store +import qualified System.Nix.StorePath as Store + +import Text.Megaparsec +import Text.Megaparsec.Char + + +data Derivation = Derivation + { name :: Text + , outputs :: Map Text Text + , inputs :: (Set Text, Map Text [Text]) + , platform :: Text + , builder :: Text -- should be typed as a store path + , args :: [ Text ] + , env :: Map Text Text + , mFixed :: Maybe Store.SomeNamedDigest + , hashMode :: HashMode + , useJson :: Bool + } + deriving Show + +defaultDerivation :: Derivation +defaultDerivation = Derivation + { name = undefined + , outputs = Map.empty + , inputs = (Set.empty, Map.empty) + , platform = undefined + , builder = undefined + , args = [] + , env = Map.empty + , mFixed = Nothing + , hashMode = Flat + , useJson = False + } + +data HashMode = Flat | Recursive + deriving (Show, Eq) + +makeStorePathName :: (Framed e m) => Text -> m Store.StorePathName +makeStorePathName name = case Store.makeStorePathName name of + Left err -> throwError $ ErrorCall $ "Invalid name '" ++ show name ++ "' for use in a store path: " ++ err + Right spname -> return spname + +parsePath :: (Framed e m) => Text -> m Store.StorePath +parsePath p = case Store.parsePath "/nix/store" (Text.encodeUtf8 p) of + Left err -> throwError $ ErrorCall $ "Cannot parse store path " ++ show p ++ ":\n" ++ show err + Right path -> return path + +writeDerivation :: (Framed e m, MonadStore m) => Derivation -> m Store.StorePath +writeDerivation (drv@Derivation {inputs, name}) = do + let (inputSrcs, inputDrvs) = inputs + references <- Set.fromList <$> (mapM parsePath $ Set.toList $ inputSrcs `Set.union` (Set.fromList $ Map.keys inputDrvs)) + path <- addTextToStore (Text.append name ".drv") (unparseDrv drv) (S.fromList $ Set.toList references) False + parsePath $ Text.pack $ unStorePath path + +-- | Traverse the graph of inputDrvs to replace fixed output derivations with their fixed output hash. +-- this avoids propagating changes to their .drv when the output hash stays the same. +hashDerivationModulo :: (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => Derivation -> m (Store.Digest 'Store.SHA256) +hashDerivationModulo (Derivation { + mFixed = Just (Store.SomeDigest (digest :: Store.Digest hashType)), + outputs, + hashMode + }) = case Map.toList outputs of + [("out", path)] -> return $ Store.hash @'Store.SHA256 $ Text.encodeUtf8 + $ "fixed:out" + <> (if hashMode == Recursive then ":r" else "") + <> ":" <> (Store.algoName @hashType) + <> ":" <> (Store.encodeBase16 digest) + <> ":" <> path + outputsList -> throwError $ ErrorCall $ "This is weird. A fixed output drv should only have one output named 'out'. Got " ++ show outputsList +hashDerivationModulo drv@(Derivation {inputs = (inputSrcs, inputDrvs)}) = do + cache <- gets snd + inputsModulo <- Map.fromList <$> forM (Map.toList inputDrvs) (\(path, outs) -> + case MS.lookup path cache of + Just hash -> return (hash, outs) + Nothing -> do + drv' <- readDerivation $ Text.unpack path + hash <- Store.encodeBase16 <$> hashDerivationModulo drv' + return (hash, outs) + ) + return $ Store.hash @'Store.SHA256 $ Text.encodeUtf8 $ unparseDrv (drv {inputs = (inputSrcs, inputsModulo)}) + +unparseDrv :: Derivation -> Text +unparseDrv (Derivation {..}) = Text.append "Derive" $ parens + [ -- outputs: [("out", "/nix/store/.....-out", "", ""), ...] + list $ flip map (Map.toList outputs) (\(outputName, outputPath) -> + let prefix = if hashMode == Recursive then "r:" else "" in + case mFixed of + Nothing -> parens [s outputName, s outputPath, s "", s ""] + Just (Store.SomeDigest (digest :: Store.Digest hashType)) -> + parens [s outputName, s outputPath, s $ prefix <> Store.algoName @hashType, s $ Store.encodeBase16 digest] + ) + , -- inputDrvs + list $ flip map (Map.toList $ snd inputs) (\(path, outs) -> + parens [s path, list $ map s $ sort outs]) + , -- inputSrcs + list (map s $ Set.toList $ fst inputs) + , s platform + , s builder + , -- run script args + list $ map s args + , -- env (key value pairs) + list $ flip map (Map.toList env) (\(k, v) -> + parens [s k, s v]) + ] + where + parens :: [Text] -> Text + parens ts = Text.concat ["(", Text.intercalate "," ts, ")"] + list :: [Text] -> Text + list ls = Text.concat ["[", Text.intercalate "," ls, "]"] + s = (Text.cons '\"') . (flip Text.snoc '\"') . Text.concatMap escape + escape :: Char -> Text + escape '\\' = "\\\\" + escape '\"' = "\\\"" + escape '\n' = "\\n" + escape '\r' = "\\r" + escape '\t' = "\\t" + escape c = Text.singleton c + +readDerivation :: (Framed e m, MonadFile m) => FilePath -> m Derivation +readDerivation path = do + content <- Text.decodeUtf8 <$> readFile path + case parse derivationParser path content of + Left err -> throwError $ ErrorCall $ "Failed to parse " ++ show path ++ ":\n" ++ show err + Right drv -> return drv + +derivationParser :: Parser Derivation +derivationParser = do + _ <- "Derive(" + fullOutputs <- list $ + fmap (\[n, p, ht, h] -> (n, p, ht, h)) $ parens s + _ <- "," + inputDrvs <- fmap Map.fromList $ list $ + fmap (,) ("(" *> s <* ",") <*> (list s <* ")") + _ <- "," + inputSrcs <- fmap Set.fromList $ list s + _ <- "," + platform <- s + _ <- "," + builder <- s + _ <- "," + args <- list s + _ <- "," + env <- fmap Map.fromList $ list $ fmap (\[a, b] -> (a, b)) $ parens s + _ <- ")" + eof + + let outputs = Map.fromList $ map (\(a, b, _, _) -> (a, b)) fullOutputs + let (mFixed, hashMode) = parseFixed fullOutputs + let name = "" -- FIXME (extract from file path ?) + let useJson = ["__json"] == Map.keys env + + return $ Derivation {inputs = (inputSrcs, inputDrvs), ..} + where + s :: Parser Text + s = fmap Text.pack $ string "\"" *> manyTill (escaped <|> regular) (string "\"") + escaped = char '\\' *> + ( '\n' <$ string "n" + <|> '\r' <$ string "r" + <|> '\t' <$ string "t" + <|> anySingle + ) + regular = noneOf ['\\', '"'] + + parens :: Parser a -> Parser [a] + parens p = (string "(") *> sepBy p (string ",") <* (string ")") + list p = (string "[") *> sepBy p (string ",") <* (string "]") + + parseFixed :: [(Text, Text, Text, Text)] -> (Maybe Store.SomeNamedDigest, HashMode) + parseFixed fullOutputs = case fullOutputs of + [("out", _path, rht, hash)] | rht /= "" && hash /= "" -> + let (hashType, hashMode) = case Text.splitOn ":" rht of + ["r", ht] -> (ht, Recursive) + [ht] -> (ht, Flat) + _ -> undefined -- What ?! -- TODO: Throw a proper error + in case Store.mkNamedDigest hashType hash of + Right digest -> (Just digest, hashMode) + Left _err -> undefined -- TODO: Raise a proper parse error. + _ -> (Nothing, Flat) + + +defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => NValue t f m -> m (NValue t f m) +defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do + (drv, ctx) <- runWithStringContextT' $ buildDerivationWithContext s + drvName <- makeStorePathName $ name drv + let inputs = toStorePaths ctx + + -- Compute the output paths, and add them to the environment if needed. + -- Also add the inputs, just computed from the strings contexts. + drv' <- case mFixed drv of + Just (Store.SomeDigest digest) -> do + let out = pathToText $ Store.makeFixedOutputPath "/nix/store" (hashMode drv == Recursive) digest drvName + let env' = if useJson drv then env drv else Map.insert "out" out (env drv) + return $ drv { inputs, env = env', outputs = Map.singleton "out" out } + + Nothing -> do + hash <- hashDerivationModulo $ drv + { inputs + --, outputs = Map.map (const "") (outputs drv) -- not needed, this is already the case + , env = if useJson drv then env drv + else foldl' (\m k -> Map.insert k "" m) (env drv) (Map.keys $ outputs drv) + } + outputs' <- sequence $ Map.mapWithKey (\o _ -> makeOutputPath o hash drvName) (outputs drv) + return $ drv + { inputs + , outputs = outputs' + , env = if useJson drv then env drv else Map.union outputs' (env drv) + } + + drvPath <- pathToText <$> writeDerivation drv' + + -- Memoize here, as it may be our last chance in case of readonly stores. + drvHash <- Store.encodeBase16 <$> hashDerivationModulo drv' + modify (\(a, b) -> (a, MS.insert drvPath drvHash b)) + + let outputsWithContext = Map.mapWithKey (\out path -> principledMakeNixStringWithSingletonContext path (StringContext drvPath (DerivationOutput out))) (outputs drv') + drvPathWithContext = principledMakeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs) + attrSet = M.map nvStr $ M.fromList $ ("drvPath", drvPathWithContext): Map.toList outputsWithContext + -- TODO: Add location information for all the entries. + -- here --v + return $ nvSet attrSet M.empty + + where + + pathToText = Text.decodeUtf8 . Store.storePathToRawFilePath + + makeOutputPath o h n = do + name <- makeStorePathName (Store.unStorePathName n <> if o == "out" then "" else "-" <> o) + return $ pathToText $ Store.makeStorePath "/nix/store" ("output:" <> Text.encodeUtf8 o) h name + + toStorePaths ctx = foldl (flip addToInputs) (Set.empty, Map.empty) ctx + addToInputs (StringContext path kind) = case kind of + DirectPath -> first (Set.insert path) + DerivationOutput o -> second (Map.insertWith (++) path [o]) + AllOutputs -> + -- TODO: recursive lookup. See prim_derivationStrict + -- XXX: When is this really used ? + undefined + + +-- | Build a derivation in a context collecting string contexts. +-- This is complex from a typing standpoint, but it allows to perform the +-- full computation without worrying too much about all the string's contexts. +buildDerivationWithContext :: forall e t f m. (MonadNix e t f m) => AttrSet (NValue t f m) -> WithStringContextT m Derivation +buildDerivationWithContext drvAttrs = do + -- Parse name first, so we can add an informative frame + drvName <- getAttr "name" $ extractNixString >=> assertDrvStoreName + withFrame' Info (ErrorCall $ "While evaluating derivation " ++ show drvName) $ do + + useJson <- getAttrOr "__structuredAttrs" False $ return + ignoreNulls <- getAttrOr "__ignoreNulls" False $ return + + args <- getAttrOr "args" [] $ mapM (fromValue' >=> extractNixString) + builder <- getAttr "builder" $ extractNixString + platform <- getAttr "system" $ extractNoCtx >=> assertNonNull + mHash <- getAttrOr "outputHash" Nothing $ extractNoCtx >=> (return . Just) + hashMode <- getAttrOr "outputHashMode" Flat $ extractNoCtx >=> parseHashMode + outputs <- getAttrOr "outputs" ["out"] $ mapM (fromValue' >=> extractNoCtx) + + mFixedOutput <- case mHash of + Nothing -> return Nothing + Just hash -> do + when (outputs /= ["out"]) $ lift $ throwError $ ErrorCall $ "Multiple outputs are not supported for fixed-output derivations" + hashType <- getAttr "outputHashAlgo" $ extractNoCtx + digest <- lift $ either (throwError . ErrorCall) return $ Store.mkNamedDigest hashType hash + return $ Just digest + + -- filter out null values if needed. + attrs <- if not ignoreNulls + then return drvAttrs + else M.mapMaybe id <$> forM drvAttrs (demand' ?? (\case + NVConstant NNull -> return Nothing + value -> return $ Just value + )) + + env <- if useJson + then do + jsonString :: NixString <- lift $ nvalueToJSONNixString $ flip nvSet M.empty $ + deleteKeys [ "args", "__ignoreNulls", "__structuredAttrs" ] attrs + rawString :: Text <- extractNixString jsonString + return $ Map.singleton "__json" rawString + else + mapM (lift . coerceToString callFunc CopyToStore CoerceAny >=> extractNixString) $ + Map.fromList $ M.toList $ deleteKeys [ "args", "__ignoreNulls" ] attrs + + return $ defaultDerivation { platform, builder, args, env, hashMode, useJson + , name = drvName + , outputs = Map.fromList $ map (\o -> (o, "")) outputs + , mFixed = mFixedOutput + } + where + -- common functions, lifted to WithStringContextT + + demand' :: NValue t f m -> (NValue t f m -> WithStringContextT m a) -> WithStringContextT m a + demand' v f = join $ lift $ demand v (return . f) + + fromValue' :: (FromValue a m (NValue' t f m (NValue t f m)), MonadNix e t f m) => NValue t f m -> WithStringContextT m a + fromValue' = lift . fromValue + + withFrame' :: (Framed e m, Exception s) => NixLevel -> s -> WithStringContextT m a -> WithStringContextT m a + withFrame' level f = join . lift . withFrame level f . return + + -- shortcuts to get the (forced) value of an AttrSet field + + getAttrOr' :: forall v a. (MonadNix e t f m, FromValue v m (NValue' t f m (NValue t f m))) + => Text -> m a -> (v -> WithStringContextT m a) -> WithStringContextT m a + getAttrOr' n d f = case M.lookup n drvAttrs of + Nothing -> lift d + Just v -> withFrame' Info (ErrorCall $ "While evaluating attribute '" ++ show n ++ "'") $ + fromValue' v >>= f + + getAttrOr n d f = getAttrOr' n (return d) f + + getAttr n = getAttrOr' n (throwError $ ErrorCall $ "Required attribute '" ++ show n ++ "' not found.") + + -- Test validity for fields + + assertDrvStoreName :: MonadNix e t f m => Text -> WithStringContextT m Text + assertDrvStoreName name = lift $ do + let invalid c = not $ isAscii c && (isAlphaNum c || c `elem` ("+-._?=" :: String)) -- isAlphaNum allows non-ascii chars. + let failWith reason = throwError $ ErrorCall $ "Store name " ++ show name ++ " " ++ reason + when ("." `Text.isPrefixOf` name) $ failWith "cannot start with a period" + when (Text.length name > 211) $ failWith "must be no longer than 211 characters" + when (Text.any invalid name) $ failWith "contains some invalid character" + when (".drv" `Text.isSuffixOf` name) $ failWith "is not allowed to end in '.drv'" + return name + + extractNoCtx :: MonadNix e t f m => NixString -> WithStringContextT m Text + extractNoCtx ns = case principledGetStringNoContext ns of + Nothing -> lift $ throwError $ ErrorCall $ "The string " ++ show ns ++ " is not allowed to have a context." + Just v -> return v + + assertNonNull :: MonadNix e t f m => Text -> WithStringContextT m Text + assertNonNull t = do + when (Text.null t) $ lift $ throwError $ ErrorCall "Value must not be empty" + return t + + parseHashMode :: MonadNix e t f m => Text -> WithStringContextT m HashMode + parseHashMode = \case + "flat" -> return Flat + "recursive" -> return Recursive + other -> lift $ throwError $ ErrorCall $ "Hash mode " ++ show other ++ " is not valid. It must be either 'flat' or 'recursive'" + + -- Other helpers + + deleteKeys :: [Text] -> AttrSet a -> AttrSet a + deleteKeys keys attrSet = foldl' (flip M.delete) attrSet keys + diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index f93e4612b..261d3772c 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -298,13 +298,11 @@ callFunc fun arg = demand fun $ \fun' -> do "Function call stack exhausted" case fun' of NVClosure params f -> do - traceM $ "callFunc:NVFunction taking " ++ show params f arg NVBuiltin name f -> do span <- currentPos withFrame Info (Calling @m @t name span) (f arg) s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do - traceM "callFunc:__functor" demand f $ (`callFunc` s) >=> (`callFunc` arg) x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x @@ -316,7 +314,6 @@ execUnaryOp -> NValue t f m -> m (NValue t f m) execUnaryOp scope span op arg = do - traceM "NUnary" case arg of NVConstant c -> case (op, c) of (NNeg, NInt i ) -> unaryOp $ NInt (-i) @@ -478,7 +475,7 @@ execBinaryOpForced scope span op lval rval = case op of fromStringNoContext :: Framed e m => NixString -> m Text fromStringNoContext ns = case principledGetStringNoContext ns of Just str -> pure str - Nothing -> throwError $ ErrorCall "expected string with no context" + Nothing -> throwError $ ErrorCall $ "expected string with no context, but got " ++ show ns addTracing :: (MonadNix e t f m, Has e Options, MonadReader Int n, Alternative n) diff --git a/src/Nix/Fresh.hs b/src/Nix/Fresh.hs index a52e1152e..6f262a512 100644 --- a/src/Nix/Fresh.hs +++ b/src/Nix/Fresh.hs @@ -22,6 +22,7 @@ import Control.Monad.Fail import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.ST +import Control.Monad.Trans.Control import Data.Typeable import Nix.Var @@ -50,6 +51,24 @@ instance MonadTrans (FreshIdT i) where instance MonadBase b m => MonadBase b (FreshIdT i m) where liftBase = FreshIdT . liftBase +-- | MonadBaseControl instance for FreshIdT +-- +-- This one is needed for monad stacks containing hnix-store stores performing IO. +-- +-- The reason why the MonadBaseControl instance is so convoluted is that I +-- could not come up with a MonadTransControl instance. (layus, 2020-11) +-- +-- ATM I have no idea if such an instance makes sense because the m is used +-- inside the readable (Var m i) and MonadTransControl is supposed to be +-- defined without mentioning that m +-- +instance MonadBaseControl b m => MonadBaseControl b (FreshIdT i m) where + type StM (FreshIdT i m) a = StM m a + liftBaseWith f = FreshIdT $ ReaderT $ \r -> + liftBaseWith $ \runInBase -> + f $ runInBase . (\t -> runReaderT (unFreshIdT t) r) + restoreM = (\action -> FreshIdT { unFreshIdT = ReaderT $ const action }) . restoreM + instance ( MonadVar m , Eq i , Ord i diff --git a/src/Nix/Fresh/Basic.hs b/src/Nix/Fresh/Basic.hs index 2c0e96ed2..54cf897b3 100644 --- a/src/Nix/Fresh/Basic.hs +++ b/src/Nix/Fresh/Basic.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -13,7 +14,9 @@ module Nix.Fresh.Basic where import Control.Monad.Fail ( MonadFail ) #endif import Control.Monad.Reader +import Control.Monad.Except import Nix.Effects +import System.Nix.Store.Remote.Types (MonadRemoteStore) import Nix.Render import Nix.Fresh import Nix.Value @@ -22,15 +25,15 @@ type StdIdT = FreshIdT Int instance (MonadFail m, MonadFile m) => MonadFile (StdIdT m) instance MonadIntrospect m => MonadIntrospect (StdIdT m) -instance MonadStore m => MonadStore (StdIdT m) where - addPath' = lift . addPath' - toFile_' = (lift .) . toFile_' instance MonadPutStr m => MonadPutStr (StdIdT m) instance MonadHttp m => MonadHttp (StdIdT m) instance MonadEnv m => MonadEnv (StdIdT m) instance MonadPaths m => MonadPaths (StdIdT m) instance MonadInstantiate m => MonadInstantiate (StdIdT m) instance MonadExec m => MonadExec (StdIdT m) +instance MonadError String m => MonadError String (StdIdT m) +instance MonadRemoteStore m => MonadRemoteStore (StdIdT m) +instance (MonadIO m, MonadRemoteStore m) => MonadStore (StdIdT m) instance (MonadEffects t f m, MonadDataContext f m) => MonadEffects t f (StdIdT m) where diff --git a/src/Nix/Parser.hs b/src/Nix/Parser.hs index a3b43cc9b..f0da9b9a9 100644 --- a/src/Nix/Parser.hs +++ b/src/Nix/Parser.hs @@ -264,7 +264,7 @@ nixIf = annotateLocation1 nixAssert :: Parser NExprLoc nixAssert = annotateLocation1 ( NAssert - <$> (reserved "assert" *> nixExpr) + <$> (reserved "assert" *> nixToplevelForm) <*> (semi *> nixToplevelForm) "assert" ) diff --git a/src/Nix/Reduce.hs b/src/Nix/Reduce.hs index c035c8593..633a484c9 100644 --- a/src/Nix/Reduce.hs +++ b/src/Nix/Reduce.hs @@ -42,6 +42,7 @@ import Control.Monad.State.Strict import Data.Fix ( Fix(..), foldFix, foldFixM ) import Data.HashMap.Lazy ( HashMap ) import qualified Data.HashMap.Lazy as M +import qualified Data.HashMap.Strict as MS import Data.IORef import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE @@ -66,11 +67,11 @@ import System.FilePath newtype Reducer m a = Reducer { runReducer :: ReaderT (Maybe FilePath, Scopes (Reducer m) NExprLoc) - (StateT (HashMap FilePath NExprLoc) m) a } + (StateT (HashMap FilePath NExprLoc, MS.HashMap Text Text) m) a } deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix, MonadIO, MonadFail, MonadReader (Maybe FilePath, Scopes (Reducer m) NExprLoc), - MonadState (HashMap FilePath NExprLoc)) + MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text)) staticImport :: forall m @@ -78,7 +79,7 @@ staticImport , Scoped NExprLoc m , MonadFail m , MonadReader (Maybe FilePath, Scopes m NExprLoc) m - , MonadState (HashMap FilePath NExprLoc) m + , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) m ) => SrcSpan -> FilePath @@ -89,7 +90,7 @@ staticImport pann path = do path' <- liftIO $ pathToDefaultNixFile =<< canonicalizePath (maybe path (\p -> takeDirectory p path) mfile) - imports <- get + imports <- gets fst case M.lookup path' imports of Just expr -> pure expr Nothing -> go path' @@ -108,10 +109,10 @@ staticImport pann path = do (Fix (NLiteralPath_ pann path)) pos x' = Fix (NLet_ span [cur] x) - modify (M.insert path x') + modify (\(a, b) -> (M.insert path x' a, b)) local (const (Just path, emptyScopes @m @NExprLoc)) $ do x'' <- foldFix reduce x' - modify (M.insert path x'') + modify (\(a, b) -> (M.insert path x'' a, b)) return x'' -- gatherNames :: NExprLoc -> HashSet VarName @@ -122,7 +123,7 @@ staticImport pann path = do reduceExpr :: (MonadIO m, MonadFail m) => Maybe FilePath -> NExprLoc -> m NExprLoc reduceExpr mpath expr = - (`evalStateT` M.empty) + (`evalStateT` (M.empty, MS.empty)) . (`runReaderT` (mpath, emptyScopes)) . runReducer $ foldFix reduce expr @@ -133,7 +134,7 @@ reduce , Scoped NExprLoc m , MonadFail m , MonadReader (Maybe FilePath, Scopes m NExprLoc) m - , MonadState (HashMap FilePath NExprLoc) m + , MonadState (HashMap FilePath NExprLoc, MS.HashMap Text Text) m ) => NExprLocF (m NExprLoc) -> m NExprLoc diff --git a/src/Nix/Render.hs b/src/Nix/Render.hs index 343000678..ea5cf9b00 100644 --- a/src/Nix/Render.hs +++ b/src/Nix/Render.hs @@ -77,6 +77,9 @@ posAndMsg (SourcePos _ lineNo _) msg = FancyError renderLocation :: MonadFile m => SrcSpan -> Doc a -> m (Doc a) renderLocation (SrcSpan (SourcePos file begLine begCol) (SourcePos file' endLine endCol)) msg + | file == file' && file == "" && begLine == endLine + = pure $ "In raw input string at position " <> pretty (unPos begCol) + | file /= "" && file == file' = do exist <- doesFileExist file diff --git a/src/Nix/Render/Frame.hs b/src/Nix/Render/Frame.hs index 2dd6dc756..04a2bf865 100644 --- a/src/Nix/Render/Frame.hs +++ b/src/Nix/Render/Frame.hs @@ -90,7 +90,8 @@ renderFrame (NixFrame level f) | Just (e :: ExecFrame t f m) <- fromException f = renderExecFrame level e | Just (e :: ErrorCall) <- fromException f = pure [pretty (show e)] | Just (e :: SynHoleInfo m v) <- fromException f = pure [pretty (show e)] - | otherwise = error $ "Unrecognized frame: " ++ show f +renderFrame (NixFrame level (SomeException e)) = + pure [ pretty $ "Unrecognized frame: " ++ show e ++ " of type " ++ show (typeOf e) ] wrapExpr :: NExprF r -> NExpr wrapExpr x = Fix (Fix (NSym "") <$ x) diff --git a/src/Nix/Standard.hs b/src/Nix/Standard.hs index e3ed3d005..2b82e2d33 100644 --- a/src/Nix/Standard.hs +++ b/src/Nix/Standard.hs @@ -22,6 +22,7 @@ import Control.Applicative import Control.Comonad ( Comonad ) import Control.Comonad.Env ( ComonadEnv ) import Control.Monad.Catch hiding ( catchJust ) +import Control.Monad.Except #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif @@ -29,7 +30,10 @@ import Control.Monad.Free import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.State +import Control.Monad.Trans.Control ( MonadBaseControl ) import Data.HashMap.Lazy ( HashMap ) +import qualified Data.HashMap.Strict +import Data.Text ( Text ) import Data.Typeable import GHC.Generics import Nix.Cited @@ -37,6 +41,7 @@ import Nix.Cited.Basic import Nix.Context import Nix.Effects import Nix.Effects.Basic +import Nix.Effects.Derivation import Nix.Expr.Types.Annotated import Nix.Fresh import Nix.Fresh.Basic @@ -49,24 +54,32 @@ import Nix.Utils.Fix1 import Nix.Value import Nix.Value.Monad import Nix.Var +import System.Nix.Store.Remote ( runStore ) +import System.Nix.Store.Remote.Types ( RemoteStoreT(..) , MonadRemoteStore ) -- All of the following type classes defer to the underlying 'm'. deriving instance MonadPutStr (t (Fix1 t)) => MonadPutStr (Fix1 t) deriving instance MonadHttp (t (Fix1 t)) => MonadHttp (Fix1 t) deriving instance MonadEnv (t (Fix1 t)) => MonadEnv (Fix1 t) +-- deriving instance MonadStore (t (Fix1 t)) => MonadStore (Fix1 t) deriving instance MonadPaths (t (Fix1 t)) => MonadPaths (Fix1 t) deriving instance MonadInstantiate (t (Fix1 t)) => MonadInstantiate (Fix1 t) deriving instance MonadExec (t (Fix1 t)) => MonadExec (Fix1 t) deriving instance MonadIntrospect (t (Fix1 t)) => MonadIntrospect (Fix1 t) +deriving instance MonadError e (t (Fix1 t)) => MonadError e (Fix1 t) +deriving instance MonadRemoteStore (t (Fix1 t)) => MonadRemoteStore (Fix1 t) deriving instance MonadPutStr (t (Fix1T t m) m) => MonadPutStr (Fix1T t m) deriving instance MonadHttp (t (Fix1T t m) m) => MonadHttp (Fix1T t m) deriving instance MonadEnv (t (Fix1T t m) m) => MonadEnv (Fix1T t m) +-- deriving instance MonadStore (t (Fix1T t m) m) => MonadStore (Fix1T t m) deriving instance MonadPaths (t (Fix1T t m) m) => MonadPaths (Fix1T t m) deriving instance MonadInstantiate (t (Fix1T t m) m) => MonadInstantiate (Fix1T t m) deriving instance MonadExec (t (Fix1T t m) m) => MonadExec (Fix1T t m) +deriving instance MonadError e (t (Fix1T t m) m) => MonadError e (Fix1T t m) deriving instance MonadIntrospect (t (Fix1T t m) m) => MonadIntrospect (Fix1T t m) +deriving instance MonadRemoteStore (t (Fix1T t m) m) => MonadRemoteStore (Fix1T t m) type MonadFix1T t m = (MonadTrans (Fix1T t), Monad (t (Fix1T t m) m)) @@ -81,10 +94,6 @@ instance (MonadFix1T t m, MonadAtomicRef m) => MonadAtomicRef (Fix1T t m) where instance (MonadFix1T t m, MonadFail (Fix1T t m), MonadFile m) => MonadFile (Fix1T t m) -instance (MonadFix1T t m, MonadStore m) => MonadStore (Fix1T t m) where - addPath' = lift . addPath' - toFile_' n = lift . toFile_' n - {------------------------------------------------------------------------} newtype StdCited m a = StdCited @@ -138,7 +147,7 @@ instance ( MonadFix m , Typeable m , Scoped (StdValue m) m , MonadReader (Context m (StdValue m)) m - , MonadState (HashMap FilePath NExprLoc) m + , MonadState (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) m , MonadDataErrorContext (StdThunk m) (StdCited m) m , MonadThunk (StdThunk m) m (StdValue m) , MonadValue (StdValue m) m @@ -189,9 +198,19 @@ instance ( MonadAtomicRef m -- whileForcingThunk frame = -- withFrame Debug (ForcingThunk @t @f @m) . withFrame Debug frame +-- RemoteStoreT lacks some of these, needed in the deriving clause of StandardTF +-- deriving instance MonadState a m => MonadState a (RemoteStoreT m) +-- deriving instance MonadReader a m => MonadReader a (RemoteStoreT m) +deriving instance MonadPlus m => MonadPlus (RemoteStoreT m) +deriving instance MonadFix m => MonadFix (RemoteStoreT m) +deriving instance MonadCatch m => MonadCatch (RemoteStoreT m) +deriving instance MonadThrow m => MonadThrow (RemoteStoreT m) +deriving instance MonadMask m => MonadMask (RemoteStoreT m) + newtype StandardTF r m a = StandardTF (ReaderT (Context r (StdValue r)) - (StateT (HashMap FilePath NExprLoc) m) a) + (StateT (HashMap FilePath NExprLoc, HashMap Text Text) + (RemoteStoreT m)) a) deriving ( Functor , Applicative @@ -204,16 +223,20 @@ newtype StandardTF r m a , MonadCatch , MonadThrow , MonadMask + , MonadError String , MonadReader (Context r (StdValue r)) - , MonadState (HashMap FilePath NExprLoc) + , MonadState (HashMap FilePath NExprLoc, HashMap Text Text) ) +deriving instance (MonadIO m) => MonadRemoteStore (StandardTF r m) + instance MonadTrans (StandardTF r) where - lift = StandardTF . lift . lift + lift = StandardTF . lift . lift . lift instance (MonadPutStr r, MonadPutStr m) => MonadPutStr (StandardTF r m) instance (MonadHttp r, MonadHttp m) => MonadHttp (StandardTF r m) instance (MonadEnv r, MonadEnv m) => MonadEnv (StandardTF r m) +instance (MonadStore r, MonadStore m) => MonadStore (StandardTF r m) instance (MonadPaths r, MonadPaths m) => MonadPaths (StandardTF r m) instance (MonadInstantiate r, MonadInstantiate m) => MonadInstantiate (StandardTF r m) instance (MonadExec r, MonadExec m) => MonadExec (StandardTF r m) @@ -229,26 +252,32 @@ instance MonadTrans (Fix1T StandardTF) where instance MonadThunkId m => MonadThunkId (Fix1T StandardTF m) where type ThunkId (Fix1T StandardTF m) = ThunkId m +instance (MonadIO m) => MonadStore (Fix1T StandardTF m) + mkStandardT - :: ReaderT - (Context (StandardT m) (StdValue (StandardT m))) - (StateT (HashMap FilePath NExprLoc) m) - a + :: (ReaderT (Context (StandardT m) (StdValue (StandardT m))) + (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) + (RemoteStoreT m)) a) -> StandardT m a mkStandardT = Fix1T . StandardTF runStandardT :: StandardT m a - -> ReaderT - (Context (StandardT m) (StdValue (StandardT m))) - (StateT (HashMap FilePath NExprLoc) m) - a + -> (ReaderT (Context (StandardT m) (StdValue (StandardT m))) + (StateT (HashMap FilePath NExprLoc, Data.HashMap.Strict.HashMap Text Text) + (RemoteStoreT m)) a) runStandardT (Fix1T (StandardTF m)) = m +runStoreSimple :: (MonadIO m, MonadBaseControl IO m) => RemoteStoreT m a -> m a +runStoreSimple action = do + (res, _log) <- runStore action + -- TODO: replace this error call by something smarter. throwE ? throwError ? + either (error) return res + runWithBasicEffects - :: (MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a + :: (MonadBaseControl IO m, MonadIO m, MonadAtomicRef m) => Options -> StandardT (StdIdT m) a -> m a runWithBasicEffects opts = - go . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT + go . runStoreSimple . (`evalStateT` mempty) . (`runReaderT` newContext opts) . runStandardT where go action = do i <- newVar (1 :: Int) diff --git a/src/Nix/String.hs b/src/Nix/String.hs index 23da44bc3..f8791da64 100644 --- a/src/Nix/String.hs +++ b/src/Nix/String.hs @@ -32,7 +32,9 @@ module Nix.String , addStringContext , addSingletonStringContext , runWithStringContextT + , runWithStringContextT' , runWithStringContext + , runWithStringContext' ) where @@ -231,6 +233,16 @@ runWithStringContextT :: Monad m => WithStringContextT m Text -> m NixString runWithStringContextT (WithStringContextT m) = uncurry NixString <$> runWriterT m +-- | Run an action that manipulates nix strings, and collect the contexts encountered. +-- Warning: this may be unsafe, depending on how you handle the resulting context list. +runWithStringContextT' :: Monad m => WithStringContextT m a -> m (a, S.HashSet StringContext) +runWithStringContextT' (WithStringContextT m) = runWriterT m + -- | Run an action producing a string with a context and put those into a 'NixString'. runWithStringContext :: WithStringContextT Identity Text -> NixString runWithStringContext = runIdentity . runWithStringContextT + +-- | Run an action that manipulates nix strings, and collect the contexts encountered. +-- Warning: this may be unsafe, depending on how you handle the resulting context list. +runWithStringContext' :: WithStringContextT Identity a -> (a, S.HashSet StringContext) +runWithStringContext' = runIdentity . runWithStringContextT' diff --git a/src/Nix/Thunk/Basic.hs b/src/Nix/Thunk/Basic.hs index a66398ef1..6bde604b2 100644 --- a/src/Nix/Thunk/Basic.hs +++ b/src/Nix/Thunk/Basic.hs @@ -15,7 +15,6 @@ import Control.Exception hiding ( catch ) import Control.Monad.Catch import Nix.Thunk -import Nix.Utils import Nix.Var data Deferred m v = Deferred (m v) | Computed v @@ -75,7 +74,6 @@ forceThunk (Thunk n active ref) k = do if nowActive then throwM $ ThunkLoop $ show n else do - traceM $ "Forcing " ++ show n v <- catch action $ \(e :: SomeException) -> do _ <- atomicModifyVar active (False, ) throwM e diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs index cb937953d..dbcc62cea 100644 --- a/tests/EvalTests.hs +++ b/tests/EvalTests.hs @@ -494,7 +494,9 @@ freeVarsEqual a xs = do maskedFiles :: [FilePath] maskedFiles = - [ "builtins.fetchurl-01.nix" ] + [ "builtins.fetchurl-01.nix" + , "builtins.nix" -- FIXME (layus) nix conditionally enables exec & co. + ] testDir :: FilePath testDir = "tests/eval-compare" diff --git a/tests/NixLanguageTests.hs b/tests/NixLanguageTests.hs index d7eb83bc5..c27b9087a 100644 --- a/tests/NixLanguageTests.hs +++ b/tests/NixLanguageTests.hs @@ -69,8 +69,6 @@ newFailingTests :: Set String newFailingTests = Set.fromList [ "eval-okay-hash" , "eval-okay-hashfile" - , "eval-okay-path" - , "eval-okay-types" , "eval-okay-fromTOML" , "eval-okay-context-introspection" ]