picnoir/hnix
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into prettyprinter

Browse source
This commit is contained in:
John Ericson 2018-11-20 18:23:15 -05:00
parent 6d9deac55f bf57d2d6eb
commit f227911ce0
30 changed files with 663 additions and 398 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
.travis.yml
View file

@ -15,19 +15,13 @@ env:
- secure: "dm6I+M4+V+C7QMTpcSADdKPE633SvmToXZrTbZ7miNDGmMN+/SfHeN2ybi1+PW6oViMlbPN/7J/aEfiGjSJI8vLk72Y4uCWGmpSb8TXZLu6+whnxtZzzW8+z4tsM4048QJg7CF3N/25U8thRFgs3DqUub1Sf3nG9LrNWdz6ZcDQ="
matrix:
- GHCVERSION=ghc802 STRICT=false TRACING=false
- GHCVERSION=ghc802 STRICT=false TRACING=true
- GHCVERSION=ghc822 STRICT=true TRACING=false
- GHCVERSION=ghc822 STRICT=true TRACING=true
- GHCVERSION=ghc843 STRICT=false TRACING=false
- GHCVERSION=ghc843 STRICT=false TRACING=true
- GHCVERSION=ghcjs
matrix:
allow_failures:
- env: GHCVERSION=ghcjs
- env: GHCVERSION=ghc802 STRICT=false TRACING=false
- env: GHCVERSION=ghc802 STRICT=false TRACING=true
- GHCVERSION=ghc844 STRICT=false TRACING=false
- GHCVERSION=ghc844 STRICT=false TRACING=true
# - GHCVERSION=ghcjs
#
# matrix:
# allow_failures:
# - env: GHCVERSION=ghcjs
before_script:
- sudo mount -o remount,exec,size=4G,mode=755 /run/user || true

12
README.md
View file

@ -99,6 +99,8 @@ the specific dependencies used by hnix. Just use these commands:
## How you can help
### Issue Tracker Backlog
If you're looking for a way to help out, try taking a look
[here](https://github.com/haskell-nix/hnix/issues?q=is%3Aissue+is%3Aopen+label%3A%22help+wanted%22+no%3Aassignee).
When you find an issue that looks interesting to you, comment on the ticket to
@ -114,3 +116,13 @@ nix-shell --run "LANGUAGE_TESTS=yes cabal test"
Make sure that all the tests that were passing prior to your PR are still
passing afterwards; it's OK if no new tests are passing.
### Evaluating Nixpkgs with HNix
Currently the main high-level goal is to be able to evaluate all of nixpkgs. To
run this yourself, first build hnix with `nix-build`, then run the following
command:
```
./result/bin/hnix --eval -E "import <nixpkgs> {}" --find
```

10
default.nix
View file

@ -1,11 +1,11 @@
{ compiler ? "ghc822"
{ compiler ? "ghc844"
, doBenchmark ? false
, doTracing ? false
, doStrict ? false
, rev ? "d1ae60cbad7a49874310de91cd17708b042400c8"
, sha256 ? "0a1w4702jlycg2ab87m7n8frjjngf0cis40lyxm3vdwn7p4fxikz"
, rev ? "b37872d4268164614e3ecef6e1f730d48cf5a90f"
, sha256 ? "05km33sz4srf05vvmkidz3k59phm5a3k9wpj1jc6ly9yqws0dbn4"
, pkgs ?
if builtins.compareVersions builtins.nixVersion "2.0" < 0
then abort "hnix requires at least nix 2.0"
@ -80,8 +80,8 @@ drv = haskellPackages.developPackage {
# .cabal file will be. Otherwise, Travis may error out claiming that
# the cabal file needs to be updated because the result is different
# that the version we committed to Git.
pkgs.haskell.packages.ghc822.hpack
pkgs.haskell.packages.ghc822.criterion
pkgs.haskell.packages.ghc844.hpack
pkgs.haskell.packages.ghc844.criterion
];
inherit doBenchmark;

7
hnix.cabal
View file

@ -2,9 +2,8 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 0e0438f43eaffbbd952e85bc24499b40e17f276ec7488f3a483e7d848ea1075d
-- hash: 07b6631da5bfe4929607211146ef8fdde38ea28d4aece34188af8e33d0287e5e
cabal-version: >= 1.10
name: hnix
version: 0.5.2
synopsis: Haskell implementation of the Nix language
@ -17,6 +16,7 @@ maintainer: johnw@newartisans.com
license: BSD3
license-file: LICENSE
build-type: Simple
cabal-version: >= 1.10
extra-source-files:
data/let-comments-multiline.nix
data/let-comments.nix
@ -493,6 +493,7 @@ library
, containers
, data-fix
, deepseq >=1.4.2 && <1.5
, dependent-sum
, deriving-compat >=0.3 && <0.6
, directory
, exceptions
@ -511,6 +512,7 @@ library
, optparse-applicative
, prettyprinter
, process
, ref-tf
, regex-tdfa
, regex-tdfa-text
, scientific
@ -638,6 +640,7 @@ test-suite hnix-tests
, containers
, data-fix
, deepseq >=1.4.2 && <1.5
, dependent-sum
, directory
, exceptions
, filepath

2
main/Repl.hs
View file

@ -21,7 +21,7 @@
module Repl where
import Nix
import Nix hiding (exec)
import Nix.Convert
import Nix.Eval
import Nix.Scope

3
package.yaml
View file

@ -100,6 +100,7 @@ library:
- array >= 0.4 && < 0.6
- binary
- deriving-compat >= 0.3 && < 0.6
- dependent-sum
- directory
- free
- http-types
@ -114,6 +115,7 @@ library:
- process
- regex-tdfa
- regex-tdfa-text
- ref-tf
- scientific
- semigroups >= 0.18 && < 0.19
- split
@ -194,6 +196,7 @@ tests:
- tasty-quickcheck
- pretty-show
- prettyprinter
- dependent-sum
when:
- condition: "impl(ghcjs)"
then:

44
src/Nix/Builtins.hs
View file

@ -59,7 +59,6 @@ import Data.Foldable (foldrM)
import qualified Data.HashMap.Lazy as M
import Data.List
import Data.Maybe
import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as S
import Data.String.Interpolate.IsString
@ -90,7 +89,7 @@ import Nix.Utils
import Nix.Value
import Nix.XML
import System.FilePath
import System.Posix.Files
import System.Posix.Files (isRegularFile, isDirectory, isSymbolicLink)
import Text.Regex.TDFA
-- | Evaluate a nix expression in the default context
@ -110,7 +109,7 @@ withNixContext mpath action = do
let ref = value @(NValue m) @(NThunk m) @m $ nvPath path
pushScope (M.singleton "__cur_file" ref) action
builtins :: (MonadNix e m, Scoped e (NThunk m) m)
builtins :: (MonadNix e m, Scoped (NThunk m) m)
=> m (Scopes m (NThunk m))
builtins = do
ref <- thunk $ flip nvSet M.empty <$> buildMap
@ -296,7 +295,7 @@ builtinsList = sequence [
foldNixPath :: forall e m r. MonadNix e m
=> (FilePath -> Maybe String -> NixPathEntryType -> r -> m r) -> r -> m r
foldNixPath f z = do
mres <- lookupVar @_ @(NThunk m) "__includes"
mres <- lookupVar "__includes"
dirs <- case mres of
Nothing -> return []
Just v -> fromNix @[Text] v
@ -324,7 +323,7 @@ nixPath = fmap nvList $ flip foldNixPath [] $ \p mn ty rest ->
nvStr (hackyMakeNixStringWithoutContext $ Text.pack (fromMaybe "" mn))) ]) : rest
toString :: MonadNix e m => m (NValue m) -> m (NValue m)
toString str = str >>= coerceToString False True >>= toNix . Text.pack
toString str = str >>= coerceToString DontCopyToStore CoerceAny >>= toNix
hasAttr :: forall e m. MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
hasAttr x y =
@ -388,9 +387,9 @@ div_ x y = x >>= \x' -> y >>= \y' -> case (x', y') of
toNix (floor (fromInteger x / fromInteger y :: Double) :: Integer)
(NVConstant (NFloat x), NVConstant (NInt y)) | y /= 0 ->
toNix (x / fromInteger y)
(NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 ->
(NVConstant (NInt x), NVConstant (NFloat y)) | y /= 0 ->
toNix (fromInteger x / y)
(NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 ->
(NVConstant (NFloat x), NVConstant (NFloat y)) | y /= 0 ->
toNix (x / y)
(_, _) ->
throwError $ Division x' y'
@ -468,10 +467,9 @@ splitVersion s = case Text.uncons s of
in thisComponent : splitVersion rest
splitVersion_ :: MonadNix e m => m (NValue m) -> m (NValue m)
splitVersion_ = fromValue >=> \s -> do
let vals = flip map (splitVersion s) $ \c ->
valueThunk $ nvStr $ hackyMakeNixStringWithoutContext $ versionComponentToString c
return $ nvList vals
splitVersion_ = fromStringNoContext >=> \s ->
return $ nvList $ flip map (splitVersion s) $ \c ->
valueThunk $ nvStr $ principledMakeNixStringWithoutContext $ versionComponentToString c
compareVersions :: Text -> Text -> Ordering
compareVersions s1 s2 =
@ -482,12 +480,12 @@ compareVersions s1 s2 =
compareVersions_ :: MonadNix e m => m (NValue m) -> m (NValue m) -> m (NValue m)
compareVersions_ t1 t2 =
fromValue t1 >>= \s1 ->
fromValue t2 >>= \s2 ->
return $ nvConstant $ NInt $ case compareVersions s1 s2 of
LT -> -1
EQ -> 0
GT -> 1
fromStringNoContext t1 >>= \s1 ->
fromStringNoContext t2 >>= \s2 ->
return $ nvConstant $ NInt $ case compareVersions s1 s2 of
LT -> -1
EQ -> 0
GT -> 1
splitDrvName :: Text -> (Text, Text)
splitDrvName s =
@ -601,7 +599,7 @@ catAttrs attrName xs =
baseNameOf :: MonadNix e m => m (NValue m) -> m (NValue m)
baseNameOf x = x >>= \case
NVStr ns -> pure $ nvStr (hackyModifyNixContents (Text.pack . takeFileName . Text.unpack) ns)
NVStr ns -> pure $ nvStr (principledModifyNixContents (Text.pack . takeFileName . Text.unpack) ns)
NVPath path -> pure $ nvPath $ takeFileName path
v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v
@ -622,7 +620,7 @@ bitXor x y =
dirOf :: MonadNix e m => m (NValue m) -> m (NValue m)
dirOf x = x >>= \case
NVStr ns -> pure $ nvStr (hackyModifyNixContents (Text.pack . takeDirectory . Text.unpack) ns)
NVStr ns -> pure $ nvStr (principledModifyNixContents (Text.pack . takeDirectory . Text.unpack) ns)
NVPath path -> pure $ nvPath $ takeDirectory path
v -> throwError $ ErrorCall $ "dirOf: expected string or path, got " ++ show v
@ -822,7 +820,7 @@ scopedImport asetArg pathArg =
fromValue @(AttrSet (NThunk m)) asetArg >>= \s ->
fromValue pathArg >>= \(Path p) -> do
path <- pathToDefaultNix p
mres <- lookupVar @_ @(NThunk m) "__cur_file"
mres <- lookupVar "__cur_file"
path' <- case mres of
Nothing -> do
traceM "No known current directory"
@ -965,7 +963,7 @@ readDir_ pathThunk = do
path <- absolutePathFromValue =<< pathThunk
items <- listDirectory path
itemsWithTypes <- forM items $ \item -> do
s <- Nix.Effects.getSymbolicLinkStatus $ path </> item
s <- getSymbolicLinkStatus $ path </> item
let t = if
| isRegularFile s -> FileTypeRegular
| isDirectory s -> FileTypeDirectory
@ -1038,7 +1036,9 @@ fetchurl v = v >>= \case
where
go :: Maybe (NThunk m) -> NValue m -> m (NValue m)
go _msha = \case
NVStr ns -> getURL (hackyStringIgnoreContext ns) -- msha
NVStr ns -> getURL (hackyStringIgnoreContext ns) >>= \case -- msha
Left e -> throwError e
Right p -> toValue p
v -> throwError $ ErrorCall $
"builtins.fetchurl: Expected URI or string, got " ++ show v

20
src/Nix/Convert.hs
View file

@ -148,7 +148,7 @@ instance Convertible e m
instance (Convertible e m, MonadEffects m)
=> FromValue Text m (NValueNF m) where
fromValueMay = \case
Free (NVStrF ns) -> pure $ hackyStringIgnoreContextMaybe ns
Free (NVStrF ns) -> pure $ hackyGetStringNoContext ns
Free (NVPathF p) -> Just . Text.pack . unStorePath <$> addPath p
Free (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing
@ -161,7 +161,7 @@ instance (Convertible e m, MonadEffects m)
instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
=> FromValue Text m (NValue m) where
fromValueMay = \case
NVStr ns -> pure $ hackyStringIgnoreContextMaybe ns
NVStr ns -> pure $ hackyGetStringNoContext ns
NVPath p -> Just . Text.pack . unStorePath <$> addPath p
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
@ -200,7 +200,7 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m, MonadEffects m)
instance Convertible e m
=> FromValue ByteString m (NValueNF m) where
fromValueMay = \case
Free (NVStrF ns) -> pure $ encodeUtf8 <$> hackyStringIgnoreContextMaybe ns
Free (NVStrF ns) -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -209,7 +209,7 @@ instance Convertible e m
instance Convertible e m
=> FromValue ByteString m (NValue m) where
fromValueMay = \case
NVStr ns -> pure $ encodeUtf8 <$> hackyStringIgnoreContextMaybe ns
NVStr ns -> pure $ encodeUtf8 <$> hackyGetStringNoContext ns
_ -> pure Nothing
fromValue v = fromValueMay v >>= \case
Just b -> pure b
@ -221,7 +221,7 @@ newtype Path = Path { getPath :: FilePath }
instance Convertible e m => FromValue Path m (NValueNF m) where
fromValueMay = \case
Free (NVPathF p) -> pure $ Just (Path p)
Free (NVStrF ns) -> pure $ Path . Text.unpack <$> hackyStringIgnoreContextMaybe ns
Free (NVStrF ns) -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
Free (NVSetF s _) -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
@ -234,7 +234,7 @@ instance (Convertible e m, MonadThunk (NValue m) (NThunk m) m)
=> FromValue Path m (NValue m) where
fromValueMay = \case
NVPath p -> pure $ Just (Path p)
NVStr ns -> pure $ Path . Text.unpack <$> hackyStringIgnoreContextMaybe ns
NVStr ns -> pure $ Path . Text.unpack <$> hackyGetStringNoContext ns
NVSet s _ -> case M.lookup "outPath" s of
Nothing -> pure Nothing
Just p -> fromValueMay @Path p
@ -322,7 +322,7 @@ instance (Convertible e m, MonadEffects m)
NFloat n -> toJSON n
NBool b -> toJSON b
NNull -> A.Null
Free (NVStrF ns) -> pure $ toJSON <$> hackyStringIgnoreContextMaybe ns
Free (NVStrF ns) -> pure $ toJSON <$> hackyGetStringNoContext ns
Free (NVListF l) ->
fmap (A.Array . V.fromList) . sequence
<$> traverse fromValueMay l
@ -391,6 +391,12 @@ instance Applicative m => ToValue Path m (NValueNF m) where
instance Applicative m => ToValue Path m (NValue m) where
toValue = pure . nvPath . getPath
instance Applicative m => ToValue StorePath m (NValueNF m) where
toValue = toValue . Path . unStorePath
instance Applicative m => ToValue StorePath m (NValue m) where
toValue = toValue . Path . unStorePath
instance MonadThunk (NValue m) (NThunk m) m
=> ToValue SourcePos m (NValue m) where
toValue (SourcePos f l c) = do

212
src/Nix/Effects.hs
View file

@ -1,19 +1,37 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
module Nix.Effects where
import Data.Text (Text)
import Nix.Render
import Nix.Value
import System.Posix.Files
import Prelude hiding (putStr, putStrLn, print)
import qualified Prelude
import Control.Monad.Trans
import Data.Text (Text)
import qualified Data.Text as T
import Network.HTTP.Client hiding (path)
import Network.HTTP.Client.TLS
import Network.HTTP.Types
import Nix.Expr
import Nix.Frames
import Nix.Parser
import Nix.Render
import Nix.Utils
import Nix.Value
import qualified System.Directory as S
import System.Environment
import System.Exit
import qualified System.Info
import System.Process
-- | A path into the nix store
newtype StorePath = StorePath { unStorePath :: FilePath }
class MonadFile m => MonadEffects m where
-- | Import a path into the nix store, and return the resulting path
addPath :: FilePath -> m StorePath
toFile_ :: FilePath -> String -> m StorePath
class (MonadFile m, MonadStore m, MonadPutStr m, MonadHttp m, MonadEnv m, MonadInstantiate m, MonadExec m, MonadIntrospect m) => MonadEffects m where
-- | Determine the absolute path of relative path in the current context
makeAbsolutePath :: FilePath -> m FilePath
findEnvPath :: String -> m FilePath
@ -22,26 +40,170 @@ class MonadFile m => MonadEffects m where
-- and a file path try to find an existing path
findPath :: [NThunk m] -> FilePath -> m FilePath
pathExists :: FilePath -> m Bool
importPath :: FilePath -> m (NValue m)
pathToDefaultNix :: FilePath -> m FilePath
getEnvVar :: String -> m (Maybe String)
getCurrentSystemOS :: m Text
getCurrentSystemArch :: m Text
listDirectory :: FilePath -> m [FilePath]
getSymbolicLinkStatus :: FilePath -> m FileStatus
derivationStrict :: NValue m -> m (NValue m)
nixInstantiateExpr :: String -> m (NValue m)
getURL :: Text -> m (NValue m)
getRecursiveSize :: a -> m (NValue m)
traceEffect :: String -> m ()
exec :: [String] -> m (NValue m)
class Monad m => MonadIntrospect m where
recursiveSize :: a -> m Word
default recursiveSize :: (MonadTrans t, MonadIntrospect m', m ~ t m') => a -> m Word
recursiveSize = lift . recursiveSize
instance MonadIntrospect IO where
recursiveSize =
#ifdef MIN_VERSION_ghc_datasize
#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804
recursiveSize
#else
\_ -> return 0
#endif
#else
\_ -> return 0
#endif
class Monad m => MonadExec m where
exec' :: [String] -> m (Either ErrorCall NExprLoc)
default exec' :: (MonadTrans t, MonadExec m', m ~ t m') => [String] -> m (Either ErrorCall NExprLoc)
exec' = lift . exec'
instance MonadExec IO where
exec' = \case
[] -> return $ Left $ ErrorCall "exec: missing program"
(prog:args) -> do
(exitCode, out, _) <-
liftIO $ readProcessWithExitCode prog args ""
let t = T.strip (T.pack out)
let emsg = "program[" ++ prog ++ "] args=" ++ show args
case exitCode of
ExitSuccess ->
if T.null t
then return $ Left $ ErrorCall $ "exec has no output :" ++ emsg
else case parseNixTextLoc t of
Failure err ->
return $ Left $ ErrorCall $
"Error parsing output of exec: " ++ show err ++ " " ++ emsg
Success v -> return $ Right v
err -> return $ Left $ ErrorCall $
"exec failed: " ++ show err ++ " " ++ emsg
class Monad m => MonadInstantiate m where
instantiateExpr :: String -> m (Either ErrorCall NExprLoc)
default instantiateExpr :: (MonadTrans t, MonadInstantiate m', m ~ t m') => String -> m (Either ErrorCall NExprLoc)
instantiateExpr = lift . instantiateExpr
instance MonadInstantiate IO where
instantiateExpr expr = do
traceM $ "Executing: "
++ show ["nix-instantiate", "--eval", "--expr ", expr]
(exitCode, out, err) <-
readProcessWithExitCode "nix-instantiate"
[ "--eval", "--expr", expr] ""
case exitCode of
ExitSuccess -> case parseNixTextLoc (T.pack out) of
Failure e ->
return $ Left $ ErrorCall $
"Error parsing output of nix-instantiate: " ++ show e
Success v -> return $ Right v
status ->
return $ Left $ ErrorCall $ "nix-instantiate failed: " ++ show status
++ ": " ++ err
pathExists :: MonadFile m => FilePath -> m Bool
pathExists = doesFileExist
class Monad m => MonadEnv m where
getEnvVar :: String -> m (Maybe String)
default getEnvVar :: (MonadTrans t, MonadEnv m', m ~ t m') => String -> m (Maybe String)
getEnvVar = lift . getEnvVar
getCurrentSystemOS :: m Text
default getCurrentSystemOS :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
getCurrentSystemOS = lift getCurrentSystemOS
getCurrentSystemArch :: m Text
default getCurrentSystemArch :: (MonadTrans t, MonadEnv m', m ~ t m') => m Text
getCurrentSystemArch = lift getCurrentSystemArch
instance MonadEnv IO where
getEnvVar = lookupEnv
getCurrentSystemOS = return $ T.pack System.Info.os
-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
getCurrentSystemArch = return $ T.pack $ case System.Info.arch of
"i386" -> "i686"
arch -> arch
class Monad m => MonadHttp m where
getURL :: Text -> m (Either ErrorCall StorePath)
default getURL :: (MonadTrans t, MonadHttp m', m ~ t m') => Text -> m (Either ErrorCall StorePath)
getURL = lift . getURL
instance MonadHttp IO where
getURL url = do
let urlstr = T.unpack url
traceM $ "fetching HTTP URL: " ++ urlstr
req <- parseRequest urlstr
manager <-
if secure req
then newTlsManager
else newManager defaultManagerSettings
-- print req
response <- httpLbs (req { method = "GET" }) manager
let status = statusCode (responseStatus response)
if status /= 200
then return $ Left $ ErrorCall $
"fail, got " ++ show status ++ " when fetching url:" ++ urlstr
else -- do
-- let bstr = responseBody response
return $ Left $ ErrorCall $
"success in downloading but hnix-store is not yet ready; url = " ++ urlstr
class Monad m => MonadPutStr m where
--TODO: Should this be used *only* when the Nix to be evaluated invokes a
--`trace` operation?
putStr :: String -> m ()
default putStr :: (MonadTrans t, MonadPutStr m', m ~ t m') => String -> m ()
putStr = lift . putStr
putStrLn :: MonadPutStr m => String -> m ()
putStrLn = putStr . (++"\n")
print :: (MonadPutStr m, Show a) => a -> m ()
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)
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
return $ Right $ StorePath $ dropTrailingLinefeed out
_ -> return $ 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
return storepath
addPath :: (Framed e m, MonadStore m) => FilePath -> m StorePath
addPath p = either throwError return =<< addPath' p
toFile_ :: (Framed e m, MonadStore m) => FilePath -> String -> m StorePath
toFile_ p contents = either throwError return =<< toFile_' p contents

40
src/Nix/Eval.hs
View file

@ -76,9 +76,9 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
-}
evalError :: Exception s => s -> m a
type MonadNixEval e v t m =
type MonadNixEval v t m =
(MonadEval v m,
Scoped e t m,
Scoped t m,
MonadThunk v t m,
MonadFix m,
ToValue Bool m v,
@ -95,12 +95,12 @@ data EvalFrame m v
instance (Typeable m, Typeable v) => Exception (EvalFrame m v)
eval :: forall e v t m. MonadNixEval e v t m => NExprF (m v) -> m v
eval :: forall v t m. MonadNixEval v t m => NExprF (m v) -> m v
eval (NSym "__curPos") = evalCurPos
eval (NSym var) =
lookupVar var >>= maybe (freeVariable var) (force ?? evaledSym var)
(lookupVar var :: m (Maybe t)) >>= maybe (freeVariable var) (force ?? evaledSym var)
eval (NConstant x) = evalConstant x
eval (NStr str) = evalString str
@ -109,7 +109,7 @@ eval (NEnvPath p) = evalEnvPath p
eval (NUnary op arg) = evalUnary op =<< arg
eval (NBinary NApp fun arg) = do
scope <- currentScopes @_ @t
scope <- currentScopes :: m (Scopes m t)
fun >>= (`evalApp` withScopes scope arg)
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
@ -143,25 +143,25 @@ eval (NAbs params body) = do
-- needs to be used when evaluating the body and default arguments, hence
-- we defer here so the present scope is restored when the parameters and
-- body are forced during application.
scope <- currentScopes @_ @t
evalAbs params $ \arg k -> withScopes @t scope $ do
scope <- currentScopes :: m (Scopes m t)
evalAbs params $ \arg k -> withScopes scope $ do
args <- buildArgument params arg
pushScope args (k (M.map (`force` pure) args) body)
-- | If you know that the 'scope' action will result in an 'AttrSet t', then
-- this implementation may be used as an implementation for 'evalWith'.
evalWithAttrSet :: forall e v t m. MonadNixEval e v t m => m v -> m v -> m v
evalWithAttrSet :: forall v t m. MonadNixEval v t m => m v -> m v -> m v
evalWithAttrSet aset body = do
-- The scope is deliberately wrapped in a thunk here, since it is
-- evaluated each time a name is looked up within the weak scope, and
-- we want to be sure the action it evaluates is to force a thunk, so
-- its value is only computed once.
scope <- currentScopes @_ @t
scope <- currentScopes :: m (Scopes m t)
s <- thunk $ withScopes scope aset
pushWeakScope ?? body $ force s $
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
attrSetAlter :: forall e v t m. MonadNixEval e v t m
attrSetAlter :: forall v t m. MonadNixEval v t m
=> [Text]
-> SourcePos
-> AttrSet (m v)
@ -208,12 +208,12 @@ desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
Just (p, v) <- gets $ M.lookup x
pure $ NamedVar (StaticKey x :| []) (embed v) p
evalBinds :: forall e v t m. MonadNixEval e v t m
evalBinds :: forall v t m. MonadNixEval v t m
=> Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
evalBinds recursive binds = do
scope <- currentScopes @_ @t
scope <- currentScopes :: m (Scopes m t)
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where
moveOverridesLast = uncurry (++) .
@ -278,7 +278,7 @@ evalBinds recursive binds = do
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
evalSelect :: forall e v t m. MonadNixEval e v t m
evalSelect :: forall v t m. MonadNixEval v t m
=> m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) (m v))
@ -320,14 +320,14 @@ assembleString = \case
Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
where
fromParts = fmap (fmap hackyStringMConcat . sequence) . traverse go
fromParts = fmap (fmap principledStringMConcat . sequence) . traverse go
go = runAntiquoted "\n" (pure . Just . hackyMakeNixStringWithoutContext) (>>= fromValueMay)
go = runAntiquoted "\n" (pure . Just . principledMakeNixStringWithoutContext) (>>= fromValueMay)
buildArgument :: forall e v t m. MonadNixEval e v t m
buildArgument :: forall v t m. MonadNixEval v t m
=> Params (m v) -> m v -> m (AttrSet t)
buildArgument params arg = do
scope <- currentScopes @_ @t
scope <- currentScopes :: m (Scopes m t)
case params of
Param name -> M.singleton name <$> thunk (withScopes scope arg)
ParamSet s isVariadic m ->
@ -364,15 +364,15 @@ addSourcePositions f v@(Fix (Compose (Ann ann _))) =
local (set hasLens ann) (f v)
addStackFrames
:: forall t e m a. (Scoped e t m, Framed e m, Typeable t, Typeable m)
:: forall t e m a. (Scoped t m, Framed e m, Typeable t, Typeable m)
=> Transform NExprLocF (m a)
addStackFrames f v = do
scopes <- currentScopes @e @t
scopes <- currentScopes :: m (Scopes m t)
withFrame Info (EvaluatingExpr scopes v) (f v)
framedEvalExprLoc
:: forall t e v m.
(MonadNixEval e v t m, Framed e m, Has e SrcSpan,
(MonadNixEval v t m, Framed e m, Has e SrcSpan,
Typeable t, Typeable m)
=> NExprLoc -> m v
framedEvalExprLoc = adi (eval . annotated . getCompose)

302
src/Nix/Exec.hs
View file

@ -26,34 +26,30 @@
module Nix.Exec where
import Prelude hiding (putStr, putStrLn, print)
import Control.Applicative
import Control.Monad
import Control.Monad.Catch hiding (catchJust)
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.State.Strict
import Control.Monad.Trans.Reader (ReaderT(..))
import Control.Monad.Trans.State.Strict (StateT(..))
import qualified Data.ByteString as BS
import Data.Coerce
import Data.Fix
import Data.GADT.Compare
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.IORef
import Data.List
import qualified Data.List.NonEmpty as NE
import Data.List.Split
import Data.Maybe (maybeToList)
import Data.Semigroup
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Prettyprint.Doc
import Data.Typeable
import GHC.IO.Exception (IOErrorType(..))
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import Network.HTTP.Types
import Nix.Atoms
import Nix.Context
import Nix.Convert
@ -74,14 +70,7 @@ import Nix.Value
#ifdef MIN_VERSION_haskeline
import System.Console.Haskeline.MonadException hiding (catch)
#endif
import System.Directory
import System.Environment
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath
import qualified System.Info
import System.IO.Error
import System.Posix.Files
import System.Process (readProcessWithExitCode)
#ifdef MIN_VERSION_pretty_show
import qualified Text.Show.Pretty as PS
#endif
@ -93,7 +82,7 @@ import GHC.DataSize
#endif
type MonadNix e m =
(Scoped e (NThunk m) m, Framed e m, Has e SrcSpan, Has e Options,
(Scoped (NThunk m) m, Framed e m, Has e SrcSpan, Has e Options,
Typeable m, MonadVar m, MonadEffects m, MonadFix m, MonadCatch m,
Alternative m)
@ -335,7 +324,7 @@ execBinaryOp scope span op lval rarg = do
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr ls, NVStr rs) -> case op of
NPlus -> pure $ bin nvStrP (ls `hackyStringMappend` rs)
NPlus -> pure $ bin nvStrP (ls `principledStringMappend` rs)
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
NLt -> toBool $ ls < rs
@ -345,13 +334,13 @@ execBinaryOp scope span op lval rarg = do
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr _, NVConstant NNull) -> case op of
NEq -> toBool =<< valueEq lval (nvStr (hackyMakeNixStringWithoutContext ""))
NNEq -> toBool . not =<< valueEq lval (nvStr (hackyMakeNixStringWithoutContext ""))
NEq -> toBool False
NNEq -> toBool True
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVConstant NNull, NVStr _) -> case op of
NEq -> toBool =<< valueEq (nvStr (hackyMakeNixStringWithoutContext "")) rval
NNEq -> toBool . not =<< valueEq (nvStr (hackyMakeNixStringWithoutContext "")) rval
NEq -> toBool False
NNEq -> toBool True
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVSet ls lp, NVSet rs rp) -> case op of
@ -373,15 +362,15 @@ execBinaryOp scope span op lval rarg = do
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(ls@NVSet {}, NVStr rs) -> case op of
NPlus -> (\ls -> bin nvStrP (hackyModifyNixContents (Text.pack ls `mappend`) rs))
<$> coerceToString False False ls
NPlus -> (\ls2 -> bin nvStrP (ls2 `principledStringMappend` rs))
<$> coerceToString DontCopyToStore CoerceStringy ls
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVStr ls, rs@NVSet {}) -> case op of
NPlus -> (\rs -> bin nvStrP (hackyModifyNixContents (`mappend` Text.pack rs) ls))
<$> coerceToString False False rs
NPlus -> (\rs2 -> bin nvStrP (ls `principledStringMappend` rs2))
<$> coerceToString DontCopyToStore CoerceStringy rs
NEq -> toBool =<< valueEq lval rval
NNEq -> toBool . not =<< valueEq lval rval
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
@ -405,8 +394,8 @@ execBinaryOp scope span op lval rarg = do
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
(NVPath p, NVStr ns) -> case op of
NEq -> toBool $ Just p == fmap Text.unpack (hackyStringIgnoreContextMaybe ns)
NNEq -> toBool $ Just p /= fmap Text.unpack (hackyStringIgnoreContextMaybe ns)
NEq -> toBool $ Just p == fmap Text.unpack (hackyGetStringNoContext ns)
NNEq -> toBool $ Just p /= fmap Text.unpack (hackyGetStringNoContext ns)
NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack (hackyStringIgnoreContext ns))
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
@ -442,21 +431,37 @@ execBinaryOp scope span op lval rarg = do
toInt = pure . bin nvConstantP . NInt
toFloat = pure . bin nvConstantP . NFloat
coerceToString :: MonadNix e m => Bool -> Bool -> NValue m -> m String
coerceToString copyToStore coerceMore = go
-- | Data type to avoid boolean blindness on what used to be called coerceMore
data CoercionLevel
= CoerceStringy
-- ^ Coerce only stringlike types: strings, paths, and appropriate sets
| CoerceAny
-- ^ Coerce everything but functions
deriving (Eq,Ord,Enum,Bounded)
-- | Data type to avoid boolean blindness on what used to be called copyToStore
data CopyToStoreMode
= CopyToStore
-- ^ Add paths to the store as they are encountered
| DontCopyToStore
-- ^ Add paths to the store as they are encountered
deriving (Eq,Ord,Enum,Bounded)
coerceToString :: MonadNix e m => CopyToStoreMode -> CoercionLevel -> NValue m -> m NixString
coerceToString ctsm clevel = go
where
go = \case
NVConstant (NBool b)
| b && coerceMore -> pure "1"
| coerceMore -> pure ""
NVConstant (NInt n) | coerceMore -> pure $ show n
NVConstant (NFloat n) | coerceMore -> pure $ show n
NVConstant NNull | coerceMore -> pure ""
NVStr ns -> pure $ Text.unpack (hackyStringIgnoreContext ns)
NVPath p | copyToStore -> unStorePath <$> addPath p
| otherwise -> pure p
NVList l | coerceMore -> unwords <$> traverse (`force` go) l
-- TODO Return a singleton for "" and "1"
| b && clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext "1"
| clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext ""
NVConstant (NInt n) | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
NVConstant (NFloat n) | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext $ Text.pack $ show n
NVConstant NNull | clevel == CoerceAny -> pure $ principledMakeNixStringWithoutContext ""
NVStr ns -> pure ns
NVPath p | ctsm == CopyToStore -> storePathToNixString <$> addPath p
| otherwise -> pure $ principledMakeNixStringWithoutContext $ Text.pack p
NVList l | clevel == CoerceAny -> nixStringUnwords <$> traverse (`force` go) l
v@(NVSet s _) | Just p <- M.lookup "__toString" s ->
force p $ (`callFunc` pure v) >=> go
@ -466,6 +471,20 @@ coerceToString copyToStore coerceMore = go
v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v
nixStringUnwords = principledIntercalateNixString (principledMakeNixStringWithoutContext " ")
storePathToNixString :: StorePath -> NixString
storePathToNixString sp =
principledMakeNixStringWithSingletonContext t (StringContext t DirectPath)
where
t = Text.pack $ unStorePath sp
fromStringNoContext :: MonadNix e m => m (NValue m) -> m Text
fromStringNoContext =
fromValue >=> \s -> case principledGetStringNoContext s of
Just str -> return str
Nothing -> throwError $ ErrorCall
"expected string with no context"
newtype Lazy m a = Lazy
{ runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m)))
(StateT (HashMap FilePath NExprLoc) m) a }
@ -473,17 +492,19 @@ newtype Lazy m a = Lazy
MonadFix, MonadIO,
MonadReader (Context (Lazy m) (NThunk (Lazy m))))
instance MonadIO m => MonadVar (Lazy m) where
type Var (Lazy m) = IORef
instance MonadTrans Lazy where
lift = Lazy . lift . lift
eqVar = (==)
newVar = liftIO . newIORef
readVar = liftIO . readIORef
writeVar = (liftIO .) . writeIORef
atomicModifyVar = (liftIO .) . atomicModifyIORef
instance MonadRef m => MonadRef (Lazy m) where
type Ref (Lazy m) = Ref m
newRef = lift . newRef
readRef = lift . readRef
writeRef r = lift . writeRef r
instance (MonadIO m, Monad m) => MonadFile m where
readFile = liftIO . BS.readFile
instance MonadAtomicRef m => MonadAtomicRef (Lazy m) where
atomicModifyRef r = lift . atomicModifyRef r
instance (MonadFile m, Monad m) => MonadFile (Lazy m)
instance MonadCatch m => MonadCatch (Lazy m) where
catch (Lazy (ReaderT m)) f = Lazy $ ReaderT $ \e ->
@ -499,32 +520,33 @@ instance MonadException m => MonadException (Lazy m) where
in runLazy <$> f run'
#endif
instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
MonadPlus m, Typeable m)
instance MonadStore m => MonadStore (Lazy m) where
addPath' = lift . addPath'
toFile_' n = lift . toFile_' n
instance MonadPutStr m => MonadPutStr (Lazy m)
instance MonadHttp m => MonadHttp (Lazy m)
instance MonadEnv m => MonadEnv (Lazy m)
instance MonadInstantiate m => MonadInstantiate (Lazy m)
instance MonadExec m => MonadExec (Lazy m)
instance MonadIntrospect m => MonadIntrospect (Lazy m)
instance (MonadFix m, MonadCatch m, MonadFile m, MonadStore m, MonadVar m,
MonadPutStr m, MonadHttp m, MonadEnv m, MonadInstantiate m, MonadExec m,
MonadIntrospect m, Alternative m, MonadPlus m, Typeable m)
=> MonadEffects (Lazy m) where
addPath path = do
(exitCode, out, _) <-
liftIO $ readProcessWithExitCode "nix-store" ["--add", path] ""
case exitCode of
ExitSuccess -> do
let dropTrailingLinefeed p = take (length p - 1) p
return $ StorePath $ dropTrailingLinefeed out
_ -> throwError $ ErrorCall $
"addPath: failed: nix-store --add " ++ show path
toFile_ filepath content = do
liftIO $ writeFile filepath content
storepath <- addPath filepath
liftIO $ removeFile filepath
return storepath
makeAbsolutePath origPath = do
origPathExpanded <- liftIO $ expandHomePath origPath
origPathExpanded <- expandHomePath origPath
absPath <- if isAbsolute origPathExpanded then pure origPathExpanded else do
cwd <- do
mres <- lookupVar @_ @(NThunk (Lazy m)) "__cur_file"
mres <- lookupVar "__cur_file"
case mres of
Nothing -> liftIO getCurrentDirectory
Nothing -> getCurrentDirectory
Just v -> force v $ \case
NVPath s -> return $ takeDirectory s
v -> throwError $ ErrorCall $ "when resolving relative path,"
@ -532,21 +554,14 @@ instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
++ " but is not a path; it is: "
++ show v
pure $ cwd <///> origPathExpanded
liftIO $ removeDotDotIndirections <$> canonicalizePath absPath
removeDotDotIndirections <$> canonicalizePath absPath
-- Given a path, determine the nix file to load
pathToDefaultNix = liftIO . pathToDefaultNixFile
pathToDefaultNix = pathToDefaultNixFile
findEnvPath = findEnvPathM
findPath = findPathM
pathExists fp = liftIO $ catchJust
-- "inappropriate type" error is thrown if `fileExist` is given a filepath where
-- a plain file appears as a directory, i.e. /bin/sh/nonexistent-file
(\ e -> guard (ioeGetErrorType e == InappropriateType) >> pure e)
(fileExist fp)
(\ _ -> return False)
importPath path = do
traceM $ "Importing file " ++ path
withFrame Info (ErrorCall $ "While importing file " ++ show path) $ do
@ -554,7 +569,7 @@ instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
evalExprLoc =<< case M.lookup path imports of
Just expr -> pure expr
Nothing -> do
eres <- Lazy $ parseNixFileLoc path
eres <- parseNixFileLoc path
case eres of
Failure err ->
throwError $ ErrorCall . show $ fillSep $
@ -566,18 +581,6 @@ instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
modify (M.insert path expr)
pure expr
getEnvVar = liftIO . lookupEnv
getCurrentSystemOS = return $ Text.pack System.Info.os
-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
getCurrentSystemArch = return $ Text.pack $ case System.Info.arch of
"i386" -> "i686"
arch -> arch
listDirectory = liftIO . System.Directory.listDirectory
getSymbolicLinkStatus = liftIO . System.Posix.Files.getSymbolicLinkStatus
derivationStrict = fromValue @(ValueSet (Lazy m)) >=> \s -> do
nn <- maybe (pure False) fromNix (M.lookup "__ignoreNulls" s)
s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)
@ -597,77 +600,12 @@ instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
NVConstant NNull | ignoreNulls -> pure Nothing
v' -> Just <$> coerceNix v'
where
coerceNix = toNix . Text.pack <=< coerceToString True True
coerceNix = toNix <=< coerceToString CopyToStore CoerceAny
nixInstantiateExpr expr = do
traceM $ "Executing: "
++ show ["nix-instantiate", "--eval", "--expr ", expr]
(exitCode, out, err) <-
liftIO $ readProcessWithExitCode "nix-instantiate"
[ "--eval", "--expr", expr] ""
case exitCode of
ExitSuccess -> case parseNixTextLoc (Text.pack out) of
Failure err ->
throwError $ ErrorCall $
"Error parsing output of nix-instantiate: " ++ show err
Success v -> evalExprLoc v
status ->
throwError $ ErrorCall $ "nix-instantiate failed: " ++ show status
++ ": " ++ err
traceEffect = putStrLn
getRecursiveSize =
#ifdef MIN_VERSION_ghc_datasize
#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804
toNix @Integer <=< fmap fromIntegral . liftIO . recursiveSize
#else
const $ toNix (0 :: Integer)
#endif
#else
const $ toNix (0 :: Integer)
#endif
getURL url = do
let urlstr = Text.unpack url
traceM $ "fetching HTTP URL: " ++ urlstr
response <- liftIO $ do
req <- parseRequest urlstr
manager <-
if secure req
then newTlsManager
else newManager defaultManagerSettings
-- print req
httpLbs (req { method = "GET" }) manager
-- return response
let status = statusCode (responseStatus response)
if status /= 200
then throwError $ ErrorCall $
"fail, got " ++ show status ++ " when fetching url:" ++ urlstr
else -- do
-- let bstr = responseBody response
-- liftIO $ print bstr
throwError $ ErrorCall $
"success in downloading but hnix-store is not yet ready; url = " ++ urlstr
traceEffect = liftIO . putStrLn
exec = \case
[] -> throwError $ ErrorCall "exec: missing program"
(prog:args) -> do
(exitCode, out, _) <-
liftIO $ readProcessWithExitCode prog args ""
let t = Text.strip (Text.pack out)
let emsg = "program[" ++ prog ++ "] args=" ++ show args
case exitCode of
ExitSuccess ->
if Text.null t
then throwError $ ErrorCall $ "exec has no output :" ++ emsg
else case parseNixTextLoc t of
Failure err ->
throwError $ ErrorCall $
"Error parsing output of exec: " ++ show err ++ " " ++ emsg
Success v -> evalExprLoc v
err -> throwError $ ErrorCall $
"exec failed: " ++ show err ++ " " ++ emsg
getRecursiveSize :: MonadIntrospect m => a -> m (NValue m)
getRecursiveSize = toNix @Integer . fromIntegral <=< recursiveSize
runLazyM :: Options -> MonadIO m => Lazy m a -> m a
runLazyM opts = (`evalStateT` M.empty)
@ -684,12 +622,12 @@ removeDotDotIndirections = intercalate "/" . go [] . splitOn "/"
go (_:s) ("..":rest) = go s rest
go s (this:rest) = go (this:s) rest
expandHomePath :: FilePath -> IO FilePath
expandHomePath :: MonadFile m => FilePath -> m FilePath
expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory
expandHomePath p = return p
-- Given a path, determine the nix file to load
pathToDefaultNixFile :: FilePath -> IO FilePath
pathToDefaultNixFile :: MonadFile m => FilePath -> m FilePath
pathToDefaultNixFile p = do
isDir <- doesDirectoryExist p
pure $ if isDir then p </> "default.nix" else p
@ -703,7 +641,7 @@ x <///> y | isAbsolute y || "." `isPrefixOf` y = x </> y
joinPath $ head [ xs ++ drop (length tx) ys
| tx <- tails xs, tx `elem` inits ys ]
findPathBy :: forall e m. (MonadNix e m, MonadIO m) =>
findPathBy :: forall e m. MonadNix e m =>
(FilePath -> m (Maybe FilePath)) ->
[NThunk m] -> FilePath -> m FilePath
findPathBy finder l name = do
@ -740,36 +678,36 @@ findPathBy finder l name = do
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) =>
findPathM :: forall e m. MonadNix e m =>
[NThunk m] -> FilePath -> m FilePath
findPathM l name = findPathBy path l name
where
path :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath)
path :: MonadEffects m => FilePath -> m (Maybe FilePath)
path path = do
path <- makeAbsolutePath path
exists <- liftIO $ doesPathExist path
exists <- doesPathExist path
return $ if exists then Just path else Nothing
findEnvPathM :: forall e m. (MonadNix e m, MonadIO m)
findEnvPathM :: forall e m. MonadNix e m
=> FilePath -> m FilePath
findEnvPathM name = do
mres <- lookupVar @_ @(NThunk m) "__nixPath"
mres <- lookupVar "__nixPath"
case mres of
Nothing -> error "impossible"
Just x -> force x $ fromValue >=> \(l :: [NThunk m]) ->
findPathBy nixFilePath l name
where
nixFilePath :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath)
nixFilePath :: MonadEffects m => FilePath -> m (Maybe FilePath)
nixFilePath path = do
path <- makeAbsolutePath path
exists <- liftIO $ doesDirectoryExist path
exists <- doesDirectoryExist path
path' <- if exists
then makeAbsolutePath $ path </> "default.nix"
else return path
exists <- liftIO $ doesFileExist path'
exists <- doesFileExist path'
return $ if exists then Just path' else Nothing
addTracing :: (MonadNix e m, Has e Options, MonadIO m,
addTracing :: (MonadNix e m, Has e Options,
MonadReader Int n, Alternative n)
=> Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
addTracing k v = do
@ -789,12 +727,12 @@ addTracing k v = do
else prettyNix (Fix (Fix (NSym "?") <$ x))
msg x = pretty ("eval: " ++ replicate depth ' ') <> x
loc <- renderLocation span (msg rendered <> " ...\n")
liftIO $ putStr $ show loc
putStr $ show loc
res <- k v'
liftIO $ print $ msg rendered <> " ...done"
print $ msg rendered <> " ...done"
return res
evalExprLoc :: forall e m. (MonadNix e m, Has e Options, MonadIO m)
evalExprLoc :: forall e m. (MonadNix e m, Has e Options)
=> NExprLoc -> m (NValue m)
evalExprLoc expr = do
opts :: Options <- asks (view hasLens)
@ -805,7 +743,7 @@ evalExprLoc expr = do
expr
else adi phi (addStackFrames @(NThunk m) . addSourcePositions) expr
where
phi = Eval.eval @_ @(NValue m) @(NThunk m) @m . annotated . getCompose
phi = Eval.eval . 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)
@ -844,3 +782,15 @@ fetchTarball v = v >>= \case
nixInstantiateExpr $ "builtins.fetchTarball { "
++ "url = \"" ++ Text.unpack url ++ "\"; "
++ "sha256 = \"" ++ Text.unpack sha ++ "\"; }"
exec :: (MonadExec m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e Options, Has e SrcSpan, Scoped (NThunk m) m) => [String] -> m (NValue m)
exec args = either throwError evalExprLoc =<< exec' args
nixInstantiateExpr :: (MonadInstantiate m, Framed e m, MonadThrow m, Alternative m, MonadCatch m, MonadFix m, MonadEffects m, GEq (Ref m), MonadAtomicRef m, Typeable m, Has e Options, Has e SrcSpan, Scoped (NThunk m) m) => String -> m (NValue m)
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s
instance Monad m => Scoped (NThunk (Lazy m)) (Lazy m) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Lazy m) @(NThunk (Lazy m))
pushScopes = pushScopesReader
lookupVar = lookupVarReader

1
src/Nix/Expr/Shorthands.hs
View file

@ -9,7 +9,6 @@ module Nix.Expr.Shorthands where
import Data.Fix
import Data.List.NonEmpty (NonEmpty(..))
import Data.Monoid
import Data.Text (Text)
import Nix.Atoms
import Nix.Expr.Types

1
src/Nix/Expr/Types.hs
View file

@ -50,7 +50,6 @@ import Data.List (inits, tails)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Ord.Deriving
import Data.Text (Text, pack, unpack)
import Data.Traversable

1
src/Nix/Expr/Types/Annotated.hs
View file

@ -38,7 +38,6 @@ import Data.Hashable
import Data.Hashable.Lifted
#endif
import Data.Ord.Deriving
import Data.Semigroup
import Data.Text (Text, pack)
import GHC.Generics
import Nix.Atoms

25
src/Nix/Lint.hs
View file

@ -1,8 +1,8 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@ -13,6 +13,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
@ -27,6 +28,7 @@ import Control.Monad
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.Reader (MonadReader)
import Control.Monad.Ref
import Control.Monad.ST
import Control.Monad.Trans.Reader
import Data.Coerce
@ -115,7 +117,7 @@ unpackSymbolic :: MonadVar m
=> Symbolic m -> m (NSymbolicF (NTypeF m (SThunk m)))
unpackSymbolic = readVar . coerce
type MonadLint e m = (Scoped e (SThunk m) m, Framed e m, MonadVar m,
type MonadLint e m = (Scoped (SThunk m) m, Framed e m, MonadVar m,
MonadCatch m)
symerr :: forall e m a. MonadLint e m => String -> m a
@ -391,13 +393,14 @@ newtype Lint s a = Lint
deriving (Functor, Applicative, Monad, MonadFix,
MonadReader (Context (Lint s) (SThunk (Lint s))))
instance MonadVar (Lint s) where
type Var (Lint s) = STRef s
instance MonadRef (Lint s) where
type Ref (Lint s) = Ref (ST s)
newRef x = Lint $ newRef x
readRef x = Lint $ readRef x
writeRef x y = Lint $ writeRef x y
newVar x = Lint $ ReaderT $ \_ -> newSTRef x
readVar x = Lint $ ReaderT $ \_ -> readSTRef x
writeVar x y = Lint $ ReaderT $ \_ -> writeSTRef x y
atomicModifyVar x f = Lint $ ReaderT $ \_ -> do
instance MonadAtomicRef (Lint s) where
atomicModifyRef x f = Lint $ ReaderT $ \_ -> do
res <- snd . f <$> readSTRef x
_ <- modifySTRef x (fst . f)
return res
@ -420,3 +423,9 @@ lint opts expr = runLintM opts $
>>= (`pushScopes`
adi (Eval.eval . annotated . getCompose)
Eval.addSourcePositions expr)
instance Scoped (SThunk (Lint s)) (Lint s) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Lint s) @(SThunk (Lint s))
pushScopes = pushScopesReader
lookupVar = lookupVarReader

34
src/Nix/Normal.hs
View file

@ -19,13 +19,8 @@ import Control.Monad.Trans.State
import qualified Data.HashMap.Lazy as M
import Data.List (find)
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as Text
import Nix.Atoms
import Nix.Effects
import Nix.Frames
-- import Nix.Pretty
import Nix.String
import Nix.Thunk
import Nix.Utils
import Nix.Value
@ -108,32 +103,3 @@ embed (Free x) = case x of
NVClosureF p f -> return $ nvClosure p f
NVPathF fp -> return $ nvPath fp
NVBuiltinF n f -> return $ nvBuiltin n f
valueText :: forall e m. (Framed e m, MonadEffects m, Typeable m)
=> Bool -> NValueNF m -> m NixString
valueText addPathsToStore = iter phi . check
where
check :: NValueNF m -> Free (NValueF m) (m NixString)
check = fmap (const $ pure (hackyMakeNixStringWithoutContext "<CYCLE>"))
phi :: NValueF m (m NixString) -> m NixString
phi (NVConstantF a) = pure (hackyMakeNixStringWithoutContext (atomText a))
phi (NVStrF ns) = pure ns
phi v@(NVListF _) = coercionFailed v
phi v@(NVSetF s _)
| Just asString <- M.lookup "__asString" s = asString
| otherwise = coercionFailed v
phi v@NVClosureF {} = coercionFailed v
phi (NVPathF originalPath)
| addPathsToStore = do
storePath <- addPath originalPath
pure (hackyMakeNixStringWithoutContext $ Text.pack $ unStorePath storePath)
| otherwise = pure (hackyMakeNixStringWithoutContext (Text.pack originalPath))
phi v@(NVBuiltinF _ _) = coercionFailed v
coercionFailed v =
throwError $ Coercion @m (valueType v) TString
valueTextNoContext :: (Framed e m, MonadEffects m, Typeable m)
=> Bool -> NValueNF m -> m Text
valueTextNoContext addPathsToStore = fmap hackyStringIgnoreContext . valueText addPathsToStore

1
src/Nix/Options/Parser.hs
View file

@ -5,7 +5,6 @@ import Data.Char (isDigit)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Prettyprint.Doc
import Data.Time
import Nix.Options
import Options.Applicative hiding (ParserResult(..))

14
src/Nix/Parser.hs
View file

@ -46,10 +46,11 @@ module Nix.Parser
, whiteSpace
) where
import Prelude hiding (readFile)
import Control.Applicative hiding (many, some)
import Control.DeepSeq
import Control.Monad
import Control.Monad.IO.Class
import Data.Char (isAlpha, isDigit, isSpace)
import Data.Data (Data(..))
import Data.Foldable (concat)
@ -63,11 +64,12 @@ import qualified Data.Map as Map
import Data.Text (Text)
import Data.Text hiding (map, foldr1, concat, concatMap, zipWith)
import Data.Text.Prettyprint.Doc (Doc, pretty)
import qualified Data.Text.IO as T
import Data.Text.Encoding
import Data.Typeable (Typeable)
import Data.Void
import GHC.Generics hiding (Prefix)
import Nix.Expr hiding (($>))
import Nix.Render
import Nix.Strings
import Text.Megaparsec
import Text.Megaparsec.Char
@ -357,11 +359,11 @@ nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set") where
isRec = (reserved "rec" $> NRecSet <?> "recursive set")
<+> pure NSet
parseNixFile :: MonadIO m => FilePath -> m (Result NExpr)
parseNixFile :: MonadFile m => FilePath -> m (Result NExpr)
parseNixFile =
parseFromFileEx $ stripAnnotation <$> (whiteSpace *> nixToplevelForm <* eof)
parseNixFileLoc :: MonadIO m => FilePath -> m (Result NExprLoc)
parseNixFileLoc :: MonadFile m => FilePath -> m (Result NExprLoc)
parseNixFileLoc = parseFromFileEx (whiteSpace *> nixToplevelForm <* eof)
parseNixText :: Text -> Result NExpr
@ -439,9 +441,9 @@ type Parser = ParsecT Void Text Identity
data Result a = Success a | Failure (Doc Void) deriving (Show, Functor)
parseFromFileEx :: MonadIO m => Parser a -> FilePath -> m (Result a)
parseFromFileEx :: MonadFile m => Parser a -> FilePath -> m (Result a)
parseFromFileEx p path = do
txt <- liftIO (T.readFile path)
txt <- decodeUtf8 <$> readFile path
return $ either (Failure . pretty . parseErrorPretty' txt) Success
$ parse p path txt

19
src/Nix/Pretty.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
@ -264,14 +265,11 @@ fixate g = Fix . go
go (Pure a) = g a
go (Free f) = fmap (Fix . go) f
prettyNValueNF :: Functor m => NValueNF m -> Doc ann
prettyNValueNF = prettyNix . valueToExpr
valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = transport go . check
where
check :: NValueNF m -> Fix (NValueF m)
check = fixate (const (NVStrF (hackyMakeNixStringWithoutContext "<CYCLE>")))
valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = transport go . check
check = fixate $ const $ NVStrF $ principledMakeNixStringWithoutContext "<CYCLE>"
go (NVConstantF a) = NConstant a
go (NVStrF ns) = NStr (DoubleQuoted [Plain (hackyStringIgnoreContext ns)])
@ -283,6 +281,9 @@ prettyNValueNF = prettyNix . valueToExpr
go (NVPathF p) = NLiteralPath p
go (NVBuiltinF name _) = NSym $ Text.pack $ "builtins." ++ name
prettyNValueNF :: Functor m => NValueNF m -> Doc ann
prettyNValueNF = prettyNix . valueToExpr
printNix :: Functor m => NValueNF m -> String
printNix = iter phi . check
where
@ -304,7 +305,7 @@ removeEffects :: Functor m => NValueF m (NThunk m) -> NValueNF m
removeEffects = Free . fmap dethunk
where
dethunk (NThunk _ (Value v)) = removeEffects (_baseValue v)
dethunk (NThunk _ _) = Free $ NVStrF (hackyMakeNixStringWithoutContext "<thunk>")
dethunk (NThunk _ _) = Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
removeEffectsM :: MonadVar m => NValueF m (NThunk m) -> m (NValueNF m)
removeEffectsM = fmap Free . traverse dethunk
@ -342,11 +343,11 @@ dethunk = \case
NThunk _ (Thunk _ active ref) -> do
nowActive <- atomicModifyVar active (True,)
if nowActive
then pure $ Free $ NVStrF (hackyMakeNixStringWithoutContext "<thunk>")
then pure $ Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
else do
eres <- readVar ref
res <- case eres of
Computed v -> removeEffectsM (_baseValue v)
_ -> pure $ Free $ NVStrF (hackyMakeNixStringWithoutContext "<thunk>")
_ -> pure $ Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
_ <- atomicModifyVar active (False,)
return res

14
src/Nix/Reduce.hs
View file

@ -72,8 +72,8 @@ newtype Reducer m a = Reducer
MonadState (HashMap FilePath NExprLoc))
staticImport
:: forall e m.
(MonadIO m, Scoped e NExprLoc m,
:: forall m.
(MonadIO m, Scoped NExprLoc m,
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
MonadState (HashMap FilePath NExprLoc) m)
=> SrcSpan -> FilePath -> m NExprLoc
@ -118,8 +118,8 @@ reduceExpr mpath expr
. runReducer
$ cata reduce expr
reduce :: forall e m.
(MonadIO m, Scoped e NExprLoc m,
reduce :: forall m.
(MonadIO m, Scoped NExprLoc m,
MonadReader (Maybe FilePath, Scopes m NExprLoc) m,
MonadState (HashMap FilePath NExprLoc) m)
=> NExprLocF (m NExprLoc) -> m NExprLoc
@ -407,3 +407,9 @@ reducingEvalExpr eval mpath expr = do
return (fromMaybe nNull expr'', eres)
where
addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x
instance Monad m => Scoped NExprLoc (Reducer m) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Reducer m) @NExprLoc
pushScopes = pushScopesReader
lookupVar = lookupVarReader

44
src/Nix/Render.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
@ -9,17 +10,60 @@
module Nix.Render where
import Prelude hiding (readFile)
import Control.Monad.Trans
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.Set as Set
import Data.Text.Prettyprint.Doc
import Data.Void
import Nix.Expr.Types.Annotated
import qualified System.Posix.Files as S
import qualified System.Directory as S
import Text.Megaparsec.Error
import Text.Megaparsec.Pos (SourcePos(..))
class Monad m => MonadFile m where
readFile :: FilePath -> m ByteString
default readFile :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m ByteString
readFile = lift . readFile
listDirectory :: FilePath -> m [FilePath]
default listDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m [FilePath]
listDirectory = lift . listDirectory
getCurrentDirectory :: m FilePath
default getCurrentDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath
getCurrentDirectory = lift getCurrentDirectory
canonicalizePath :: FilePath -> m FilePath
default canonicalizePath :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m FilePath
canonicalizePath = lift . canonicalizePath
getHomeDirectory :: m FilePath
default getHomeDirectory :: (MonadTrans t, MonadFile m', m ~ t m') => m FilePath
getHomeDirectory = lift getHomeDirectory
doesPathExist :: FilePath -> m Bool
default doesPathExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool
doesPathExist = lift . doesPathExist
doesFileExist :: FilePath -> m Bool
default doesFileExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool
doesFileExist = lift . doesFileExist
doesDirectoryExist :: FilePath -> m Bool
default doesDirectoryExist :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m Bool
doesDirectoryExist = lift . doesDirectoryExist
getSymbolicLinkStatus :: FilePath -> m S.FileStatus
default getSymbolicLinkStatus :: (MonadTrans t, MonadFile m', m ~ t m') => FilePath -> m S.FileStatus
getSymbolicLinkStatus = lift . getSymbolicLinkStatus
instance MonadFile IO where
readFile = BS.readFile
listDirectory = S.listDirectory
getCurrentDirectory = S.getCurrentDirectory
canonicalizePath = S.canonicalizePath
getHomeDirectory = S.getHomeDirectory
doesPathExist = S.doesPathExist
doesFileExist = S.doesFileExist
doesDirectoryExist = S.doesDirectoryExist
getSymbolicLinkStatus = S.getSymbolicLinkStatus
posAndMsg :: SourcePos -> Doc a-> ParseError t Void
posAndMsg beg msg =

40
src/Nix/Scope.hs
View file

@ -1,10 +1,13 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -13,7 +16,6 @@ module Nix.Scope where
import Control.Applicative
import Control.Monad.Reader
import qualified Data.HashMap.Lazy as M
import Data.Semigroup
import Data.Text (Text)
import Lens.Family2
import Nix.Utils
@ -49,28 +51,32 @@ instance Monoid (Scopes m v) where
mempty = emptyScopes
mappend = (<>)
type Scoped e v m = (MonadReader e m, Has e (Scopes m v))
emptyScopes :: Scopes m v
emptyScopes :: forall m v. Scopes m v
emptyScopes = Scopes [] []
currentScopes :: Scoped e v m => m (Scopes m v)
currentScopes = asks (view hasLens)
class Scoped t m | m -> t where
currentScopes :: m (Scopes m t)
clearScopes :: m a -> m a
pushScopes :: Scopes m t -> m a -> m a
lookupVar :: Text -> m (Maybe t)
clearScopes :: forall v m e r. Scoped e v m => m r -> m r
clearScopes = local (set hasLens (emptyScopes @m @v))
currentScopesReader :: forall m t e. (MonadReader e m, Has e (Scopes m t)) => m (Scopes m t)
currentScopesReader = asks (view hasLens)
pushScope :: forall v m e r. Scoped e v m => AttrSet v -> m r -> m r
clearScopesReader :: forall m t e a. (MonadReader e m, Has e (Scopes m t)) => m a -> m a
clearScopesReader = local (set hasLens (emptyScopes @m @t))
pushScope :: Scoped t m => AttrSet t -> m a -> m a
pushScope s = pushScopes (Scopes [Scope s] [])
pushWeakScope :: forall v m e r. Scoped e v m => m (AttrSet v) -> m r -> m r
pushWeakScope :: (Functor m, Scoped t m) => m (AttrSet t) -> m a -> m a
pushWeakScope s = pushScopes (Scopes [] [Scope <$> s])
pushScopes :: Scoped e v m => Scopes m v -> m r -> m r
pushScopes s = local (over hasLens (s <>))
pushScopesReader :: (MonadReader e m, Has e (Scopes m t)) => Scopes m t -> m a -> m a
pushScopesReader s = local (over hasLens (s <>))
lookupVar :: forall e v m. (Scoped e v m, Monad m) => Text -> m (Maybe v)
lookupVar k = do
lookupVarReader :: forall m t e. (MonadReader e m, Has e (Scopes m t)) => Text -> m (Maybe t)
lookupVarReader k = do
mres <- asks (scopeLookup k . lexicalScopes @m . view hasLens)
case mres of
Just sym -> return $ Just sym
@ -83,5 +89,5 @@ lookupVar k = do
Nothing -> rest)
(return Nothing) ws
withScopes :: forall v m e a. Scoped e v m => Scopes m v -> m a -> m a
withScopes scope = clearScopes @v . pushScopes scope
withScopes :: Scoped t m => Scopes m t -> m a -> m a
withScopes scope = clearScopes . pushScopes scope

94
src/Nix/String.hs
View file

@ -1,26 +1,36 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
module Nix.String (
NixString
, principledMempty
, StringContext(..)
, ContextFlavor(..)
, stringHasContext
, hackyStringIgnoreContextMaybe
, principledIntercalateNixString
, hackyGetStringNoContext
, principledGetStringNoContext
, principledStringIgnoreContext
, hackyStringIgnoreContext
, hackyMakeNixStringWithoutContext
, hackyModifyNixContents
, hackyStringMappend
, hackyStringMConcat
, principledMakeNixStringWithoutContext
, principledMakeNixStringWithSingletonContext
, principledModifyNixContents
, principledStringMappend
, principledStringMempty
, principledStringMConcat
) where
import qualified Data.HashSet as S
import Data.Hashable
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics
import Data.Semigroup
-- {-# WARNING hackyStringMappend, hackyStringMConcat, hackyStringIgnoreContextMaybe, hackyStringIgnoreContext, hackyMakeNixStringWithoutContext, hackyModifyNixContents "This NixString function needs to be replaced" #-}
-- {-# WARNING hackyGetStringNoContext, hackyStringIgnoreContext, hackyMakeNixStringWithoutContext "This NixString function needs to be replaced" #-}
-- | A 'ContextFlavor' describes the sum of possible derivations for string contexts
data ContextFlavor =
data ContextFlavor =
DirectPath
| DerivationOutput !Text
deriving (Show, Eq, Ord, Generic)
@ -28,27 +38,52 @@ data ContextFlavor =
instance Hashable ContextFlavor
-- | A 'StringContext' ...
data StringContext =
data StringContext =
StringContext { scPath :: !Text
, scFlavor :: !ContextFlavor
} deriving (Eq, Ord, Show, Generic)
} deriving (Eq, Ord, Show, Generic)
instance Hashable StringContext
data NixString = NixString
data NixString = NixString
{ nsContents :: !Text
, nsContext :: !(S.HashSet StringContext)
} deriving (Eq, Ord, Show, Generic)
} deriving (Eq, Ord, Show, Generic)
instance Hashable NixString
-- | Combine two NixStrings using mappend
-- | Combine two NixStrings using mappend
principledMempty :: NixString
principledMempty = NixString "" mempty
-- | Combine two NixStrings using mappend
principledStringMappend :: NixString -> NixString -> NixString
principledStringMappend (NixString s1 t1) (NixString s2 t2) = NixString (s1 <> s2) (t1 <> t2)
-- | Combine two NixStrings using mappend
hackyStringMappend :: NixString -> NixString -> NixString
hackyStringMappend (NixString s1 t1) (NixString s2 t2) = NixString (s1 <> s2) (t1 <> t2)
-- | Combine NixStrings using mconcat
-- | Combine NixStrings with a separator
principledIntercalateNixString :: NixString -> [NixString] -> NixString
principledIntercalateNixString _ [] = principledMempty
principledIntercalateNixString _ [ns] = ns
principledIntercalateNixString sep nss = NixString contents ctx
where
contents = Text.intercalate (nsContents sep) (map nsContents nss)
ctx = S.unions (nsContext sep : map nsContext nss)
-- | Combine NixStrings using mconcat
hackyStringMConcat :: [NixString] -> NixString
hackyStringMConcat = foldr hackyStringMappend (NixString mempty mempty)
hackyStringMConcat = foldr hackyStringMappend (NixString mempty mempty)
-- | Empty string with empty context.
principledStringMempty :: NixString
principledStringMempty = NixString mempty mempty
-- | Combine NixStrings using mconcat
principledStringMConcat :: [NixString] -> NixString
principledStringMConcat = foldr principledStringMappend (NixString mempty mempty)
--instance Semigroup NixString where
--NixString s1 t1 <> NixString s2 t2 = NixString (s1 <> s2) (t1 <> t2)
@ -57,10 +92,19 @@ hackyStringMConcat = foldr hackyStringMappend (NixString mempty mempty)
-- mempty = NixString mempty mempty
-- mappend = (<>)
-- | Extract the string contents from a NixString that has no context
hackyStringIgnoreContextMaybe :: NixString -> Maybe Text
hackyStringIgnoreContextMaybe (NixString s c) | null c = Just s
| otherwise = Nothing
-- | Extract the string contents from a NixString that has no context
hackyGetStringNoContext :: NixString -> Maybe Text
hackyGetStringNoContext (NixString s c) | null c = Just s
| otherwise = Nothing
-- | Extract the string contents from a NixString that has no context
principledGetStringNoContext :: NixString -> Maybe Text
principledGetStringNoContext (NixString s c) | null c = Just s
| otherwise = Nothing
-- | Extract the string contents from a NixString even if the NixString has an associated context
principledStringIgnoreContext :: NixString -> Text
principledStringIgnoreContext (NixString s _) = s
-- | Extract the string contents from a NixString even if the NixString has an associated context
hackyStringIgnoreContext :: NixString -> Text
@ -72,10 +116,16 @@ stringHasContext (NixString _ c) = not (null c)
-- | Constructs a NixString without a context
hackyMakeNixStringWithoutContext :: Text -> NixString
hackyMakeNixStringWithoutContext = flip NixString mempty
hackyMakeNixStringWithoutContext = flip NixString mempty
-- | Constructs a NixString without a context
principledMakeNixStringWithoutContext :: Text -> NixString
principledMakeNixStringWithoutContext = flip NixString mempty
-- | Modify the string part of the NixString -- ignores the context
hackyModifyNixContents :: (Text -> Text) -> NixString -> NixString
hackyModifyNixContents f (NixString s c) = NixString (f s) c
principledModifyNixContents :: (Text -> Text) -> NixString -> NixString
principledModifyNixContents f (NixString s c) = NixString (f s) c
-- | Create a NixString using a singleton context
principledMakeNixStringWithSingletonContext :: Text -> StringContext -> NixString
principledMakeNixStringWithSingletonContext s c = NixString s (S.singleton c)

45
src/Nix/Thunk.hs
View file

@ -1,5 +1,6 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
@ -19,8 +20,15 @@ module Nix.Thunk where
import Control.Exception hiding (catch)
import Control.Monad.Catch
import Control.Monad.Ref
import Data.GADT.Compare
import Data.IORef
import Data.Maybe
import Data.STRef
import Data.Typeable
import Unsafe.Coerce
#if ENABLE_TRACING
import Data.IORef
import System.IO.Unsafe
@ -34,13 +42,36 @@ counter = unsafePerformIO $ newIORef 0
data Deferred m v = Deferred (m v) | Computed v
deriving (Functor, Foldable, Traversable)
class Monad m => MonadVar m where
type Var m :: * -> *
eqVar :: Var m a -> Var m a -> Bool
newVar :: a -> m (Var m a)
readVar :: Var m a -> m a
writeVar :: Var m a -> a -> m ()
atomicModifyVar :: Var m a -> (a -> (a, b)) -> m b
type Var m = Ref m
--TODO: Eliminate the old MonadVar shims
type MonadVar m = (MonadAtomicRef m, GEq (Ref m))
eqVar :: forall m a. GEq (Ref m) => Ref m a -> Ref m a -> Bool
eqVar a b = isJust $ geq a b
newVar :: MonadRef m => a -> m (Ref m a)
newVar = newRef
readVar :: MonadRef m => Ref m a -> m a
readVar = readRef
writeVar :: MonadRef m => Ref m a -> a -> m ()
writeVar = writeRef
atomicModifyVar :: MonadAtomicRef m => Ref m a -> (a -> (a, b)) -> m b
atomicModifyVar = atomicModifyRef
--TODO: Upstream GEq instances
instance GEq IORef where
a `geq` b = if a == unsafeCoerce b
then Just $ unsafeCoerce Refl
else Nothing
instance GEq (STRef s) where
a `geq` b = if a == unsafeCoerce b
then Just $ unsafeCoerce Refl
else Nothing
class Monad m => MonadThunk v t m | v -> m, v -> t, t -> m, t -> v where
thunk :: m v -> m t

1
src/Nix/Type/Env.hs
View file

@ -19,7 +19,6 @@ import Nix.Type.Type
import Data.Foldable hiding (toList)
import qualified Data.Map as Map
import Data.Semigroup
-------------------------------------------------------------------------------
-- Typing Environment

26
src/Nix/Type/Infer.hs
View file

@ -9,6 +9,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
@ -28,6 +29,7 @@ import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Logic
import Control.Monad.Reader
import Control.Monad.Ref
import Control.Monad.ST
import Control.Monad.State
import Data.Fix
@ -38,7 +40,6 @@ import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromJust)
import Data.STRef
import Data.Semigroup
import qualified Data.Set as Set
import Data.Text (Text)
import Nix.Atoms
@ -304,14 +305,17 @@ binops u1 = \case
, typeFun [typeFloat, typeInt, typeFloat]
]) ]
instance MonadVar (Infer s) where
type Var (Infer s) = STRef s
eqVar = (==)
liftInfer :: ST s a -> Infer s a
liftInfer = Infer . lift . lift . lift
newVar x = Infer . lift . lift . lift $ newSTRef x
readVar x = Infer . lift . lift . lift $ readSTRef x
writeVar x y = Infer . lift . lift . lift $ writeSTRef x y
atomicModifyVar x f = Infer . lift . lift . lift $ do
instance MonadRef (Infer s) where
type Ref (Infer s) = STRef s
newRef x = liftInfer $ newSTRef x
readRef x = liftInfer $ readSTRef x
writeRef x y = liftInfer $ writeSTRef x y
instance MonadAtomicRef (Infer s) where
atomicModifyRef x f = liftInfer $ do
res <- snd . f <$> readSTRef x
_ <- modifySTRef x (fst . f)
return res
@ -612,3 +616,9 @@ solve cs = solve' (nextSolvable cs)
solve' (ExpInstConst t s, cs) = do
s' <- lift $ instantiate s
solve (EqConst t s' : cs)
instance Scoped (JThunk s) (Infer s) where
currentScopes = currentScopesReader
clearScopes = clearScopesReader @(Infer s) @(JThunk s)
pushScopes = pushScopesReader
lookupVar = lookupVarReader

2
src/Nix/Utils.hs
View file

@ -27,7 +27,7 @@ import Lens.Family2.Stock (_1, _2)
#if ENABLE_TRACING
import Debug.Trace as X
#else
import Prelude as X
import Prelude as X hiding (putStr, putStrLn, print)
trace :: String -> a -> a
trace = const id
traceM :: Monad m => String -> m ()

14
src/Nix/Value.hs
View file

@ -249,15 +249,19 @@ isDerivation :: MonadThunk (NValue m) (NThunk m) m
=> AttrSet (NThunk m) -> m Bool
isDerivation m = case M.lookup "type" m of
Nothing -> pure False
Just t -> force t $ valueEq (nvStr (hackyMakeNixStringWithoutContext "derivation"))
Just t -> force t $ \case
-- We should probably really make sure the context is empty here but the
-- C++ implementation ignores it.
NVStr s -> pure $ principledStringIgnoreContext s == "derivation"
_ -> pure False
valueEq :: MonadThunk (NValue m) (NThunk m) m
=> NValue m -> NValue m -> m Bool
valueEq l r = case (l, r) of
valueEq = curry $ \case
(NVConstant lc, NVConstant rc) -> pure $ lc == rc
(NVStr ls, NVStr rs) -> pure (ls == rs)
(NVStr ns, NVConstant NNull) -> pure (hackyStringIgnoreContextMaybe ns == Just "")
(NVConstant NNull, NVStr ns) -> pure (Just "" == hackyStringIgnoreContextMaybe ns)
(NVStr ls, NVStr rs) -> pure $ principledStringIgnoreContext ls == principledStringIgnoreContext rs
(NVStr ns, NVConstant NNull) -> pure (hackyGetStringNoContext ns == Just "")
(NVConstant NNull, NVStr ns) -> pure (Just "" == hackyGetStringNoContext ns)
(NVList ls, NVList rs) -> alignEqM thunkEq ls rs
(NVSet lm _, NVSet rm _) -> do
let compareAttrs = alignEqM thunkEq lm rm

12
tests/EvalTests.hs
View file

@ -352,6 +352,18 @@ case_mapattrs_builtin =
})
|]
case_empty_string_equal_null_is_false =
constantEqualText "false" "\"\" == null"
case_null_equal_empty_string_is_false =
constantEqualText "false" "null == \"\""
case_empty_string_not_equal_null_is_true =
constantEqualText "true" "\"\" != null"
case_null_equal_not_empty_string_is_true =
constantEqualText "true" "null != \"\""
-----------------------
tests :: TestTree

1
tests/ParserTests.hs
View file

@ -10,7 +10,6 @@ module ParserTests (tests) where
import Data.Fix
import Data.List.NonEmpty (NonEmpty(..))
import Data.Semigroup
import Data.String.Interpolate.IsString
import Data.Text (Text, unpack)
import Data.Text.Prettyprint.Doc