Some refactoring and simplification in Eval.hs
This commit is contained in:
parent
1d5c0370ae
commit
f59a17db72
146
src/Nix/Eval.hs
146
src/Nix/Eval.hs
|
@ -1,19 +1,14 @@
|
|||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# 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 #-}
|
||||
|
||||
|
@ -23,16 +18,16 @@ import Control.Monad
|
|||
import Control.Monad.Fix
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad.State.Strict
|
||||
import Data.Align.Key
|
||||
import Data.Fix
|
||||
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 qualified Data.Text as Text
|
||||
import Data.These
|
||||
import Data.These (These(..))
|
||||
import Data.Traversable (for)
|
||||
import Nix.Atoms
|
||||
import Nix.Convert
|
||||
|
@ -44,10 +39,9 @@ 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
|
||||
|
||||
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
|
||||
|
@ -64,7 +58,6 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
|
|||
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
|
||||
|
@ -80,7 +73,6 @@ class (Show v, Monad m) => MonadEval v m | v -> m where
|
|||
evalLetElem :: Text -> m v -> m v
|
||||
evalLet :: m v -> m v
|
||||
-}
|
||||
|
||||
evalError :: Exception s => s -> m a
|
||||
|
||||
type MonadNixEval e v t m =
|
||||
|
@ -109,52 +101,35 @@ 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 (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
|
||||
evalApp ?? withScopes scope arg =<< fun
|
||||
fun >>= (`evalApp` withScopes scope arg)
|
||||
|
||||
eval (NBinary op larg rarg) = larg >>= \lval -> evalBinary op lval rarg
|
||||
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
|
||||
|
||||
eval (NSelect aset attr alt) = do
|
||||
traceM "NSelect"
|
||||
mres <- evalSelect aset attr
|
||||
traceM "NSelect..2"
|
||||
case mres of
|
||||
Right v -> v
|
||||
Left (s, ks) -> fromMaybe (attrMissing ks (Just s)) alt
|
||||
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) =
|
||||
toValue . either (const False) (const True) =<< evalSelect aset attr
|
||||
eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
|
||||
|
||||
eval (NList l) = do
|
||||
scope <- currentScopes
|
||||
toValue =<< for l (thunk . withScopes @t scope)
|
||||
for l (thunk . withScopes @t scope) >>= toValue
|
||||
|
||||
eval (NSet binds) = do
|
||||
traceM "NSet..1"
|
||||
(s, p) <- evalBinds False (desugarBinds (eval . NSet) binds)
|
||||
traceM $ "NSet..2: s = " ++ show (void s)
|
||||
traceM $ "NSet..2: p = " ++ show (void p)
|
||||
toValue (s, p)
|
||||
eval (NSet binds) =
|
||||
evalBinds False (desugarBinds (eval . NSet) binds) >>= toValue
|
||||
|
||||
eval (NRecSet binds) = do
|
||||
traceM "NRecSet..1"
|
||||
(s, p) <- evalBinds True (desugarBinds (eval . NRecSet) binds)
|
||||
traceM $ "NRecSet..2: s = " ++ show (void s)
|
||||
traceM $ "NRecSet..2: p = " ++ show (void p)
|
||||
toValue (s, p)
|
||||
eval (NRecSet binds) =
|
||||
evalBinds True (desugarBinds (eval . NRecSet) binds) >>= toValue
|
||||
|
||||
eval (NLet binds body) = do
|
||||
traceM "Let..1"
|
||||
(s, _) <- evalBinds True binds
|
||||
traceM $ "Let..2: s = " ++ show (void s)
|
||||
pushScope s body
|
||||
eval (NLet binds body) = evalBinds True binds >>= (pushScope ?? body) . fst
|
||||
|
||||
eval (NIf cond t f) = cond >>= \v -> evalIf v t f
|
||||
|
||||
|
@ -168,21 +143,20 @@ eval (NAbs params body) = do
|
|||
-- 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)
|
||||
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 scope body = do
|
||||
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.
|
||||
cur <- currentScopes @_ @t
|
||||
s <- thunk $ withScopes cur scope
|
||||
scope <- currentScopes @_ @t
|
||||
s <- thunk $ withScopes scope aset
|
||||
pushWeakScope ?? body $ force s $
|
||||
fmap fst . fromValue @(AttrSet t, AttrSet SourcePos)
|
||||
|
||||
|
@ -195,15 +169,14 @@ attrSetAlter :: forall e v t m. MonadNixEval e v t m
|
|||
-> 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
|
||||
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)
|
||||
|
||||
|
@ -222,7 +195,7 @@ desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
|
|||
m <- get
|
||||
put $ M.insert x ?? m $ case M.lookup x m of
|
||||
Nothing -> (p, [NamedVar (y:|ys) val p])
|
||||
Just (p, v) -> (p, NamedVar (y:|ys) val p : v)
|
||||
Just (q, v) -> (q, NamedVar (y:|ys) val q : v)
|
||||
pure $ Left x
|
||||
collect x = pure $ Right x
|
||||
|
||||
|
@ -275,8 +248,8 @@ evalBinds recursive binds = do
|
|||
|
||||
go scope (Inherit ms names pos) = fmap catMaybes $ forM names $
|
||||
evalSetterKeyName >=> \case
|
||||
Nothing -> return Nothing
|
||||
Just key -> return $ Just ([key], pos, do
|
||||
Nothing -> pure Nothing
|
||||
Just key -> pure $ Just ([key], pos, do
|
||||
mv <- case ms of
|
||||
Nothing -> withScopes scope $ lookupVar key
|
||||
Just s -> s
|
||||
|
@ -294,10 +267,12 @@ evalBinds recursive binds = do
|
|||
(s, p) <- foldM insert (M.empty, M.empty) bindings
|
||||
res <- if recursive
|
||||
then loebM (encapsulate <$> s)
|
||||
else traverse (thunk . withScopes scope) s
|
||||
else traverse mkThunk s
|
||||
return (res, p)
|
||||
where
|
||||
encapsulate f attrs = thunk . withScopes scope . pushScope attrs $ f
|
||||
mkThunk = thunk . withScopes scope
|
||||
|
||||
encapsulate f attrs = mkThunk . pushScope attrs $ f
|
||||
|
||||
insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
|
||||
|
||||
|
@ -306,27 +281,17 @@ evalSelect :: forall e v t m. MonadNixEval e v t m
|
|||
-> NAttrPath (m v)
|
||||
-> m (Either (v, NonEmpty Text) (m v))
|
||||
evalSelect aset attr = do
|
||||
traceM "evalSelect"
|
||||
s <- aset
|
||||
traceM "evalSelect..2"
|
||||
path <- traverse evalGetterKeyName attr
|
||||
traceM $ "evalSelect..3: " ++ show path
|
||||
res <- extract s path
|
||||
traceM "evalSelect..4"
|
||||
return res
|
||||
extract s path
|
||||
where
|
||||
extract x path@(k:|ks) = fromValueMay x >>= \case
|
||||
Just (s :: AttrSet t, p :: AttrSet SourcePos) ->
|
||||
case M.lookup k s of
|
||||
Just t -> do
|
||||
traceM $ "Forcing value at selector " ++ Text.unpack k
|
||||
case ks of
|
||||
[] -> pure $ Right $ force t pure
|
||||
y:ys -> force t $ extract ?? (y:|ys)
|
||||
Nothing ->
|
||||
Left . (, path) <$> toValue (s, p)
|
||||
Nothing ->
|
||||
return $ Left (x, path)
|
||||
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
|
||||
|
@ -341,7 +306,7 @@ evalGetterKeyName = evalSetterKeyName >=> \case
|
|||
evalSetterKeyName :: (MonadEval v m, FromValue (Text, DList Text) m v)
|
||||
=> NKeyName (m v) -> m (Maybe Text)
|
||||
evalSetterKeyName = \case
|
||||
StaticKey k -> pure (Just k)
|
||||
StaticKey k -> pure (Just k)
|
||||
DynamicKey k -> runAntiquoted "\n" assembleString (>>= fromValueMay) k
|
||||
<&> \case Just (t, _) -> Just t
|
||||
_ -> Nothing
|
||||
|
@ -352,17 +317,16 @@ assembleString = \case
|
|||
Indented _ parts -> fromParts parts
|
||||
DoubleQuoted parts -> fromParts parts
|
||||
where
|
||||
go = runAntiquoted "\n" (pure . Just . (, mempty)) (>>= fromValueMay)
|
||||
fromParts = fmap (fmap mconcat . sequence) . traverse go
|
||||
|
||||
fromParts parts = fmap mconcat . sequence <$> mapM go parts
|
||||
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)
|
||||
Param name -> M.singleton name <$> thunk (withScopes scope arg)
|
||||
ParamSet s isVariadic m ->
|
||||
arg >>= fromValue @(AttrSet t, AttrSet SourcePos)
|
||||
>>= \(args, _) -> do
|
||||
|
|
Loading…
Reference in a new issue