picnoir
/
hnix
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Rewrite ToNix/FromNix, although Builtins.hs is not using it yet

This commit is contained in:
John Wiegley 2018-04-13 18:09:12 -07:00
parent 7f6a64da04
commit 6c9cbf241a
7 changed files with 475 additions and 129 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
hnix.cabal
View File

@ -2,7 +2,7 @@
--
-- see: https://github.com/sol/hpack
--
-- hash: aadafd05c71b074e10eb082201d88f7358d995ee842fc8308b3222482f43971c
-- hash: 73ce99ca34076fded0b4f77fcb56f2aaa62f1c4e59e575ebae3a44a793fc3a0f
name: hnix
version: 0.5.0
@ -32,7 +32,9 @@ library
Nix.Builtins
Nix.Cache
Nix.Context
Nix.Convert
Nix.Effects
Nix.Entry
Nix.Eval
Nix.Exec
Nix.Expr

74
src/Nix.hs
View File

@ -1,73 +1,3 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Nix (module X) where
module Nix where
import Control.Applicative
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.IO.Class
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as Text
import Nix.Builtins
import qualified Nix.Eval as Eval
import Nix.Exec
import Nix.Expr.Types (NExpr)
import Nix.Expr.Types.Annotated (NExprLoc)
import Nix.Normal
import Nix.Scope
import Nix.Thunk
import Nix.Utils
import Nix.Value
-- | Evaluate a nix expression in the default context
evalTopLevelExprGen
:: forall e m a. MonadBuiltins e m
=> (a -> m (NValue m)) -> Maybe FilePath -> [String] -> a
-> m (NValueNF m)
evalTopLevelExprGen cont mpath incls expr = do
base <- baseEnv
let i = value @(NValue m) @(NThunk m) @m $ NVList $
map (value @(NValue m) @(NThunk m) @m
. flip NVStr mempty . Text.pack) incls
pushScope (M.singleton "__includes" i) $
(normalForm =<<) $ 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
evalTopLevelExpr :: forall e m. MonadBuiltins e m
=> Maybe FilePath -> [String] -> NExpr -> m (NValueNF m)
evalTopLevelExpr = evalTopLevelExprGen $
Eval.evalExpr @_ @(NValue m) @(NThunk m) @m
eval :: (MonadFix m, MonadThrow m, MonadCatch m, MonadIO m)
=> Maybe FilePath -> [String] -> NExpr -> m (NValueNF (Lazy m))
eval mpath incls = runLazyM . evalTopLevelExpr mpath incls
-- | Evaluate a nix expression in the default context
evalTopLevelExprLoc :: forall e m. MonadBuiltins e m
=> Maybe FilePath -> [String] -> NExprLoc -> m (NValueNF m)
evalTopLevelExprLoc = evalTopLevelExprGen $
Eval.framedEvalExpr (Eval.eval @_ @(NValue m) @(NThunk m) @m)
evalLoc :: (MonadFix m, MonadThrow m, MonadCatch m, MonadIO m)
=> Maybe FilePath -> [String] -> NExprLoc -> m (NValueNF (Lazy m))
evalLoc mpath incls = runLazyM . evalTopLevelExprLoc mpath incls
tracingEvalLoc
:: forall m. (MonadFix m, MonadThrow m, MonadCatch m,
Alternative m, MonadIO m)
=> Maybe FilePath -> [String] -> NExprLoc -> m (NValueNF (Lazy m))
tracingEvalLoc mpath incls expr =
runLazyM . evalTopLevelExprGen id mpath incls
=<< Eval.tracingEvalExpr @_ @(Lazy m) @_ @(NValue (Lazy m))
(Eval.eval @_ @(NValue (Lazy m))
@(NThunk (Lazy m)) @(Lazy m)) expr
import Nix.Entry as X

4
src/Nix/Builtins.hs
View File

@ -224,9 +224,7 @@ call2 f arg1 arg2 = force f $ \f' ->
-- Primops
foldNixPath :: forall e m r.
(Scoped e (NThunk m) m, MonadEffects m,
Framed e m, MonadThrow m, MonadVar m, MonadFile m)
foldNixPath :: forall e m r. MonadBuiltins e m
=> (FilePath -> Maybe String -> r -> m r) -> r -> m r
foldNixPath f z = do
mres <- lookupVar @_ @(NThunk m) "__includes"

311
src/Nix/Convert.hs Normal file
View File

@ -0,0 +1,311 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
module Nix.Convert where
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Aeson (toJSON)
import qualified Data.Aeson as A
import qualified Data.Aeson.Encoding as A
import Data.Fix
import Data.Functor.Compose
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.List (sortOn)
import Data.Text (Text)
import qualified Data.Vector as V
import Nix.Atoms
import Nix.Effects
import {-# SOURCE #-} Nix.Entry
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Normal
import Nix.Stack
import Nix.Thunk
import Nix.Utils
import Nix.Value
import Text.Megaparsec.Pos
class FromNix a m v where
fromNix :: MonadNix e m => v -> m a
fromNixMay :: MonadNix e m => v -> m (Maybe a)
instance FromNix Bool m (NValueNF m) where
fromNixMay = \case
Fix (NVConstant (NBool b)) -> pure $ Just b
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a bool, but saw: " ++ show v
instance FromNix Bool m (NValue m) where
fromNixMay = \case
NVConstant (NBool b) -> pure $ Just b
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a bool, but saw: " ++ show v
instance FromNix Int m (NValueNF m) where
fromNixMay = \case
Fix (NVConstant (NInt b)) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected an integer, but saw: " ++ show v
instance FromNix Int m (NValue m) where
fromNixMay = \case
NVConstant (NInt b) -> pure $ Just (fromInteger b)
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected an integer, but saw: " ++ show v
instance FromNix Integer m (NValueNF m) where
fromNixMay = \case
Fix (NVConstant (NInt b)) -> pure $ Just b
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected an integer, but saw: " ++ show v
instance FromNix Integer m (NValue m) where
fromNixMay = \case
NVConstant (NInt b) -> pure $ Just b
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected an integer, but saw: " ++ show v
instance FromNix Float m (NValueNF m) where
fromNixMay = \case
Fix (NVConstant (NFloat b)) -> pure $ Just b
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a float, but saw: " ++ show v
instance FromNix Float m (NValue m) where
fromNixMay = \case
NVConstant (NFloat b) -> pure $ Just b
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a float, but saw: " ++ show v
instance FromNix Text m (NValueNF m) where
fromNixMay = \case
Fix (NVStr t _) -> pure $ Just t
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a string, but saw: " ++ show v
instance FromNix Text m (NValue m) where
fromNixMay = \case
NVStr t _ -> pure $ Just t
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a string, but saw: " ++ show v
newtype Path = Path { getPath :: FilePath }
deriving Show
instance FromNix Path m (NValueNF m) where
fromNixMay = \case
Fix (NVPath p) -> pure $ Just (Path p)
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a path, but saw: " ++ show v
instance FromNix Path m (NValue m) where
fromNixMay = \case
NVPath p -> pure $ Just (Path p)
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a path, but saw: " ++ show v
instance FromNix [NValueNF m] m (NValueNF m) where
fromNixMay = \case
Fix (NVList l) -> pure $ Just l
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a list, but saw: " ++ show v
instance FromNix [NThunk m] m (NValue m) where
fromNixMay = \case
NVList l -> pure $ Just l
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected a list, but saw: " ++ show v
instance FromNix (HashMap Text (NValueNF m)) m (NValueNF m) where
fromNixMay = \case
Fix (NVSet s _) -> pure $ Just s
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected an attrset, but saw: " ++ show v
instance FromNix (HashMap Text (NThunk m)) m (NValue m) where
fromNixMay = \case
NVSet s _ -> pure $ Just s
_ -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Expected an attrset, but saw: " ++ show v
instance FromNix a m (NValue m) => FromNix a m (m (NValue m)) where
fromNix v = v >>= fromNix
fromNixMay v = v >>= fromNixMay
instance (MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValue m)) => FromNix a m (NThunk m) where
fromNix = force ?? fromNix
fromNixMay = force ?? fromNixMay
instance (MonadThunk (NValue m) (NThunk m) m,
FromNix a m (NValue m)) => FromNix a m (m (NThunk m)) where
fromNix v = v >>= fromNix
fromNixMay v = v >>= fromNixMay
instance (MonadCatch m, MonadFix m, MonadIO m,
FromNix a m (NValueNF m)) => FromNix a m NExprLoc where
fromNix = evalTopLevelExprLoc Nothing [] >=> fromNix
fromNixMay = evalTopLevelExprLoc Nothing [] >=> fromNixMay
instance (MonadCatch m, MonadFix m, MonadIO m,
FromNix a m (NValueNF m)) => FromNix a m NExpr where
fromNix = evalTopLevelExpr Nothing [] >=> fromNix
fromNixMay = evalTopLevelExpr Nothing [] >=> fromNixMay
toEncodingSorted :: A.Value -> A.Encoding
toEncodingSorted = \case
A.Object m ->
A.pairs . mconcat
. fmap (\(k, v) -> A.pair k $ toEncodingSorted v)
. sortOn fst
$ M.toList m
A.Array l -> A.list toEncodingSorted $ V.toList l
v -> A.toEncoding v
instance FromNix A.Value m (NValueNF m) where
fromNixMay = \case
Fix (NVConstant a) -> pure $ Just $ case a of
NInt n -> toJSON n
NFloat n -> toJSON n
NBool b -> toJSON b
NNull -> A.Null
NUri u -> toJSON u
Fix (NVStr s _) -> pure $ Just $ toJSON s
Fix (NVList l) -> fmap (A.Array . V.fromList) . sequence
<$> traverse fromNixMay l
Fix (NVSet m _) -> fmap A.Object . sequence <$> traverse fromNixMay m
Fix NVClosure {} -> pure Nothing
Fix (NVPath p) -> Just . toJSON . unStorePath <$> addPath p
Fix (NVBuiltin _ _) -> pure Nothing
fromNix = fromNixMay >=> \case
Just b -> pure b
v -> throwError $ "Cannot convert value to JSON: " ++ show v
instance MonadThunk (NValue m) (NThunk m) m
=> FromNix A.Value m (NValue m) where
fromNixMay = normalForm >=> fromNixMay
fromNix = normalForm >=> fromNix
class ToNix a m v where
toNix :: MonadNix e m => a -> m v
instance ToNix Bool m (NValueNF m) where
toNix = pure . Fix . NVConstant . NBool
instance ToNix Bool m (NValue m) where
toNix = pure . NVConstant . NBool
instance ToNix Int m (NValueNF m) where
toNix = pure . Fix . NVConstant . NInt . toInteger
instance ToNix Int m (NValue m) where
toNix = pure . NVConstant . NInt . toInteger
instance ToNix Integer m (NValueNF m) where
toNix = pure . Fix . NVConstant . NInt
instance ToNix Integer m (NValue m) where
toNix = pure . NVConstant . NInt
instance ToNix Float m (NValueNF m) where
toNix = pure . Fix . NVConstant . NFloat
instance ToNix Float m (NValue m) where
toNix = pure . NVConstant . NFloat
instance ToNix Text m (NValueNF m) where
toNix = pure . Fix . flip NVStr mempty
instance ToNix Text m (NValue m) where
toNix = pure . flip NVStr mempty
instance ToNix Path m (NValueNF m) where
toNix = pure . Fix . NVPath . getPath
instance ToNix Path m (NValue m) where
toNix = pure . NVPath . getPath
instance ToNix a m (NValueNF m) => ToNix [a] m (NValueNF m) where
toNix = fmap (Fix . NVList) . traverse toNix
instance (MonadThunk (NValue m) (NThunk m) m,
ToNix a m (NValue m)) => ToNix [a] m (NValue m) where
toNix = fmap NVList . traverse toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValueNF m))
=> ToNix (HashMap Text a) m (NValueNF m) where
toNix = fmap (Fix . flip NVSet M.empty) . traverse toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
=> ToNix (HashMap Text a) m (NValue m) where
toNix = fmap (flip NVSet M.empty) . traverse toNix
instance ToNix a m (NValue m) => ToNix a m (m (NValue m)) where
toNix = pure . toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
=> ToNix a m (NThunk m) where
toNix = fmap (value @(NValue m) @_ @m) . toNix
instance (MonadThunk (NValue m) (NThunk m) m, ToNix a m (NValue m))
=> ToNix a m (m (NThunk m)) where
toNix = pure . fmap (value @(NValue m) @_ @m) . toNix
instance ToNix Bool m (NExprF r) where
toNix = pure . NConstant . NBool
instance ToNix a m (NExprF (Fix NExprF)) => ToNix a m NExpr where
toNix = fmap Fix . toNix
instance ToNix a m (NExprF (Fix (Compose (Ann SrcSpan) NExprF)))
=> ToNix a m NExprLoc where
toNix = fmap (Fix . Compose . Ann (SrcSpan blankSpan blankSpan)) . toNix
where
blankSpan = SourcePos "<unknown>" (mkPos 1) (mkPos 1)

80
src/Nix/Entry.hs Normal file
View File

@ -0,0 +1,80 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Nix.Entry where
import Control.Applicative
import Control.Monad.Catch
import Control.Monad.Fix
import Control.Monad.IO.Class
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as Text
import Nix.Builtins
import Nix.Effects
import qualified Nix.Eval as Eval
import Nix.Exec
import Nix.Expr.Types (NExpr)
import Nix.Expr.Types.Annotated (NExprLoc)
import Nix.Normal
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. MonadNix e m
=> (a -> m (NValue m)) -> Maybe FilePath -> [String] -> a
-> m (NValueNF m)
evalTopLevelExprGen cont mpath incls expr = do
base <- baseEnv
let i = value @(NValue m) @(NThunk m) @m $ NVList $
map (value @(NValue m) @(NThunk m) @m
. flip NVStr mempty . Text.pack) incls
pushScope (M.singleton "__includes" i) $
(normalForm =<<) $ 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
evalTopLevelExpr :: forall e m. MonadNix e m
=> Maybe FilePath -> [String] -> NExpr -> m (NValueNF m)
evalTopLevelExpr = evalTopLevelExprGen $
Eval.evalExpr @_ @(NValue m) @(NThunk m) @m
eval :: (MonadFix m, MonadThrow m, MonadCatch m, MonadIO m)
=> Maybe FilePath -> [String] -> NExpr -> m (NValueNF (Lazy m))
eval mpath incls = runLazyM . evalTopLevelExpr mpath incls
-- | Evaluate a nix expression in the default context
evalTopLevelExprLoc :: forall e m. MonadNix e m
=> Maybe FilePath -> [String] -> NExprLoc -> m (NValueNF m)
evalTopLevelExprLoc = evalTopLevelExprGen $
Eval.framedEvalExpr (Eval.eval @_ @(NValue m) @(NThunk m) @m)
evalLoc :: (MonadFix m, MonadThrow m, MonadCatch m, MonadIO m)
=> Maybe FilePath -> [String] -> NExprLoc -> m (NValueNF (Lazy m))
evalLoc mpath incls = runLazyM . evalTopLevelExprLoc mpath incls
tracingEvalLoc
:: forall m. (MonadFix m, MonadThrow m, MonadCatch m,
Alternative m, MonadIO m)
=> Maybe FilePath -> [String] -> NExprLoc -> m (NValueNF (Lazy m))
tracingEvalLoc mpath incls expr =
runLazyM . evalTopLevelExprGen id mpath incls
=<< Eval.tracingEvalExpr @_ @(Lazy m) @_ @(NValue (Lazy m))
(Eval.eval @_ @(NValue (Lazy m))
@(NThunk (Lazy m)) @(Lazy m)) expr

33
src/Nix/Entry.hs-boot Normal file
View File

@ -0,0 +1,33 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module Nix.Entry where
import Control.Monad.Catch (MonadCatch)
import Control.Monad.Fix (MonadFix)
import Nix.Effects (MonadEffects)
import Nix.Expr.Types (NExpr)
import Nix.Expr.Types.Annotated (NExprLoc)
import Nix.Scope (Scoped)
import Nix.Stack (Framed, MonadFile)
import Nix.Thunk
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)
evalTopLevelExprGen
:: forall e m a. MonadNix e m
=> (a -> m (NValue m)) -> Maybe FilePath -> [String] -> a
-> m (NValueNF m)
-- | Evaluate a nix expression in the default context
evalTopLevelExpr :: forall e m. MonadNix e m
=> Maybe FilePath -> [String] -> NExpr -> m (NValueNF m)
evalTopLevelExprLoc :: forall e m. MonadNix e m
=> Maybe FilePath -> [String] -> NExprLoc -> m (NValueNF m)

98
src/Nix/Exec.hs
View File

@ -35,6 +35,7 @@ import qualified Data.ByteString as BS
import Data.Coerce
import Data.Fix
import Data.Functor.Compose
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as M
import Data.IORef
import Data.List
@ -44,6 +45,7 @@ import Data.Text (Text)
import qualified Data.Text as Text
import Nix.Atoms
import Nix.Context
import Nix.Convert
import Nix.Effects
import Nix.Eval
import qualified Nix.Eval as Eval
@ -63,15 +65,12 @@ import System.FilePath
import qualified System.Info
import System.Posix.Files
import System.Process (readProcessWithExitCode)
import {-# SOURCE #-} Nix.Entry
type MonadExec e m =
(Scoped e (NThunk m) m, Framed e m, MonadVar m, MonadFile m,
MonadEffects m)
nverr :: forall e m a. MonadExec e m => String -> m a
nverr :: forall e m a. MonadNix e m => String -> m a
nverr = evalError @(NValue m)
instance MonadExec e m => ConvertValue (NValue m) Bool where
instance MonadNix e m => ConvertValue (NValue m) Bool where
ofVal = NVConstant . NBool
wantVal = \case NVConstant (NBool b) -> Just b; _ -> Nothing
@ -127,12 +126,12 @@ instance ConvertValue (NValue m) (AttrSet (NThunk m)) where
ofVal = flip NVSet M.empty
wantVal = \case NVSet s _ -> Just s; _ -> Nothing
instance MonadExec e m => MonadThunk (NValue m) (NThunk m) m where
instance MonadNix e m => MonadThunk (NValue m) (NThunk m) m where
thunk = fmap coerce . buildThunk
force = forceThunk . coerce
value = coerce . valueRef
instance MonadExec e m => MonadEval (NValue m) m where
instance MonadNix e m => MonadEval (NValue m) m where
freeVariable var =
nverr $ "Undefined variable '" ++ Text.unpack var ++ "'"
@ -188,7 +187,7 @@ instance MonadExec e m => MonadEval (NValue m) m where
v -> fmap (Just . Just) . valueText True =<< normalForm v
infixl 1 `callFunc`
callFunc :: MonadExec e m => NValue m -> m (NValue m) -> m (NValue m)
callFunc :: MonadNix e m => NValue m -> m (NValue m) -> m (NValue m)
callFunc fun arg = case fun of
NVClosure _ f -> do
traceM "callFunc:NVFunction"
@ -217,7 +216,7 @@ execUnaryOp op arg = do
++ " must evaluate to an atomic type: " ++ show x
execBinaryOp
:: forall e m. (MonadExec e m, MonadEval (NValue m) m)
:: forall e m. (MonadNix e m, MonadEval (NValue m) m)
=> NBinaryOp -> NValue m -> m (NValue m) -> m (NValue m)
execBinaryOp NOr larg rarg = case larg of
@ -362,7 +361,8 @@ instance MonadCatch m => MonadCatch (Lazy m) where
instance MonadThrow m => MonadThrow (Lazy m) where
throwM = Lazy . throwM
instance (MonadFix m, MonadThrow m, MonadIO m) => MonadEffects (Lazy m) where
instance (MonadFix m, MonadCatch m, MonadThrow m, MonadIO m)
=> MonadEffects (Lazy m) where
addPath path = do
(exitCode, out, _) <-
liftIO $ readProcessWithExitCode "nix-store" ["--add", path] ""
@ -387,48 +387,7 @@ instance (MonadFix m, MonadThrow m, MonadIO m) => MonadEffects (Lazy m) where
pure $ cwd <///> origPath
liftIO $ removeDotDotIndirections <$> canonicalizePath absPath
findEnvPath name = do
mres <- lookupVar @_ @(NThunk (Lazy m)) "__nixPath"
mpath <- case mres of
Nothing -> error "impossible"
Just x -> force x $ \case
NVList l -> foldM go Nothing l
v -> throwError $
"__nixPath must be a list of attr sets, but saw: "
++ show v
case mpath of
Nothing ->
throwError $ "file '" ++ name
++ "' was not found in the Nix search path"
++ " (add it using $NIX_PATH or -I)"
Just path -> return path
where
-- jww (2018-04-13): Introduce abstractions to make working with Nix
-- values like this within Haskell much easier!
go :: Maybe FilePath -> NThunk (Lazy m) -> Lazy m (Maybe FilePath)
go p@(Just _) _ = pure p
go Nothing l = force l $ \case
v@(NVSet s _) -> case M.lookup "path" s of
Just p -> force p $ \p' -> case wantVal p' of
Just (path :: Text) -> case M.lookup "prefix" s of
Nothing -> tryPath (Text.unpack path) Nothing
Just pf -> force pf $ \pf' -> case wantVal pf' of
Just (pfx :: Text) | not (Text.null pfx) ->
tryPath (Text.unpack path)
(Just (Text.unpack pfx))
_ -> tryPath (Text.unpack path) Nothing
_ -> throwError $ "__nixPath must be a list of attr sets"
++ " with textual 'path' elements, but saw: " ++ show v
Nothing ->
throwError $ "__nixPath must be a list of attr sets"
++ " with 'path' elements, but saw: "
++ show v
v -> throwError $ "__nixPath must be a list of attr sets"
++ " with textual 'path' elements, but saw: " ++ show v
tryPath p (Just n) | n':ns <- splitDirectories name, n == n' =
nixFilePath $ p <///> joinPath ns
tryPath p _ = nixFilePath $ p <///> name
findEnvPath = findEnvPathM
pathExists = liftIO . fileExist
@ -528,3 +487,36 @@ nixFilePath path = do
else return path
exists <- liftIO $ doesFileExist path'
return $ if exists then Just path' else Nothing
findEnvPathM :: forall e m. (MonadNix e m, MonadIO m)
=> FilePath -> m FilePath
findEnvPathM name = do
mres <- lookupVar @_ @(NThunk m) "__nixPath"
mpath <- case mres of
Nothing -> error "impossible"
Just x -> fromNix x >>= \(l :: [NThunk m]) -> foldM go Nothing l
case mpath of
Nothing ->
throwError $ "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 = fromNix l >>= \(s :: HashMap Text (NThunk m)) ->
case M.lookup "path" s of
Just p -> fromNix p >>= \(Path path) ->
case M.lookup "prefix" s of
Nothing -> tryPath path Nothing
Just pf -> fromNixMay pf >>= \case
Just (pfx :: Text) | not (Text.null pfx) ->
tryPath path (Just (Text.unpack pfx))
_ -> tryPath path Nothing
Nothing ->
throwError $ "__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' =
nixFilePath $ p <///> joinPath ns
tryPath p _ = nixFilePath $ p <///> name