2018-04-09 09:52:10 +02:00
|
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
|
|
{-# LANGUAGE ApplicativeDo #-}
|
2018-04-29 02:12:32 +02:00
|
|
|
{-# LANGUAGE CPP #-}
|
2018-04-09 09:52:10 +02:00
|
|
|
{-# LANGUAGE ConstraintKinds #-}
|
2018-04-11 06:01:48 +02:00
|
|
|
{-# LANGUAGE DeriveFunctor #-}
|
2018-04-09 09:52:10 +02:00
|
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
|
|
{-# LANGUAGE FlexibleInstances #-}
|
2018-04-11 06:01:48 +02:00
|
|
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
2018-04-09 09:52:10 +02:00
|
|
|
{-# LANGUAGE LambdaCase #-}
|
|
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
|
|
{-# LANGUAGE MultiWayIf #-}
|
2018-04-11 06:01:48 +02:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2018-04-09 09:52:10 +02:00
|
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2018-04-18 06:32:20 +02:00
|
|
|
{-# LANGUAGE TupleSections #-}
|
2018-04-09 09:52:10 +02:00
|
|
|
{-# LANGUAGE TypeApplications #-}
|
|
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
{-# LANGUAGE TypeSynonymInstances #-}
|
|
|
|
{-# LANGUAGE UndecidableInstances #-}
|
2018-04-14 01:37:11 +02:00
|
|
|
{-# LANGUAGE ViewPatterns #-}
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-04-11 06:01:48 +02:00
|
|
|
{-# OPTIONS_GHC -Wno-missing-signatures #-}
|
2018-04-09 09:52:10 +02:00
|
|
|
{-# OPTIONS_GHC -Wno-orphans #-}
|
2018-04-11 06:01:48 +02:00
|
|
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
2018-04-09 09:52:10 +02:00
|
|
|
|
|
|
|
module Nix.Exec where
|
|
|
|
|
2018-04-14 04:29:18 +02:00
|
|
|
import Control.Applicative
|
2018-04-09 09:52:10 +02:00
|
|
|
import Control.Monad
|
2018-04-11 06:01:48 +02:00
|
|
|
import Control.Monad.Catch
|
|
|
|
import Control.Monad.Fix
|
|
|
|
import Control.Monad.IO.Class
|
2018-04-21 19:26:42 +02:00
|
|
|
import Control.Monad.Reader
|
2018-04-29 01:13:24 +02:00
|
|
|
import Control.Monad.State.Strict
|
2018-04-21 19:26:42 +02:00
|
|
|
import Control.Monad.Trans.Reader (ReaderT(..))
|
2018-04-29 01:13:24 +02:00
|
|
|
import Control.Monad.Trans.State.Strict (StateT(..))
|
2018-04-11 06:01:48 +02:00
|
|
|
import qualified Data.ByteString as BS
|
2018-04-09 09:52:10 +02:00
|
|
|
import Data.Coerce
|
2018-04-11 06:01:48 +02:00
|
|
|
import Data.Fix
|
2018-04-14 03:09:12 +02:00
|
|
|
import Data.HashMap.Lazy (HashMap)
|
2018-04-09 09:52:10 +02:00
|
|
|
import qualified Data.HashMap.Lazy as M
|
2018-04-11 06:01:48 +02:00
|
|
|
import Data.IORef
|
|
|
|
import Data.List
|
2018-05-03 00:07:30 +02:00
|
|
|
import qualified Data.List.NonEmpty as NE
|
2018-04-11 06:01:48 +02:00
|
|
|
import Data.List.Split
|
2018-05-09 23:39:27 +02:00
|
|
|
import Data.Monoid
|
2018-04-09 09:52:10 +02:00
|
|
|
import Data.Text (Text)
|
|
|
|
import qualified Data.Text as Text
|
2018-04-24 11:14:27 +02:00
|
|
|
import Data.Typeable
|
2018-05-03 06:38:13 +02:00
|
|
|
import Network.HTTP.Client
|
|
|
|
import Network.HTTP.Client.TLS
|
|
|
|
import Network.HTTP.Types
|
2018-04-09 09:52:10 +02:00
|
|
|
import Nix.Atoms
|
2018-04-11 06:01:48 +02:00
|
|
|
import Nix.Context
|
2018-04-14 03:09:12 +02:00
|
|
|
import Nix.Convert
|
2018-04-11 06:01:48 +02:00
|
|
|
import Nix.Effects
|
2018-04-21 07:36:40 +02:00
|
|
|
import Nix.Eval as Eval
|
2018-04-09 09:52:10 +02:00
|
|
|
import Nix.Expr
|
2018-04-24 11:14:27 +02:00
|
|
|
import Nix.Frames
|
2018-05-08 22:47:50 +02:00
|
|
|
import Nix.NixString
|
2018-04-09 09:52:10 +02:00
|
|
|
import Nix.Normal
|
2018-04-18 02:25:59 +02:00
|
|
|
import Nix.Options
|
2018-04-11 06:01:48 +02:00
|
|
|
import Nix.Parser
|
2018-04-09 09:52:10 +02:00
|
|
|
import Nix.Pretty
|
2018-04-24 11:14:27 +02:00
|
|
|
import Nix.Render
|
2018-04-11 06:01:48 +02:00
|
|
|
import Nix.Scope
|
2018-04-09 09:52:10 +02:00
|
|
|
import Nix.Thunk
|
|
|
|
import Nix.Utils
|
|
|
|
import Nix.Value
|
2018-05-13 23:17:55 +02:00
|
|
|
#ifdef MIN_VERSION_haskeline
|
2018-04-29 01:13:24 +02:00
|
|
|
import System.Console.Haskeline.MonadException hiding (catch)
|
2018-05-09 01:40:56 +02:00
|
|
|
#endif
|
2018-04-11 06:01:48 +02:00
|
|
|
import System.Directory
|
|
|
|
import System.Environment
|
|
|
|
import System.Exit (ExitCode (ExitSuccess))
|
|
|
|
import System.FilePath
|
|
|
|
import qualified System.Info
|
|
|
|
import System.Posix.Files
|
|
|
|
import System.Process (readProcessWithExitCode)
|
2018-04-21 19:26:42 +02:00
|
|
|
import Text.PrettyPrint.ANSI.Leijen (text)
|
2018-04-26 06:01:45 +02:00
|
|
|
import qualified Text.PrettyPrint.ANSI.Leijen as P
|
2018-05-13 23:17:55 +02:00
|
|
|
#ifdef MIN_VERSION_pretty_show
|
2018-05-09 23:39:27 +02:00
|
|
|
import qualified Text.Show.Pretty as PS
|
2018-05-13 23:17:55 +02:00
|
|
|
#endif
|
2018-04-21 07:36:40 +02:00
|
|
|
|
2018-04-29 03:38:43 +02:00
|
|
|
#ifdef MIN_VERSION_ghc_datasize
|
2018-04-29 03:29:37 +02:00
|
|
|
#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804
|
2018-04-29 02:12:32 +02:00
|
|
|
import GHC.DataSize
|
|
|
|
#endif
|
2018-04-29 03:38:43 +02:00
|
|
|
#endif
|
2018-04-29 02:12:32 +02:00
|
|
|
|
2018-04-21 07:36:40 +02:00
|
|
|
type MonadNix e m =
|
2018-04-27 00:58:59 +02:00
|
|
|
(Scoped e (NThunk m) m, Framed e m, Has e SrcSpan, Has e Options,
|
|
|
|
Typeable m, MonadVar m, MonadEffects m, MonadFix m, MonadCatch m,
|
|
|
|
Alternative m)
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-04-28 01:36:24 +02:00
|
|
|
data ExecFrame m = Assertion SrcSpan (NValue m)
|
2018-04-24 20:12:20 +02:00
|
|
|
deriving (Show, Typeable)
|
|
|
|
|
2018-05-02 02:33:17 +02:00
|
|
|
instance Typeable m => Exception (ExecFrame m)
|
2018-04-24 20:12:20 +02:00
|
|
|
|
2018-05-02 02:33:17 +02:00
|
|
|
nverr :: forall s e m a. (MonadNix e m, Exception s) => s -> m a
|
2018-04-09 09:52:10 +02:00
|
|
|
nverr = evalError @(NValue m)
|
|
|
|
|
2018-04-25 22:00:41 +02:00
|
|
|
currentPos :: forall e m. (MonadReader e m, Has e SrcSpan) => m SrcSpan
|
2018-05-06 09:40:08 +02:00
|
|
|
currentPos = asks (view hasLens)
|
2018-04-25 22:00:41 +02:00
|
|
|
|
2018-04-25 08:09:43 +02:00
|
|
|
wrapExprLoc :: SrcSpan -> NExprLocF r -> NExprLoc
|
|
|
|
wrapExprLoc span x = Fix (Fix (NSym_ span "<?>") <$ x)
|
|
|
|
|
2018-04-14 03:09:12 +02:00
|
|
|
instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
|
2018-04-25 08:09:43 +02:00
|
|
|
thunk mv = do
|
2018-04-27 00:58:59 +02:00
|
|
|
opts :: Options <- asks (view hasLens)
|
2018-04-25 08:09:43 +02:00
|
|
|
|
2018-04-27 00:58:59 +02:00
|
|
|
if thunks opts
|
|
|
|
then do
|
2018-05-06 09:34:38 +02:00
|
|
|
frames :: Frames <- asks (view hasLens)
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-04-27 00:58:59 +02:00
|
|
|
-- Gather the current evaluation context at the time of thunk
|
|
|
|
-- creation, and record it along with the thunk.
|
2018-05-02 02:33:17 +02:00
|
|
|
let go (fromException ->
|
|
|
|
Just (EvaluatingExpr scope
|
|
|
|
(Fix (Compose (Ann span e))))) =
|
2018-04-27 00:58:59 +02:00
|
|
|
let e' = Compose (Ann span (Nothing <$ e))
|
|
|
|
in [Provenance scope e']
|
|
|
|
go _ = []
|
|
|
|
ps = concatMap (go . frame) frames
|
|
|
|
|
|
|
|
fmap (NThunk ps . coerce) . buildThunk $ mv
|
|
|
|
else
|
|
|
|
fmap (NThunk [] . coerce) . buildThunk $ mv
|
2018-04-25 22:00:41 +02:00
|
|
|
|
2018-05-02 02:33:17 +02:00
|
|
|
-- The ThunkLoop exception is thrown as an exception with MonadThrow,
|
|
|
|
-- which does not capture the current stack frame information to provide
|
|
|
|
-- it in a NixException, so we catch and re-throw it here using
|
|
|
|
-- 'throwError' from Frames.hs.
|
|
|
|
force (NThunk ps t) f = catch go (throwError @ThunkLoop)
|
|
|
|
where
|
|
|
|
go = case ps of
|
|
|
|
[] -> forceThunk t f
|
|
|
|
Provenance scope e@(Compose (Ann span _)):_ ->
|
|
|
|
withFrame Info (ForcingExpr scope (wrapExprLoc span e))
|
|
|
|
(forceThunk t f)
|
2018-04-25 22:00:41 +02:00
|
|
|
|
|
|
|
value = NThunk [] . coerce . valueRef
|
2018-04-22 23:32:55 +02:00
|
|
|
|
2018-04-27 00:58:59 +02:00
|
|
|
{-
|
|
|
|
prov :: MonadNix e m
|
|
|
|
=> (NValue m -> Provenance m) -> NValue m -> m (NValue m)
|
|
|
|
prov p v = do
|
|
|
|
opts :: Options <- asks (view hasLens)
|
|
|
|
pure $ if values opts
|
|
|
|
then addProvenance p v
|
|
|
|
else v
|
|
|
|
-}
|
|
|
|
|
2018-04-14 03:09:12 +02:00
|
|
|
instance MonadNix e m => MonadEval (NValue m) m where
|
2018-04-11 20:53:30 +02:00
|
|
|
freeVariable var =
|
2018-05-02 02:33:17 +02:00
|
|
|
nverr $ ErrorCall $ "Undefined variable '" ++ Text.unpack var ++ "'"
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-05-03 00:07:30 +02:00
|
|
|
attrMissing ks Nothing =
|
|
|
|
evalError @(NValue m) $ ErrorCall $
|
|
|
|
"Inheriting unknown attribute: "
|
|
|
|
++ intercalate "." (map Text.unpack (NE.toList ks))
|
|
|
|
|
|
|
|
attrMissing ks (Just s) =
|
|
|
|
evalError @(NValue m) $ ErrorCall $ "Could not look up attribute "
|
|
|
|
++ intercalate "." (map Text.unpack (NE.toList ks))
|
|
|
|
++ " in " ++ show s
|
|
|
|
|
2018-04-09 09:52:10 +02:00
|
|
|
evalCurPos = do
|
2018-04-23 19:06:49 +02:00
|
|
|
scope <- currentScopes
|
2018-04-25 22:00:41 +02:00
|
|
|
span@(SrcSpan delta _) <- currentPos
|
2018-04-25 06:41:23 +02:00
|
|
|
addProvenance (\_ -> Provenance scope (NSym_ span "__curPos"))
|
|
|
|
<$> toValue delta
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-04-23 19:06:49 +02:00
|
|
|
evaledSym name val = do
|
2018-04-25 06:41:23 +02:00
|
|
|
scope <- currentScopes
|
2018-04-23 19:06:49 +02:00
|
|
|
span <- currentPos
|
2018-04-25 06:41:23 +02:00
|
|
|
pure $ addProvenance (const $ Provenance scope (NSym_ span name)) val
|
2018-04-23 19:06:49 +02:00
|
|
|
|
|
|
|
evalConstant c = do
|
2018-04-22 23:32:55 +02:00
|
|
|
scope <- currentScopes
|
|
|
|
span <- currentPos
|
2018-04-25 06:41:23 +02:00
|
|
|
pure $ nvConstantP (Provenance scope (NConstant_ span c)) c
|
2018-04-22 23:32:55 +02:00
|
|
|
|
2018-05-01 01:57:23 +02:00
|
|
|
evalString = assembleString >=> \case
|
2018-07-28 21:32:15 +02:00
|
|
|
Just ns -> do
|
2018-05-01 01:57:23 +02:00
|
|
|
scope <- currentScopes
|
|
|
|
span <- currentPos
|
|
|
|
pure $ nvStrP (Provenance scope
|
2018-07-28 21:32:15 +02:00
|
|
|
(NStr_ span (DoubleQuoted [Plain (stringIntentionallyDropContext ns)]))) ns
|
2018-05-06 09:34:38 +02:00
|
|
|
Nothing -> nverr $ ErrorCall "Failed to assemble string"
|
2018-04-22 23:32:55 +02:00
|
|
|
|
|
|
|
evalLiteralPath p = do
|
|
|
|
scope <- currentScopes
|
|
|
|
span <- currentPos
|
2018-04-25 06:41:23 +02:00
|
|
|
nvPathP (Provenance scope (NLiteralPath_ span p)) <$> makeAbsolutePath p
|
2018-04-22 23:32:55 +02:00
|
|
|
|
|
|
|
evalEnvPath p = do
|
|
|
|
scope <- currentScopes
|
|
|
|
span <- currentPos
|
2018-04-25 06:41:23 +02:00
|
|
|
nvPathP (Provenance scope (NEnvPath_ span p)) <$> findEnvPath p
|
2018-04-22 23:32:55 +02:00
|
|
|
|
|
|
|
evalUnary op arg = do
|
|
|
|
scope <- currentScopes
|
|
|
|
span <- currentPos
|
|
|
|
execUnaryOp scope span op arg
|
|
|
|
|
|
|
|
evalBinary op larg rarg = do
|
|
|
|
scope <- currentScopes
|
|
|
|
span <- currentPos
|
|
|
|
execBinaryOp scope span op larg rarg
|
|
|
|
|
|
|
|
evalWith c b = do
|
2018-04-25 06:41:23 +02:00
|
|
|
scope <- currentScopes
|
2018-04-23 19:06:49 +02:00
|
|
|
span <- currentPos
|
2018-04-25 06:41:23 +02:00
|
|
|
addProvenance (\b -> Provenance scope (NWith_ span Nothing (Just b)))
|
2018-04-23 19:06:49 +02:00
|
|
|
<$> evalWithAttrSet c b
|
2018-04-22 23:32:55 +02:00
|
|
|
|
|
|
|
evalIf c t f = do
|
|
|
|
scope <- currentScopes
|
|
|
|
span <- currentPos
|
|
|
|
fromValue c >>= \b ->
|
|
|
|
if b
|
2018-04-25 06:41:23 +02:00
|
|
|
then addProvenance (\t -> Provenance scope (NIf_ span (Just c) (Just t) Nothing)) <$> t
|
|
|
|
else addProvenance (\f -> Provenance scope (NIf_ span (Just c) Nothing (Just f))) <$> f
|
2018-04-23 19:06:49 +02:00
|
|
|
|
2018-04-28 01:36:24 +02:00
|
|
|
evalAssert c body = fromValue c >>= \b -> do
|
|
|
|
span <- currentPos
|
2018-04-23 19:06:49 +02:00
|
|
|
if b
|
2018-05-02 22:46:32 +02:00
|
|
|
then do
|
|
|
|
scope <- currentScopes
|
|
|
|
addProvenance (\b -> Provenance scope (NAssert_ span (Just c) (Just b))) <$> body
|
|
|
|
else nverr $ Assertion span c
|
2018-04-23 19:06:49 +02:00
|
|
|
|
|
|
|
evalApp f x = do
|
2018-04-25 06:41:23 +02:00
|
|
|
scope <- currentScopes
|
2018-04-23 19:06:49 +02:00
|
|
|
span <- currentPos
|
2018-04-25 06:41:23 +02:00
|
|
|
addProvenance (const $ Provenance scope (NBinary_ span NApp (Just f) Nothing))
|
2018-04-23 19:06:49 +02:00
|
|
|
<$> callFunc f x
|
|
|
|
|
2018-05-02 22:46:32 +02:00
|
|
|
evalAbs p k = do
|
2018-04-22 23:32:55 +02:00
|
|
|
scope <- currentScopes
|
|
|
|
span <- currentPos
|
2018-05-02 22:46:32 +02:00
|
|
|
pure $ nvClosureP (Provenance scope (NAbs_ span (Nothing <$ p) Nothing))
|
|
|
|
(void p) (\arg -> snd <$> k arg (\_ b -> ((),) <$> b))
|
2018-04-09 09:52:10 +02:00
|
|
|
|
|
|
|
evalError = throwError
|
|
|
|
|
|
|
|
infixl 1 `callFunc`
|
2018-05-06 09:35:21 +02:00
|
|
|
callFunc :: forall e m. (MonadNix e m, Typeable m)
|
|
|
|
=> NValue m -> m (NValue m) -> m (NValue m)
|
2018-04-09 09:52:10 +02:00
|
|
|
callFunc fun arg = case fun of
|
2018-04-18 02:25:59 +02:00
|
|
|
NVClosure params f -> do
|
|
|
|
traceM $ "callFunc:NVFunction taking " ++ show params
|
2018-04-09 09:52:10 +02:00
|
|
|
f arg
|
|
|
|
NVBuiltin name f -> do
|
2018-05-06 09:35:21 +02:00
|
|
|
span <- currentPos
|
|
|
|
withFrame Info (Calling @m @(NThunk m) name span) $ f arg
|
2018-04-09 09:52:10 +02:00
|
|
|
s@(NVSet m _) | Just f <- M.lookup "__functor" m -> do
|
|
|
|
traceM "callFunc:__functor"
|
2018-04-17 00:02:04 +02:00
|
|
|
force f $ (`callFunc` pure s) >=> (`callFunc` arg)
|
2018-05-02 02:33:17 +02:00
|
|
|
x -> throwError $ ErrorCall $ "Attempt to call non-function: " ++ show x
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-04-24 11:14:27 +02:00
|
|
|
execUnaryOp :: (Framed e m, MonadVar m)
|
2018-04-22 23:32:55 +02:00
|
|
|
=> Scopes m (NThunk m) -> SrcSpan -> NUnaryOp -> NValue m
|
|
|
|
-> m (NValue m)
|
|
|
|
execUnaryOp scope span op arg = do
|
2018-04-09 09:52:10 +02:00
|
|
|
traceM "NUnary"
|
|
|
|
case arg of
|
|
|
|
NVConstant c -> case (op, c) of
|
2018-04-22 23:32:55 +02:00
|
|
|
(NNeg, NInt i) -> unaryOp $ NInt (-i)
|
|
|
|
(NNeg, NFloat f) -> unaryOp $ NFloat (-f)
|
|
|
|
(NNot, NBool b) -> unaryOp $ NBool (not b)
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> throwError $ ErrorCall $
|
|
|
|
"unsupported argument type for unary operator " ++ show op
|
|
|
|
x -> throwError $ ErrorCall $ "argument to unary operator"
|
2018-04-12 05:46:44 +02:00
|
|
|
++ " must evaluate to an atomic type: " ++ show x
|
2018-04-22 23:32:55 +02:00
|
|
|
where
|
2018-04-25 06:41:23 +02:00
|
|
|
unaryOp = pure . nvConstantP (Provenance scope (NUnary_ span op (Just arg)))
|
2018-04-09 09:52:10 +02:00
|
|
|
|
|
|
|
execBinaryOp
|
2018-04-14 03:09:12 +02:00
|
|
|
:: forall e m. (MonadNix e m, MonadEval (NValue m) m)
|
2018-04-22 23:32:55 +02:00
|
|
|
=> Scopes m (NThunk m)
|
|
|
|
-> SrcSpan
|
|
|
|
-> NBinaryOp
|
|
|
|
-> NValue m
|
|
|
|
-> m (NValue m)
|
|
|
|
-> m (NValue m)
|
|
|
|
|
|
|
|
execBinaryOp scope span NOr larg rarg = fromNix larg >>= \l ->
|
2018-04-17 23:59:24 +02:00
|
|
|
if l
|
2018-04-22 23:32:55 +02:00
|
|
|
then orOp Nothing True
|
|
|
|
else rarg >>= \rval -> fromNix @Bool rval >>= orOp (Just rval)
|
|
|
|
where
|
|
|
|
orOp r b = pure $
|
2018-04-25 06:41:23 +02:00
|
|
|
nvConstantP (Provenance scope (NBinary_ span NOr (Just larg) r)) (NBool b)
|
2018-04-17 23:59:24 +02:00
|
|
|
|
2018-04-22 23:32:55 +02:00
|
|
|
execBinaryOp scope span NAnd larg rarg = fromNix larg >>= \l ->
|
2018-04-17 23:59:24 +02:00
|
|
|
if l
|
2018-04-22 23:32:55 +02:00
|
|
|
then rarg >>= \rval -> fromNix @Bool rval >>= andOp (Just rval)
|
|
|
|
else andOp Nothing False
|
|
|
|
where
|
|
|
|
andOp r b = pure $
|
2018-04-25 06:41:23 +02:00
|
|
|
nvConstantP (Provenance scope (NBinary_ span NAnd (Just larg) r)) (NBool b)
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-04-22 23:32:55 +02:00
|
|
|
execBinaryOp scope span op lval rarg = do
|
2018-04-19 08:21:30 +02:00
|
|
|
rval <- rarg
|
2018-04-22 23:32:55 +02:00
|
|
|
let bin :: (Provenance m -> a) -> a
|
2018-04-25 06:41:23 +02:00
|
|
|
bin f = f (Provenance scope (NBinary_ span op (Just lval) (Just rval)))
|
2018-04-22 23:32:55 +02:00
|
|
|
toBool = pure . bin nvConstantP . NBool
|
2018-04-09 09:52:10 +02:00
|
|
|
case (lval, rval) of
|
|
|
|
(NVConstant lc, NVConstant rc) -> case (op, lc, rc) of
|
2018-04-22 23:32:55 +02:00
|
|
|
(NEq, _, _) -> toBool =<< valueEq lval rval
|
|
|
|
(NNEq, _, _) -> toBool . not =<< valueEq lval rval
|
|
|
|
(NLt, l, r) -> toBool $ l < r
|
|
|
|
(NLte, l, r) -> toBool $ l <= r
|
|
|
|
(NGt, l, r) -> toBool $ l > r
|
|
|
|
(NGte, l, r) -> toBool $ l >= r
|
2018-04-24 20:12:20 +02:00
|
|
|
(NAnd, _, _) ->
|
2018-05-02 02:33:17 +02:00
|
|
|
nverr $ ErrorCall "should be impossible: && is handled above"
|
2018-04-24 20:12:20 +02:00
|
|
|
(NOr, _, _) ->
|
2018-05-02 02:33:17 +02:00
|
|
|
nverr $ ErrorCall "should be impossible: || is handled above"
|
2018-04-22 23:32:55 +02:00
|
|
|
(NPlus, l, r) -> numBinOp bin (+) l r
|
|
|
|
(NMinus, l, r) -> numBinOp bin (-) l r
|
|
|
|
(NMult, l, r) -> numBinOp bin (*) l r
|
|
|
|
(NDiv, l, r) -> numBinOp' bin div (/) l r
|
2018-04-18 06:34:41 +02:00
|
|
|
(NImpl,
|
2018-04-22 23:32:55 +02:00
|
|
|
NBool l, NBool r) -> toBool $ not l || r
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-07-28 21:32:15 +02:00
|
|
|
(NVStr ls, NVStr rs) -> case op of
|
|
|
|
NPlus -> pure $ bin nvStrP (ls `mappend` rs)
|
2018-04-22 23:32:55 +02:00
|
|
|
NEq -> toBool =<< valueEq lval rval
|
|
|
|
NNEq -> toBool . not =<< valueEq lval rval
|
|
|
|
NLt -> toBool $ ls < rs
|
|
|
|
NLte -> toBool $ ls <= rs
|
|
|
|
NGt -> toBool $ ls > rs
|
|
|
|
NGte -> toBool $ ls >= rs
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-05-08 22:47:50 +02:00
|
|
|
(NVStr _, NVConstant NNull) -> case op of
|
|
|
|
NEq -> toBool =<< valueEq lval (nvStr (makeNixStringWithoutContext ""))
|
|
|
|
NNEq -> toBool . not =<< valueEq lval (nvStr (makeNixStringWithoutContext ""))
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-05-08 22:47:50 +02:00
|
|
|
(NVConstant NNull, NVStr _) -> case op of
|
|
|
|
NEq -> toBool =<< valueEq (nvStr (makeNixStringWithoutContext "")) rval
|
|
|
|
NNEq -> toBool . not =<< valueEq (nvStr (makeNixStringWithoutContext "")) rval
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-09 09:52:10 +02:00
|
|
|
|
|
|
|
(NVSet ls lp, NVSet rs rp) -> case op of
|
2018-04-22 23:32:55 +02:00
|
|
|
NUpdate -> pure $ bin nvSetP (rs `M.union` ls) (rp `M.union` lp)
|
|
|
|
NEq -> toBool =<< valueEq lval rval
|
|
|
|
NNEq -> toBool . not =<< valueEq lval rval
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-04-21 19:51:54 +02:00
|
|
|
(NVSet ls lp, NVConstant NNull) -> case op of
|
2018-04-22 23:32:55 +02:00
|
|
|
NUpdate -> pure $ bin nvSetP ls lp
|
|
|
|
NEq -> toBool =<< valueEq lval (nvSet M.empty M.empty)
|
|
|
|
NNEq -> toBool . not =<< valueEq lval (nvSet M.empty M.empty)
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-21 19:51:54 +02:00
|
|
|
|
|
|
|
(NVConstant NNull, NVSet rs rp) -> case op of
|
2018-04-22 23:32:55 +02:00
|
|
|
NUpdate -> pure $ bin nvSetP rs rp
|
|
|
|
NEq -> toBool =<< valueEq (nvSet M.empty M.empty) rval
|
|
|
|
NNEq -> toBool . not =<< valueEq (nvSet M.empty M.empty) rval
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-21 19:51:54 +02:00
|
|
|
|
2018-07-28 19:23:23 +02:00
|
|
|
(ls@NVSet {}, NVStr rs) -> case op of
|
|
|
|
NPlus -> (\lx -> bin nvStrP (modifyNixContents (Text.pack lx `mappend`) rs))
|
2018-05-10 01:54:31 +02:00
|
|
|
<$> coerceToString False ls
|
|
|
|
NEq -> toBool =<< valueEq lval rval
|
|
|
|
NNEq -> toBool . not =<< valueEq lval rval
|
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
|
|
|
|
2018-07-28 19:23:23 +02:00
|
|
|
(NVStr ls, rs@NVSet {}) -> case op of
|
|
|
|
NPlus -> (\rx -> bin nvStrP (modifyNixContents (`mappend` Text.pack rx) ls))
|
2018-05-10 01:54:31 +02:00
|
|
|
<$> coerceToString False rs
|
|
|
|
NEq -> toBool =<< valueEq lval rval
|
|
|
|
NNEq -> toBool . not =<< valueEq lval rval
|
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
|
|
|
|
2018-04-09 09:52:10 +02:00
|
|
|
(NVList ls, NVList rs) -> case op of
|
2018-04-22 23:32:55 +02:00
|
|
|
NConcat -> pure $ bin nvListP $ ls ++ rs
|
|
|
|
NEq -> toBool =<< valueEq lval rval
|
|
|
|
NNEq -> toBool . not =<< valueEq lval rval
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-09 09:52:10 +02:00
|
|
|
|
|
|
|
(NVList ls, NVConstant NNull) -> case op of
|
2018-04-22 23:32:55 +02:00
|
|
|
NConcat -> pure $ bin nvListP ls
|
|
|
|
NEq -> toBool =<< valueEq lval (nvList [])
|
|
|
|
NNEq -> toBool . not =<< valueEq lval (nvList [])
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-09 09:52:10 +02:00
|
|
|
|
|
|
|
(NVConstant NNull, NVList rs) -> case op of
|
2018-04-22 23:32:55 +02:00
|
|
|
NConcat -> pure $ bin nvListP rs
|
|
|
|
NEq -> toBool =<< valueEq (nvList []) rval
|
|
|
|
NNEq -> toBool . not =<< valueEq (nvList []) rval
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-09 09:52:10 +02:00
|
|
|
|
2018-05-08 22:47:50 +02:00
|
|
|
(NVPath p, NVStr ns) -> case op of
|
|
|
|
NEq -> toBool $ Just p == fmap Text.unpack (stringNoContext ns)
|
|
|
|
NNEq -> toBool $ Just p /= fmap Text.unpack (stringNoContext ns)
|
2018-07-28 19:23:23 +02:00
|
|
|
NPlus -> bin nvPathP <$> makeAbsolutePath (p `mappend` Text.unpack (stringIntentionallyDropContext ns))
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-09 09:52:10 +02:00
|
|
|
|
|
|
|
(NVPath ls, NVPath rs) -> case op of
|
2018-04-22 23:32:55 +02:00
|
|
|
NPlus -> bin nvPathP <$> makeAbsolutePath (ls ++ rs)
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-18 03:11:58 +02:00
|
|
|
|
2018-04-27 07:30:32 +02:00
|
|
|
_ -> case op of
|
|
|
|
NEq -> toBool False
|
|
|
|
NNEq -> toBool True
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes lval rval
|
2018-04-18 03:11:58 +02:00
|
|
|
where
|
|
|
|
unsupportedTypes :: Show a => a -> a -> String
|
|
|
|
unsupportedTypes lval rval =
|
|
|
|
"Unsupported argument types for binary operator "
|
|
|
|
++ show op ++ ": " ++ show lval ++ ", " ++ show rval
|
|
|
|
|
2018-04-22 23:32:55 +02:00
|
|
|
numBinOp :: (forall r. (Provenance m -> r) -> r)
|
|
|
|
-> (forall a. Num a => a -> a -> a) -> NAtom -> NAtom -> m (NValue m)
|
|
|
|
numBinOp bin f = numBinOp' bin f f
|
|
|
|
|
|
|
|
numBinOp' :: (forall r. (Provenance m -> r) -> r)
|
|
|
|
-> (Integer -> Integer -> Integer)
|
|
|
|
-> (Float -> Float -> Float)
|
|
|
|
-> NAtom -> NAtom -> m (NValue m)
|
|
|
|
numBinOp' bin intF floatF l r = case (l, r) of
|
|
|
|
(NInt li, NInt ri) -> toInt $ li `intF` ri
|
|
|
|
(NInt li, NFloat rf) -> toFloat $ fromInteger li `floatF` rf
|
|
|
|
(NFloat lf, NInt ri) -> toFloat $ lf `floatF` fromInteger ri
|
|
|
|
(NFloat lf, NFloat rf) -> toFloat $ lf `floatF` rf
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> nverr $ ErrorCall $ unsupportedTypes l r
|
2018-04-22 23:32:55 +02:00
|
|
|
where
|
|
|
|
toInt = pure . bin nvConstantP . NInt
|
|
|
|
toFloat = pure . bin nvConstantP . NFloat
|
2018-04-11 06:01:48 +02:00
|
|
|
|
2018-05-10 01:54:24 +02:00
|
|
|
coerceToString :: MonadNix e m => Bool -> NValue m -> m String
|
|
|
|
coerceToString copyToStore = go
|
|
|
|
where
|
|
|
|
go = \case
|
|
|
|
NVConstant (NBool b)
|
|
|
|
| b -> pure "1"
|
|
|
|
| otherwise -> pure ""
|
|
|
|
NVConstant (NInt n) -> pure $ show n
|
|
|
|
NVConstant (NFloat n) -> pure $ show n
|
|
|
|
NVConstant NNull -> pure ""
|
2018-04-26 05:22:48 +02:00
|
|
|
|
2018-07-28 21:32:15 +02:00
|
|
|
NVStr ns -> pure $ Text.unpack (stringIntentionallyDropContext ns)
|
2018-05-10 01:54:24 +02:00
|
|
|
NVPath p | copyToStore -> unStorePath <$> addPath p
|
|
|
|
| otherwise -> pure p
|
|
|
|
NVList l -> unwords <$> traverse (`force` go) l
|
2018-04-26 05:22:48 +02:00
|
|
|
|
2018-05-10 01:54:24 +02:00
|
|
|
v@(NVSet s _) | Just p <- M.lookup "__toString" s ->
|
|
|
|
force p $ (`callFunc` pure v) >=> go
|
2018-04-26 05:22:48 +02:00
|
|
|
|
2018-05-10 01:54:24 +02:00
|
|
|
NVSet s _ | Just p <- M.lookup "outPath" s ->
|
|
|
|
force p go
|
2018-04-26 05:22:48 +02:00
|
|
|
|
2018-05-10 01:54:24 +02:00
|
|
|
v -> throwError $ ErrorCall $ "Expected a string, but saw: " ++ show v
|
2018-04-26 05:22:48 +02:00
|
|
|
|
2018-04-11 06:01:48 +02:00
|
|
|
newtype Lazy m a = Lazy
|
2018-04-26 06:01:45 +02:00
|
|
|
{ runLazy :: ReaderT (Context (Lazy m) (NThunk (Lazy m)))
|
|
|
|
(StateT (HashMap FilePath NExprLoc) m) a }
|
2018-04-14 04:29:18 +02:00
|
|
|
deriving (Functor, Applicative, Alternative, Monad, MonadPlus,
|
|
|
|
MonadFix, MonadIO,
|
2018-04-11 06:01:48 +02:00
|
|
|
MonadReader (Context (Lazy m) (NThunk (Lazy m))))
|
|
|
|
|
|
|
|
instance MonadIO m => MonadVar (Lazy m) where
|
|
|
|
type Var (Lazy m) = IORef
|
|
|
|
|
|
|
|
newVar = liftIO . newIORef
|
|
|
|
readVar = liftIO . readIORef
|
|
|
|
writeVar = (liftIO .) . writeIORef
|
|
|
|
atomicModifyVar = (liftIO .) . atomicModifyIORef
|
|
|
|
|
2018-04-24 11:14:27 +02:00
|
|
|
instance (MonadIO m, Monad m) => MonadFile m where
|
2018-04-11 06:01:48 +02:00
|
|
|
readFile = liftIO . BS.readFile
|
|
|
|
|
|
|
|
instance MonadCatch m => MonadCatch (Lazy m) where
|
|
|
|
catch (Lazy (ReaderT m)) f = Lazy $ ReaderT $ \e ->
|
|
|
|
catch (m e) ((`runReaderT` e) . runLazy . f)
|
|
|
|
|
|
|
|
instance MonadThrow m => MonadThrow (Lazy m) where
|
|
|
|
throwM = Lazy . throwM
|
|
|
|
|
2018-05-13 23:17:55 +02:00
|
|
|
#ifdef MIN_VERSION_haskeline
|
2018-04-29 01:13:24 +02:00
|
|
|
instance MonadException m => MonadException (Lazy m) where
|
|
|
|
controlIO f = Lazy $ controlIO $ \(RunIO run) ->
|
|
|
|
let run' = RunIO (fmap Lazy . run . runLazy)
|
2018-04-29 02:13:05 +02:00
|
|
|
in runLazy <$> f run'
|
2018-05-09 01:40:56 +02:00
|
|
|
#endif
|
2018-04-29 01:13:24 +02:00
|
|
|
|
2018-05-02 02:33:17 +02:00
|
|
|
instance (MonadFix m, MonadCatch m, MonadIO m, Alternative m,
|
|
|
|
MonadPlus m, Typeable m)
|
2018-04-14 03:09:12 +02:00
|
|
|
=> MonadEffects (Lazy m) where
|
2018-04-11 06:01:48 +02:00
|
|
|
addPath path = do
|
|
|
|
(exitCode, out, _) <-
|
|
|
|
liftIO $ readProcessWithExitCode "nix-store" ["--add", path] ""
|
|
|
|
case exitCode of
|
|
|
|
ExitSuccess -> do
|
|
|
|
let dropTrailingLinefeed p = take (length p - 1) p
|
|
|
|
return $ StorePath $ dropTrailingLinefeed out
|
2018-05-02 02:33:17 +02:00
|
|
|
_ -> throwError $ ErrorCall $
|
|
|
|
"addPath: failed: nix-store --add " ++ show path
|
2018-04-11 06:01:48 +02:00
|
|
|
|
2018-05-11 02:32:47 +02:00
|
|
|
toFile_ filepath content = do
|
|
|
|
liftIO $ writeFile filepath content
|
|
|
|
storepath <- addPath filepath
|
|
|
|
liftIO $ removeFile filepath
|
|
|
|
return storepath
|
|
|
|
|
2018-04-11 06:01:48 +02:00
|
|
|
makeAbsolutePath origPath = do
|
2018-04-21 08:17:57 +02:00
|
|
|
origPathExpanded <- liftIO $ expandHomePath origPath
|
|
|
|
absPath <- if isAbsolute origPathExpanded then pure origPathExpanded else do
|
2018-04-11 06:01:48 +02:00
|
|
|
cwd <- do
|
|
|
|
mres <- lookupVar @_ @(NThunk (Lazy m)) "__cur_file"
|
|
|
|
case mres of
|
|
|
|
Nothing -> liftIO getCurrentDirectory
|
|
|
|
Just v -> force v $ \case
|
|
|
|
NVPath s -> return $ takeDirectory s
|
2018-05-02 02:33:17 +02:00
|
|
|
v -> throwError $ ErrorCall $ "when resolving relative path,"
|
2018-04-11 06:01:48 +02:00
|
|
|
++ " __cur_file is in scope,"
|
|
|
|
++ " but is not a path; it is: "
|
2018-04-11 06:11:46 +02:00
|
|
|
++ show v
|
2018-04-21 08:17:57 +02:00
|
|
|
pure $ cwd <///> origPathExpanded
|
2018-04-11 06:01:48 +02:00
|
|
|
liftIO $ removeDotDotIndirections <$> canonicalizePath absPath
|
|
|
|
|
2018-04-14 03:09:12 +02:00
|
|
|
findEnvPath = findEnvPathM
|
2018-04-13 09:52:09 +02:00
|
|
|
|
2018-05-20 15:47:53 +02:00
|
|
|
findPath = findPathM
|
|
|
|
|
2018-04-11 06:01:48 +02:00
|
|
|
pathExists = liftIO . fileExist
|
|
|
|
|
|
|
|
importPath scope origPath = do
|
|
|
|
path <- liftIO $ pathToDefaultNixFile origPath
|
|
|
|
mres <- lookupVar @(Context (Lazy m) (NThunk (Lazy m)))
|
|
|
|
"__cur_file"
|
|
|
|
path' <- case mres of
|
|
|
|
Nothing -> do
|
|
|
|
traceM "No known current directory"
|
|
|
|
return path
|
2018-04-18 05:44:01 +02:00
|
|
|
Just p -> fromValue @_ @_ @(NThunk (Lazy m)) p >>= \(Path p') -> do
|
|
|
|
traceM $ "Current file being evaluated is: " ++ show p'
|
|
|
|
return $ takeDirectory p' </> path
|
2018-04-11 06:01:48 +02:00
|
|
|
|
|
|
|
traceM $ "Importing file " ++ path'
|
2018-05-02 02:33:17 +02:00
|
|
|
withFrame Info (ErrorCall $ "While importing file " ++ show path') $ do
|
2018-04-26 06:01:45 +02:00
|
|
|
imports <- Lazy $ ReaderT $ const get
|
|
|
|
expr <- case M.lookup path' imports of
|
|
|
|
Just expr -> pure expr
|
|
|
|
Nothing -> do
|
|
|
|
eres <- Lazy $ parseNixFileLoc path'
|
|
|
|
case eres of
|
|
|
|
Failure err ->
|
2018-05-02 02:33:17 +02:00
|
|
|
throwError $ ErrorCall . show $
|
|
|
|
text "Parse during import failed:" P.</> err
|
2018-04-26 06:01:45 +02:00
|
|
|
Success expr -> do
|
|
|
|
Lazy $ ReaderT $ const $
|
|
|
|
modify (M.insert origPath expr)
|
|
|
|
pure expr
|
|
|
|
|
|
|
|
let ref = value @_ @_ @(Lazy m) (nvPath path')
|
|
|
|
-- Use this cookie so that when we evaluate the next
|
|
|
|
-- import, we'll remember which directory its containing
|
|
|
|
-- file was in.
|
|
|
|
pushScope (M.singleton "__cur_file" ref) $
|
|
|
|
pushScope scope $ evalExprLoc expr
|
2018-04-11 06:01:48 +02:00
|
|
|
|
|
|
|
getEnvVar = liftIO . lookupEnv
|
|
|
|
|
|
|
|
getCurrentSystemOS = return $ Text.pack System.Info.os
|
|
|
|
|
|
|
|
-- Invert the conversion done by GHC_CONVERT_CPU in GHC's aclocal.m4
|
|
|
|
getCurrentSystemArch = return $ Text.pack $ case System.Info.arch of
|
|
|
|
"i386" -> "i686"
|
|
|
|
arch -> arch
|
|
|
|
|
|
|
|
listDirectory = liftIO . System.Directory.listDirectory
|
|
|
|
getSymbolicLinkStatus = liftIO . System.Posix.Files.getSymbolicLinkStatus
|
|
|
|
|
2018-04-18 06:32:20 +02:00
|
|
|
derivationStrict = fromValue @(ValueSet (Lazy m)) >=> \s -> do
|
2018-04-26 05:22:48 +02:00
|
|
|
nn <- maybe (pure False) fromNix (M.lookup "__ignoreNulls" s)
|
|
|
|
s' <- M.fromList <$> mapMaybeM (handleEntry nn) (M.toList s)
|
|
|
|
v' <- normalForm =<< toValue @(ValueSet (Lazy m)) s'
|
2018-04-28 05:08:47 +02:00
|
|
|
nixInstantiateExpr $ "derivationStrict " ++ show (prettyNValueNF v')
|
2018-04-18 06:32:20 +02:00
|
|
|
where
|
|
|
|
mapMaybeM :: (a -> Lazy m (Maybe b)) -> [a] -> Lazy m [b]
|
|
|
|
mapMaybeM op = foldr f (return [])
|
2018-04-26 05:22:48 +02:00
|
|
|
where f x xs = op x >>= \case
|
|
|
|
Nothing -> xs
|
|
|
|
Just x -> (x:) <$> xs
|
|
|
|
|
|
|
|
handleEntry ignoreNulls (k, v) = fmap (k,) <$> case k of
|
|
|
|
-- The `args' attribute is special: it supplies the command-line
|
|
|
|
-- arguments to the builder.
|
|
|
|
"args" -> Just <$> convertNix @[Text] v
|
|
|
|
"__ignoreNulls" -> pure Nothing
|
|
|
|
_ -> force v $ \case
|
|
|
|
NVConstant NNull | ignoreNulls -> pure Nothing
|
2018-05-10 01:54:24 +02:00
|
|
|
v' -> Just <$> (toNix =<< Text.pack <$> coerceToString True v')
|
2018-04-11 22:56:18 +02:00
|
|
|
|
|
|
|
nixInstantiateExpr expr = do
|
2018-04-18 22:27:25 +02:00
|
|
|
traceM $ "Executing: "
|
2018-04-18 06:32:20 +02:00
|
|
|
++ show ["nix-instantiate", "--eval", "--expr ", expr]
|
2018-04-30 19:41:03 +02:00
|
|
|
(exitCode, out, err) <-
|
2018-04-11 06:01:48 +02:00
|
|
|
liftIO $ readProcessWithExitCode "nix-instantiate"
|
2018-04-11 22:56:18 +02:00
|
|
|
[ "--eval", "--expr", expr] ""
|
2018-04-11 06:01:48 +02:00
|
|
|
case exitCode of
|
2018-04-26 05:22:48 +02:00
|
|
|
ExitSuccess -> case parseNixTextLoc (Text.pack out) of
|
|
|
|
Failure err ->
|
2018-05-02 02:33:17 +02:00
|
|
|
throwError $ ErrorCall $
|
|
|
|
"Error parsing output of nix-instantiate: " ++ show err
|
2018-04-26 05:22:48 +02:00
|
|
|
Success v -> evalExprLoc v
|
2018-04-30 19:41:03 +02:00
|
|
|
status ->
|
2018-05-02 02:33:17 +02:00
|
|
|
throwError $ ErrorCall $ "nix-instantiate failed: " ++ show status
|
2018-04-30 19:41:03 +02:00
|
|
|
++ ": " ++ err
|
2018-04-11 06:01:48 +02:00
|
|
|
|
2018-04-29 02:12:32 +02:00
|
|
|
getRecursiveSize =
|
2018-04-29 03:38:43 +02:00
|
|
|
#ifdef MIN_VERSION_ghc_datasize
|
2018-04-29 03:29:37 +02:00
|
|
|
#if MIN_VERSION_ghc_datasize(0,2,0) && __GLASGOW_HASKELL__ >= 804
|
2018-04-29 02:12:32 +02:00
|
|
|
toNix @Integer <=< fmap fromIntegral . liftIO . recursiveSize
|
|
|
|
#else
|
2018-04-29 03:39:56 +02:00
|
|
|
const $ toNix (0 :: Integer)
|
2018-04-29 02:12:32 +02:00
|
|
|
#endif
|
2018-04-29 03:38:43 +02:00
|
|
|
#else
|
|
|
|
const $ toNix (0 :: Integer)
|
|
|
|
#endif
|
2018-04-29 02:12:32 +02:00
|
|
|
|
2018-05-03 06:38:13 +02:00
|
|
|
getURL url = do
|
|
|
|
let urlstr = Text.unpack url
|
|
|
|
traceM $ "fetching HTTP URL: " ++ urlstr
|
|
|
|
response <- liftIO $ do
|
|
|
|
req <- parseRequest urlstr
|
|
|
|
manager <-
|
|
|
|
if secure req
|
|
|
|
then newTlsManager
|
|
|
|
else newManager defaultManagerSettings
|
|
|
|
-- print req
|
|
|
|
httpLbs (req { method = "GET" }) manager
|
|
|
|
-- return response
|
|
|
|
let status = statusCode (responseStatus response)
|
|
|
|
if status /= 200
|
2018-05-20 15:47:53 +02:00
|
|
|
then throwError $ ErrorCall $
|
2018-05-03 06:38:13 +02:00
|
|
|
"fail, got " ++ show status ++ " when fetching url:" ++ urlstr
|
2018-05-06 09:34:38 +02:00
|
|
|
else -- do
|
2018-05-03 06:38:13 +02:00
|
|
|
-- let bstr = responseBody response
|
|
|
|
-- liftIO $ print bstr
|
2018-05-20 15:47:53 +02:00
|
|
|
throwError $ ErrorCall $
|
2018-05-03 06:38:13 +02:00
|
|
|
"success in downloading but hnix-store is not yet ready; url = " ++ urlstr
|
|
|
|
|
2018-04-28 23:28:16 +02:00
|
|
|
traceEffect = liftIO . putStrLn
|
|
|
|
|
2018-04-29 00:09:53 +02:00
|
|
|
exec = \case
|
2018-04-29 01:37:01 +02:00
|
|
|
[] -> throwError $ ErrorCall "exec: missing program"
|
|
|
|
(prog:args) -> do
|
|
|
|
(exitCode, out, _) <-
|
|
|
|
liftIO $ readProcessWithExitCode prog args ""
|
|
|
|
let t = Text.strip (Text.pack out)
|
|
|
|
let emsg = "program[" ++ prog ++ "] args=" ++ show args
|
|
|
|
case exitCode of
|
|
|
|
ExitSuccess ->
|
|
|
|
if Text.null t
|
|
|
|
then throwError $ ErrorCall $ "exec has no output :" ++ emsg
|
|
|
|
else case parseNixTextLoc t of
|
|
|
|
Failure err ->
|
|
|
|
throwError $ ErrorCall $
|
|
|
|
"Error parsing output of exec: " ++ show err ++ " " ++ emsg
|
|
|
|
Success v -> evalExprLoc v
|
|
|
|
err -> throwError $ ErrorCall $
|
|
|
|
"exec failed: " ++ show err ++ " " ++ emsg
|
2018-04-29 00:09:53 +02:00
|
|
|
|
2018-04-18 02:25:59 +02:00
|
|
|
runLazyM :: Options -> MonadIO m => Lazy m a -> m a
|
2018-04-26 06:01:45 +02:00
|
|
|
runLazyM opts = (`evalStateT` M.empty)
|
|
|
|
. (`runReaderT` newContext opts)
|
|
|
|
. runLazy
|
2018-04-11 06:01:48 +02:00
|
|
|
|
|
|
|
-- | Incorrectly normalize paths by rewriting patterns like @a/b/..@ to @a@.
|
|
|
|
-- This is incorrect on POSIX systems, because if @b@ is a symlink, its
|
|
|
|
-- parent may be a different directory from @a@. See the discussion at
|
|
|
|
-- https://hackage.haskell.org/package/directory-1.3.1.5/docs/System-Directory.html#v:canonicalizePath
|
|
|
|
removeDotDotIndirections :: FilePath -> FilePath
|
|
|
|
removeDotDotIndirections = intercalate "/" . go [] . splitOn "/"
|
|
|
|
where go s [] = reverse s
|
|
|
|
go (_:s) ("..":rest) = go s rest
|
|
|
|
go s (this:rest) = go (this:s) rest
|
|
|
|
|
2018-04-21 08:17:57 +02:00
|
|
|
expandHomePath :: FilePath -> IO FilePath
|
|
|
|
expandHomePath ('~' : xs) = flip (++) xs <$> getHomeDirectory
|
|
|
|
expandHomePath p = return p
|
|
|
|
|
2018-04-11 06:01:48 +02:00
|
|
|
-- Given a path, determine the nix file to load
|
|
|
|
pathToDefaultNixFile :: FilePath -> IO FilePath
|
|
|
|
pathToDefaultNixFile p = do
|
|
|
|
isDir <- doesDirectoryExist p
|
2018-04-14 01:37:11 +02:00
|
|
|
pure $ if isDir then p </> "default.nix" else p
|
|
|
|
|
|
|
|
infixr 9 <///>
|
|
|
|
(<///>) :: FilePath -> FilePath -> FilePath
|
|
|
|
x <///> y | isAbsolute y || "." `isPrefixOf` y = x </> y
|
|
|
|
| otherwise = joinByLargestOverlap x y
|
|
|
|
where
|
|
|
|
joinByLargestOverlap (splitDirectories -> xs) (splitDirectories -> ys) =
|
|
|
|
joinPath $ head [ xs ++ drop (length tx) ys
|
|
|
|
| tx <- tails xs, tx `elem` inits ys ]
|
2018-04-13 19:38:57 +02:00
|
|
|
|
2018-05-20 15:47:53 +02:00
|
|
|
findPathBy :: forall e m. (MonadNix e m, MonadIO m) =>
|
|
|
|
(FilePath -> m (Maybe FilePath)) ->
|
|
|
|
[NThunk m] -> FilePath -> m FilePath
|
|
|
|
findPathBy finder l name = do
|
|
|
|
mpath <- foldM go Nothing l
|
|
|
|
case mpath of
|
|
|
|
Nothing ->
|
|
|
|
throwError $ ErrorCall $ "file '" ++ name
|
|
|
|
++ "' was not found in the Nix search path"
|
|
|
|
++ " (add it using $NIX_PATH or -I)"
|
|
|
|
Just path -> return path
|
|
|
|
where
|
|
|
|
go :: Maybe FilePath -> NThunk m -> m (Maybe FilePath)
|
|
|
|
go p@(Just _) _ = pure p
|
|
|
|
go Nothing l = force l $ fromValue >=>
|
|
|
|
\(s :: HashMap Text (NThunk m)) ->
|
|
|
|
case M.lookup "path" s of
|
|
|
|
Just p -> force p $ fromValue >=> \(Path path) ->
|
|
|
|
case M.lookup "prefix" s of
|
|
|
|
Nothing -> tryPath path Nothing
|
|
|
|
Just pf -> force pf $ fromValueMay >=> \case
|
|
|
|
Just (pfx :: Text) | not (Text.null pfx) ->
|
|
|
|
tryPath path (Just (Text.unpack pfx))
|
|
|
|
_ -> tryPath path Nothing
|
|
|
|
Nothing ->
|
|
|
|
throwError $ ErrorCall $ "__nixPath must be a list of attr sets"
|
|
|
|
++ " with 'path' elements, but saw: " ++ show s
|
|
|
|
|
|
|
|
tryPath p (Just n) | n':ns <- splitDirectories name, n == n' =
|
|
|
|
finder $ p <///> joinPath ns
|
|
|
|
tryPath p _ = finder $ p <///> name
|
|
|
|
|
|
|
|
findPathM :: forall e m. (MonadNix e m, MonadIO m) =>
|
|
|
|
[NThunk m] -> FilePath -> m FilePath
|
|
|
|
findPathM l name = findPathBy path l name
|
|
|
|
where
|
|
|
|
path :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath)
|
|
|
|
path path = do
|
|
|
|
path <- makeAbsolutePath path
|
|
|
|
exists <- liftIO $ doesPathExist path
|
|
|
|
return $ if exists then Just path else Nothing
|
2018-04-14 03:09:12 +02:00
|
|
|
|
|
|
|
findEnvPathM :: forall e m. (MonadNix e m, MonadIO m)
|
|
|
|
=> FilePath -> m FilePath
|
|
|
|
findEnvPathM name = do
|
|
|
|
mres <- lookupVar @_ @(NThunk m) "__nixPath"
|
2018-05-20 15:47:53 +02:00
|
|
|
case mres of
|
2018-04-14 03:09:12 +02:00
|
|
|
Nothing -> error "impossible"
|
2018-04-16 04:05:44 +02:00
|
|
|
Just x -> force x $ fromValue >=> \(l :: [NThunk m]) ->
|
2018-05-20 15:47:53 +02:00
|
|
|
findPathBy nixFilePath l name
|
|
|
|
where
|
|
|
|
nixFilePath :: (MonadEffects m, MonadIO m) => FilePath -> m (Maybe FilePath)
|
|
|
|
nixFilePath path = do
|
|
|
|
path <- makeAbsolutePath path
|
|
|
|
exists <- liftIO $ doesDirectoryExist path
|
|
|
|
path' <- if exists
|
|
|
|
then makeAbsolutePath $ path </> "default.nix"
|
|
|
|
else return path
|
|
|
|
exists <- liftIO $ doesFileExist path'
|
|
|
|
return $ if exists then Just path' else Nothing
|
2018-04-21 19:26:42 +02:00
|
|
|
|
2018-04-24 11:14:27 +02:00
|
|
|
addTracing :: (MonadNix e m, Has e Options, MonadIO m,
|
2018-04-21 19:26:42 +02:00
|
|
|
MonadReader Int n, Alternative n)
|
|
|
|
=> Alg NExprLocF (m a) -> Alg NExprLocF (n (m a))
|
|
|
|
addTracing k v = do
|
|
|
|
depth <- ask
|
|
|
|
guard (depth < 2000)
|
|
|
|
local succ $ do
|
|
|
|
v'@(Compose (Ann span x)) <- sequence v
|
|
|
|
return $ do
|
|
|
|
opts :: Options <- asks (view hasLens)
|
|
|
|
let rendered =
|
|
|
|
if verbose opts >= Chatty
|
2018-05-13 23:17:55 +02:00
|
|
|
#ifdef MIN_VERSION_pretty_show
|
2018-05-09 23:39:27 +02:00
|
|
|
then text $ PS.ppShow (void x)
|
2018-05-13 23:17:55 +02:00
|
|
|
#else
|
|
|
|
then text $ show (void x)
|
|
|
|
#endif
|
2018-05-09 23:39:27 +02:00
|
|
|
else prettyNix (Fix (Fix (NSym "?") <$ x))
|
|
|
|
msg x = text ("eval: " ++ replicate depth ' ') <> x
|
|
|
|
loc <- renderLocation span (msg rendered <> text " ...\n")
|
2018-04-21 19:26:42 +02:00
|
|
|
liftIO $ putStr $ show loc
|
|
|
|
res <- k v'
|
2018-05-09 23:39:27 +02:00
|
|
|
liftIO $ print $ msg rendered <> text " ...done"
|
2018-04-21 19:26:42 +02:00
|
|
|
return res
|
2018-04-21 19:36:24 +02:00
|
|
|
|
2018-04-24 11:14:27 +02:00
|
|
|
evalExprLoc :: forall e m. (MonadNix e m, Has e Options, MonadIO m)
|
2018-04-21 19:36:24 +02:00
|
|
|
=> NExprLoc -> m (NValue m)
|
|
|
|
evalExprLoc expr = do
|
|
|
|
opts :: Options <- asks (view hasLens)
|
|
|
|
if tracing opts
|
2018-04-21 19:52:01 +02:00
|
|
|
then join . (`runReaderT` (0 :: Int)) $
|
2018-04-25 22:00:41 +02:00
|
|
|
adi (addTracing phi)
|
|
|
|
(raise (addStackFrames @(NThunk m) . addSourcePositions))
|
|
|
|
expr
|
|
|
|
else adi phi (addStackFrames @(NThunk m) . addSourcePositions) expr
|
2018-04-21 19:36:24 +02:00
|
|
|
where
|
2018-04-22 23:32:55 +02:00
|
|
|
phi = Eval.eval @_ @(NValue m) @(NThunk m) @m . annotated . getCompose
|
2018-04-21 19:36:24 +02:00
|
|
|
raise k f x = ReaderT $ \e -> k (\t -> runReaderT (f t) e) x
|