{-# 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.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
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
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 (Text, DList Text) 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 . NRecSet) 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
scope <- currentScopes @_ @t
evalAbs params $ \arg k -> withScopes @t scope $ do
args <- buildArgument params arg
pushScope args (k (M.map (`force` pure) args) body)
evalWithAttrSet :: forall e v t m. MonadNixEval e v t m => m v -> m v -> m v
evalWithAttrSet aset body = do
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 = (\(x, y) -> y ++ x) .
partition (\case NamedVar (StaticKey "__overrides" :| []) _ _pos -> True
_ -> False)
go :: Scopes m t -> Binding (m v) -> m [([Text], SourcePos, m v)]
go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) =
finalValue >>= fromValue >>= \(o', p') ->
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
([], _, _) -> []
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)
evalGetterKeyName :: forall v m. (MonadEval v m, FromValue (Text, DList Text) 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"
evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
=> NKeyName (m v) -> m (Maybe Text)
evalSetterKeyName = \case
StaticKey k -> pure (Just k)
DynamicKey k -> runAntiquoted "\n" assembleString (>>= fromValueMay) k
<&> \case Just (t, _) -> Just t
_ -> Nothing
assembleString :: forall v m. (MonadEval v m, FromValue (Text, DList Text) m v)
=> NString (m v) -> m (Maybe (Text, DList Text))
assembleString = \case
Indented _ parts -> fromParts parts
DoubleQuoted parts -> fromParts parts
where
fromParts = fmap (fmap mconcat . sequence) . traverse go
go = runAntiquoted "\n" (pure . Just . (, mempty)) (>>= 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)