hnix-0.13.0: src/Nix/Exec.hs
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Nix.Exec where
import Prelude hiding ( putStr
, putStrLn
, print
)
import Control.Monad.Catch hiding ( catchJust )
import Control.Monad.Fix
import Data.Fix
import qualified Data.HashMap.Lazy as M
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as Text
import Nix.Atoms
import Nix.Cited
import Nix.Convert
import Nix.Effects
import Nix.Eval as Eval
import Nix.Expr
import Nix.Frames
import Nix.Options
import Nix.Pretty
import Nix.Render
import Nix.Scope
import Nix.String
import Nix.String.Coerce
import Nix.Thunk
import Nix.Utils
import Nix.Value
import Nix.Value.Equal
import Nix.Value.Monad
import Prettyprinter
#ifdef MIN_VERSION_pretty_show
import qualified Text.Show.Pretty as PS
#endif
#ifdef MIN_VERSION_ghc_datasize
#if MIN_VERSION_ghc_datasize(0,2,0)
import GHC.DataSize
#endif
#endif
type MonadCited t f m =
( HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
, MonadDataContext f m
)
nvConstantP
:: MonadCited t f m
=> Provenance m (NValue t f m)
-> NAtom
-> NValue t f m
nvConstantP p x = addProvenance p (nvConstant x)
nvStrP
:: MonadCited t f m
=> Provenance m (NValue t f m)
-> NixString
-> NValue t f m
nvStrP p ns = addProvenance p (nvStr ns)
nvPathP
:: MonadCited t f m
=> Provenance m (NValue t f m)
-> FilePath
-> NValue t f m
nvPathP p x = addProvenance p (nvPath x)
nvListP
:: MonadCited t f m
=> Provenance m (NValue t f m)
-> [NValue t f m]
-> NValue t f m
nvListP p l = addProvenance p (nvList l)
nvSetP
:: MonadCited t f m
=> Provenance m (NValue t f m)
-> AttrSet SourcePos
-> AttrSet (NValue t f m)
-> NValue t f m
nvSetP p x s = addProvenance p (nvSet x s)
nvClosureP
:: MonadCited t f m
=> Provenance m (NValue t f m)
-> Params ()
-> (NValue t f m -> m (NValue t f m))
-> NValue t f m
nvClosureP p x f = addProvenance p (nvClosure x f)
nvBuiltinP
:: MonadCited t f m
=> Provenance m (NValue t f m)
-> Text
-> (NValue t f m -> m (NValue t f m))
-> NValue t f m
nvBuiltinP p name f = addProvenance p (nvBuiltin name f)
type MonadCitedThunks t f m
= ( MonadThunk t m (NValue t f m)
, MonadDataErrorContext t f m
, HasCitations m (NValue t f m) t
, HasCitations1 m (NValue t f m) f
)
type MonadNix e t f m
= ( Has e SrcSpan
, Has e Options
, Scoped (NValue t f m) m
, Framed e m
, MonadFix m
, MonadCatch m
, MonadThrow m
, Alternative m
, MonadEffects t f m
, MonadCitedThunks t f m
, MonadValue (NValue t f m) m
)
data ExecFrame t f m = Assertion SrcSpan (NValue t f m)
deriving (Show, Typeable)
instance MonadDataErrorContext t f m => Exception (ExecFrame t f m)
nverr :: forall e t f s m a . (MonadNix e t f m, Exception s) => s -> m a
nverr = evalError @(NValue t f m)
currentPos :: forall e m . (MonadReader e m, Has e SrcSpan) => m SrcSpan
currentPos = asks (view hasLens)
wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc
wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)
{-# inline wrapExprLoc #-}
-- 2021-01-07: NOTE: This instance belongs to be beside MonadEval type class.
-- Currently instance is stuck in orphanage between the requirements to be MonadEval, aka Eval stage, and emposed requirement to be MonadNix (Execution stage). MonadNix constraint tries to put the cart before horse and seems superflous, since Eval in Nix also needs and can throw exceptions. It is between `nverr` and `evalError`.
instance MonadNix e t f m => MonadEval (NValue t f m) m where
freeVariable var =
nverr @e @t @f $ ErrorCall $ "Undefined variable '" <> toString var <> "'"
synHole name = do
span <- currentPos
scope <- currentScopes
evalError @(NValue t f m) $ SynHole $
SynHoleInfo
{ _synHoleInfo_expr = Fix $ NSynHole_ span name
, _synHoleInfo_scope = scope
}
attrMissing ks ms =
evalError @(NValue t f m) $ ErrorCall $ toString $
maybe
("Inheriting unknown attribute: " <> attr)
(\ s ->
"Could not look up attribute " <> attr <> " in " <> show (prettyNValue s)
)
ms
where
attr = Text.intercalate "." (NE.toList ks)
evalCurPos = do
scope <- currentScopes
span@(SrcSpan delta _) <- currentPos
addProvenance @_ @_ @(NValue t f m)
(Provenance scope (NSym_ span "__curPos")) <$>
toValue delta
evaledSym name val = do
scope <- currentScopes
span <- currentPos
pure $
addProvenance @_ @_ @(NValue t f m)
(Provenance scope (NSym_ span name))
val
evalConstant c = do
scope <- currentScopes
span <- currentPos
pure $ nvConstantP (Provenance scope (NConstant_ span c)) c
evalString =
maybe
(nverr $ ErrorCall "Failed to assemble string")
(\ ns ->
do
scope <- currentScopes
span <- currentPos
pure $
nvStrP
(Provenance
scope
(NStr_ span (DoubleQuoted [Plain (stringIgnoreContext ns)]))
)
ns
)
<=< assembleString
evalLiteralPath p = do
scope <- currentScopes
span <- currentPos
nvPathP (Provenance scope (NLiteralPath_ span p)) <$>
makeAbsolutePath @t @f @m p
evalEnvPath p = do
scope <- currentScopes
span <- currentPos
nvPathP (Provenance scope (NEnvPath_ span p)) <$>
findEnvPath @t @f @m p
evalUnary op arg = do
scope <- currentScopes
span <- currentPos
execUnaryOp scope span op arg
evalBinary op larg rarg = do
scope <- currentScopes
span <- currentPos
execBinaryOp scope span op larg rarg
evalWith c b = do
scope <- currentScopes
span <- currentPos
(\b -> addProvenance (Provenance scope (NWith_ span Nothing (pure b))) b)
<$> evalWithAttrSet c b
evalIf c t f = do
scope <- currentScopes
span <- currentPos
b <- fromValue c
let
fun x y = addProvenance (Provenance scope (NIf_ span (pure c) x y))
bool
( (\ f' -> fun Nothing (pure f') f') <$> f )
( (\ t' -> fun (pure t') Nothing t') <$> t )
b
evalAssert c body =
do
span <- currentPos
b <- fromValue c
bool
(nverr $ Assertion span c)
(do
scope <- currentScopes
(\b ->
addProvenance (Provenance scope (NAssert_ span (pure c) (pure b))) b
) <$>
body
)
b
evalApp f x = do
scope <- currentScopes
span <- currentPos
addProvenance (Provenance scope (NBinary_ span NApp (pure f) Nothing)) <$>
(callFunc f =<< defer x)
evalAbs p k = do
scope <- currentScopes
span <- currentPos
pure $
nvClosureP
(Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
(void p)
(\arg -> snd <$> k (pure arg) (\_ b -> ((), ) <$> b))
evalError = throwError
infixl 1 `callFunc`
callFunc
:: forall e t f m
. MonadNix e t f m
=> NValue t f m
-> NValue t f m
-> m (NValue t f m)
callFunc fun arg =
do
frames :: Frames <- asks (view hasLens)
when (length frames > 2000) $ throwError $ ErrorCall "Function call stack exhausted"
fun' <- demand fun
case fun' of
NVClosure _params f -> f arg
NVBuiltin name f ->
do
span <- currentPos
withFrame Info ((Calling @m @(NValue t f m)) name span) (f arg)
(NVSet m _) | Just f <- M.lookup "__functor" m ->
((`callFunc` arg) <=< (`callFunc` fun')) =<< demand f
x -> throwError $ ErrorCall $ "Attempt to call non-function: " <> show x
execUnaryOp
:: (Framed e m, MonadCited t f m, Show t)
=> Scopes m (NValue t f m)
-> SrcSpan
-> NUnaryOp
-> NValue t f m
-> m (NValue t f m)
execUnaryOp scope span op arg = do
case arg of
NVConstant c ->
case (op, c) of
(NNeg, NInt i ) -> unaryOp $ NInt (-i)
(NNeg, NFloat f) -> unaryOp $ NFloat (-f)
(NNot, NBool b ) -> unaryOp $ NBool (not b)
_ ->
throwError $ ErrorCall $ "unsupported argument type for unary operator " <> show op
x ->
throwError $ ErrorCall $ "argument to unary operator must evaluate to an atomic type: " <> show x
where
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (pure arg)))
execBinaryOp
:: forall e t f m
. (MonadNix e t f m, MonadEval (NValue t f m) m)
=> Scopes m (NValue t f m)
-> SrcSpan
-> NBinaryOp
-> NValue t f m
-> m (NValue t f m)
-> m (NValue t f m)
execBinaryOp scope span op lval rarg =
case op of
NEq -> helperEq id
NNEq -> helperEq not
NOr -> helperLogic flip True
NAnd -> helperLogic id False
NImpl -> helperLogic id True
_ ->
do
rval <- rarg
rval' <- demand rval
lval' <- demand lval
execBinaryOpForced scope span op lval' rval'
where
helperEq flag =
do
rval <- rarg
eq <- valueEqM lval rval
boolOp rval $ flag eq
helperLogic flp flag =
flp bool
(bypass flag)
(do
rval <- rarg
x <- fromValue rval
boolOp rval x
)
=<< fromValue lval
boolOp rval = toBoolOp (pure rval)
bypass = toBoolOp Nothing
toBoolOp :: Maybe (NValue t f m) -> Bool -> m (NValue t f m)
toBoolOp r b =
pure $
nvConstantP
(Provenance scope (NBinary_ span op (pure lval) r))
(NBool b)
execBinaryOpForced
:: forall e t f m
. (MonadNix e t f m, MonadEval (NValue t f m) m)
=> Scopes m (NValue t f m)
-> SrcSpan
-> NBinaryOp
-> NValue t f m
-> NValue t f m
-> m (NValue t f m)
execBinaryOpForced scope span op lval rval = case op of
NLt -> compare (<)
NLte -> compare (<=)
NGt -> compare (>)
NGte -> compare (>=)
NMinus -> numBinOp (-)
NMult -> numBinOp (*)
NDiv -> numBinOp' div (/)
NConcat ->
case (lval, rval) of
(NVList ls, NVList rs) -> pure $ nvListP prov $ ls <> rs
_ -> unsupportedTypes
NUpdate ->
case (lval, rval) of
(NVSet ls lp, NVSet rs rp) -> pure $ nvSetP prov (rp `M.union` lp) (rs `M.union` ls)
(NVSet ls lp, NVConstant NNull) -> pure $ nvSetP prov lp ls
(NVConstant NNull, NVSet rs rp) -> pure $ nvSetP prov rp rs
_ -> unsupportedTypes
NPlus ->
case (lval, rval) of
(NVConstant _, NVConstant _) -> numBinOp (+)
(NVStr ls, NVStr rs) -> pure $ nvStrP prov (ls <> rs)
(NVStr ls, rs@NVPath{}) ->
(\rs2 -> nvStrP prov (ls <> rs2)) <$>
coerceToString callFunc CopyToStore CoerceStringy rs
(NVPath ls, NVStr rs) ->
maybe
(throwError $ ErrorCall "A string that refers to a store path cannot be appended to a path.") -- data/nix/src/libexpr/eval.cc:1412
(\ rs2 ->
nvPathP prov <$>
makeAbsolutePath @t @f (ls <> toString rs2)
)
(getStringNoContext rs)
(NVPath ls, NVPath rs) -> nvPathP prov <$> makeAbsolutePath @t @f (ls <> rs)
(ls@NVSet{}, NVStr rs) ->
(\ls2 -> nvStrP prov (ls2 <> rs)) <$>
coerceToString callFunc DontCopyToStore CoerceStringy ls
(NVStr ls, rs@NVSet{}) ->
(\rs2 -> nvStrP prov (ls <> rs2)) <$>
coerceToString callFunc DontCopyToStore CoerceStringy rs
_ -> unsupportedTypes
NEq -> alreadyHandled
NNEq -> alreadyHandled
NAnd -> alreadyHandled
NOr -> alreadyHandled
NImpl -> alreadyHandled
NApp -> throwError $ ErrorCall "NApp should be handled by evalApp"
where
prov :: Provenance m (NValue t f m)
prov = Provenance scope (NBinary_ span op (pure lval) (pure rval))
toBool = pure . nvConstantP prov . NBool
compare :: (forall a. Ord a => a -> a -> Bool) -> m (NValue t f m)
compare op = case (lval, rval) of
(NVConstant l, NVConstant r) -> toBool $ l `op` r
(NVStr l, NVStr r) -> toBool $ l `op` r
_ -> unsupportedTypes
toInt = pure . nvConstantP prov . NInt
toFloat = pure . nvConstantP prov . NFloat
numBinOp :: (forall a. Num a => a -> a -> a) -> m (NValue t f m)
numBinOp op = numBinOp' op op
numBinOp'
:: (Integer -> Integer -> Integer)
-> (Float -> Float -> Float)
-> m (NValue t f m)
numBinOp' intOp floatOp = case (lval, rval) of
(NVConstant l, NVConstant r) -> case (l, r) of
(NInt li, NInt ri) -> toInt $ li `intOp` ri
(NInt li, NFloat rf) -> toFloat $ fromInteger li `floatOp` rf
(NFloat lf, NInt ri) -> toFloat $ lf `floatOp` fromInteger ri
(NFloat lf, NFloat rf) -> toFloat $ lf `floatOp` rf
_ -> unsupportedTypes
_ -> unsupportedTypes
unsupportedTypes = throwError $ ErrorCall $ "Unsupported argument types for binary operator " <> show op <> ": " <> show lval <> ", " <> show rval
alreadyHandled = throwError $ ErrorCall $ "This cannot happen: operator " <> show op <> " should have been handled in execBinaryOp."
-- This function is here, rather than in 'Nix.String', because of the need to
-- use 'throwError'.
fromStringNoContext :: Framed e m => NixString -> m Text
fromStringNoContext ns =
maybe
(throwError $ ErrorCall $ "expected string with no context, but got " <> show ns)
pure
(getStringNoContext ns)
addTracing
:: (MonadNix e t f m, Has e Options, 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
pure $ do
opts :: Options <- asks (view hasLens)
let
rendered =
if verbose opts >= Chatty
then
pretty $
#ifdef MIN_VERSION_pretty_show
PS.ppShow (void x)
#else
show (void x)
#endif
else prettyNix (Fix (Fix (NSym "?") <$ x))
msg x = pretty ("eval: " <> replicate depth ' ') <> x
loc <- renderLocation span (msg rendered <> " ...\n")
putStr $ show loc
res <- k v'
print $ msg rendered <> " ...done"
pure res
evalExprLoc :: forall e t f m . MonadNix e t f m => NExprLoc -> m (NValue t f m)
evalExprLoc expr = do
opts :: Options <- asks (view hasLens)
bool
(adi
phi
(addStackFrames @(NValue t f m) . addSourcePositions)
)
(join . (`runReaderT` (0 :: Int)) .
adi
(addTracing phi)
(raise (addStackFrames @(NValue t f m) . addSourcePositions))
)
(tracing opts)
expr
where
phi = Eval.eval . annotated . getCompose
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
exec :: (MonadNix e t f m, MonadInstantiate m) => [Text] -> m (NValue t f m)
exec args = either throwError evalExprLoc =<< exec' args
nixInstantiateExpr
:: (MonadNix e t f m, MonadInstantiate m) => Text -> m (NValue t f m)
nixInstantiateExpr s = either throwError evalExprLoc =<< instantiateExpr s