Add derivation builtin

This commit is contained in:
Ryan Trinkle 2018-04-07 18:34:54 -04:00
parent a704bb045f
commit 8b0de962b0
6 changed files with 85 additions and 13 deletions

View file

@ -7,6 +7,7 @@
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
@ -52,11 +53,13 @@ import Data.These (fromThese)
import Data.Traversable (mapM)
import qualified Data.Vector as V
import GHC.Stack.Types (HasCallStack)
import Language.Haskell.TH.Syntax (addDependentFile, runIO)
import Nix.Atoms
import Nix.Eval
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Monad
import Nix.Parser
import Nix.Pretty
import Nix.Scope
import Nix.Stack
@ -109,6 +112,13 @@ builtinsList = sequence [
, add TopLevel "abort" throw_ -- for now
, add TopLevel "throw" throw_
, add2 TopLevel "scopedImport" scopedImport
, add TopLevel "derivationStrict" derivationStrict_
, add0 TopLevel "derivation" $(do
let f = "data/nix/corepkgs/derivation.nix"
addDependentFile f
Success expr <- runIO $ parseNixFile f
[| evalExpr expr |]
)
, add Normal "getEnv" getEnv_
, add2 Normal "hasAttr" hasAttr
, add2 Normal "getAttr" getAttr
@ -207,7 +217,7 @@ deltaInfo = \case
Columns c _ -> ("<string>", 1, fromIntegral c + 1)
Tab {} -> ("<string>", 1, 1)
Lines l _ _ _ -> ("<string>", fromIntegral l + 1, 1)
Directed fn l c _ _ -> (decodeUtf8 fn,
Directed fn l c _ _ -> (Text.pack fn,
fromIntegral l + 1, fromIntegral c + 1)
posFromDelta :: Delta -> NValue m
@ -790,6 +800,11 @@ currentSystem = do
arch <- getCurrentSystemArch
return $ NVStr (os <> "-" <> arch) mempty
derivationStrict_ :: MonadBuiltins e m => NThunk m -> m (NValue m)
derivationStrict_ t = do
v <- force t normalForm
toValue =<< derivationStrict v
newtype Prim m a = Prim { runPrim :: m a }
class ToNix a where

View file

@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveGeneric #-}
@ -7,6 +8,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
-- | The nix expression type and supporting types.
module Nix.Expr.Types where
@ -15,14 +17,17 @@ import Data.Eq.Deriving
import Data.Fix
import Data.Functor.Classes
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import Data.Text (Text, pack)
import Data.Text (Text, pack, unpack)
import Data.Traversable
import GHC.Exts
import GHC.Generics
import Language.Haskell.TH.Syntax
import Nix.Atoms
import Nix.Parser.Library (Delta(..))
import Nix.Utils
import Text.Show.Deriving
import Type.Reflection (eqTypeRep)
import qualified Type.Reflection as Reflection
type VarName = Text
@ -81,6 +86,12 @@ data NExprF r
instance IsString NExpr where
fromString = Fix . NSym . fromString
instance Lift (Fix NExprF) where
lift = dataToExpQ $ \b ->
case Reflection.typeOf b `eqTypeRep` Reflection.typeRep @Text of
Just HRefl -> Just [| pack $(liftString $ unpack b) |]
Nothing -> Nothing
-- | The monomorphic expression type is a fixed point of the polymorphic one.
type NExpr = Fix NExprF

View file

@ -10,6 +10,7 @@
module Nix.Monad where
import Data.Text (Text)
import Data.HashMap.Strict (HashMap)
import Nix.Value
import System.Posix.Files
@ -32,6 +33,8 @@ class Monad m => MonadNix m where
listDirectory :: FilePath -> m [FilePath]
getSymbolicLinkStatus :: FilePath -> m FileStatus
derivationStrict :: NValueNF m -> m (HashMap Text Text)
builtin :: MonadNix m => String -> (NThunk m -> m (NValue m)) -> m (NValue m)
builtin name f = return $ NVBuiltin name f

View file

@ -21,6 +21,7 @@ import Control.Monad.Fix
import Control.Monad.IO.Class
import Control.Monad.Reader (MonadReader)
import Control.Monad.Trans.Reader
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import Data.Fix
import qualified Data.HashMap.Lazy as M
@ -29,10 +30,12 @@ import Data.List
import Data.List.Split
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding
import Nix.Atoms
import Nix.Eval
import Nix.Monad
import Nix.Parser
import Nix.Pretty
import Nix.Scope
import Nix.Stack
import Nix.Thunk
@ -111,7 +114,7 @@ instance (MonadFix m, MonadIO m) => MonadNix (Lazy m) where
ExitSuccess -> do
let dropTrailingLinefeed p = take (length p - 1) p
return $ StorePath $ dropTrailingLinefeed out
_ -> error $ "No such file or directory: " ++ show path
_ -> error $ "addPath: failed: nix-store --add " ++ show path
makeAbsolutePath origPath = do
absPath <- if isAbsolute origPath then pure origPath else do
@ -171,5 +174,19 @@ instance (MonadFix m, MonadIO m) => MonadNix (Lazy m) where
listDirectory = liftIO . System.Directory.listDirectory
getSymbolicLinkStatus = liftIO . System.Posix.Files.getSymbolicLinkStatus
derivationStrict v = liftIO $ do
(exitCode, out, _) <-
readProcessWithExitCode "nix-instantiate"
[ "--eval"
, "--json"
, "-E", "derivationStrict " ++ show (prettyNixValue v) --TODO: use prettyNix to generate this
] ""
case exitCode of
ExitSuccess -> do
case A.eitherDecodeStrict $ encodeUtf8 $ Text.pack out of
Left e -> error $ "derivationStrict: error parsing JSON output of nix-instantiate: " ++ show e
Right v -> pure v
_ -> error "derivationStrict: nix-instantiate failed"
runLazyM :: MonadIO m => Lazy m a -> m a
runLazyM = flip runReaderT (Context emptyScopes []) . runLazy

View file

@ -1,21 +1,27 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Nix.Parser.Library
( module Nix.Parser.Library
, module X
, Trifecta.Delta(..)
) where
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.Data
import Data.Functor
import qualified Data.HashSet as HashSet
import Data.Int (Int64)
import Data.List (nub)
import Data.Text
import Data.Text.Encoding
import GHC.Generics
import Text.Parser.Char as X hiding (text)
import Text.Parser.Combinators as X
import Text.Parser.Expression as X
@ -141,9 +147,31 @@ someTill p end = go
scan = (end $> []) <|> go
--------------------------------------------------------------------------------
-- | Like Text.Trifecta.Delta.Delta, but with FilePath instead of ByteString
data Delta
= Columns !Int64 !Int64
| Tab !Int64 !Int64 !Int64
| Lines !Int64 !Int64 !Int64 !Int64
| Directed !FilePath !Int64 !Int64 !Int64 !Int64
deriving (Generic, Data, Eq, Ord, Show, Read)
deltaFromTrifecta :: Trifecta.Delta -> Delta
deltaFromTrifecta = \case
Trifecta.Columns a b -> Columns a b
Trifecta.Tab a b c -> Tab a b c
Trifecta.Lines a b c d -> Lines a b c d
Trifecta.Directed a b c d e -> Directed (unpack $ decodeUtf8 a) b c d e
deltaToTrifecta :: Delta -> Trifecta.Delta
deltaToTrifecta = \case
Columns a b -> Trifecta.Columns a b
Tab a b c -> Trifecta.Tab a b c
Lines a b c d -> Trifecta.Lines a b c d
Directed a b c d e -> Trifecta.Directed (encodeUtf8 $ pack a) b c d e
parseFromFileEx :: MonadIO m => Parser a -> FilePath -> m (Result a)
parseFromString :: Parser a -> String -> Result a
position :: Parser Trifecta.Delta
position :: Parser Delta
#if USE_PARSEC
data Result a = Success a
@ -168,6 +196,6 @@ parseFromFileEx p = Trifecta.parseFromFileEx (runNixParser p)
parseFromString p = Trifecta.parseString (runNixParser p) (Trifecta.Directed "<string>" 0 0 0 0)
position = Trifecta.position
position = deltaFromTrifecta <$> Trifecta.position
#endif

View file

@ -11,13 +11,11 @@ import Control.Monad.Reader
import Data.ByteString (ByteString)
import Data.Fix
import Data.Functor.Compose
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Nix.Expr.Types
import Nix.Expr.Types.Annotated
import Nix.Parser.Library
import Nix.Pretty
import Nix.Utils
import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
import Text.Trifecta.Rendering
import Text.Trifecta.Result
@ -36,14 +34,14 @@ class Monad m => MonadFile m where
renderLocation :: MonadFile m => SrcSpan -> Doc -> m Doc
renderLocation (SrcSpan beg@(Directed "<string>" _ _ _ _) end) msg =
return $ explain (addSpan beg end emptyRendering)
return $ explain (addSpan (deltaToTrifecta beg) (deltaToTrifecta end) emptyRendering)
(Err (Just msg) [] mempty [])
renderLocation (SrcSpan beg@(Directed path _ _ _ _) end) msg = do
contents <- Nix.Stack.readFile (Text.unpack (Text.decodeUtf8 path))
return $ explain (addSpan beg end (rendered beg contents))
contents <- Nix.Stack.readFile path
return $ explain (addSpan (deltaToTrifecta beg) (deltaToTrifecta end) (rendered (deltaToTrifecta beg) contents))
(Err (Just msg) [] mempty [])
renderLocation (SrcSpan beg end) msg =
return $ explain (addSpan beg end emptyRendering)
return $ explain (addSpan (deltaToTrifecta beg) (deltaToTrifecta end) emptyRendering)
(Err (Just msg) [] mempty [])
renderFrame :: MonadFile m => Either String (NExprLocF ()) -> m String