Skip to content

Commit 4a173e5

Browse files
Anton-LatukhaAnton-Latukha
committed
Eval: refactor
Post `demand` update refactor.
1 parent 867dd41 commit 4a173e5

File tree

1 file changed

+151
-97
lines changed

1 file changed

+151
-97
lines changed

‎src/Nix/Eval.hs‎

Lines changed: 151 additions & 97 deletions
Original file line numberDiff line numberDiff line change
@@ -29,7 +29,6 @@ import Data.Maybe ( fromMaybe
2929
)
3030
import Data.Text ( Text )
3131
import Data.These ( These(..) )
32-
import Data.Traversable ( for )
3332
import Nix.Atoms
3433
import Nix.Convert
3534
import Nix.Expr
@@ -113,22 +112,24 @@ eval :: forall v m . MonadNixEval v m => NExprF (m v) -> m v
113112

114113
eval (NSym "__curPos") = evalCurPos
115114

116-
eval (NSym var ) = do
117-
mres <- lookupVar var
118-
maybe
119-
(freeVariable var)
120-
(evaledSym var <=< demand)
121-
mres
115+
eval (NSym var ) =
116+
do
117+
mres <- lookupVar var
118+
maybe
119+
(freeVariable var)
120+
(evaledSym var <=< demand)
121+
mres
122122

123123
eval (NConstant x ) = evalConstant x
124124
eval (NStr str ) = evalString str
125125
eval (NLiteralPath p ) = evalLiteralPath p
126126
eval (NEnvPath p ) = evalEnvPath p
127127
eval (NUnary op arg ) = evalUnary op =<< arg
128128

129-
eval (NBinary NApp fun arg) = do
130-
scope <- currentScopes :: m (Scopes m v)
131-
fun >>= (`evalApp` withScopes scope arg)
129+
eval (NBinary NApp fun arg) =
130+
do
131+
scope <- currentScopes :: m (Scopes m v)
132+
(`evalApp` withScopes scope arg) =<< fun
132133

133134
eval (NBinary op larg rarg) = larg >>= evalBinary op ?? rarg
134135

@@ -137,23 +138,33 @@ eval (NSelect aset attr alt ) = evalSelect aset attr >>= either go id
137138

138139
eval (NHasAttr aset attr) = evalSelect aset attr >>= toValue . isRight
139140

140-
eval (NList l ) = do
141-
scope <- currentScopes
142-
for l (defer @v @m . withScopes @v scope) >>= toValue
141+
eval (NList l ) =
142+
do
143+
scope <- currentScopes
144+
toValue =<< traverse (defer @v @m . withScopes @v scope) l
143145

144146
eval (NSet NNonRecursive binds) =
145-
evalBinds False (desugarBinds (eval . NSet NNonRecursive) binds) >>= toValue
147+
toValue =<< evalBinds False (desugarBinds (eval . NSet NNonRecursive) binds)
146148

147149
eval (NSet NRecursive binds) =
148-
evalBinds True (desugarBinds (eval . NSet NNonRecursive) binds) >>= toValue
150+
toValue =<< evalBinds True (desugarBinds (eval . NSet NNonRecursive) binds)
149151

150-
eval (NLet binds body ) = evalBinds True binds >>= (pushScope ?? body) . fst
152+
eval (NLet binds body ) =
153+
do
154+
(x, _) <- evalBinds True binds
155+
pushScope x body
151156

152-
eval (NIf cond t f ) = cond >>= \v -> evalIf v t f
157+
eval (NIf cond t f ) =
158+
do
159+
v <- cond
160+
evalIf v t f
153161

154162
eval (NWith scope body) = evalWith scope body
155163

156-
eval (NAssert cond body) = cond >>= evalAssert ?? body
164+
eval (NAssert cond body) =
165+
do
166+
x <- cond
167+
evalAssert x body
157168

158169
eval (NAbs params body) = do
159170
-- It is the environment at the definition site, not the call site, that
@@ -224,14 +235,15 @@ desugarBinds embed binds = evalState (mapM (go <=< collect) binds) M.empty
224235
-> State
225236
(HashMap VarName (SourcePos, [Binding r]))
226237
(Either VarName (Binding r))
227-
collect (NamedVar (StaticKey x :| y : ys) val p) = do
228-
m <- get
229-
put $ M.insert x ?? m $
230-
maybe
231-
(p, [NamedVar (y :| ys) val p])
232-
(\ (q, v) -> (q, NamedVar (y :| ys) val q : v))
233-
(M.lookup x m)
234-
pure $ Left x
238+
collect (NamedVar (StaticKey x :| y : ys) val p) =
239+
do
240+
m <- get
241+
put $ M.insert x ?? m $
242+
maybe
243+
(p, [NamedVar (y :| ys) val p])
244+
(\ (q, v) -> (q, NamedVar (y :| ys) val q : v))
245+
(M.lookup x m)
246+
pure $ Left x
235247
collect x = pure $ pure x
236248

237249
go
@@ -266,34 +278,60 @@ evalBinds recursive binds = do
266278

267279
go :: Scopes m v -> Binding (m v) -> m [([Text], SourcePos, m v)]
268280
go _ (NamedVar (StaticKey "__overrides" :| []) finalValue pos) =
269-
finalValue >>= fromValue >>= \(o', p') ->
270-
-- jww (2018-05-09): What to do with the key position here?
271-
pure $ fmap
272-
(\(k, v) -> ([k], fromMaybe pos (M.lookup k p'), pure =<< demand v))
273-
(M.toList o')
281+
do
282+
(o', p') <- fromValue =<< finalValue
283+
-- jww (2018-05-09): What to do with the key position here?
284+
pure $
285+
(\ (k, v) ->
286+
( [k]
287+
, fromMaybe pos (M.lookup k p')
288+
, pure =<< demand v
289+
)
290+
) <$>
291+
M.toList o'
274292

275293
go _ (NamedVar pathExpr finalValue pos) = do
276294
let
277295
gogo :: NAttrPath (m v) -> m ([Text], SourcePos, m v)
278-
gogo = \case
279-
h :| t -> evalSetterKeyName h >>= \case
280-
Nothing ->
281-
pure
282-
( mempty
283-
, nullPos
284-
, toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty)
296+
gogo =
297+
\case
298+
h :| t ->
299+
maybe
300+
(pure
301+
( mempty
302+
, nullPos
303+
, toValue @(AttrSet v, AttrSet SourcePos) (mempty, mempty)
304+
)
305+
)
306+
(\ k ->
307+
list
308+
(pure
309+
( [k]
310+
, pos
311+
, finalValue
312+
)
313+
)
314+
(\ (x : xs) ->
315+
do
316+
(restOfPath, _, v) <- gogo (x :| xs)
317+
pure
318+
( k : restOfPath
319+
, pos
320+
, v
321+
)
322+
)
323+
t
285324
)
286-
Just k -> case t of
287-
[] -> pure ([k], pos, finalValue)
288-
x : xs -> do
289-
(restOfPath, _, v) <- gogo (x :| xs)
290-
pure (k : restOfPath, pos, v)
325+
=<< evalSetterKeyName h
291326

292-
gogo pathExpr <&> \case
327+
fmap
328+
(\case
293329
-- When there are no path segments, e.g. `${null} = 5;`, we don't
294330
-- bind anything
295-
([], _, _) -> mempty
296-
result -> [result]
331+
([], _, _) -> mempty
332+
result -> [result]
333+
)
334+
(gogo pathExpr)
297335

298336
go scope (Inherit ms names pos) =
299337
fmap catMaybes $ forM names $ evalSetterKeyName >=>
@@ -302,20 +340,18 @@ evalBinds recursive binds = do
302340
(\ key -> pure
303341
([key]
304342
, pos
305-
, do
306-
mv <-
307-
maybe
308-
(withScopes scope $ lookupVar key)
309-
(\ s ->
310-
-- 2021-02-25: NOTE: This is obviously a do block.
311-
-- In the middle of the huge move, can not test refactor compilation.
312-
s >>= fromValue @(AttrSet v, AttrSet SourcePos) >>= \(attrset, _) ->
313-
clearScopes @v $ pushScope attrset $ lookupVar key)
314-
ms
315-
maybe
343+
, maybe
316344
(attrMissing (key :| []) Nothing)
317345
(pure <=< demand)
318-
mv
346+
=<< maybe
347+
(withScopes scope $ lookupVar key)
348+
(\ s ->
349+
do
350+
(attrset, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< s
351+
352+
clearScopes @v $ pushScope attrset $ lookupVar key
353+
)
354+
ms
319355
)
320356
)
321357
)
@@ -324,10 +360,17 @@ evalBinds recursive binds = do
324360
:: Scopes m v
325361
-> [([Text], SourcePos, m v)]
326362
-> m (AttrSet v, AttrSet SourcePos)
327-
buildResult scope bindings = do
328-
(s, p) <- foldM insert (M.empty, M.empty) bindings
329-
res <- if recursive then loebM (encapsulate <$> s) else traverse mkThunk s
330-
pure (res, p)
363+
buildResult scope bindings =
364+
do
365+
(s, p) <- foldM insert (M.empty, M.empty) bindings
366+
res <-
367+
bool
368+
(traverse mkThunk s)
369+
(loebM (encapsulate <$> s))
370+
recursive
371+
372+
pure (res, p)
373+
331374
where
332375
mkThunk = defer . withScopes scope
333376

@@ -341,18 +384,27 @@ evalSelect
341384
=> m v
342385
-> NAttrPath (m v)
343386
-> m (Either (v, NonEmpty Text) (m v))
344-
evalSelect aset attr = do
345-
s <- aset
346-
path <- traverse evalGetterKeyName attr
347-
extract s path
387+
evalSelect aset attr =
388+
do
389+
s <- aset
390+
path <- traverse evalGetterKeyName attr
391+
392+
extract s path
393+
348394
where
349-
extract x path@(k :| ks) = fromValueMay x >>= \case
350-
Just (s :: AttrSet v, p :: AttrSet SourcePos)
351-
| Just t <- M.lookup k s -> case ks of
352-
[] -> pure $ pure $ pure =<< demand t
353-
y : ys -> (extract ?? (y :| ys)) =<< demand t
354-
| otherwise -> Left . (, path) <$> toValue (s, p)
355-
Nothing -> pure $ Left (x, path)
395+
extract x path@(k :| ks) =
396+
do
397+
x' <- fromValueMay x
398+
case x' of
399+
Just (s :: AttrSet v, p :: AttrSet SourcePos)
400+
| Just t <- M.lookup k s ->
401+
do
402+
list
403+
(pure $ pure $ pure =<< demand t)
404+
(\ (y : ys) -> (extract ?? (y :| ys)) =<< demand t)
405+
ks
406+
| otherwise -> Left . (, path) <$> toValue (s, p)
407+
Nothing -> pure $ Left (x, path)
356408

357409
-- | Evaluate a component of an attribute path in a context where we are
358410
-- *retrieving* a value
@@ -361,10 +413,11 @@ evalGetterKeyName
361413
. (MonadEval v m, FromValue NixString m v)
362414
=> NKeyName (m v)
363415
-> m Text
364-
evalGetterKeyName = evalSetterKeyName >=>
416+
evalGetterKeyName =
365417
maybe
366418
(evalError @v $ ErrorCall "value is null while a string was expected")
367419
pure
420+
<=< evalSetterKeyName
368421

369422
-- | Evaluate a component of an attribute path in a context where we are
370423
-- *binding* a value
@@ -375,7 +428,7 @@ evalSetterKeyName
375428
evalSetterKeyName = \case
376429
StaticKey k -> pure (pure k)
377430
DynamicKey k ->
378-
((pure . stringIgnoreContext) `ifJust`) <$>runAntiquoted "\n" assembleString (fromValueMay =<<) k
431+
((pure . stringIgnoreContext) `ifJust`) <$> runAntiquoted "\n" assembleString (fromValueMay =<<) k
379432

380433
assembleString
381434
:: forall v m
@@ -398,28 +451,29 @@ assembleString =
398451

399452
buildArgument
400453
:: forall v m . MonadNixEval v m => Params (m v) -> m v -> m (AttrSet v)
401-
buildArgument params arg = do
402-
scope <- currentScopes :: m (Scopes m v)
403-
case params of
404-
Param name -> M.singleton name <$> defer (withScopes scope arg)
405-
ParamSet s isVariadic m ->
406-
do
407-
(args, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< arg
408-
let
409-
inject =
410-
maybe
411-
id
412-
(\ n -> M.insert n $ const $ defer (withScopes scope arg))
413-
m
414-
loebM
415-
(inject $
416-
M.mapMaybe
454+
buildArgument params arg =
455+
do
456+
scope <- currentScopes :: m (Scopes m v)
457+
case params of
458+
Param name -> M.singleton name <$> defer (withScopes scope arg)
459+
ParamSet s isVariadic m ->
460+
do
461+
(args, _) <- fromValue @(AttrSet v, AttrSet SourcePos) =<< arg
462+
let
463+
inject =
464+
maybe
417465
id
418-
$ ialignWith
419-
(assemble scope isVariadic)
420-
args
421-
(M.fromList s)
422-
)
466+
(\ n -> M.insert n $ const $ defer (withScopes scope arg))
467+
m
468+
loebM
469+
(inject $
470+
M.mapMaybe
471+
id
472+
(ialignWith
473+
(assemble scope isVariadic)
474+
args
475+
(M.fromList s))
476+
)
423477
where
424478
assemble
425479
:: Scopes m v
@@ -429,7 +483,7 @@ buildArgument params arg = do
429483
-> Maybe (AttrSet v -> m v)
430484
assemble scope isVariadic k =
431485
\case
432-
That Nothing -> pure $ const $ evalError @v $ ErrorCall $ "Missing value for parameter: " <>show k
486+
That Nothing -> pure $ const $ evalError @v $ ErrorCall $ "Missing value for parameter: " <> show k
433487
That (Just f) -> pure $ \args -> defer $ withScopes scope $ pushScope args f
434488
This _
435489
| isVariadic -> Nothing

0 commit comments

Comments
 (0)