From 86b09103d6c72e80de7b005fd4888c7d49e12d65 Mon Sep 17 00:00:00 2001 From: John Wiegley Date: Fri, 20 Apr 2018 22:36:40 -0700 Subject: [PATCH] Move production of a reduced test case to --reduce, improve --trace --- default.nix | 2 +- hnix.cabal | 4 +- main/Main.hs | 42 ++++- main/Repl.hs | 13 +- src/Nix.hs | 172 +++++++++++++++-- src/Nix/Builtins.hs | 5 +- src/Nix/Core.hs | 412 ++++++++++++++++++++++++++++++++++++++++ src/Nix/Entry.hs | 151 --------------- src/Nix/Entry.hs-boot | 37 ---- src/Nix/Eval.hs | 430 +----------------------------------------- src/Nix/Exec.hs | 15 +- src/Nix/Lint.hs | 4 +- src/Nix/Options.hs | 17 +- src/Nix/Stack.hs | 34 ++-- src/Nix/Trace.hs | 74 +++++--- src/Nix/Utils.hs | 29 ++- tests/EvalTests.hs | 4 +- tests/Main.hs | 2 +- tests/TestCommon.hs | 4 +- 19 files changed, 733 insertions(+), 718 deletions(-) create mode 100644 src/Nix/Core.hs delete mode 100644 src/Nix/Entry.hs delete mode 100644 src/Nix/Entry.hs-boot diff --git a/default.nix b/default.nix index 9782ff1..5fda701 100644 --- a/default.nix +++ b/default.nix @@ -30,7 +30,7 @@ in haskellPackages.developPackage { [ pkgs.nix haskellPackages.hpack - haskellPackages.cabal-install + # haskellPackages.cabal-install ]; enableLibraryProfiling = doProfiling; diff --git a/hnix.cabal b/hnix.cabal index 85984e4..e127692 100644 --- a/hnix.cabal +++ b/hnix.cabal @@ -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 diff --git a/main/Main.hs b/main/Main.hs index 4626ebe..a3d96e9 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -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 diff --git a/main/Repl.hs b/main/Repl.hs index 4f9afe5..b2631dc 100644 --- a/main/Repl.hs +++ b/main/Repl.hs @@ -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 () diff --git a/src/Nix.hs b/src/Nix.hs index 2d7cf39..7f8123c 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -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 diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs index 8421bac..61bd0e8 100644 --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -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_ diff --git a/src/Nix/Core.hs b/src/Nix/Core.hs new file mode 100644 index 0000000..f0361e3 --- /dev/null +++ b/src/Nix/Core.hs @@ -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) diff --git a/src/Nix/Entry.hs b/src/Nix/Entry.hs deleted file mode 100644 index 66e48c4..0000000 --- a/src/Nix/Entry.hs +++ /dev/null @@ -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 diff --git a/src/Nix/Entry.hs-boot b/src/Nix/Entry.hs-boot deleted file mode 100644 index 147404c..0000000 --- a/src/Nix/Entry.hs-boot +++ /dev/null @@ -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) diff --git a/src/Nix/Eval.hs b/src/Nix/Eval.hs index 901e55b..7f26907 100644 --- a/src/Nix/Eval.hs +++ b/src/Nix/Eval.hs @@ -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 diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index bf005ff..110b8e3 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -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 diff --git a/src/Nix/Lint.hs b/src/Nix/Lint.hs index 062ffb1..a0961b7 100644 --- a/src/Nix/Lint.hs +++ b/src/Nix/Lint.hs @@ -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) diff --git a/src/Nix/Options.hs b/src/Nix/Options.hs index e07544f..6385902 100644 --- a/src/Nix/Options.hs +++ b/src/Nix/Options.hs @@ -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)") diff --git a/src/Nix/Stack.hs b/src/Nix/Stack.hs index 9d73339..77933f1 100644 --- a/src/Nix/Stack.hs +++ b/src/Nix/Stack.hs @@ -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 "" _ _) _) msg = do - opts :: Options <- asks (view hasLens) - return $ text $ parseErrorPretty @Char (posAndMsg opts beg msg) +renderLocation (SrcSpan beg@(SourcePos "" _ _) _) 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 diff --git a/src/Nix/Trace.hs b/src/Nix/Trace.hs index a671932..60fccaa 100644 --- a/src/Nix/Trace.hs +++ b/src/Nix/Trace.hs @@ -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 "" (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 "" (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 diff --git a/src/Nix/Utils.hs b/src/Nix/Utils.hs index 86f9c6e..a72e403 100644 --- a/src/Nix/Utils.hs +++ b/src/Nix/Utils.hs @@ -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) diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs index 1cb78f3..f38dd2e 100644 --- a/tests/EvalTests.hs +++ b/tests/EvalTests.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs index b656c54..f9e0e65 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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 diff --git a/tests/TestCommon.hs b/tests/TestCommon.hs index d156f8b..36d955d 100644 --- a/tests/TestCommon.hs +++ b/tests/TestCommon.hs @@ -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