From c3eb7a94b95554bb108ae2c7fce3c1fb7296ca25 Mon Sep 17 00:00:00 2001 From: John Wiegley Date: Tue, 3 Apr 2018 14:21:33 -0700 Subject: [PATCH] Add basic support for quasi-quotation of Nix expressions in Haskell --- Nix.hs | 70 ++++++++++++++++++++++----------------- Nix/Lint.hs | 1 + Nix/Monad/Instance.hs | 13 ++++---- Nix/TH.hs | 36 ++++++++++++++++++++ default.nix | 5 +-- hnix.cabal | 4 +++ main/Main.hs | 36 +++++++++++--------- tests/EvalTests.hs | 11 +++--- tests/NixLanguageTests.hs | 10 +++--- 9 files changed, 119 insertions(+), 67 deletions(-) create mode 100644 Nix/TH.hs diff --git a/Nix.hs b/Nix.hs index 9e6c3cb..ddf4f82 100644 --- a/Nix.hs +++ b/Nix.hs @@ -7,8 +7,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeSynonymInstances #-} -module Nix where +module Nix (eval, evalLoc, tracingEvalLoc, lint, runLintM) where +import Control.Applicative import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class @@ -17,9 +18,12 @@ import Control.Monad.Trans.Reader import qualified Data.HashMap.Lazy as M import Data.Text (Text) import Nix.Builtins -import Nix.Eval -import Nix.Expr.Types.Annotated (NExprLoc, stripAnnotation) -import Nix.Lint +import qualified Nix.Eval as Eval +import Nix.Eval hiding (eval) +import Nix.Expr.Types (NExpr) +import Nix.Expr.Types.Annotated (NExprLoc) +import qualified Nix.Lint as Lint +import Nix.Lint hiding (lint) import Nix.Monad import Nix.Monad.Instance import Nix.Scope @@ -27,32 +31,44 @@ import Nix.Utils -- | Evaluate a nix expression in the default context evalTopLevelExpr :: MonadBuiltins e m - => Maybe FilePath -> NExprLoc -> m (NValueNF m) -evalTopLevelExpr mpath expr = do + => NExpr -> m (NValueNF m) +evalTopLevelExpr expr = do + base <- baseEnv + normalForm =<< pushScopes base (Eval.evalExpr expr) + +eval :: (MonadFix m, MonadIO m) + => NExpr -> m (NValueNF (Lazy m)) +eval = runLazyM . evalTopLevelExpr + +-- | Evaluate a nix expression in the default context +evalTopLevelExprLoc :: MonadBuiltins e m + => Maybe FilePath -> NExprLoc -> m (NValueNF m) +evalTopLevelExprLoc mpath expr = do base <- baseEnv (normalForm =<<) $ pushScopes base $ case mpath of - Nothing -> framedEvalExpr eval expr + Nothing -> framedEvalExpr Eval.eval expr Just path -> do traceM $ "Setting __cur_file = " ++ show path ref <- valueThunk $ NVLiteralPath path pushScope (M.singleton "__cur_file" ref) - (framedEvalExpr eval expr) + (framedEvalExpr Eval.eval expr) -evalTopLevelExprIO :: Maybe FilePath -> NExprLoc -> IO (NValueNF (Lazy IO)) -evalTopLevelExprIO mpath = runLazyIO . evalTopLevelExpr mpath +evalLoc :: (MonadFix m, MonadIO m) + => Maybe FilePath -> NExprLoc -> m (NValueNF (Lazy m)) +evalLoc mpath = runLazyM . evalTopLevelExprLoc mpath -tracingEvalTopLevelExprIO :: Maybe FilePath -> NExprLoc - -> IO (NValueNF (Lazy IO)) -tracingEvalTopLevelExprIO mpath expr = do - traced <- tracingEvalExpr eval expr +tracingEvalLoc :: (MonadFix m, MonadIO m, Alternative m) + => Maybe FilePath -> NExprLoc -> m (NValueNF (Lazy m)) +tracingEvalLoc mpath expr = do + traced <- tracingEvalExpr Eval.eval expr case mpath of Nothing -> - runLazyIO (normalForm =<< (`pushScopes` traced) =<< baseEnv) + runLazyM (normalForm =<< (`pushScopes` traced) =<< baseEnv) Just path -> do traceM $ "Setting __cur_file = " ++ show path - ref <- runLazyIO (valueThunk $ NVLiteralPath path) + ref <- runLazyM (valueThunk $ NVLiteralPath path) let m = M.singleton "__cur_file" ref - runLazyIO (baseEnv >>= (`pushScopes` pushScope m traced) + runLazyM (baseEnv >>= (`pushScopes` pushScope m traced) >>= normalForm) newtype Lint m a = Lint @@ -61,7 +77,7 @@ newtype Lint m a = Lint MonadReader (Context (Lint m) (SThunk (Lint m)))) instance (MonadFix m, MonadIO m) - => MonadEval (SThunk (Lint m)) (Symbolic (Lint m)) (Lint m) where + => Eval.MonadEval (SThunk (Lint m)) (Symbolic (Lint m)) (Lint m) where embedSet s = mkSymbolic [TSet (Just s)] projectSet = unpackSymbolic >=> \case NMany [TSet s] -> return s @@ -75,20 +91,12 @@ instance (MonadFix m, MonadIO m) embedText = const $ mkSymbolic [TStr] projectText = const $ return Nothing -runLintIO :: Lint IO a -> IO a -runLintIO = flip runReaderT (Context emptyScopes []) . runLint +runLintM :: Lint m a -> m a +runLintM = flip runReaderT (Context emptyScopes []) . runLint symbolicBaseEnv :: Monad m => m (Scopes m (SThunk m)) symbolicBaseEnv = return [] -- jww (2018-04-02): TODO -lintExprIO :: NExprLoc -> IO (Symbolic (Lint IO)) -lintExprIO expr = - runLintIO $ symbolicBaseEnv - >>= (`pushScopes` lintExpr (stripAnnotation expr)) - -tracingLintExprIO :: NExprLoc -> IO (Symbolic (Lint IO)) -tracingLintExprIO expr = do - traced <- tracingEvalExpr lint expr - ref <- runLintIO $ sthunk $ mkSymbolic [TPath] - let m = M.singleton "__cur_file" ref - runLintIO $ symbolicBaseEnv >>= (`pushScopes` pushScope m traced) +lint :: (MonadFix m, MonadIO m) => NExpr -> m (Symbolic (Lint m)) +lint expr = runLintM $ symbolicBaseEnv + >>= (`pushScopes` Lint.lintExpr expr) diff --git a/Nix/Lint.hs b/Nix/Lint.hs index 88d8108..e9a9482 100644 --- a/Nix/Lint.hs +++ b/Nix/Lint.hs @@ -294,6 +294,7 @@ lint (NSelect aset attr alternative) = do ++ intercalate "." (map show ks) ++ " in " ++ show (void aset') where + extract NAny (_:_) = Just <$> everyPossible extract (NMany [TSet Nothing]) (_:_ks) = error "NYI: Selection in unknown set" extract (NMany [TSet (Just s)]) (k:ks) = case M.lookup k s of diff --git a/Nix/Monad/Instance.hs b/Nix/Monad/Instance.hs index 511063c..2a4a62d 100644 --- a/Nix/Monad/Instance.hs +++ b/Nix/Monad/Instance.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -65,7 +66,7 @@ instance (MonadFix m, MonadNix (Lazy m), MonadIO m) NVConstant NNull -> return $ Just Nothing v -> fmap (Just . Just) . valueText True =<< normalForm v -instance MonadNix (Lazy IO) where +instance (MonadFix m, MonadIO m) => MonadNix (Lazy m) where addPath path = liftIO $ do (exitCode, out, _) <- readProcessWithExitCode "nix-store" ["--add", path] "" @@ -78,7 +79,7 @@ instance MonadNix (Lazy IO) where makeAbsolutePath origPath = do absPath <- if isAbsolute origPath then pure origPath else do cwd <- do - mres <- lookupVar @_ @(NThunk (Lazy IO)) "__cur_file" + mres <- lookupVar @_ @(NThunk (Lazy m)) "__cur_file" case mres of Nothing -> liftIO getCurrentDirectory Just v -> force v >>= \case @@ -106,11 +107,11 @@ instance Has (Context m v) (Scopes m v) where instance Has (Context m v) Frames where hasLens f (Context x y) = Context x <$> f y -instance MonadNixEnv (Lazy IO) where +instance (MonadFix m, MonadIO m) => MonadNixEnv (Lazy m) where -- jww (2018-03-29): Cache which files have been read in. importFile = force >=> \case NVLiteralPath path -> do - mres <- lookupVar @(Context (Lazy IO) (NThunk (Lazy IO))) + mres <- lookupVar @(Context (Lazy m) (NThunk (Lazy m))) "__cur_file" path' <- case mres of Nothing -> do @@ -144,5 +145,5 @@ instance MonadNixEnv (Lazy IO) where Just v -> NVStr (Text.pack v) mempty p -> error $ "Unexpected argument to getEnv: " ++ show (void p) -runLazyIO :: Lazy IO a -> IO a -runLazyIO = flip runReaderT (Context emptyScopes []) . runLazy +runLazyM :: MonadIO m => Lazy m a -> m a +runLazyM = flip runReaderT (Context emptyScopes []) . runLazy diff --git a/Nix/TH.hs b/Nix/TH.hs new file mode 100644 index 0000000..3f60b8c --- /dev/null +++ b/Nix/TH.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -Wno-missing-fields #-} + +module Nix.TH where + +import Data.Fix +import Data.Generics.Aliases +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Nix.Expr +import Nix.Parser + +quoteExprExp :: String -> ExpQ +quoteExprExp s = do + expr <- case parseNixString s of + Failure err -> fail $ show err + Success e -> return e + dataToExpQ (const Nothing `extQ` metaExp (freeVars expr)) expr + +freeVars :: NExpr -> Set VarName +freeVars = error "NYI: Implement an evaluator to find free variables" + +metaExp :: Set VarName -> NExpr -> Maybe ExpQ +metaExp fvs (Fix (NSym x)) | x `Set.member` fvs = + Just [| toExpr $(varE (mkName (Text.unpack x))) |] +metaExp _ _ = Nothing + +nix :: QuasiQuoter +nix = QuasiQuoter + { quoteExp = quoteExprExp + } diff --git a/default.nix b/default.nix index ca57898..c7365d3 100644 --- a/default.nix +++ b/default.nix @@ -10,7 +10,7 @@ let , tasty, tasty-hunit, tasty-th, text, transformers, trifecta , unordered-containers, these, optparse-applicative, interpolate , process, exceptions, bytestring, mtl, monadlist, base16-bytestring - , cryptohash + , cryptohash, template-haskell, syb }: mkDerivation { pname = "hnix"; @@ -23,10 +23,11 @@ let parsers regex-tdfa regex-tdfa-text semigroups text transformers trifecta unordered-containers these process directory filepath exceptions bytestring mtl monadlist base16-bytestring cryptohash + template-haskell syb ]; executableHaskellDepends = [ ansi-wl-pprint base containers data-fix deepseq optparse-applicative - text transformers + text transformers template-haskell ]; testHaskellDepends = [ base containers data-fix directory filepath Glob split tasty diff --git a/hnix.cabal b/hnix.cabal index 6c8c2c5..b45085a 100644 --- a/hnix.cabal +++ b/hnix.cabal @@ -37,6 +37,7 @@ Library Nix.Pretty Nix.Parser.Operators Nix.StringOperations + Nix.TH Nix.Expr.Types Nix.Expr.Types.Annotated Other-modules: @@ -65,10 +66,12 @@ Library , filepath , semigroups >= 0.18 && < 0.19 , split + , template-haskell , regex-tdfa , regex-tdfa-text , these , unix + , syb if flag(parsec) Cpp-options: -DUSE_PARSEC Build-depends: parsec @@ -104,6 +107,7 @@ Executable hnix , deepseq , optparse-applicative , text + , template-haskell , transformers , filepath Ghc-options: -Wall diff --git a/main/Main.hs b/main/Main.hs index 4d7bfa6..6ffeff4 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -1,17 +1,19 @@ {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TupleSections #-} module Main where -import Control.Monad -import Nix -import Nix.Expr.Types.Annotated (stripAnnotation) -import Nix.Lint -import Nix.Parser -import Nix.Pretty -import Options.Applicative hiding (ParserResult(..)) -import System.IO -import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) +import Control.Monad +import qualified Nix +import Nix.Expr.Types.Annotated (stripAnnotation) +import Nix.Lint +import Nix.Parser +import Nix.Pretty +import Nix.TH +import Options.Applicative hiding (ParserResult(..)) +import System.IO +import Text.PrettyPrint.ANSI.Leijen hiding ((<$>)) data Options = Options { verbose :: Bool @@ -53,20 +55,22 @@ main = do (eres, mpath) <- case expression opts of Just s -> return (parseNixStringLoc s, Nothing) Nothing -> case filePath opts of - Nothing -> (, Nothing) . parseNixStringLoc <$> getContents - Just "-" -> (, Nothing) . parseNixStringLoc <$> getContents + Nothing -> (, Nothing) . parseNixStringLoc <$> System.IO.getContents + Just "-" -> (, Nothing) . parseNixStringLoc <$> System.IO.getContents Just path -> (, Just path) <$> parseNixFileLoc path + print . printNix =<< Nix.eval [nix|1 + 3|] + case eres of Failure err -> hPutStrLn stderr $ "Parse failed: " ++ show err Success expr -> do - when (check opts) $ do - sym <- lintExprIO expr - putStrLn =<< runLintIO (renderSymbolic sym) + when (check opts) $ + putStrLn =<< Nix.runLintM . renderSymbolic + =<< Nix.lint (stripAnnotation expr) if | evaluate opts, debug opts -> - print =<< tracingEvalTopLevelExprIO mpath expr + print =<< Nix.tracingEvalLoc mpath expr | evaluate opts -> - putStrLn . printNix =<< evalTopLevelExprIO mpath expr + putStrLn . printNix =<< Nix.evalLoc mpath expr | debug opts -> print expr | otherwise -> diff --git a/tests/EvalTests.hs b/tests/EvalTests.hs index f8e1b89..50982d1 100644 --- a/tests/EvalTests.hs +++ b/tests/EvalTests.hs @@ -9,7 +9,6 @@ module EvalTests (tests) where import Data.String.Interpolate import Nix import Nix.Expr -import Nix.Lint import Nix.Monad import Nix.Parser import Test.Tasty @@ -82,12 +81,10 @@ instance (Show r, Eq r) => Eq (NValueF m r) where constantEqual :: NExprLoc -> NExprLoc -> Assertion constantEqual a b = do - -- asym <- lintExprIO a - -- putStrLn =<< runLintIO (renderSymbolic asym) - a' <- tracingEvalTopLevelExprIO Nothing a - -- bsym <- lintExprIO b - -- putStrLn =<< runLintIO (renderSymbolic bsym) - b' <- tracingEvalTopLevelExprIO Nothing b + -- putStrLn =<< lint (stripAnnotation a) + a' <- tracingEvalLoc Nothing a + -- putStrLn =<< lint (stripAnnotation b) + b' <- tracingEvalLoc Nothing b assertEqual "" a' b' constantEqualStr :: String -> String -> Assertion diff --git a/tests/NixLanguageTests.hs b/tests/NixLanguageTests.hs index e9c32e5..27b8368 100644 --- a/tests/NixLanguageTests.hs +++ b/tests/NixLanguageTests.hs @@ -71,16 +71,16 @@ genTests = do _ -> error $ "Unexpected: " ++ show kind assertParse :: FilePath -> Assertion -assertParse file = parseNixFileLoc file >>= \case - Success expr -> void $ lintExprIO expr +assertParse file = parseNixFile file >>= \case + Success expr -> void $ lint expr Failure err -> assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err assertParseFail :: FilePath -> Assertion assertParseFail file = do - eres <- parseNixFileLoc file + eres <- parseNixFile file catch (case eres of Success expr -> do - _ <- lintExprIO expr + _ <- lint expr assertFailure $ "Unexpected success parsing `" ++ file ++ ":\nParsed value: " ++ show expr Failure _ -> return ()) $ \(_ :: SomeException) -> @@ -123,4 +123,4 @@ nixEvalFile file = do error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err Success expression -> do setEnv "TEST_VAR" "foo" - evalTopLevelExprIO (Just file) expression + evalLoc (Just file) expression