From 6c9cbf241acd45263552efce440f6962e66eeb32 Mon Sep 17 00:00:00 2001 From: John Wiegley Date: Fri, 13 Apr 2018 18:09:12 -0700 Subject: [PATCH] Rewrite ToNix/FromNix, although Builtins.hs is not using it yet --- hnix.cabal | 4 +- src/Nix.hs | 74 +--------- src/Nix/Builtins.hs | 4 +- src/Nix/Convert.hs | 311 ++++++++++++++++++++++++++++++++++++++++++ src/Nix/Entry.hs | 80 +++++++++++ src/Nix/Entry.hs-boot | 33 +++++ src/Nix/Exec.hs | 98 ++++++------- 7 files changed, 475 insertions(+), 129 deletions(-) create mode 100644 src/Nix/Convert.hs create mode 100644 src/Nix/Entry.hs create mode 100644 src/Nix/Entry.hs-boot diff --git a/hnix.cabal b/hnix.cabal index d340a8a..e11f07c 100644 --- a/hnix.cabal +++ b/hnix.cabal @@ -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 diff --git a/src/Nix.hs b/src/Nix.hs index 05b3319..5acc515 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -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 diff --git a/src/Nix/Builtins.hs b/src/Nix/Builtins.hs index 7fbfaa5..8528016 100644 --- a/src/Nix/Builtins.hs +++ b/src/Nix/Builtins.hs @@ -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" diff --git a/src/Nix/Convert.hs b/src/Nix/Convert.hs new file mode 100644 index 0000000..bbd9dee --- /dev/null +++ b/src/Nix/Convert.hs @@ -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 "" (mkPos 1) (mkPos 1) diff --git a/src/Nix/Entry.hs b/src/Nix/Entry.hs new file mode 100644 index 0000000..2f802ea --- /dev/null +++ b/src/Nix/Entry.hs @@ -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 diff --git a/src/Nix/Entry.hs-boot b/src/Nix/Entry.hs-boot new file mode 100644 index 0000000..eeaa79f --- /dev/null +++ b/src/Nix/Entry.hs-boot @@ -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) diff --git a/src/Nix/Exec.hs b/src/Nix/Exec.hs index 0670212..e857ef6 100644 --- a/src/Nix/Exec.hs +++ b/src/Nix/Exec.hs @@ -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