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

Add basic support for quasi-quotation of Nix expressions in Haskell

This commit is contained in:
John Wiegley 2018-04-03 14:21:33 -07:00
parent 3072b1829d
commit c3eb7a94b9
9 changed files with 119 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
Nix.hs
View File

@ -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)

1
Nix/Lint.hs
View File

@ -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

13
Nix/Monad/Instance.hs
View File

@ -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

36
Nix/TH.hs Normal file
View File

@ -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
}

5
default.nix
View File

@ -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

4
hnix.cabal
View File

@ -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

36
main/Main.hs
View File

@ -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 ->

11
tests/EvalTests.hs
View File

@ -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

10
tests/NixLanguageTests.hs
View File

@ -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