2018-04-02 07:49:12 +02:00
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
2018-04-02 23:41:42 +02:00
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
2018-04-01 19:33:43 +02:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
2018-04-02 23:41:42 +02:00
|
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
2018-04-02 07:49:12 +02:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2018-04-02 23:41:42 +02:00
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
2018-04-01 19:33:43 +02:00
|
|
|
|
2018-03-30 23:08:38 +02:00
|
|
|
module Nix where
|
|
|
|
|
2018-04-02 23:41:42 +02:00
|
|
|
import Control.Monad
|
2018-04-01 19:33:43 +02:00
|
|
|
import Control.Monad.Fix
|
|
|
|
import Control.Monad.IO.Class
|
|
|
|
import Control.Monad.Reader (MonadReader)
|
|
|
|
import Control.Monad.Trans.Reader
|
2018-03-31 23:43:08 +02:00
|
|
|
import qualified Data.HashMap.Lazy as M
|
2018-04-02 23:41:42 +02:00
|
|
|
import Data.Text (Text)
|
2018-03-30 23:08:38 +02:00
|
|
|
import Nix.Builtins
|
|
|
|
import Nix.Eval
|
2018-03-31 08:00:06 +02:00
|
|
|
import Nix.Expr.Types.Annotated (NExprLoc, stripAnnotation)
|
2018-03-30 23:08:38 +02:00
|
|
|
import Nix.Lint
|
2018-03-30 23:25:03 +02:00
|
|
|
import Nix.Monad
|
2018-03-30 23:08:38 +02:00
|
|
|
import Nix.Monad.Instance
|
2018-03-31 23:43:08 +02:00
|
|
|
import Nix.Scope
|
2018-03-30 23:08:38 +02:00
|
|
|
import Nix.Utils
|
|
|
|
|
|
|
|
-- | Evaluate a nix expression in the default context
|
2018-03-31 23:43:08 +02:00
|
|
|
evalTopLevelExpr :: MonadBuiltins e m
|
2018-03-31 08:00:06 +02:00
|
|
|
=> Maybe FilePath -> NExprLoc -> m (NValueNF m)
|
2018-04-03 04:57:05 +02:00
|
|
|
evalTopLevelExpr mpath expr = do
|
2018-03-30 23:55:30 +02:00
|
|
|
base <- baseEnv
|
2018-04-03 04:57:05 +02:00
|
|
|
(normalForm =<<) $ pushScopes base $ case mpath of
|
2018-04-02 23:41:42 +02:00
|
|
|
Nothing -> framedEvalExpr eval expr
|
2018-04-03 04:57:05 +02:00
|
|
|
Just path -> do
|
|
|
|
traceM $ "Setting __cur_file = " ++ show path
|
|
|
|
ref <- valueThunk $ NVLiteralPath path
|
|
|
|
pushScope (M.singleton "__cur_file" ref)
|
2018-04-02 23:41:42 +02:00
|
|
|
(framedEvalExpr eval expr)
|
2018-03-30 23:08:38 +02:00
|
|
|
|
2018-04-01 19:33:43 +02:00
|
|
|
evalTopLevelExprIO :: Maybe FilePath -> NExprLoc -> IO (NValueNF (Lazy IO))
|
2018-04-03 04:57:05 +02:00
|
|
|
evalTopLevelExprIO mpath = runLazyIO . evalTopLevelExpr mpath
|
2018-03-31 08:00:06 +02:00
|
|
|
|
|
|
|
tracingEvalTopLevelExprIO :: Maybe FilePath -> NExprLoc
|
2018-04-01 19:33:43 +02:00
|
|
|
-> IO (NValueNF (Lazy IO))
|
2018-04-03 04:57:05 +02:00
|
|
|
tracingEvalTopLevelExprIO mpath expr = do
|
2018-04-02 23:41:42 +02:00
|
|
|
traced <- tracingEvalExpr eval expr
|
2018-04-03 04:57:05 +02:00
|
|
|
case mpath of
|
2018-03-30 23:55:30 +02:00
|
|
|
Nothing ->
|
2018-04-01 19:33:43 +02:00
|
|
|
runLazyIO (normalForm =<< (`pushScopes` traced) =<< baseEnv)
|
2018-04-03 04:57:05 +02:00
|
|
|
Just path -> do
|
|
|
|
traceM $ "Setting __cur_file = " ++ show path
|
|
|
|
ref <- runLazyIO (valueThunk $ NVLiteralPath path)
|
|
|
|
let m = M.singleton "__cur_file" ref
|
2018-04-01 19:33:43 +02:00
|
|
|
runLazyIO (baseEnv >>= (`pushScopes` pushScope m traced)
|
2018-03-30 23:55:30 +02:00
|
|
|
>>= normalForm)
|
2018-03-30 23:08:38 +02:00
|
|
|
|
2018-04-01 19:33:43 +02:00
|
|
|
newtype Lint m a = Lint
|
2018-04-02 09:18:01 +02:00
|
|
|
{ runLint :: ReaderT (Context (SThunk (Lint m))) m a }
|
2018-04-01 19:33:43 +02:00
|
|
|
deriving (Functor, Applicative, Monad, MonadFix, MonadIO,
|
2018-04-02 09:18:01 +02:00
|
|
|
MonadReader (Context (SThunk (Lint m))))
|
2018-04-01 19:33:43 +02:00
|
|
|
|
2018-04-02 23:41:42 +02:00
|
|
|
instance (MonadFix m, MonadIO m)
|
|
|
|
=> MonadEval (SThunk (Lint m)) (Symbolic (Lint m)) (Lint m) where
|
|
|
|
wrapThunk = SThunk
|
|
|
|
unwrapThunk = getSThunk
|
|
|
|
|
|
|
|
embedSet s = mkSymbolic [TSet (Just s)]
|
|
|
|
projectSet = unpackSymbolic >=> \case
|
|
|
|
NMany [TSet s] -> return s
|
|
|
|
_ -> return Nothing
|
|
|
|
|
|
|
|
type MText (Lint m) = Text
|
|
|
|
|
|
|
|
wrapText = return
|
|
|
|
unwrapText = return
|
|
|
|
|
|
|
|
embedText = const $ mkSymbolic [TStr]
|
|
|
|
projectText = const $ return Nothing
|
|
|
|
|
2018-04-01 19:33:43 +02:00
|
|
|
runLintIO :: Lint IO a -> IO a
|
|
|
|
runLintIO = flip runReaderT (Context emptyScopes []) . runLint
|
|
|
|
|
2018-04-02 09:18:01 +02:00
|
|
|
symbolicBaseEnv :: Monad m => m (Scopes (SThunk m))
|
2018-04-01 19:33:43 +02:00
|
|
|
symbolicBaseEnv = return [Scope M.empty False]
|
|
|
|
|
2018-04-02 07:49:12 +02:00
|
|
|
lintExprIO :: NExprLoc -> IO (Symbolic (Lint IO))
|
2018-04-01 19:33:43 +02:00
|
|
|
lintExprIO expr =
|
2018-04-03 04:57:05 +02:00
|
|
|
runLintIO $ symbolicBaseEnv
|
|
|
|
>>= (`pushScopes` lintExpr (stripAnnotation expr))
|
2018-04-02 07:49:12 +02:00
|
|
|
|
|
|
|
tracingLintExprIO :: NExprLoc -> IO (Symbolic (Lint IO))
|
|
|
|
tracingLintExprIO expr = do
|
2018-04-02 23:41:42 +02:00
|
|
|
traced <- tracingEvalExpr lint expr
|
2018-04-02 09:18:01 +02:00
|
|
|
ref <- runLintIO $ sthunk $ mkSymbolic [TPath]
|
2018-04-03 04:57:05 +02:00
|
|
|
let m = M.singleton "__cur_file" ref
|
|
|
|
runLintIO $ symbolicBaseEnv >>= (`pushScopes` pushScope m traced)
|