380 lines
14 KiB
Haskell
Executable file
380 lines
14 KiB
Haskell
Executable file
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
{-# LANGUAGE ConstraintKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FunctionalDependencies #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
|
|
module Nix.Eval where
|
|
|
|
import Control.Monad
|
|
import Control.Monad.Fix
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State.Strict
|
|
import Data.Align.Key (alignWithKey)
|
|
import Data.Either (isRight)
|
|
import Data.Fix (Fix(Fix))
|
|
import Data.HashMap.Lazy (HashMap)
|
|
import qualified Data.HashMap.Lazy as M
|
|
import Data.List (partition)
|
|
import Data.List.NonEmpty (NonEmpty(..))
|
|
import Data.Maybe (fromMaybe, catMaybes)
|
|
import Data.Text (Text)
|
|
import Data.These (These(..))
|
|
import Data.Traversable (for)
|
|
import Nix.Atoms
|
|
import Nix.Convert
|
|
import Nix.Expr
|
|
import Nix.Frames
|
|
import Nix.NixString
|
|
import Nix.Scope
|
|
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
|
|
attrMissing :: NonEmpty Text -> Maybe v -> m v
|
|
evaledSym :: Text -> v -> m v
|
|
evalCurPos :: m v
|
|
evalConstant :: NAtom -> m v
|
|
evalString :: NString (m v) -> 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 (m v)
|
|
-> (forall a. m v -> (AttrSet (m v) -> m v -> m (a, v)) -> m (a, v))
|
|
-> m v
|
|
{-
|
|
evalSelect :: v -> NonEmpty Text -> Maybe (m v) -> m v
|
|
evalHasAttr :: v -> NonEmpty Text -> m v
|
|
|
|
-- | This and the following methods are intended to allow things like
|
|
-- adding provenance information.
|
|
evalListElem :: [m v] -> Int -> m v -> m v
|
|
evalList :: [t] -> m v
|
|
evalSetElem :: AttrSet (m v) -> Text -> m v -> m v
|
|
evalSet :: AttrSet t -> AttrSet SourcePos -> m v
|
|
evalRecSetElem :: AttrSet (m v) -> Text -> m v -> m v
|
|
evalRecSet :: AttrSet t -> AttrSet SourcePos -> m v
|
|
evalLetElem :: Text -> m v -> m v
|
|
evalLet :: m v -> m v
|
|
-}
|
|
evalError :: Exception s => s -> m a
|
|
|
|
type MonadNixEval e v t m =
|
|
(MonadEval v m,
|
|
Scoped e t m,
|
|
MonadThunk v t m,
|
|
MonadFix m,
|
|
ToValue Bool m v,
|
|
ToValue [t] m v,
|
|
FromValue NixString m v,
|
|
ToValue (AttrSet t, AttrSet SourcePos) m v,
|
|
FromValue (AttrSet t, AttrSet SourcePos) m v)
|
|
|
|
data EvalFrame m v
|
|
= EvaluatingExpr (Scopes m v) NExprLoc
|
|
| ForcingExpr (Scopes m v) NExprLoc
|
|
| Calling String SrcSpan
|
|
deriving (Show, Typeable)
|
|
|
|
instance (Typeable m, Typeable v) => Exception (EvalFrame m v)
|
|
|
|
eval :: forall e v t m. MonadNixEval e v t m => NExprF (m v) -> m v
|
|
|
|
eval (NSym "__curPos") = evalCurPos
|
|
|
|
eval (NSym var) =
|
|
lookupVar var >>= maybe (freeVariable var) (force ?? evaledSym var)
|
|
|
|
eval (NConstant x) = evalConstant x
|
|
eval (NStr str) = evalString 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
|
|
fun >>= (`evalApp` withScopes scope arg)
|
|
|
|
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
|
|
|
|
eval (NSelect aset attr alt) = evalSelect aset attr >>= either go id
|
|
where
|
|
go (s, ks) = fromMaybe (attrMissing ks (Just s)) alt
|
|
|
|
eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
|
|
|
|
eval (NList l) = do
|
|
scope <- currentScopes
|
|
for l (thunk . withScopes @t scope) >>= toValue
|
|
|
|
eval (NSet binds) =
|
|
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
|
|
|
|
eval (NRecSet binds) =
|
|
evalBinds True (desugarBinds (eval . NSet) binds) >>= toValue
|
|
|
|
eval (NLet binds body) = evalBinds True binds >>= (pushScope ?? body) . fst
|
|
|
|
eval (NIf cond t f) = cond >>= \v -> evalIf v t f
|
|
|
|
eval (NWith scope body) = evalWith scope body
|
|
|
|
eval (NAssert cond body) = cond >>= evalAssert ?? body
|
|
|
|
eval (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 params $ \arg k -> withScopes @t scope $ do
|
|
args <- buildArgument params arg
|
|
pushScope args (k (M.map (`force` pure) args) body)
|
|
|
|
-- | If you know that the 'scope' action will result in an 'AttrSet t', then
|
|
-- this implementation may be used as an implementation for 'evalWith'.
|
|
evalWithAttrSet :: forall e v t m. MonadNixEval e v t m => m v -> m v -> m v
|
|
evalWithAttrSet aset body = do
|
|
-- The scope is deliberately wrapped in a thunk here, since it is
|
|
-- evaluated each time a name is looked up within the weak scope, and
|
|
-- we want to be sure the action it evaluates is to force a thunk, so
|
|
-- its value is only computed once.
|
|
scope <- currentScopes @_ @t
|
|
s <- thunk $ withScopes scope aset
|
|
pushWeakScope ?? body $ force s $
|
|
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
|
|
|
|
attrSetAlter :: forall e v t m. MonadNixEval e v t m
|
|
=> [Text]
|
|
-> SourcePos
|
|
-> AttrSet (m v)
|
|
-> AttrSet SourcePos
|
|
-> m v
|
|
-> m (AttrSet (m v), AttrSet SourcePos)
|
|
attrSetAlter [] _ _ _ _ =
|
|
evalError @v $ ErrorCall "invalid selector with no components"
|
|
|
|
attrSetAlter (k:ks) pos m p val = case M.lookup k m of
|
|
Nothing | null ks -> go
|
|
| otherwise -> recurse M.empty M.empty
|
|
Just x | null ks -> go
|
|
| otherwise ->
|
|
x >>= fromValue @(AttrSet t, AttrSet SourcePos)
|
|
>>= \(st, sp) -> recurse (force ?? pure <$> st) sp
|
|
where
|
|
go = return (M.insert k val m, M.insert k pos p)
|
|
|
|
recurse st sp = attrSetAlter ks pos st sp val <&> \(st', _) ->
|
|
( M.insert k (toValue @(AttrSet t, AttrSet SourcePos)
|
|
=<< (, mempty) . fmap value <$> sequence st') st
|
|
, M.insert k pos sp )
|
|
|
|
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 (SourcePos, [Binding r]))
|
|
(Either VarName (Binding r))
|
|
collect (NamedVar (StaticKey x :| y:ys) val p) = do
|
|
m <- get
|
|
put $ M.insert x ?? m $ case M.lookup x m of
|
|
Nothing -> (p, [NamedVar (y:|ys) val p])
|
|
Just (q, v) -> (q, NamedVar (y:|ys) val q : v)
|
|
pure $ Left x
|
|
collect x = pure $ Right x
|
|
|
|
go :: Either VarName (Binding r)
|
|
-> State (HashMap VarName (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 :| []) (embed v) p
|
|
|
|
evalBinds :: forall e v t m. MonadNixEval e v t m
|
|
=> Bool
|
|
-> [Binding (m v)]
|
|
-> m (AttrSet t, AttrSet SourcePos)
|
|
evalBinds recursive binds = do
|
|
scope <- currentScopes @_ @t
|
|
buildResult scope . concat =<< mapM (go scope) (moveOverridesLast binds)
|
|
where
|
|
moveOverridesLast = uncurry (++) .
|
|
partition (\case
|
|
NamedVar (StaticKey "__overrides" :| []) _ _pos -> False
|
|
_ -> True)
|
|
|
|
go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)]
|
|
go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) =
|
|
finalValue >>= fromValue >>= \(o', p') ->
|
|
-- jww (2018-05-09): What to do with the key position here?
|
|
return $ map (\(k, v) -> ([k], fromMaybe pos (M.lookup k p'),
|
|
force v pure))
|
|
(M.toList o')
|
|
|
|
go _ (NamedVar pathExpr finalValue pos) = do
|
|
let go :: NAttrPath (m v) -> m ([Text], SourcePos, m v)
|
|
go = \case
|
|
h :| t -> evalSetterKeyName h >>= \case
|
|
Nothing ->
|
|
pure ([], nullPos,
|
|
toValue @(AttrSet t, AttrSet SourcePos)
|
|
(mempty, mempty))
|
|
Just k -> 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 pos) = fmap catMaybes $ forM names $
|
|
evalSetterKeyName >=> \case
|
|
Nothing -> pure Nothing
|
|
Just key -> pure $ Just ([key], pos, do
|
|
mv <- case ms of
|
|
Nothing -> withScopes scope $ lookupVar key
|
|
Just s -> s
|
|
>>= fromValue @(AttrSet t, AttrSet SourcePos)
|
|
>>= \(s, _) ->
|
|
clearScopes @t $ pushScope s $ lookupVar key
|
|
case mv of
|
|
Nothing -> attrMissing (key :| []) Nothing
|
|
Just v -> force v pure)
|
|
|
|
buildResult :: Scopes m t
|
|
-> [([Text], SourcePos, m v)]
|
|
-> m (AttrSet t, AttrSet SourcePos)
|
|
buildResult scope bindings = do
|
|
(s, p) <- foldM insert (M.empty, M.empty) bindings
|
|
res <- if recursive
|
|
then loebM (encapsulate <$> s)
|
|
else traverse mkThunk s
|
|
return (res, p)
|
|
where
|
|
mkThunk = thunk . withScopes scope
|
|
|
|
encapsulate f attrs = mkThunk . pushScope attrs $ f
|
|
|
|
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
|
|
|
|
evalSelect :: forall e v t m. MonadNixEval e v t m
|
|
=> m v
|
|
-> NAttrPath (m v)
|
|
-> m (Either (v, NonEmpty Text) (m v))
|
|
evalSelect aset attr = do
|
|
s <- aset
|
|
path <- traverse evalGetterKeyName attr
|
|
extract s path
|
|
where
|
|
extract x path@(k:|ks) = fromValueMay x >>= \case
|
|
Just (s :: AttrSet t, p :: AttrSet SourcePos)
|
|
| Just t <- M.lookup k s -> case ks of
|
|
[] -> pure $ Right $ force t pure
|
|
y:ys -> force t $ extract ?? (y:|ys)
|
|
| otherwise -> Left . (, path) <$> toValue (s, p)
|
|
Nothing -> return $ Left (x, path)
|
|
|
|
-- | Evaluate a component of an attribute path in a context where we are
|
|
-- *retrieving* a value
|
|
evalGetterKeyName :: forall v m. (MonadEval v m, FromValue NixString m v)
|
|
=> NKeyName (m v) -> m Text
|
|
evalGetterKeyName = evalSetterKeyName >=> \case
|
|
Just k -> pure k
|
|
Nothing -> evalError @v $ ErrorCall "value is null while a string was expected"
|
|
|
|
-- | Evaluate a component of an attribute path in a context where we are
|
|
-- *binding* a value
|
|
evalSetterKeyName :: (MonadEval v m, FromValue NixString m v)
|
|
=> NKeyName (m v) -> m (Maybe Text)
|
|
evalSetterKeyName = \case
|
|
StaticKey k -> pure (Just k)
|
|
DynamicKey k ->
|
|
runAntiquoted "\n" assembleString (>>= fromValueMay) k <&>
|
|
\case Just ns -> Just (hackyStringIgnoreContext ns)
|
|
_ -> Nothing
|
|
|
|
assembleString :: forall v m. (MonadEval v m, FromValue NixString m v)
|
|
=> NString (m v) -> m (Maybe NixString)
|
|
assembleString = \case
|
|
Indented _ parts -> fromParts parts
|
|
DoubleQuoted parts -> fromParts parts
|
|
where
|
|
fromParts = fmap (fmap mconcat . sequence) . traverse go
|
|
|
|
go = runAntiquoted "\n" (pure . Just . hackyMakeNixStringWithoutContext) (>>= fromValueMay)
|
|
|
|
buildArgument :: forall e v t m. MonadNixEval e v t m
|
|
=> Params (m v) -> m v -> m (AttrSet t)
|
|
buildArgument params arg = do
|
|
scope <- currentScopes @_ @t
|
|
case params of
|
|
Param name -> M.singleton name <$> thunk (withScopes scope arg)
|
|
ParamSet s isVariadic m ->
|
|
arg >>= fromValue @(AttrSet t, AttrSet SourcePos)
|
|
>>= \(args, _) -> do
|
|
let inject = case m of
|
|
Nothing -> id
|
|
Just n -> M.insert n $ const $
|
|
thunk (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 $ ErrorCall $
|
|
"Missing value for parameter: " ++ show k
|
|
That (Just f) -> \args ->
|
|
thunk $ withScopes scope $ pushScope args f
|
|
This x | isVariadic -> const (pure x)
|
|
| otherwise ->
|
|
const $ evalError @v $ ErrorCall $
|
|
"Unexpected parameter: " ++ show k
|
|
These x _ -> const (pure x)
|
|
|
|
addSourcePositions :: (MonadReader e m, Has e SrcSpan)
|
|
=> Transform NExprLocF (m a)
|
|
addSourcePositions f v@(Fix (Compose (Ann ann _))) =
|
|
local (set hasLens ann) (f v)
|
|
|
|
addStackFrames
|
|
:: forall t e m a. (Scoped e t m, Framed e m, Typeable t, Typeable m)
|
|
=> Transform NExprLocF (m a)
|
|
addStackFrames f v = do
|
|
scopes <- currentScopes @e @t
|
|
withFrame Info (EvaluatingExpr scopes v) (f v)
|
|
|
|
framedEvalExprLoc
|
|
:: forall t e v m.
|
|
(MonadNixEval e v t m, Framed e m, Has e SrcSpan,
|
|
Typeable t, Typeable m)
|
|
=> NExprLoc -> m v
|
|
framedEvalExprLoc = adi (eval . annotated . getCompose)
|
|
(addStackFrames @t . addSourcePositions)
|