Rename Nix.Core back to Nix.Eval, since Nix.Eval was now almost empty
This commit is contained in:
parent
fc85f1a7b9
commit
8a93068102
|
@ -2,7 +2,7 @@
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: a049f208472f58a7ad617291f7dde633bcb0e3bc6e593eac9fc8a7e69d350f01
|
-- hash: 56c36b358efbc2aa305346fe938ba2b0e71f68d456134e558c23f2959af02505
|
||||||
|
|
||||||
name: hnix
|
name: hnix
|
||||||
version: 0.5.0
|
version: 0.5.0
|
||||||
|
@ -38,7 +38,6 @@ library
|
||||||
Nix.Cache
|
Nix.Cache
|
||||||
Nix.Context
|
Nix.Context
|
||||||
Nix.Convert
|
Nix.Convert
|
||||||
Nix.Core
|
|
||||||
Nix.Effects
|
Nix.Effects
|
||||||
Nix.Eval
|
Nix.Eval
|
||||||
Nix.Exec
|
Nix.Exec
|
||||||
|
|
|
@ -20,7 +20,7 @@ import qualified Data.Text.Lazy.Encoding as TL
|
||||||
import qualified Data.Text.Lazy.IO as TL
|
import qualified Data.Text.Lazy.IO as TL
|
||||||
import Nix
|
import Nix
|
||||||
import Nix.Convert
|
import Nix.Convert
|
||||||
import qualified Nix.Core as Core
|
import qualified Nix.Eval as Eval
|
||||||
-- import Nix.Lint
|
-- import Nix.Lint
|
||||||
import Nix.Utils
|
import Nix.Utils
|
||||||
import Options.Applicative hiding (ParserResult(..))
|
import Options.Applicative hiding (ParserResult(..))
|
||||||
|
@ -121,7 +121,7 @@ main = do
|
||||||
|
|
||||||
reduction path mp x = do
|
reduction path mp x = do
|
||||||
eres <- Nix.withNixContext mp $
|
eres <- Nix.withNixContext mp $
|
||||||
Nix.reducingEvalExpr (Core.eval . annotated . getCompose) mp x
|
Nix.reducingEvalExpr (Eval.eval . annotated . getCompose) mp x
|
||||||
handleReduced path eres
|
handleReduced path eres
|
||||||
|
|
||||||
handleReduced :: (MonadThrow m, MonadIO m)
|
handleReduced :: (MonadThrow m, MonadIO m)
|
||||||
|
|
|
@ -20,7 +20,6 @@ module Repl where
|
||||||
|
|
||||||
import Nix
|
import Nix
|
||||||
import Nix.Eval
|
import Nix.Eval
|
||||||
import Nix.Core
|
|
||||||
import Nix.Scope
|
import Nix.Scope
|
||||||
import qualified Nix.Type.Env as Env
|
import qualified Nix.Type.Env as Env
|
||||||
import Nix.Type.Infer
|
import Nix.Type.Infer
|
||||||
|
|
11
src/Nix.hs
11
src/Nix.hs
|
@ -34,8 +34,7 @@ import qualified Data.Text as Text
|
||||||
import qualified Data.Text.Read as Text
|
import qualified Data.Text.Read as Text
|
||||||
import Nix.Builtins
|
import Nix.Builtins
|
||||||
import Nix.Cache
|
import Nix.Cache
|
||||||
import qualified Nix.Core as Core
|
import qualified Nix.Eval as Eval
|
||||||
import Nix.Eval
|
|
||||||
import Nix.Exec
|
import Nix.Exec
|
||||||
import Nix.Expr
|
import Nix.Expr
|
||||||
-- import Nix.Expr.Shorthands
|
-- import Nix.Expr.Shorthands
|
||||||
|
@ -81,13 +80,13 @@ nixEval mpath xform alg = withNixContext mpath . adi alg xform
|
||||||
-- | Evaluate a nix expression in the default context
|
-- | Evaluate a nix expression in the default context
|
||||||
nixEvalExpr :: forall e m. MonadNix e m
|
nixEvalExpr :: forall e m. MonadNix e m
|
||||||
=> Maybe FilePath -> NExpr -> m (NValue m)
|
=> Maybe FilePath -> NExpr -> m (NValue m)
|
||||||
nixEvalExpr mpath = nixEval mpath id Core.eval
|
nixEvalExpr mpath = nixEval mpath id Eval.eval
|
||||||
|
|
||||||
-- | Evaluate a nix expression in the default context
|
-- | Evaluate a nix expression in the default context
|
||||||
nixEvalExprLoc :: MonadNix e m
|
nixEvalExprLoc :: MonadNix e m
|
||||||
=> Maybe FilePath -> NExprLoc -> m (NValue m)
|
=> Maybe FilePath -> NExprLoc -> m (NValue m)
|
||||||
nixEvalExprLoc mpath =
|
nixEvalExprLoc mpath =
|
||||||
nixEval mpath addStackFrames (Core.eval . annotated . getCompose)
|
nixEval mpath Eval.addStackFrames (Eval.eval . annotated . getCompose)
|
||||||
|
|
||||||
-- | Evaluate a nix expression with tracing in the default context
|
-- | Evaluate a nix expression with tracing in the default context
|
||||||
nixTracingEvalExprLoc :: forall e m. (MonadNix e m, MonadIO m, Alternative m)
|
nixTracingEvalExprLoc :: forall e m. (MonadNix e m, MonadIO m, Alternative m)
|
||||||
|
@ -95,8 +94,8 @@ nixTracingEvalExprLoc :: forall e m. (MonadNix e m, MonadIO m, Alternative m)
|
||||||
nixTracingEvalExprLoc mpath
|
nixTracingEvalExprLoc mpath
|
||||||
= withNixContext mpath
|
= withNixContext mpath
|
||||||
. join . (`runReaderT` (0 :: Int))
|
. join . (`runReaderT` (0 :: Int))
|
||||||
. adi (addTracing (Core.eval . annotated . getCompose))
|
. adi (addTracing (Eval.eval . annotated . getCompose))
|
||||||
(raise addStackFrames)
|
(raise Eval.addStackFrames)
|
||||||
where
|
where
|
||||||
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
|
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
|
||||||
|
|
||||||
|
|
|
@ -55,8 +55,8 @@ import Data.Traversable (mapM)
|
||||||
import Language.Haskell.TH.Syntax (addDependentFile, runIO)
|
import Language.Haskell.TH.Syntax (addDependentFile, runIO)
|
||||||
import Nix.Atoms
|
import Nix.Atoms
|
||||||
import Nix.Convert
|
import Nix.Convert
|
||||||
import qualified Nix.Core as Core
|
|
||||||
import Nix.Effects
|
import Nix.Effects
|
||||||
|
import qualified Nix.Eval as Eval
|
||||||
import Nix.Exec
|
import Nix.Exec
|
||||||
import Nix.Expr.Types
|
import Nix.Expr.Types
|
||||||
import Nix.Expr.Types.Annotated
|
import Nix.Expr.Types.Annotated
|
||||||
|
@ -125,7 +125,7 @@ builtinsList = sequence [
|
||||||
let f = "data/nix/corepkgs/derivation.nix"
|
let f = "data/nix/corepkgs/derivation.nix"
|
||||||
addDependentFile f
|
addDependentFile f
|
||||||
Success expr <- runIO $ parseNixFile f
|
Success expr <- runIO $ parseNixFile f
|
||||||
[| cata Core.eval expr |]
|
[| cata Eval.eval expr |]
|
||||||
)
|
)
|
||||||
|
|
||||||
, add Normal "getEnv" getEnv_
|
, add Normal "getEnv" getEnv_
|
||||||
|
|
412
src/Nix/Core.hs
412
src/Nix/Core.hs
|
@ -1,412 +0,0 @@
|
||||||
{-# 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)
|
|
409
src/Nix/Eval.hs
409
src/Nix/Eval.hs
|
@ -1,18 +1,419 @@
|
||||||
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
|
{-# LANGUAGE ApplicativeDo #-}
|
||||||
|
{-# LANGUAGE ConstraintKinds #-}
|
||||||
{-# LANGUAGE FlexibleContexts #-}
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE FunctionalDependencies #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE MultiWayIf #-}
|
||||||
|
{-# LANGUAGE PartialTypeSignatures #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE ScopedTypeVariables #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
|
|
||||||
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||||
|
|
||||||
module Nix.Eval where
|
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.Functor.Compose
|
||||||
import Nix.Core (MonadNixEval)
|
import Data.HashMap.Lazy (HashMap)
|
||||||
import qualified Nix.Core as Core
|
import qualified Data.HashMap.Lazy as M
|
||||||
import Nix.Expr.Types.Annotated
|
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.Stack
|
||||||
|
import Nix.Strings (runAntiquoted)
|
||||||
|
import Nix.Thunk
|
||||||
import Nix.Utils
|
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)
|
||||||
|
|
||||||
addStackFrames :: Framed e m => Transform NExprLocF (m a)
|
addStackFrames :: Framed e m => Transform NExprLocF (m a)
|
||||||
addStackFrames f v = withExprContext v (f v)
|
addStackFrames f v = withExprContext v (f v)
|
||||||
|
|
||||||
framedEvalExpr :: MonadNixEval e v t m => NExprLoc -> m v
|
framedEvalExpr :: MonadNixEval e v t m => NExprLoc -> m v
|
||||||
framedEvalExpr = adi (Core.eval . annotated . getCompose) addStackFrames
|
framedEvalExpr = adi (eval . annotated . getCompose) addStackFrames
|
||||||
|
|
|
@ -47,7 +47,6 @@ import qualified Data.Text as Text
|
||||||
import Nix.Atoms
|
import Nix.Atoms
|
||||||
import Nix.Context
|
import Nix.Context
|
||||||
import Nix.Convert
|
import Nix.Convert
|
||||||
import Nix.Core (MonadEval(..), evalWithAttrSet)
|
|
||||||
import Nix.Effects
|
import Nix.Effects
|
||||||
import Nix.Eval as Eval
|
import Nix.Eval as Eval
|
||||||
import Nix.Expr
|
import Nix.Expr
|
||||||
|
|
|
@ -41,7 +41,7 @@ import Data.Void
|
||||||
import Nix.Atoms
|
import Nix.Atoms
|
||||||
import Nix.Context
|
import Nix.Context
|
||||||
import Nix.Convert
|
import Nix.Convert
|
||||||
import Nix.Core (MonadEval(..))
|
import Nix.Eval (MonadEval(..))
|
||||||
import qualified Nix.Eval as Eval
|
import qualified Nix.Eval as Eval
|
||||||
import Nix.Expr
|
import Nix.Expr
|
||||||
import Nix.Options
|
import Nix.Options
|
||||||
|
|
Loading…
Reference in a new issue