/
Entry.hs
146 lines (134 loc) · 5.1 KB
/
Entry.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
module Nix.Entry where
import Control.Applicative
import Control.Arrow (second)
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Fix
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as Text
import qualified Data.Text.Read as Text
import Nix.Builtins
import Nix.Effects
import qualified Nix.Eval as Eval
import qualified Nix.Trace as Trace
import Nix.Expr.Shorthands
import Nix.Expr.Types (NExpr)
import Nix.Expr.Types.Annotated (NExprLoc, stripAnnotation)
import Nix.Normal
import Nix.Options
import Nix.Parser
import Nix.Parser.Library (Result(..))
import Nix.Pretty
import Nix.Scope
import Nix.Stack
import Nix.Thunk
import Nix.Utils
import Nix.Value
type MonadNix e m =
(Scoped e (NThunk m) m, Framed e m, MonadVar m, MonadFile m,
MonadEffects m, MonadFix m, MonadCatch m)
-- | Evaluate a nix expression in the default context
evalTopLevelExprGen :: forall e m a r. MonadNix e m
=> (a -> m r) -> Maybe FilePath -> a -> m r
evalTopLevelExprGen cont mpath expr = do
base <- baseEnv
opts :: Options <- asks (view hasLens)
let i = value @(NValue m) @(NThunk m) @m $ NVList $
map (value @(NValue m) @(NThunk m) @m
. flip NVStr mempty . Text.pack) (include opts)
pushScope (M.singleton "__includes" i) $
pushScopes base $ case mpath of
Nothing -> cont expr
Just path -> do
traceM $ "Setting __cur_file = " ++ show path
let ref = value @(NValue m) @(NThunk m) @m $ NVPath path
pushScope (M.singleton "__cur_file" ref) $ cont expr
-- | Evaluate a nix expression in the default context
eval :: forall e m. MonadNix e m
=> Maybe FilePath -> NExpr -> m (NValue m)
eval = evalTopLevelExprGen $
Eval.evalExpr @_ @(NValue m) @(NThunk m) @m
-- | Evaluate a nix expression in the default context
evalLoc :: forall e m. MonadNix e m
=> Maybe FilePath -> NExprLoc -> m (NValue m)
evalLoc = evalTopLevelExprGen $
Eval.framedEvalExpr (Eval.eval @_ @(NValue m) @(NThunk m) @m)
tracingEvalLoc
:: forall e m. (MonadNix e m, Alternative m, MonadIO m)
=> Maybe FilePath -> NExprLoc -> m (NValue m)
tracingEvalLoc mpath expr = do
(expr', v) <- evalTopLevelExprGen id mpath
=<< Trace.tracingEvalExpr @_ @m @_ @(NValue m)
(Eval.eval @_ @(NValue m)
@(NThunk m) @m) expr
liftIO $ do
putStrLn "Evaluated expression tree:"
putStrLn "--------"
print $ prettyNix (stripAnnotation expr)
putStrLn "--------"
print $ prettyNix (stripAnnotation expr')
putStrLn "--------"
return v
evaluateExpression
:: forall e m a. MonadNix e m
=> Maybe FilePath
-> (Maybe FilePath -> NExprLoc -> m (NValue m))
-> (NValue m -> m a)
-> NExprLoc
-> m a
evaluateExpression mpath evaluator handler expr = do
opts :: Options <- asks (view hasLens)
args <- traverse (traverse eval') $
map (second parseArg) (arg opts) ++
map (second mkStr) (argstr opts)
compute evaluator expr (argmap args) handler
where
parseArg s = case parseNixText s of
Success x -> x
Failure err -> errorWithoutStackTrace (show err)
eval' = (normalForm =<<) . eval mpath
argmap args = embed $ Fix $ NVSet (M.fromList args) mempty
compute ev x args p = do
f <- ev mpath x
processResult p =<< case f of
NVClosure _ g -> g args
_ -> pure f
processResult :: forall e m a. MonadNix e m
=> (NValue m -> m a) -> NValue m -> m a
processResult h val = do
opts :: Options <- asks (view hasLens)
case attr opts of
Nothing -> h val
Just (Text.splitOn "." -> keys) -> go keys val
where
go :: [Text.Text] -> NValue m -> m a
go [] v = h v
go ((Text.decimal -> Right (n,"")):ks) v = case v of
NVList xs -> case ks of
[] -> force @(NValue m) @(NThunk m) (xs !! n) h
_ -> force (xs !! n) (go ks)
_ -> errorWithoutStackTrace $
"Expected a list for selector '" ++ show n
++ "', but got: " ++ show v
go (k:ks) v = case v of
NVSet xs _ -> case M.lookup k xs of
Nothing ->
errorWithoutStackTrace $
"Set does not contain key '"
++ Text.unpack k ++ "'"
Just v' -> case ks of
[] -> force v' h
_ -> force v' (go ks)
_ -> errorWithoutStackTrace $
"Expected a set for selector '" ++ Text.unpack k
++ "', but got: " ++ show v