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

Move production of a reduced test case to --reduce, improve --trace

This commit is contained in:
John Wiegley 2018-04-20 22:36:40 -07:00
parent 47e8829a28
commit 86b09103d6
19 changed files with 733 additions and 718 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
default.nix
View File

@ -30,7 +30,7 @@ in haskellPackages.developPackage {
[
pkgs.nix
haskellPackages.hpack
haskellPackages.cabal-install
# haskellPackages.cabal-install
];
enableLibraryProfiling = doProfiling;

4
hnix.cabal
View File

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: 2b1afd3f4604aa1943b1ff294fdcebd3f08c880354229c9005b9d44c0c40794d
-- hash: a049f208472f58a7ad617291f7dde633bcb0e3bc6e593eac9fc8a7e69d350f01
name: hnix
version: 0.5.0
@ -38,8 +38,8 @@ library
Nix.Cache
Nix.Context
Nix.Convert
Nix.Core
Nix.Effects
Nix.Entry
Nix.Eval
Nix.Exec
Nix.Expr

42
main/Main.hs
View File

@ -9,15 +9,19 @@ module Main where
import qualified Control.DeepSeq as Deep
import qualified Control.Exception as Exc
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.ST
-- import Control.Monad.ST
import qualified Data.Aeson.Encoding as A
import qualified Data.Aeson.Text as A
import Data.Functor.Compose
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy.Encoding as TL
import qualified Data.Text.Lazy.IO as TL
import Nix
import Nix.Convert
import qualified Nix.Core as Core
-- import Nix.Lint
import Nix.Utils
import Options.Applicative hiding (ParserResult(..))
import qualified Repl
@ -61,9 +65,9 @@ main = do
NixEvalException msg -> errorWithoutStackTrace msg
process opts mpath expr = do
when (check opts) $
putStrLn $ runST $
runLintM opts . renderSymbolic =<< lint opts expr
-- when (check opts) $
-- putStrLn $ runST $
-- runLintM opts . renderSymbolic =<< lint opts expr
let printer :: (MonadNix e m, MonadIO m) => NValue m -> m ()
printer | xml opts =
@ -81,14 +85,21 @@ main = do
if | evaluate opts, tracing opts ->
runLazyM opts $ evaluateExpression mpath
Nix.tracingEvalLoc printer expr
Nix.nixTracingEvalExprLoc printer expr
| evaluate opts, Just path <- reduce opts ->
runLazyM opts $ evaluateExpression mpath
(\mp x -> handleReduced path
=<< Nix.reducingEvalExpr
(Core.eval . annotated . getCompose) mp x)
printer expr
| evaluate opts, not (null (arg opts) && null (argstr opts)) ->
runLazyM opts $ evaluateExpression mpath
Nix.evalLoc printer expr
Nix.nixEvalExprLoc printer expr
| evaluate opts -> runLazyM opts $
processResult printer =<< Nix.evalLoc mpath expr
processResult printer =<< Nix.nixEvalExprLoc mpath expr
| xml opts ->
error "Rendering expression trees to XML is not yet implemented"
@ -98,9 +109,8 @@ main = do
| verbose opts >= Debug -> print $ stripAnnotation expr
| cache opts, Just path <- mpath -> do
let file = addExtension (dropExtension path) "nixc"
writeCache file expr
| cache opts, Just path <- mpath ->
writeCache (addExtension (dropExtension path) "nixc") expr
| parseOnly opts -> void $ Exc.evaluate $ Deep.force expr
@ -111,3 +121,15 @@ main = do
. stripAnnotation $ expr
when (repl opts) $ Repl.shell (pure ())
handleReduced :: (MonadThrow m, MonadIO m)
=> FilePath
-> (NExprLoc, Either SomeException (NValue m))
-> m (NValue m)
handleReduced path (expr', eres) = do
liftIO $ do
putStrLn $ "Wrote winnowed expression tree to " ++ path
writeFile path $ show $ prettyNix (stripAnnotation expr')
case eres of
Left err -> throwM err
Right v -> return v

13
main/Repl.hs
View File

@ -20,6 +20,7 @@ module Repl where
import Nix
import Nix.Eval
import Nix.Core
import Nix.Scope
import qualified Nix.Type.Env as Env
import Nix.Type.Infer
@ -88,14 +89,10 @@ exec update source = do
-- If a value is entered, print it.
val <- liftIO $ runLazyM defaultOptions $
evalTopLevelExprGen
-- jww (2018-04-12): Once the user is able to establish definitions
-- in the repl, they should be passed here.
(pushScope @(NThunk (Lazy IO)) M.empty
. framedEvalExpr
(Nix.Eval.eval @_ @(NValue (Lazy IO))
@(NThunk (Lazy IO)) @(Lazy IO)))
Nothing expr
-- jww (2018-04-12): Once the user is able to establish definitions
-- in the repl, they should be passed here.
pushScope @(NThunk (Lazy IO)) M.empty $
nixEvalExprLoc Nothing expr
liftIO $ print val
cmd :: String -> Repl ()

172
src/Nix.hs
View File

@ -1,15 +1,159 @@
module Nix (module X) where
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
import Nix.Cache as X
import Nix.Entry as X
import Nix.Exec as X
import Nix.Expr as X
import Nix.Lint as X
import Nix.Normal as X
import Nix.Options as X
import Nix.Parser as X
import Nix.Pretty as X
import Nix.Stack as X hiding (readFile)
import Nix.Thunk as X
import Nix.Value as X
import Nix.XML as X
module Nix (module Nix.Cache,
module Nix.Exec,
module Nix.Expr,
module Nix.Normal,
module Nix.Options,
module Nix.Parser,
module Nix.Pretty,
module Nix.Reduce,
module Nix.Stack,
module Nix.Thunk,
module Nix.Trace,
module Nix.Value,
module Nix.XML,
withNixContext,
nixEvalExpr, nixEvalExprLoc, nixTracingEvalExprLoc,
evaluateExpression, processResult) where
import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Reader
-- import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader (ReaderT(..))
import Data.Fix
import Data.Functor.Compose
import qualified Data.HashMap.Lazy as M
-- import Data.Monoid
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import Nix.Builtins
import Nix.Cache
import qualified Nix.Core as Core
import Nix.Eval
import Nix.Exec
import Nix.Expr
-- import Nix.Expr.Shorthands
-- import Nix.Expr.Types
-- import Nix.Expr.Types.Annotated
import Nix.Normal
import Nix.Options
import Nix.Parser
import Nix.Parser.Library (Result(..))
import Nix.Pretty
import Nix.Reduce
import Nix.Scope
import Nix.Stack hiding (readFile)
import Nix.Thunk
import Nix.Trace
import Nix.Utils
import Nix.Value
import Nix.XML
-- | Evaluate a nix expression in the default context
withNixContext :: forall e m r. MonadNix e m => Maybe FilePath -> m r -> m r
withNixContext mpath action = do
base <- baseEnv
opts :: Options <- asks (view hasLens)
let i = value @(NValue m) @(NThunk m) @m $ NVList $
map (value @(NValue m) @(NThunk m) @m
. flip NVStr mempty . Text.pack) (include opts)
pushScope (M.singleton "__includes" i) $
pushScopes base $ case mpath of
Nothing -> action
Just path -> do
traceM $ "Setting __cur_file = " ++ show path
let ref = value @(NValue m) @(NThunk m) @m $ NVPath path
pushScope (M.singleton "__cur_file" ref) action
-- | This is the entry point for all evaluations, whatever the expression tree
-- type. It sets up the common Nix environment and applies the
-- transformations, allowing them to be easily composed.
nixEval :: (MonadNix e m, Functor f)
=> Maybe FilePath -> Transform f (m a) -> Alg f (m a) -> Fix f -> m a
nixEval mpath xform alg = withNixContext mpath . adi alg xform
-- | Evaluate a nix expression in the default context
nixEvalExpr :: forall e m. MonadNix e m
=> Maybe FilePath -> NExpr -> m (NValue m)
nixEvalExpr mpath = nixEval mpath id Core.eval
-- | Evaluate a nix expression in the default context
nixEvalExprLoc :: MonadNix e m
=> Maybe FilePath -> NExprLoc -> m (NValue m)
nixEvalExprLoc mpath =
nixEval mpath addStackFrames (Core.eval . annotated . getCompose)
-- | Evaluate a nix expression with tracing in the default context
nixTracingEvalExprLoc :: forall e m. (MonadNix e m, MonadIO m, Alternative m)
=> Maybe FilePath -> NExprLoc -> m (NValue m)
nixTracingEvalExprLoc mpath
= withNixContext mpath
. join . (`runReaderT` (0 :: Int))
. adi (addTracing (Core.eval . annotated . getCompose))
(raise addStackFrames)
where
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
evaluateExpression
:: MonadNix e m
=> Maybe FilePath
-> (Maybe FilePath -> NExprLoc -> m (NValue m))
-> (NValue m -> m a)
-> NExprLoc
-> m a
evaluateExpression mpath evaluator handler expr = do
opts :: Options <- asks (view hasLens)
args <- traverse (traverse eval') $
map (second parseArg) (arg opts) ++
map (second mkStr) (argstr opts)
compute evaluator expr (argmap args) handler
where
parseArg s = case parseNixText s of
Success x -> x
Failure err -> errorWithoutStackTrace (show err)
eval' = (normalForm =<<) . nixEvalExpr mpath
argmap args = embed $ Fix $ NVSet (M.fromList args) mempty
compute ev x args p = do
f <- ev mpath x
processResult p =<< case f of
NVClosure _ g -> g args
_ -> pure f
processResult :: forall e m a. MonadNix e m
=> (NValue m -> m a) -> NValue m -> m a
processResult h val = do
opts :: Options <- asks (view hasLens)
case attr opts of
Nothing -> h val
Just (Text.splitOn "." -> keys) -> go keys val
where
go :: [Text.Text] -> NValue m -> m a
go [] v = h v
go ((Text.decimal -> Right (n,"")):ks) v = case v of
NVList xs -> case ks of
[] -> force @(NValue m) @(NThunk m) (xs !! n) h
_ -> force (xs !! n) (go ks)
_ -> errorWithoutStackTrace $
"Expected a list for selector '" ++ show n
++ "', but got: " ++ show v
go (k:ks) v = case v of
NVSet xs _ -> case M.lookup k xs of
Nothing ->
errorWithoutStackTrace $
"Set does not contain key '"
++ Text.unpack k ++ "'"
Just v' -> case ks of
[] -> force v' h
_ -> force v' (go ks)
_ -> errorWithoutStackTrace $
"Expected a set for selector '" ++ Text.unpack k
++ "', but got: " ++ show v

5
src/Nix/Builtins.hs
View File

@ -38,6 +38,7 @@ import Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Lazy as LBS
import Data.Char (isDigit)
import Data.Coerce
import Data.Fix
import Data.Foldable (foldrM)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
@ -54,8 +55,8 @@ import Data.Traversable (mapM)
import Language.Haskell.TH.Syntax (addDependentFile, runIO)
import Nix.Atoms
import Nix.Convert
import qualified Nix.Core as Core
import Nix.Effects
import Nix.Eval
import Nix.Exec
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
@ -124,7 +125,7 @@ builtinsList = sequence [
let f = "data/nix/corepkgs/derivation.nix"
addDependentFile f
Success expr <- runIO $ parseNixFile f
[| evalExpr expr |]
[| cata Core.eval expr |]
)
, add Normal "getEnv" getEnv_

412
src/Nix/Core.hs Normal file
View File

@ -0,0 +1,412 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Nix.Core where
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Fix
import Control.Monad.State
import Data.Align.Key
import Data.Fix
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.List (intercalate, partition, foldl')
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe, catMaybes)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.These
import Data.Traversable (for)
import Data.Void
import Nix.Atoms
import Nix.Convert
import Nix.Expr
import Nix.Pretty
import Nix.Scope
import Nix.Stack
import Nix.Strings (runAntiquoted)
import Nix.Thunk
import Nix.Utils
class (Show v, Monad m) => MonadEval v m | v -> m where
freeVariable :: Text -> m v
evalCurPos :: m v
evalConstant :: NAtom -> m v
evalString :: Text -> DList Text -> m v
evalLiteralPath :: FilePath -> m v
evalEnvPath :: FilePath -> m v
evalUnary :: NUnaryOp -> v -> m v
evalBinary :: NBinaryOp -> v -> m v -> m v
-- ^ The second argument is an action because operators such as boolean &&
-- and || may not evaluate the second argument.
evalWith :: m v -> m v -> m v
evalIf :: v -> m v -> m v -> m v
evalAssert :: v -> m v -> m v
evalApp :: v -> m v -> m v
evalAbs :: Params Void -> (m v -> m v) -> m v
evalError :: String -> m a
type MonadNixEval e v t m =
(MonadEval v m, Scoped e t m, MonadThunk v t m, MonadFix m,
Framed e m, MonadFile m, MonadVar m,
ToValue Bool m v, ToValue [t] m v,
FromValue (Text, DList Text) m v,
ToValue (AttrSet t) m v, FromValue (AttrSet t) m v,
ToValue (AttrSet t, AttrSet SourcePos) m v,
FromValue (AttrSet t, AttrSet SourcePos) m v)
wrapExpr :: NExprF (m v) -> NExpr
wrapExpr x = Fix (Fix (NSym "<?>") <$ x)
exprFContext :: (Framed e m) => NExprF (m v) -> m r -> m r
exprFContext e = withStringContext $
"While forcing thunk for: " ++ show (prettyNix (wrapExpr e)) ++ "\n"
eval :: forall e v t m. MonadNixEval e v t m => NExprF (m v) -> m v
eval (NSym "__curPos") = evalCurPos
eval (NSym var) = lookupVar var >>= \case
Nothing -> freeVariable var
Just v -> force v pure
eval (NConstant x) = evalConstant x
eval (NStr str) = uncurry evalString =<< assembleString str
eval (NLiteralPath p) = evalLiteralPath p
eval (NEnvPath p) = evalEnvPath p
eval (NUnary op arg) = evalUnary op =<< arg
eval (NBinary NApp fun arg) = do
scope <- currentScopes @_ @t
evalApp ?? withScopes scope arg =<< fun
eval (NBinary op larg rarg) = larg >>= \lval -> evalBinary op lval rarg
eval (NSelect aset attr alt) = do
traceM "NSelect"
mres <- evalSelect aset attr
traceM "NSelect..2"
case mres of
Right v -> pure v
Left (s, ks) -> fromMaybe err alt
where
err = evalError @v $ "Could not look up attribute "
++ intercalate "." (map Text.unpack (NE.toList ks))
++ " in " ++ show @v s
eval (NHasAttr aset attr) =
toValue . either (const False) (const True) =<< evalSelect aset attr
eval e@(NList l) = do
scope <- currentScopes
toValue =<< for l (thunk . exprFContext e . withScopes @t scope)
eval e@(NSet binds) = do
traceM "NSet..1"
(s, p) <- evalBinds e True False binds
traceM $ "NSet..2: s = " ++ show (void s)
traceM $ "NSet..2: p = " ++ show (void p)
toValue (s, p)
eval e@(NRecSet binds) = do
traceM "NRecSet..1"
(s, p) <- evalBinds e True True (desugarBinds (eval . NRecSet) binds)
traceM $ "NRecSet..2: s = " ++ show (void s)
traceM $ "NRecSet..2: p = " ++ show (void p)
toValue (s, p)
eval e@(NLet binds body) = do
traceM "Let..1"
(s, _) <- evalBinds e True True binds
traceM $ "Let..2: s = " ++ show (void s)
pushScope s body
eval (NIf cond t f) = cond >>= \v -> evalIf v t f
eval (NWith scope body) = evalWith scope body
eval (NAssert cond body) = cond >>= \v -> evalAssert v body
eval e@(NAbs params body) = do
-- It is the environment at the definition site, not the call site, that
-- 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 (clearDefaults params) $ \arg ->
-- jww (2018-04-17): We need to use the bound library here, so that
-- the body is only evaluated once.
withScopes @t scope $ do
args <- buildArgument e params arg
pushScope args body
where
clearDefaults :: Params r -> Params Void
clearDefaults (Param name) = Param name
clearDefaults (ParamSet xs b mv) = ParamSet (map (Nothing <$) xs) b mv
-- | 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 scope 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.
cur <- currentScopes @_ @t
s <- thunk $ exprFContext (NWith scope body)
$ withScopes cur scope
pushWeakScope ?? body $ force s $ fromValue @(AttrSet t)
attrSetAlter :: forall e v t m. MonadNixEval e v t m
=> [Text]
-> AttrSet (m v)
-> m v
-> m (AttrSet (m v))
attrSetAlter [] _ _ = evalError @v "invalid selector with no components"
attrSetAlter (p:ps) m val = case M.lookup p m of
Nothing
| null ps -> go
| otherwise -> recurse M.empty
Just x
| null ps -> go
| otherwise ->
x >>= fromValue >>= \s -> recurse (force ?? pure <$> s)
where
go = return $ M.insert p val m
-- jww (2018-04-13): Need to record positions for attr paths as well
recurse s = attrSetAlter ps s val <&> \m' ->
M.insert p (toValue =<< fmap (value @_ @_ @m) <$> sequence m') m
desugarBinds :: forall r. ([Binding r] -> r) -> [Binding r] -> [Binding r]
desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
where
collect :: Binding r
-> State (HashMap VarName (Maybe SourcePos, [Binding r]))
(Either VarName (Binding r))
collect (NamedVar (StaticKey x p:|y:ys) val) = do
m <- get
let v = case M.lookup x m of
Nothing -> (p, [NamedVar (y:|ys) val])
Just (p, v) -> (p, NamedVar (y:|ys) val : v)
put $ M.insert x v m
pure $ Left x
collect x = pure $ Right x
go :: Either VarName (Binding r)
-> State (HashMap VarName (Maybe SourcePos, [Binding r]))
(Binding r)
go (Right x) = pure x
go (Left x) = do
Just (p, v) <- gets $ M.lookup x
pure $ NamedVar (StaticKey x p :| []) (embed v)
evalBinds :: forall e v t m. MonadNixEval e v t m
=> NExprF (m v)
-> Bool
-> Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
evalBinds e allowDynamic recursive binds = do
scope <- currentScopes @_ @t
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where
moveOverridesLast = (\(x, y) -> y ++ x) .
partition (\case NamedVar (StaticKey "__overrides" _ :| []) _ -> True
_ -> False)
go :: Scopes m t -> Binding (m v) -> m [([Text], Maybe SourcePos, m v)]
go _ (NamedVar (StaticKey "__overrides" _ :| []) finalValue) =
finalValue >>= fromValue >>= \(o', p') ->
return $ map (\(k, v) -> ([k], M.lookup k p', force v pure))
(M.toList o')
go _ (NamedVar pathExpr finalValue) = do
let go :: NAttrPath (m v) -> m ([Text], Maybe SourcePos, m v)
go = \case
h :| t -> evalSetterKeyName allowDynamic h >>= \case
(Nothing, _) ->
pure ([], Nothing,
toValue (mempty :: AttrSet t))
(Just k, pos) -> case t of
[] -> pure ([k], pos, finalValue)
x:xs -> do
(restOfPath, _, v) <- go (x:|xs)
pure (k : restOfPath, pos, v)
go pathExpr <&> \case
-- When there are no path segments, e.g. `${null} = 5;`, we don't
-- bind anything
([], _, _) -> []
result -> [result]
go scope (Inherit ms names) = fmap catMaybes $ forM names $ \name ->
evalSetterKeyName allowDynamic name >>= \case
(Nothing, _) -> return Nothing
(Just key, pos) -> return $ Just ([key], pos, do
mv <- case ms of
Nothing -> withScopes scope $ lookupVar key
Just s -> s >>= fromValue @(AttrSet t) >>= \s ->
clearScopes @t $ pushScope s $ lookupVar key
case mv of
Nothing -> evalError @v $ "Inheriting unknown attribute: "
++ show (void name)
Just v -> force v pure)
buildResult :: Scopes m t
-> [([Text], Maybe SourcePos, m v)]
-> m (AttrSet t, AttrSet SourcePos)
buildResult scope bindings = do
s <- foldM insert M.empty bindings
res <- if recursive
then loebM (encapsulate <$> s)
else traverse (thunk . exprFContext e . withScopes scope) s
return (res, foldl' go M.empty bindings)
where
-- jww (2018-04-13): Need to record positions for attr paths as well
go m ([k], Just pos, _) = M.insert k pos m
go m _ = m
encapsulate f attrs =
thunk . exprFContext e
. withScopes scope
. pushScope attrs $ f
insert m (path, _, value) = attrSetAlter path m value
evalSelect :: forall e v t m. MonadNixEval e v t m
=> m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) v)
evalSelect aset attr = do
traceM "evalSelect"
s <- aset
traceM "evalSelect..2"
path <- evalSelector True attr
traceM $ "evalSelect..3: " ++ show path
res <- extract s path
traceM "evalSelect..4"
return res
where
extract x path@(k:|ks) = fromValueMay x >>= \case
Just (s :: AttrSet t, p :: AttrSet SourcePos) ->
case M.lookup k s of
Just v -> do
traceM $ "Forcing value at selector " ++ Text.unpack k
force v $ case ks of
[] -> pure . Right
y:ys -> extract ?? (y:|ys)
Nothing ->
Left . (, path) <$> toValue (s, p)
Nothing ->
return $ Left (x, path)
evalSelector :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> Bool -> NAttrPath (m v) -> m (NonEmpty Text)
evalSelector allowDynamic binds =
NE.map fst <$> traverse (evalGetterKeyName allowDynamic) binds
-- | Evaluate a component of an attribute path in a context where we are
-- *retrieving* a value
evalGetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> Bool -> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalGetterKeyName canBeDynamic
| canBeDynamic = evalKeyNameDynamicNotNull
| otherwise = evalKeyNameStatic
evalKeyNameStatic :: forall v m. MonadEval v m
=> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalKeyNameStatic = \case
StaticKey k p -> pure (k, p)
DynamicKey _ ->
evalError @v "dynamic attribute not allowed in this context"
evalKeyNameDynamicNotNull
:: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalKeyNameDynamicNotNull = evalKeyNameDynamicNullable >=> \case
(Nothing, _) ->
evalError @v "value is null while a string was expected"
(Just k, p) -> pure (k, p)
-- | Evaluate a component of an attribute path in a context where we are
-- *binding* a value
evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> Bool -> NKeyName (m v) -> m (Maybe Text, Maybe SourcePos)
evalSetterKeyName canBeDynamic
| canBeDynamic = evalKeyNameDynamicNullable
| otherwise = fmap (first Just) . evalKeyNameStatic
-- | Returns Nothing iff the key value is null
evalKeyNameDynamicNullable
:: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v)
-> m (Maybe Text, Maybe SourcePos)
evalKeyNameDynamicNullable = \case
StaticKey k p -> pure (Just k, p)
DynamicKey k ->
runAntiquoted "\n" (fmap Just . assembleString) (>>= fromValueMay) k
<&> \case Just (t, _) -> (Just t, Nothing)
_ -> (Nothing, Nothing)
assembleString :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NString (m v) -> m (Text, DList Text)
assembleString = \case
Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
where
go = runAntiquoted "\n" (pure . (, mempty)) (>>= fromValue)
fromParts parts = mconcat <$> mapM go parts
buildArgument :: forall e v t m. MonadNixEval e v t m
=> NExprF (m v) -> Params (m v) -> m v -> m (AttrSet t)
buildArgument e params arg = do
scope <- currentScopes @_ @t
case params of
Param name -> M.singleton name
<$> thunk (exprFContext e (withScopes scope arg))
ParamSet s isVariadic m ->
arg >>= fromValue >>= \args -> do
let inject = case m of
Nothing -> id
Just n -> M.insert n $ const $
thunk (exprFContext e (withScopes scope arg))
loebM (inject $ alignWithKey (assemble scope isVariadic)
args (M.fromList s))
where
assemble :: Scopes m t
-> Bool
-> Text
-> These t (Maybe (m v))
-> AttrSet t
-> m t
assemble scope isVariadic k = \case
That Nothing ->
const $ evalError @v $ "Missing value for parameter: " ++ show k
That (Just f) -> \args ->
thunk $ exprFContext e
$ withScopes scope
$ pushScope args f
This x | isVariadic -> const (pure x)
| otherwise ->
const $ evalError @v $ "Unexpected parameter: " ++ show k
These x _ -> const (pure x)

151
src/Nix/Entry.hs
View File

@ -1,151 +0,0 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Nix.Entry where
import Control.Applicative
import Control.Arrow (second)
import Control.Exception
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Fix
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import Nix.Builtins
import Nix.Effects
import qualified Nix.Eval as Eval
import Nix.Expr.Shorthands
import Nix.Expr.Types (NExpr)
import Nix.Expr.Types.Annotated (NExprLoc, stripAnnotation)
import Nix.Normal
import Nix.Options
import Nix.Parser
import Nix.Parser.Library (Result(..))
import Nix.Pretty
import Nix.Scope
import Nix.Stack
import Nix.Thunk
import qualified Nix.Trace as Trace
import Nix.Utils
import Nix.Value
type MonadNix e m =
(Scoped e (NThunk m) m, Framed e m, MonadVar m, MonadFile m,
MonadEffects m, MonadFix m, MonadCatch m)
-- | Evaluate a nix expression in the default context
evalTopLevelExprGen :: forall e m a r. MonadNix e m
=> (a -> m r) -> Maybe FilePath -> a -> m r
evalTopLevelExprGen cont mpath expr = do
base <- baseEnv
opts :: Options <- asks (view hasLens)
let i = value @(NValue m) @(NThunk m) @m $ NVList $
map (value @(NValue m) @(NThunk m) @m
. flip NVStr mempty . Text.pack) (include opts)
pushScope (M.singleton "__includes" i) $
pushScopes base $ case mpath of
Nothing -> cont expr
Just path -> do
traceM $ "Setting __cur_file = " ++ show path
let ref = value @(NValue m) @(NThunk m) @m $ NVPath path
pushScope (M.singleton "__cur_file" ref) $ cont expr
-- | Evaluate a nix expression in the default context
eval :: forall e m. MonadNix e m
=> Maybe FilePath -> NExpr -> m (NValue m)
eval = evalTopLevelExprGen $
Eval.evalExpr @_ @(NValue m) @(NThunk m) @m
-- | Evaluate a nix expression in the default context
evalLoc :: forall e m. MonadNix e m
=> Maybe FilePath -> NExprLoc -> m (NValue m)
evalLoc = evalTopLevelExprGen $
Eval.framedEvalExpr (Eval.eval @_ @(NValue m) @(NThunk m) @m)
tracingEvalLoc
:: forall e m. (MonadNix e m, Alternative m, MonadIO m)
=> Maybe FilePath -> NExprLoc -> m (NValue m)
tracingEvalLoc mpath expr = do
(expr', eres) <- evalTopLevelExprGen id mpath
=<< Trace.tracingEvalExpr @_ @m @SomeException @_ @(NValue m)
(Eval.eval @_ @(NValue m)
@(NThunk m) @m) mpath expr
liftIO $ do
putStrLn "Expression tree before winnowing:"
putStrLn "--------"
print $ prettyNix (stripAnnotation expr)
putStrLn "--------"
putStrLn "Expression tree after winnowing:"
putStrLn "--------"
print $ prettyNix (stripAnnotation expr')
putStrLn "--------"
case eres of
Left err -> throwM err
Right v -> return v
evaluateExpression
:: forall e m a. MonadNix e m
=> Maybe FilePath
-> (Maybe FilePath -> NExprLoc -> m (NValue m))
-> (NValue m -> m a)
-> NExprLoc
-> m a
evaluateExpression mpath evaluator handler expr = do
opts :: Options <- asks (view hasLens)
args <- traverse (traverse eval') $
map (second parseArg) (arg opts) ++
map (second mkStr) (argstr opts)
compute evaluator expr (argmap args) handler
where
parseArg s = case parseNixText s of
Success x -> x
Failure err -> errorWithoutStackTrace (show err)
eval' = (normalForm =<<) . eval mpath
argmap args = embed $ Fix $ NVSet (M.fromList args) mempty
compute ev x args p = do
f <- ev mpath x
processResult p =<< case f of
NVClosure _ g -> g args
_ -> pure f
processResult :: forall e m a. MonadNix e m
=> (NValue m -> m a) -> NValue m -> m a
processResult h val = do
opts :: Options <- asks (view hasLens)
case attr opts of
Nothing -> h val
Just (Text.splitOn "." -> keys) -> go keys val
where
go :: [Text.Text] -> NValue m -> m a
go [] v = h v
go ((Text.decimal -> Right (n,"")):ks) v = case v of
NVList xs -> case ks of
[] -> force @(NValue m) @(NThunk m) (xs !! n) h
_ -> force (xs !! n) (go ks)
_ -> errorWithoutStackTrace $
"Expected a list for selector '" ++ show n
++ "', but got: " ++ show v
go (k:ks) v = case v of
NVSet xs _ -> case M.lookup k xs of
Nothing ->
errorWithoutStackTrace $
"Set does not contain key '"
++ Text.unpack k ++ "'"
Just v' -> case ks of
[] -> force v' h
_ -> force v' (go ks)
_ -> errorWithoutStackTrace $
"Expected a set for selector '" ++ Text.unpack k
++ "', but got: " ++ show v

37
src/Nix/Entry.hs-boot
View File

@ -1,37 +0,0 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Nix.Entry where
import Control.Applicative (Alternative)
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Fix (MonadFix)
import Control.Monad.IO.Class (MonadIO)
import Nix.Effects (MonadEffects)
import Nix.Expr.Types (NExpr)
import Nix.Expr.Types.Annotated (NExprLoc)
import Nix.Scope (Scoped)
import Nix.Stack (Framed, MonadFile)
import Nix.Thunk
import Nix.Value
type MonadNix e m =
(Scoped e (NThunk m) m, Framed e m, MonadVar m, MonadFile m,
MonadEffects m, MonadFix m, MonadCatch m)
evalTopLevelExprGen
:: forall e m a r. MonadNix e m
=> (a -> m r) -> Maybe FilePath -> a -> m r
eval :: forall e m. MonadNix e m
=> Maybe FilePath -> NExpr -> m (NValue m)
evalLoc :: forall e m. MonadNix e m
=> Maybe FilePath -> NExprLoc -> m (NValue m)
tracingEvalLoc
:: forall e m. (MonadNix e m, Alternative m, MonadIO m)
=> Maybe FilePath -> NExprLoc -> m (NValue m)

430
src/Nix/Eval.hs
View File

@ -1,434 +1,18 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Nix.Eval where
import Control.Arrow (first)
import Control.Monad
import Control.Monad.Fix
import Control.Monad.State
import Data.Align.Key
import Data.Fix
import Data.Functor.Compose
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.List (intercalate, partition, foldl')
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe, catMaybes)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.These
import Data.Traversable (for)
import Data.Void
import Nix.Atoms
import Nix.Convert
import Nix.Expr
import Nix.Pretty
import Nix.Scope
import Nix.Core (MonadNixEval)
import qualified Nix.Core as Core
import Nix.Expr.Types.Annotated
import Nix.Stack
import Nix.Thunk
import Nix.Utils
-- import System.IO.Unsafe -- move this into a tracing module
class (Show v, Monad m) => MonadEval v m | v -> m where
freeVariable :: Text -> m v
addStackFrames :: Framed e m => Transform NExprLocF (m a)
addStackFrames f v = withExprContext v (f v)
evalCurPos :: m v
evalConstant :: NAtom -> m v
evalString :: Text -> DList Text -> m v
evalLiteralPath :: FilePath -> m v
evalEnvPath :: FilePath -> m v
evalUnary :: NUnaryOp -> v -> m v
evalBinary :: NBinaryOp -> v -> m v -> m v
-- ^ The second argument is an action because operators such as boolean &&
-- and || may not evaluate the second argument.
evalWith :: m v -> m v -> m v
evalIf :: v -> m v -> m v -> m v
evalAssert :: v -> m v -> m v
evalApp :: v -> m v -> m v
evalAbs :: Params Void -> (m v -> m v) -> m v
evalError :: String -> m a
type MonadNixEval e v t m =
(MonadEval v m, Scoped e t m, MonadThunk v t m, MonadFix m,
Framed e m, MonadFile m, MonadVar m,
ToValue Bool m v, ToValue [t] m v,
FromValue (Text, DList Text) m v,
ToValue (AttrSet t) m v, FromValue (AttrSet t) m v,
ToValue (AttrSet t, AttrSet SourcePos) m v,
FromValue (AttrSet t, AttrSet SourcePos) m v)
wrapExpr :: NExprF (m v) -> NExpr
wrapExpr x = Fix (Fix (NSym "<?>") <$ x)
exprFContext :: (Framed e m) => NExprF (m v) -> m r -> m r
exprFContext e = withStringContext $
"While forcing thunk for: " ++ show (prettyNix (wrapExpr e)) ++ "\n"
-- | Evaluate an nix expression, with a given NThunkSet as environment
evalExpr :: MonadNixEval e v t m => NExpr -> m v
evalExpr = cata eval
eval :: forall e v t m. MonadNixEval e v t m => NExprF (m v) -> m v
eval (NSym "__curPos") = evalCurPos
eval (NSym var) = lookupVar var >>= \case
Nothing -> freeVariable var
Just v -> force v pure
eval (NConstant x) = evalConstant x
eval (NStr str) = uncurry evalString =<< assembleString str
eval (NLiteralPath p) = evalLiteralPath p
eval (NEnvPath p) = evalEnvPath p
eval (NUnary op arg) = evalUnary op =<< arg
eval (NBinary NApp fun arg) = do
scope <- currentScopes @_ @t
evalApp ?? withScopes scope arg =<< fun
eval (NBinary op larg rarg) = larg >>= \lval -> evalBinary op lval rarg
eval (NSelect aset attr alt) = do
traceM "NSelect"
mres <- evalSelect aset attr
traceM "NSelect..2"
case mres of
Right v -> pure v
Left (s, ks) -> fromMaybe err alt
where
err = evalError @v $ "Could not look up attribute "
++ intercalate "." (map Text.unpack (NE.toList ks))
++ " in " ++ show @v s
eval (NHasAttr aset attr) =
toValue . either (const False) (const True) =<< evalSelect aset attr
eval e@(NList l) = do
scope <- currentScopes
toValue =<< for l (thunk . exprFContext e . withScopes @t scope)
eval e@(NSet binds) = do
traceM "NSet..1"
(s, p) <- evalBinds e True False binds
traceM $ "NSet..2: s = " ++ show (void s)
traceM $ "NSet..2: p = " ++ show (void p)
toValue (s, p)
eval e@(NRecSet binds) = do
traceM "NRecSet..1"
(s, p) <- evalBinds e True True (desugarBinds (eval . NRecSet) binds)
traceM $ "NRecSet..2: s = " ++ show (void s)
traceM $ "NRecSet..2: p = " ++ show (void p)
toValue (s, p)
eval e@(NLet binds body) = do
traceM "Let..1"
(s, _) <- evalBinds e True True binds
traceM $ "Let..2: s = " ++ show (void s)
pushScope s body
eval (NIf cond t f) = cond >>= \v -> evalIf v t f
eval (NWith scope body) = evalWith scope body
eval (NAssert cond body) = cond >>= \v -> evalAssert v body
eval e@(NAbs params body) = do
-- It is the environment at the definition site, not the call site, that
-- 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 (clearDefaults params) $ \arg ->
-- jww (2018-04-17): We need to use the bound library here, so that
-- the body is only evaluated once.
withScopes @t scope $ do
args <- buildArgument e params arg
pushScope args body
where
clearDefaults :: Params r -> Params Void
clearDefaults (Param name) = Param name
clearDefaults (ParamSet xs b mv) = ParamSet (map (Nothing <$) xs) b mv
-- | 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 scope 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.
cur <- currentScopes @_ @t
s <- thunk $ exprFContext (NWith scope body)
$ withScopes cur scope
pushWeakScope ?? body $ force s $ fromValue @(AttrSet t)
attrSetAlter :: forall e v t m. MonadNixEval e v t m
=> [Text]
-> AttrSet (m v)
-> m v
-> m (AttrSet (m v))
attrSetAlter [] _ _ = evalError @v "invalid selector with no components"
attrSetAlter (p:ps) m val = case M.lookup p m of
Nothing
| null ps -> go
| otherwise -> recurse M.empty
Just x
| null ps -> go
| otherwise ->
x >>= fromValue >>= \s -> recurse (force ?? pure <$> s)
where
go = return $ M.insert p val m
-- jww (2018-04-13): Need to record positions for attr paths as well
recurse s = attrSetAlter ps s val <&> \m' ->
M.insert p (toValue =<< fmap (value @_ @_ @m) <$> sequence m') m
desugarBinds :: forall r. ([Binding r] -> r) -> [Binding r] -> [Binding r]
desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
where
collect :: Binding r
-> State (HashMap VarName (Maybe SourcePos, [Binding r]))
(Either VarName (Binding r))
collect (NamedVar (StaticKey x p:|y:ys) val) = do
m <- get
let v = case M.lookup x m of
Nothing -> (p, [NamedVar (y:|ys) val])
Just (p, v) -> (p, NamedVar (y:|ys) val : v)
put $ M.insert x v m
pure $ Left x
collect x = pure $ Right x
go :: Either VarName (Binding r)
-> State (HashMap VarName (Maybe SourcePos, [Binding r]))
(Binding r)
go (Right x) = pure x
go (Left x) = do
Just (p, v) <- gets $ M.lookup x
pure $ NamedVar (StaticKey x p :| []) (embed v)
evalBinds :: forall e v t m. MonadNixEval e v t m
=> NExprF (m v)
-> Bool
-> Bool
-> [Binding (m v)]
-> m (AttrSet t, AttrSet SourcePos)
evalBinds e allowDynamic recursive binds = do
scope <- currentScopes @_ @t
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
where
moveOverridesLast = (\(x, y) -> y ++ x) .
partition (\case NamedVar (StaticKey "__overrides" _ :| []) _ -> True
_ -> False)
go :: Scopes m t -> Binding (m v) -> m [([Text], Maybe SourcePos, m v)]
go _ (NamedVar (StaticKey "__overrides" _ :| []) finalValue) =
finalValue >>= fromValue >>= \(o', p') ->
return $ map (\(k, v) -> ([k], M.lookup k p', force v pure))
(M.toList o')
go _ (NamedVar pathExpr finalValue) = do
let go :: NAttrPath (m v) -> m ([Text], Maybe SourcePos, m v)
go = \case
h :| t -> evalSetterKeyName allowDynamic h >>= \case
(Nothing, _) ->
pure ([], Nothing,
toValue (mempty :: AttrSet t))
(Just k, pos) -> case t of
[] -> pure ([k], pos, finalValue)
x:xs -> do
(restOfPath, _, v) <- go (x:|xs)
pure (k : restOfPath, pos, v)
go pathExpr <&> \case
-- When there are no path segments, e.g. `${null} = 5;`, we don't
-- bind anything
([], _, _) -> []
result -> [result]
go scope (Inherit ms names) = fmap catMaybes $ forM names $ \name ->
evalSetterKeyName allowDynamic name >>= \case
(Nothing, _) -> return Nothing
(Just key, pos) -> return $ Just ([key], pos, do
mv <- case ms of
Nothing -> withScopes scope $ lookupVar key
Just s -> s >>= fromValue @(AttrSet t) >>= \s ->
clearScopes @t $ pushScope s $ lookupVar key
case mv of
Nothing -> evalError @v $ "Inheriting unknown attribute: "
++ show (void name)
Just v -> force v pure)
buildResult :: Scopes m t
-> [([Text], Maybe SourcePos, m v)]
-> m (AttrSet t, AttrSet SourcePos)
buildResult scope bindings = do
s <- foldM insert M.empty bindings
res <- if recursive
then loebM (encapsulate <$> s)
else traverse (thunk . exprFContext e . withScopes scope) s
return (res, foldl' go M.empty bindings)
where
-- jww (2018-04-13): Need to record positions for attr paths as well
go m ([k], Just pos, _) = M.insert k pos m
go m _ = m
encapsulate f attrs =
thunk . exprFContext e
. withScopes scope
. pushScope attrs $ f
insert m (path, _, value) = attrSetAlter path m value
evalSelect :: forall e v t m. MonadNixEval e v t m
=> m v
-> NAttrPath (m v)
-> m (Either (v, NonEmpty Text) v)
evalSelect aset attr = do
traceM "evalSelect"
s <- aset
traceM "evalSelect..2"
path <- evalSelector True attr
traceM $ "evalSelect..3: " ++ show path
res <- extract s path
traceM "evalSelect..4"
return res
where
extract x path@(k:|ks) = fromValueMay x >>= \case
Just (s :: AttrSet t, p :: AttrSet SourcePos) ->
case M.lookup k s of
Just v -> do
traceM $ "Forcing value at selector " ++ Text.unpack k
force v $ case ks of
[] -> pure . Right
y:ys -> extract ?? (y:|ys)
Nothing ->
Left . (, path) <$> toValue (s, p)
Nothing ->
return $ Left (x, path)
evalSelector :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> Bool -> NAttrPath (m v) -> m (NonEmpty Text)
evalSelector allowDynamic binds =
NE.map fst <$> traverse (evalGetterKeyName allowDynamic) binds
-- | Evaluate a component of an attribute path in a context where we are
-- *retrieving* a value
evalGetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> Bool -> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalGetterKeyName canBeDynamic
| canBeDynamic = evalKeyNameDynamicNotNull
| otherwise = evalKeyNameStatic
evalKeyNameStatic :: forall v m. MonadEval v m
=> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalKeyNameStatic = \case
StaticKey k p -> pure (k, p)
DynamicKey _ ->
evalError @v "dynamic attribute not allowed in this context"
evalKeyNameDynamicNotNull
:: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v) -> m (Text, Maybe SourcePos)
evalKeyNameDynamicNotNull = evalKeyNameDynamicNullable >=> \case
(Nothing, _) ->
evalError @v "value is null while a string was expected"
(Just k, p) -> pure (k, p)
-- | Evaluate a component of an attribute path in a context where we are
-- *binding* a value
evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> Bool -> NKeyName (m v) -> m (Maybe Text, Maybe SourcePos)
evalSetterKeyName canBeDynamic
| canBeDynamic = evalKeyNameDynamicNullable
| otherwise = fmap (first Just) . evalKeyNameStatic
-- | Returns Nothing iff the key value is null
evalKeyNameDynamicNullable
:: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v)
-> m (Maybe Text, Maybe SourcePos)
evalKeyNameDynamicNullable = \case
StaticKey k p -> pure (Just k, p)
DynamicKey k ->
runAntiquoted "\n" (fmap Just . assembleString) (>>= fromValueMay) k
<&> \case Just (t, _) -> (Just t, Nothing)
_ -> (Nothing, Nothing)
assembleString :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NString (m v) -> m (Text, DList Text)
assembleString = \case
Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
where
go = runAntiquoted "\n" (pure . (, mempty)) (>>= fromValue)
fromParts parts = mconcat <$> mapM go parts
buildArgument :: forall e v t m. MonadNixEval e v t m
=> NExprF (m v) -> Params (m v) -> m v -> m (AttrSet t)
buildArgument e params arg = do
scope <- currentScopes @_ @t
case params of
Param name -> M.singleton name
<$> thunk (exprFContext e (withScopes scope arg))
ParamSet s isVariadic m ->
arg >>= fromValue >>= \args -> do
let inject = case m of
Nothing -> id
Just n -> M.insert n $ const $
thunk (exprFContext e (withScopes scope arg))
loebM (inject $ alignWithKey (assemble scope isVariadic)
args (M.fromList s))
where
assemble :: Scopes m t
-> Bool
-> Text
-> These t (Maybe (m v))
-> AttrSet t
-> m t
assemble scope isVariadic k = \case
That Nothing ->
const $ evalError @v $ "Missing value for parameter: " ++ show k
That (Just f) -> \args ->
thunk $ exprFContext e
$ withScopes scope
$ pushScope args f
This x | isVariadic -> const (pure x)
| otherwise ->
const $ evalError @v $ "Unexpected parameter: " ++ show k
These x _ -> const (pure x)
-----
framedEvalExpr :: Framed e m => (NExprF (m v) -> m v) -> NExprLoc -> m v
framedEvalExpr eval = adi (eval . annotated . getCompose) psi
where
psi k v = withExprContext v (k v)
-----
{-
streamValues :: MonadVar m => v -> Stream (EValueF m) m ()
streamValues = void . yields . fmap go
where
go (EThunk (Left v)) = streamValues v
go (EThunk v) = effect (streamValues <$> forceThunk v)
-}
framedEvalExpr :: MonadNixEval e v t m => NExprLoc -> m v
framedEvalExpr = adi (Core.eval . annotated . getCompose) addStackFrames

15
src/Nix/Exec.hs
View File

@ -47,9 +47,9 @@ import qualified Data.Text as Text
import Nix.Atoms
import Nix.Context
import Nix.Convert
import Nix.Core (MonadEval(..), evalWithAttrSet)
import Nix.Effects
import Nix.Eval
import qualified Nix.Eval as Eval
import Nix.Eval as Eval
import Nix.Expr
import Nix.Normal
import Nix.Options
@ -67,7 +67,10 @@ import System.FilePath
import qualified System.Info
import System.Posix.Files
import System.Process (readProcessWithExitCode)
import {-# SOURCE #-} Nix.Entry as Entry
type MonadNix e m =
(Scoped e (NThunk m) m, Framed e m, MonadVar m, MonadFile m,
MonadEffects m, MonadFix m, MonadCatch m)
nverr :: forall e m a. MonadNix e m => String -> m a
nverr = evalError @(NValue m)
@ -329,8 +332,8 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m)
-- Use this cookie so that when we evaluate the next
-- import, we'll remember which directory its containing
-- file was in.
pushScope (M.singleton "__cur_file" ref)
(pushScope scope (framedEvalExpr Eval.eval expr))
pushScope (M.singleton "__cur_file" ref) $
pushScope scope $ Eval.framedEvalExpr expr
getEnvVar = liftIO . lookupEnv
@ -399,7 +402,7 @@ instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m)
Failure err ->
throwError $ "Error parsing output of nix-instantiate: "
++ show err
Success v -> framedEvalExpr Eval.eval v
Success v -> Eval.framedEvalExpr v
err -> throwError $ "nix-instantiate failed: " ++ show err
runLazyM :: Options -> MonadIO m => Lazy m a -> m a

4
src/Nix/Lint.hs
View File

@ -41,7 +41,7 @@ import Data.Void
import Nix.Atoms
import Nix.Context
import Nix.Convert
import Nix.Eval
import Nix.Core (MonadEval(..))
import qualified Nix.Eval as Eval
import Nix.Expr
import Nix.Options
@ -414,4 +414,4 @@ symbolicBaseEnv = return emptyScopes
lint :: Options -> NExprLoc -> ST s (Symbolic (Lint s))
lint opts expr = runLintM opts $
symbolicBaseEnv >>= (`pushScopes` Eval.framedEvalExpr Eval.eval expr)
symbolicBaseEnv >>= (`pushScopes` Eval.framedEvalExpr expr)

17
src/Nix/Options.hs
View File

@ -11,6 +11,9 @@ import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
data Options = Options
{ verbose :: Verbosity
, tracing :: Bool
, reduce :: Maybe FilePath
, reduceSets :: Bool
, reduceLists :: Bool
, parse :: Bool
, parseOnly :: Bool
, findFile :: Maybe FilePath
@ -38,6 +41,9 @@ defaultOptions :: Options
defaultOptions = Options
{ verbose = ErrorsOnly
, tracing = False
, reduce = Nothing
, reduceSets = False
, reduceLists = False
, parse = False
, parseOnly = False
, findFile = Nothing
@ -97,7 +103,16 @@ nixOptions = Options
<> help "Verbose output")))
<*> switch
( long "trace"
<> help "Enable tracing code (more can be seen with --flags=tracing)")
<> help "Enable tracing code (even more can be seen if built with --flags=tracing)")
<*> optional (strOption
( long "reduce"
<> help "When done evaluating, output the evaluated part of the expression to FILE"))
<*> switch
( long "reduce-sets"
<> help "Reduce set members that aren't used; breaks if hasAttr is used")
<*> switch
( long "reduce-lists"
<> help "Reduce list members that aren't used; breaks if elemAt is used")
<*> switch
( long "parse"
<> help "Whether to parse the file (also the default right now)")

34
src/Nix/Stack.hs
View File

@ -43,36 +43,34 @@ withStringContext str = local (over hasLens (Left @_ @NExprLoc str :))
class Monad m => MonadFile m where
readFile :: FilePath -> m ByteString
posAndMsg :: Options -> SourcePos -> Doc -> ParseError t Void
posAndMsg opts beg msg =
posAndMsg :: SourcePos -> Doc -> ParseError t Void
posAndMsg beg msg =
FancyError (beg :| [])
(Set.fromList [ErrorFail
(if verbose opts >= Chatty
then "While evaluating:\n>>>>>>>>\n"
++ intercalate " \n" (lines (show msg))
++ "\n<<<<<<<<"
else "Expression: " ++ show msg)
:: ErrorFancy Void])
(Set.fromList [ErrorFail (show msg) :: ErrorFancy Void])
renderLocation :: (Framed e m, MonadFile m) => SrcSpan -> Doc -> m Doc
renderLocation (SrcSpan beg@(SourcePos "<string>" _ _) _) msg = do
opts :: Options <- asks (view hasLens)
return $ text $ parseErrorPretty @Char (posAndMsg opts beg msg)
renderLocation (SrcSpan beg@(SourcePos "<string>" _ _) _) msg =
return $ text $ parseErrorPretty @Char (posAndMsg beg msg)
renderLocation (SrcSpan beg@(SourcePos path _ _) _) msg = do
opts :: Options <- asks (view hasLens)
contents <- Nix.Stack.readFile path
return $ text $ parseErrorPretty' contents (posAndMsg opts beg msg)
return $ text $ parseErrorPretty' contents (posAndMsg beg msg)
renderFrame :: (Framed e m, MonadFile m)
=> Either String NExprLoc -> m String
renderFrame (Left str) = return str
renderFrame (Right expr@(Fix (Compose (Ann ann x)))) = do
opts :: Options <- asks (view hasLens)
fmap show $ renderLocation ann $ prettyNix $
if verbose opts >= Chatty
then stripAnnotation expr
else Fix (Fix (NSym "<?>") <$ x)
let rendered = show $ prettyNix $
if verbose opts >= Chatty
then stripAnnotation expr
else Fix (Fix (NSym "<?>") <$ x)
msg = if verbose opts >= Chatty
then "While evaluating:\n>>>>>>>>\n"
++ intercalate " \n" (lines rendered)
++ "\n<<<<<<<<"
else "Expression: " ++ rendered
show <$> renderLocation ann (text msg)
throwError :: (Framed e m, MonadFile m, MonadThrow m) => String -> m a
throwError str = do

74
src/Nix/Trace.hs
View File

@ -23,7 +23,7 @@ import Control.Arrow (second)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Control.Monad.Reader
import Data.Fix
import Data.Functor.Compose
import Data.IORef
@ -31,11 +31,15 @@ import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Text (Text)
import Nix.Atoms
import Nix.Exec (MonadNix)
import Nix.Expr
import Nix.Options
import Nix.Pretty (prettyNix)
import Nix.Reduce
import Nix.Stack
import Nix.Utils
import Text.Megaparsec.Pos
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
newtype FlaggedF f r = FlaggedF { flagged :: (IORef Bool, f r) }
deriving (Functor, Foldable, Traversable)
@ -154,34 +158,44 @@ pruneTree = cataM $ \(FlaggedF (b, Compose x)) -> do
nNull :: NExprLoc
nNull = Fix (Compose (Ann (SrcSpan nullPos nullPos) (NConstant NNull)))
where
nullPos = SourcePos "<unknown>" (mkPos 0) (mkPos 0)
tracingEvalExpr :: (Framed e m, Exception r, MonadCatch m, MonadIO m,
MonadCatch n, MonadIO n, Alternative n)
=> (NExprF (m v) -> m v) -> Maybe FilePath -> NExprLoc
-> n (m (NExprLoc, Either r v))
tracingEvalExpr eval mpath expr = do
expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr)
res <- flip runReaderT (0 :: Int) $
adiM (pure <$> eval . annotated . getCompose . snd . flagged)
psi expr'
return $ do
eres <- catch (Right <$> res) (pure . Left)
expr'' <- pruneTree expr'
return (fromMaybe nNull expr'', eres)
nullAnn :: SrcSpan
nullAnn = SrcSpan nullPos nullPos
nullPos :: SourcePos
nullPos = SourcePos "<unknown>" (mkPos 0) (mkPos 0)
addTracing :: (MonadNix e m, MonadIO m,
MonadReader Int n, Alternative n)
=> Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
addTracing k v = do
depth <- ask
guard (depth < 2000)
local succ $ do
v'@(Compose (Ann span x)) <- sequence v
return $ do
opts :: Options <- asks (view hasLens)
let rendered =
if verbose opts >= Chatty
then show (void x)
else show (prettyNix (Fix (Fix (NSym "?") <$ x)))
msg x = "eval: " ++ replicate depth ' ' ++ x
loc <- renderLocation span (text (msg rendered ++ " ..."))
liftIO $ putStr $ show loc
res <- k v'
liftIO $ putStrLn $ msg (rendered ++ " ...done")
return res
reducingEvalExpr
:: (Framed e m, Exception r, MonadCatch m, MonadIO m)
=> (NExprLocF (m a) -> m a)
-> Maybe FilePath
-> NExprLoc
-> m (NExprLoc, Either r a)
reducingEvalExpr eval mpath expr = do
expr' <- flagExprLoc =<< liftIO (reduceExpr mpath expr)
eres <- catch (Right <$> cata (addEvalFlags eval) expr') (pure . Left)
expr'' <- pruneTree expr'
return (fromMaybe nNull expr'', eres)
where
psi k v@(Fix (FlaggedF (b, _x))) = do
depth <- ask
guard (depth < 200)
local succ $ do
action <- k v
-- jww (2018-04-20): We should be able to compose this evaluator
-- with framedEvalExpr, rather than replicating its behavior here.
return $ withExprContext (stripFlags v) $ do
-- liftIO $ putStrLn $ "eval: " ++ replicate depth ' '
-- ++ show (void (unFix (stripAnnotation (stripFlags v))))
liftIO $ writeIORef b True
res <- action
-- liftIO $ putStrLn $ "eval: " ++ replicate depth ' ' ++ "."
return res
addEvalFlags k (FlaggedF (b, x)) = liftIO (writeIORef b True) *> k x

29
src/Nix/Utils.hs
View File

@ -3,10 +3,12 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Nix.Utils (module Nix.Utils, module X) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad.Fix
import qualified Data.Aeson as A
@ -34,6 +36,15 @@ type DList a = Endo [a]
type AttrSet = HashMap Text
-- | An f-algebra defines how to reduced the fixed-point of a functor to a
-- value.
type Alg f a = f a -> a
type AlgM f m a = f a -> m a
-- | An "transform" here is a modification of a catamorphism.
type Transform f a = (Fix f -> a) -> Fix f -> a
infixr 0 &
(&) :: a -> (a -> c) -> c
(&) = flip ($)
@ -50,15 +61,17 @@ loeb x = go where go = fmap ($ go) x
loebM :: (MonadFix m, Traversable t) => t (t a -> m a) -> m (t a)
loebM f = mfix $ \a -> mapM ($ a) f
para :: (a -> [a] -> b -> b) -> b -> [a] -> b
para f base = h where
h [] = base
h (x:xs) = f x xs (h xs)
para :: Functor f => (f (Fix f, a) -> a) -> Fix f -> a
para f = f . fmap (id &&& para f) . unFix
paraM :: Monad m => (a -> [a] -> b -> m b) -> b -> [a] -> m b
paraM f base = h where
h [] = return base
h (x:xs) = f x xs =<< h xs
paraM :: (Traversable f, Monad m) => (f (Fix f, a) -> m a) -> Fix f -> m a
paraM f = f <=< traverse (\x -> (x,) <$> paraM f x) . unFix
cataP :: Functor f => (Fix f -> f a -> a) -> Fix f -> a
cataP f x = f x . fmap (cataP f) . unFix $ x
cataPM :: (Traversable f, Monad m) => (Fix f -> f a -> m a) -> Fix f -> m a
cataPM f x = f x <=< traverse (cataPM f) . unFix $ x
transport :: Functor g => (forall x. f x -> g x) -> Fix f -> Fix g
transport f (Fix x) = Fix $ fmap (transport f) (f x)

4
tests/EvalTests.hs
View File

@ -163,9 +163,9 @@ instance (Show r, Show (NValueF m r), Eq r) => Eq (NValueF m r) where
constantEqual :: NExprLoc -> NExprLoc -> Assertion
constantEqual a b = do
-- putStrLn =<< lint (stripAnnotation a)
a' <- runLazyM defaultOptions $ normalForm =<< evalLoc Nothing a
a' <- runLazyM defaultOptions $ normalForm =<< nixEvalExprLoc Nothing a
-- putStrLn =<< lint (stripAnnotation b)
b' <- runLazyM defaultOptions $ normalForm =<< evalLoc Nothing b
b' <- runLazyM defaultOptions $ normalForm =<< nixEvalExprLoc Nothing b
assertEqual "" a' b'
constantEqualText' :: Text -> Text -> Assertion

2
tests/Main.hs
View File

@ -57,7 +57,7 @@ ensureNixpkgsCanParse =
url = "https://github.com/NixOS/nixpkgs/archive/#{rev}.tar.gz";
sha256 = "#{sha256}";
}|]) $ \expr -> do
NVStr dir _ <- runLazyM defaultOptions $ Nix.evalLoc Nothing expr
NVStr dir _ <- runLazyM defaultOptions $ Nix.nixEvalExprLoc Nothing expr
files <- globDir1 (compile "**/*.nix") (unpack dir)
forM_ files $ \file ->
-- Parse and deepseq the resulting expression tree, to ensure the

4
tests/TestCommon.hs
View File

@ -18,7 +18,7 @@ hnixEvalFile opts file = do
Success expr -> do
setEnv "TEST_VAR" "foo"
runLazyM opts $
evaluateExpression (Just file) evalLoc normalForm expr
evaluateExpression (Just file) nixEvalExprLoc normalForm expr
hnixEvalText :: Options -> Text -> IO (NValueNF (Lazy IO))
hnixEvalText opts src = case parseNixText src of
@ -26,7 +26,7 @@ hnixEvalText opts src = case parseNixText src of
error $ "Parsing failed for expressien `"
++ unpack src ++ "`.\n" ++ show err
Success expr ->
runLazyM opts $ normalForm =<< eval Nothing expr
runLazyM opts $ normalForm =<< nixEvalExpr Nothing expr
nixEvalString :: String -> IO String
nixEvalString expr = do