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

Merge pull request #403 from haskell-nix/abstract-scopes

Browse source 
Abstract out IO and some scoping stuff
This commit is contained in:
Ryan Trinkle 2018-11-18 15:31:05 -05:00 committed by GitHub
parent b47bd010e2 df8e58d4e5
commit 07dd6ac3f3
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
21 changed files with 584 additions and 257 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
default.nix
View file

@ -89,6 +89,10 @@ drv = haskellPackages.developPackage {
configureFlags =
pkgs.stdenv.lib.optional doTracing "--flags=tracing"
++ pkgs.stdenv.lib.optional doStrict "--ghc-options=-Werror";
passthru = {
nixpkgs = pkgs;
};
});
inherit returnShellEnv;

5
hnix.cabal
View file

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 7e613ce82a3337411d625301abd33a6d7f1c400edadbd602287027f2af1e4fdf
-- hash: d6ddd115698a11c74ef8507fa6e00df1f8888a254bed435e6a75b154a4906cb3
cabal-version: >= 1.10
name: hnix
@ -494,6 +494,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
, mtl
, optparse-applicative
, process
, ref-tf
, regex-tdfa
, regex-tdfa-text
, scientific
@ -639,6 +641,7 @@ test-suite hnix-tests
, containers
, data-fix
, deepseq >=1.4.2 && <1.5
, dependent-sum
, directory
, exceptions
, filepath

29
hydra.json Normal file
View file

@ -0,0 +1,29 @@
{
"enabled": 1,
"hidden": true,
"description": "Jobsets",
"nixexprinput": "src",
"nixexprpath": "jobsets.nix",
"checkinterval": 300,
"schedulingshares": 100,
"enableemail": false,
"emailoverride": "",
"keepnr": 10,
"inputs": {
"src": {
"type": "git",
"value": "https://github.com/haskell-nix/hnix.git master 1",
"emailresponsible": false
},
"nixpkgs": {
"type": "git",
"value": "https://github.com/NixOS/nixpkgs-channels nixos-unstable",
"emailresponsible": false
},
"prs": {
"type": "githubpulls",
"value": "haskell-nix hnix",
"emailresponsible": false
}
}
}

66
jobsets.nix Normal file
View file

@ -0,0 +1,66 @@
{ prs }:
let
self = import ./. {};
pkgs = self.nixpkgs;
mkFetchGithub = value: {
inherit value;
type = "git";
emailresponsible = false;
};
in
with pkgs.lib;
let
defaults = jobs: {
inherit (jobs) description;
enabled = 1;
hidden = false;
keepnr = 10;
schedulingshares = 100;
checkinterval = 120;
enableemail = false;
emailoverride = "";
nixexprinput = "hnix";
nixexprpath = "release.nix";
inputs = jobs.inputs // {
nixpkgs = {
type = "git";
value = "https://github.com/NixOS/nixpkgs-channels nixos-unstable";
emailresponsible = false;
};
};
};
branchJobset = branch: defaults {
description = "hnix-${branch}";
inputs = {
hnix = {
value = "https://github.com/haskell-nix/hnix ${branch}";
type = "git";
emailresponsible = false;
};
};
};
makePr = num: info: {
name = "hnix-pr-${num}";
value = defaults {
description = "#${num}: ${info.title}";
inputs = {
hnix = {
#NOTE: This should really use "pull/${num}/merge"; however, GitHub's
#status checks only operate on PR heads. This creates a race
#condition, which can currently only be solved by requiring PRs to be
#up to date before they're merged. See
#https://github.com/isaacs/github/issues/1002
value = "https://github.com/haskell-nix/hnix pull/${num}/head 1";
type = "git";
emailresponsible = false;
};
};
};
};
processedPrs = mapAttrs' makePr (builtins.fromJSON (builtins.readFile prs));
jobsetsAttrs = processedPrs //
genAttrs ["master" "pending"] branchJobset;
in {
jobsets = pkgs.writeText "spec.json" (builtins.toJSON jobsetsAttrs);
}

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

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

20
release.nix Normal file
View file

@ -0,0 +1,20 @@
{}:
let matrix = [
{ compiler = "ghc843"; doStrict = false; doTracing = false; }
{ compiler = "ghc843"; doStrict = false; doTracing = true; }
# Broken
# { compiler = "ghc802"; doStrict = false; doTracing = false; }
# { compiler = "ghc802"; doStrict = false; doTracing = true; }
# Deprecated
# { compiler = "ghc822"; doStrict = true; doTracing = false; }
# { compiler = "ghc822"; doStrict = true; doTracing = true; }
# Broken
# { compiler = "ghcjs"; doStrict = false; doTracing = false; }
];
boolToString = x: if x then "true" else "false";
nameForConfig = {compiler, doStrict, doTracing}: builtins.concatStringsSep "-"
[ compiler (boolToString doStrict) (boolToString doTracing) ];
in builtins.listToAttrs (map (args: { name = nameForConfig args; value = import ./. args; }) matrix)

14
src/Nix/Builtins.hs
View file

@ -90,7 +90,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 +110,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 +296,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
@ -821,7 +821,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"
@ -964,7 +964,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
@ -1037,7 +1037,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

6
src/Nix/Convert.hs
View file

@ -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

36
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))
@ -324,10 +324,10 @@ assembleString = \case
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)

223
src/Nix/Exec.hs
View file

@ -26,21 +26,22 @@
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
@ -49,10 +50,6 @@ import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as Text
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
@ -73,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)
import Text.PrettyPrint.ANSI.Leijen (text)
import qualified Text.PrettyPrint.ANSI.Leijen as P
#ifdef MIN_VERSION_pretty_show
@ -94,7 +84,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)
@ -504,17 +494,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 ->
@ -530,32 +522,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,"
@ -563,21 +556,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
@ -585,7 +571,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 $
@ -595,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)
@ -628,75 +602,10 @@ instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
where
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)
@ -713,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
@ -732,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
@ -769,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
@ -818,12 +727,12 @@ addTracing k v = do
else prettyNix (Fix (Fix (NSym "?") <$ x))
msg x = text ("eval: " ++ replicate depth ' ') <> x
loc <- renderLocation span (msg rendered <> text " ...\n")
liftIO $ putStr $ show loc
putStr $ show loc
res <- k v'
liftIO $ print $ msg rendered <> text " ...done"
print $ msg rendered <> text " ...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)
@ -834,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)
@ -873,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

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

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)
@ -62,11 +63,12 @@ import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.Text (Text)
import Data.Text hiding (map, foldr1, concat, concatMap, zipWith)
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 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 . text . parseErrorPretty' txt) Success
$ parse p path txt

13
src/Nix/Pretty.hs
View file

@ -1,4 +1,5 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
@ -243,15 +244,12 @@ fixate g = Fix . go
go (Pure a) = g a
go (Free f) = fmap (Fix . go) f
prettyNValueNF :: Functor m => NValueNF m -> Doc
prettyNValueNF = prettyNix . valueToExpr
valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = transport go . check
where
check :: NValueNF m -> Fix (NValueF m)
check = fixate $ const $ NVStrF $ principledMakeNixStringWithoutContext "<CYCLE>"
valueToExpr :: Functor m => NValueNF m -> NExpr
valueToExpr = transport go . check
go (NVConstantF a) = NConstant a
go (NVStrF ns) = NStr (DoubleQuoted [Plain (hackyStringIgnoreContext ns)])
go (NVListF l) = NList l
@ -262,6 +260,9 @@ prettyNValueNF = prettyNix . valueToExpr
go (NVPathF p) = NLiteralPath p
go (NVBuiltinF name _) = NSym $ Text.pack $ "builtins." ++ name
prettyNValueNF :: Functor m => NValueNF m -> Doc
prettyNValueNF = prettyNix . valueToExpr
printNix :: Functor m => NValueNF m -> String
printNix = iter phi . check
where
@ -322,4 +323,4 @@ dethunk = \case
Computed v -> removeEffectsM (_baseValue v)
_ -> pure $ Free $ NVStrF $ principledMakeNixStringWithoutContext "<thunk>"
_ <- atomicModifyVar active (False,)
return res
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.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(..))
import Text.PrettyPrint.ANSI.Leijen
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 -> ParseError t Void
posAndMsg beg msg =

39
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 #-}
@ -49,28 +52,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 +90,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

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

25
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
@ -304,14 +306,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 +617,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 ()