Merge pull request #82 from layus/nix-test

Run nix language tests from upstream

.gitmodules

@@ -0,0 +1,3 @@
+[submodule "data/nix"]
+	path = data/nix
+	url = https://github.com/NixOS/nix

Nix/Builtins.hs

@@ -0,0 +1,97 @@
+
+module Nix.Builtins (baseEnv, builtins, evalTopLevelExpr) where
+
+import           Control.Applicative
+import           Control.Monad hiding (mapM, sequence)
+import           Control.Monad.Fix
+import           Data.Fix
+import qualified Data.Map as Map
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import           Data.Traversable (mapM)
+import           Nix.Atoms
+import           Nix.Eval
+import           Nix.Expr (NExpr)
+import           Prelude hiding (mapM, sequence)
+
+-- | Evaluate a nix expression in the default context
+evalTopLevelExpr :: MonadFix m => NExpr -> m (NValue m)
+evalTopLevelExpr val = evalExpr val baseEnv
+
+baseEnv :: MonadFix m => ValueSet m
+baseEnv = Map.fromList $ [ ("builtins", Fix $ NVSet builtins) ] ++ topLevelBuiltins
+  where
+    topLevelBuiltins = map mapping $ filter isTopLevel builtinsList
+    -- builtins = Map.fromList $ map mapping $ builtinsList
+
+builtins :: MonadFix m => ValueSet m
+builtins = Map.fromList $ map mapping $ builtinsList
+
+data BuiltinType = Normal | TopLevel
+data Builtin m = Builtin {kind :: BuiltinType, mapping :: (Text, NValue m) }
+
+isTopLevel :: Builtin m -> Bool
+isTopLevel b = case kind b of
+                    Normal -> False
+                    TopLevel -> True
+
+builtinsList :: MonadFix m => [ Builtin m ]
+builtinsList = [
+      topLevel ("toString", prim_toString)
+    , basic    ("hasAttr" , prim_hasAttr)
+    , basic    ("getAttr" , prim_getAttr)
+    , basic    ("any"     , prim_any )
+    , basic    ("all"     , prim_all )
+  ]
+  where
+    basic = Builtin Normal
+    topLevel = Builtin TopLevel
+
+
+-- Helpers
+
+mkBool :: Bool -> NValue m
+mkBool = Fix . NVConstant . NBool
+
+extractBool :: NValue m -> Bool
+extractBool (Fix (NVConstant (NBool b))) = b
+extractBool _                            = error "Not a bool constant"
+
+evalPred :: NValue m -> NValue m -> m (NValue m)
+evalPred (Fix (NVFunction argset pred)) = pred . buildArgument argset
+evalPred pred = error $ "Trying to call a " ++ show pred
+
+
+-- Primops
+
+prim_toString :: MonadFix m => Functor m => NValue m
+prim_toString = Fix $ NVBuiltin1 "toString" $ toString
+toString :: MonadFix m => NValue m -> m (NValue m)
+toString s = return $ Fix $ NVStr $ valueText s
+
+prim_hasAttr :: MonadFix m => NValue m
+prim_hasAttr = Fix $ NVBuiltin2 "hasAttr" [] hasAttr
+hasAttr :: MonadFix m => NValue m -> NValue m -> m (NValue m)
+hasAttr (Fix (NVStr key)) (Fix (NVSet aset)) = return $ Fix $ NVConstant $ NBool $ Map.member key aset
+hasAttr key aset = error $ "Invalid types for builtin.hasAttr: " ++ show (key, aset)
+
+prim_getAttr :: MonadFix m => NValue m
+prim_getAttr = Fix $ NVBuiltin2 "getAttr" [] getAttr
+getAttr :: MonadFix m => NValue m -> NValue m -> m (NValue m)
+getAttr (Fix (NVStr key)) (Fix (NVSet aset)) = return $ Map.findWithDefault _err key aset
+  where _err = error ("Field does not exist " ++ Text.unpack key)
+getAttr key aset = error $ "Invalid types for builtin.getAttr: " ++ show (key, aset)
+
+
+prim_any :: MonadFix m => NValue m
+prim_any = Fix $ NVBuiltin2 "any" [] _any
+_any :: MonadFix m => NValue m -> NValue m -> m (NValue m)
+_any pred (Fix (NVList l)) = mkBool . any extractBool <$> mapM (evalPred pred) l
+_any _ list = error $ "builtins.any takes a list as second argument, not a " ++ show list
+
+prim_all :: MonadFix m => NValue m
+prim_all = Fix $ NVBuiltin2 "all" [] _all
+_all :: MonadFix m => NValue m -> NValue m -> m (NValue m)
+_all pred (Fix (NVList l)) = mkBool . all extractBool <$> mapM (evalPred pred) l
+_all _ list = error $ "builtins.all takes a list as second argument, not a " ++ show list
+

Nix/Eval.hs

@@ -31,6 +31,8 @@ data NValueF m r
     | NVFunction (Params r) (ValueSet m -> m r)
     | NVLiteralPath FilePath
     | NVEnvPath FilePath
+    | NVBuiltin1 String (NValue m -> m r)
+    | NVBuiltin2 String [r] (NValue m -> NValue m -> m r)
     deriving (Generic, Typeable, Functor)
 
 instance Show f => Show (NValueF m f) where
@@ -42,6 +44,8 @@ instance Show f => Show (NValueF m f) where
       go (NVFunction r _)  = showsCon1 "NVFunction" r
       go (NVLiteralPath p) = showsCon1 "NVLiteralPath" p
       go (NVEnvPath p)     = showsCon1 "NVEnvPath" p
+      go (NVBuiltin1 name _) = showsCon1 "NVBuiltin1" name
+      go (NVBuiltin2 name _ _) = showsCon1 "NVBuiltin2" name
 
       showsCon1 :: Show a => String -> a -> Int -> String -> String
       showsCon1 con a d = showParen (d > 10) $ showString (con ++ " ") . showsPrec 11 a
@@ -59,6 +63,8 @@ valueText = cata phi where
     phi (NVFunction _ _)  = error "Cannot coerce a function to a string"
     phi (NVLiteralPath p) = Text.pack p
     phi (NVEnvPath p)     = Text.pack p
+    phi (NVBuiltin1 _ _)    = error "Cannot coerce a function to a string"
+    phi (NVBuiltin2 _ _ _)  = error "Cannot coerce a function to a string"
 
 -- | Translate an atom into its nix representation.
 atomText :: NAtom -> Text
@@ -201,6 +207,15 @@ evalExpr = cata phi
                 arg <- x env
                 let arg' = buildArgument argset arg
                 f arg'
+            Fix (NVBuiltin1 _ f) -> do
+                arg <- x env
+                f arg
+            Fix (NVBuiltin2 name [] f) -> do
+                arg <- x env
+                pure $ Fix $ NVBuiltin2 name [arg] f
+            Fix (NVBuiltin2 _ [arg1] f) -> do
+                arg2 <- x env
+                f arg1 arg2
             _ -> error "Attempt to call non-function"
 
     phi (NAbs a b) = \env -> do

Nix/Pretty.hs

@@ -6,7 +6,7 @@ import Data.Fix
 import Data.Map (toList)
 import Data.Maybe (isJust)
 import Data.Text (Text, pack, unpack, replace, strip)
-import Data.List (isPrefixOf)
+import Data.List (isPrefixOf, intercalate)
 import Nix.Atoms
 import Nix.Eval (NValue, NValueF (..), atomText)
 import Nix.Expr
@@ -185,4 +185,19 @@ prettyNixValue = prettyNix . valueToExpr
         go (NVFunction p _) = NSym . pack $ ("<function with " ++ show (() <$ p)  ++ ">")
         go (NVLiteralPath fp) = NLiteralPath fp
         go (NVEnvPath p) = NEnvPath p
+        go (NVBuiltin1 name _) = NSym $ Text.pack $ "builtins." ++ name
+        go (NVBuiltin2 name _ _) = NSym $ Text.pack $ "builtins." ++ name
 
+
+printNix :: Functor m => NValue m -> String
+printNix = cata phi
+  where phi :: NValueF m String -> String
+        phi (NVConstant a) = unpack $ atomText a
+        phi (NVStr t) = unpack t
+        phi (NVList l) = "[ " ++ (intercalate " " l) ++ " ]"
+        phi (NVSet s) = intercalate ", " $ [ unpack k ++ ":" ++ v | (k, v) <- toList s]
+        phi (NVFunction p _) = error "Cannot print a thunk"
+        phi (NVLiteralPath fp) = fp
+        phi (NVEnvPath p) = p
+        phi (NVBuiltin1 name _) = error "Cannot print a thunk"
+        phi (NVBuiltin2 name _ _) = error "Cannot print a thunk"

data/nix

@@ -0,0 +1 @@
+Subproject commit 71a5161365f40699092e491bbff88473237fc432

default.nix

@@ -1,13 +1,14 @@
-{ nixpkgs ? import <nixpkgs> {}, compiler ? "default" }:
+{ nixpkgs ? import <nixpkgs> {}, compiler ? "default", doBenchmark ? false }:
 
 let
 
   inherit (nixpkgs) pkgs;
 
   f = { mkDerivation, ansi-wl-pprint, base, containers, criterion
-      , data-fix, deepseq, deriving-compat, parsers, regex-tdfa
-      , regex-tdfa-text, semigroups, stdenv, tasty, tasty-hunit, tasty-th
-      , text, transformers, trifecta, unordered-containers
+      , data-fix, deepseq, deriving-compat, directory, filepath, Glob
+      , parsers, regex-tdfa, regex-tdfa-text, semigroups, split, stdenv
+      , tasty, tasty-hunit, tasty-th, text, transformers, trifecta
+      , unordered-containers
       }:
       mkDerivation {
         pname = "hnix";
@@ -24,7 +25,8 @@ let
           ansi-wl-pprint base containers data-fix deepseq
         ];
         testHaskellDepends = [
-          base containers data-fix tasty tasty-hunit tasty-th text
+          base containers data-fix directory filepath Glob split tasty
+          tasty-hunit tasty-th text
         ];
         benchmarkHaskellDepends = [ base containers criterion text ];
         homepage = "http://github.com/jwiegley/hnix";
@@ -36,7 +38,9 @@ let
                        then pkgs.haskellPackages
                        else pkgs.haskell.packages.${compiler};
 
-  drv = haskellPackages.callPackage f {};
+  variant = if doBenchmark then pkgs.haskell.lib.doBenchmark else pkgs.lib.id;
+
+  drv = variant (haskellPackages.callPackage f {});
 
 in
 

hnix.cabal

@@ -24,6 +24,7 @@ Library
   Exposed-modules:
     Nix.Atoms
     Nix.Eval
+    Nix.Builtins
     Nix.Parser
     Nix.Expr
     Nix.Pretty
@@ -109,6 +110,7 @@ Test-suite hnix-tests
     EvalTests
     ShorthandTests
     PrettyTests
+    NixLanguageTests
   Build-depends:
       base >= 4.3 && < 5
     , containers
@@ -118,6 +120,10 @@ Test-suite hnix-tests
     , tasty
     , tasty-th
     , tasty-hunit
+    , directory
+    , Glob
+    , filepath
+    , split
 
 Benchmark hnix-benchmarks
   Type: exitcode-stdio-1.0

tests/Main.hs

@@ -6,13 +6,17 @@ import qualified ParserTests
 import qualified EvalTests
 import qualified ShorthandTests
 import qualified PrettyTests
+import qualified NixLanguageTests
 
 import Prelude (IO, ($))
 
 main :: IO ()
-main = defaultMain $ testGroup "hnix"
-  [ ParserTests.tests
-  , EvalTests.tests
-  , ShorthandTests.tests
-  , PrettyTests.tests
-  ]
+main = do
+  nixLanguageTests <- NixLanguageTests.genTests
+  defaultMain $ testGroup "hnix"
+    [ ParserTests.tests
+    , EvalTests.tests
+    , ShorthandTests.tests
+    , PrettyTests.tests
+    , nixLanguageTests
+    ]

tests/NixLanguageTests.hs

@@ -0,0 +1,122 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module NixLanguageTests (genTests) where
+
+import Data.Fix
+import Data.Text.IO (readFile)
+import qualified Data.Text as Text
+import qualified Data.Map as Map
+import Data.Map (Map)
+import Data.List (delete, intercalate, sort)
+import Data.List.Split (splitOn)
+
+import Test.Tasty
+import Test.Tasty.HUnit
+import Test.Tasty.TH
+
+import Nix.Eval
+import Nix.Builtins
+import Nix.Expr
+import Nix.Parser
+import Nix.Pretty
+
+import System.Directory (listDirectory, doesFileExist)
+import System.FilePath.Glob (compile, globDir1)
+import System.FilePath.Posix
+
+import Control.Monad (filterM)
+import Control.Exception
+import Control.Arrow ((&&&))
+import Data.Functor.Identity
+
+import GHC.Exts
+
+import Prelude hiding (readFile)
+
+{-
+From (git://nix)/tests/lang.sh we see that
+
+    lang/parse-fail-*.nix -> parsing should fail
+    lang/parse-okay-*.nix -> parsing should succeed
+    lang/eval-fail-*.nix -> eval should fail
+
+    lang/eval-okay-*.{nix,xml} -> eval should succeed,
+        xml dump should be the same as the .xml
+    lang/eval-okay-*.{nix,exp} -> eval should succeed,
+        plain text output should be the same as the .exp
+    lang/eval-okay-*.{nix,exp,flags} -> eval should succeed,
+        plain text output should be the same as the .exp,
+        pass the extra flags to nix-instantiate
+
+    NIX_PATH=lang/dir3:lang/dir4 should be in the environment of all eval-okay-*.nix evaluations
+    TEST_VAR=foo should be in all the environments # for eval-okay-getenv.nix
+-}
+
+
+groupBy :: Ord k => (v -> k) -> [v] -> Map k [v]
+groupBy key = Map.fromListWith (++) . map (key &&& pure)
+
+genTests :: IO TestTree
+genTests = do
+  testFiles <- sort . filter ((/= ".xml") . takeExtension) <$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang"
+  let testsByName = groupBy takeBaseName testFiles
+  let testsByType = groupBy testType (Map.toList testsByName)
+  let testGroups  = map mkTestGroup (Map.toList testsByType)
+  return $ localOption (mkTimeout 100000) $ testGroup "Nix (upstream) language tests" $ testGroups
+  where
+    testType (fullpath, files) = take 2 $ splitOn "-" $ takeFileName fullpath
+    mkTestGroup (kind, tests) = testGroup (intercalate " " kind) $ map (mkTestCase kind) tests
+    mkTestCase kind (basename, files) = testCase (takeFileName basename) $ case kind of
+      ["parse", "okay"] -> assertParse $ the files
+      ["parse", "fail"] -> assertParseFail $ the files
+      ["eval", "okay"] -> assertEval files
+      ["eval", "fail"] -> assertEvalFail $ the files
+
+assertParse :: FilePath -> Assertion
+assertParse file = parseNixFile file >>= (\x -> case x of
+  Success _ -> return ()
+  Failure err -> assertFailure $ "Failed to parse " ++ file ++ ":\n" ++ show err
+  )
+
+assertParseFail :: FilePath -> Assertion
+assertParseFail file = parseNixFile file >>= (\x -> case x of
+  Success r -> assertFailure $ "Unexpected success parsing `" ++ file ++ ":\nParsed value: " ++ show r
+  Failure _ -> return ()
+  )
+
+assertLangOk :: FilePath -> Assertion
+assertLangOk file = do
+  actual <- printNix <$> nixEvalFile (file ++ ".nix")
+  expected <- readFile $ file ++ ".exp"
+  seq actual $ seq expected $
+      assertEqual "" expected $ Text.pack (actual ++ "\n")
+
+assertLangOkXml :: FilePath -> Assertion
+assertLangOkXml name = assertFailure $ "Not implemented"
+
+assertEval :: [FilePath] -> Assertion
+assertEval files =
+  case delete ".nix" $ sort $ map takeExtension files of
+    [] -> assertLangOkXml name
+    [".exp"] -> assertLangOk name
+    [".exp-disabled"] -> return ()
+    [".exp", ".flags"] -> assertFailure $ "Support for flags not implemented (needed by " ++ name ++ ".nix)."
+    otherwise -> assertFailure $ "Unknown test type " ++ show files
+  where
+    name = "data/nix/tests/lang/" ++ (the $ map takeBaseName files)
+
+assertEvalFail :: FilePath -> Assertion
+assertEvalFail file = catch eval (\(ErrorCall _) -> return ())
+  where
+    eval = do
+      evalResult <- printNix <$> nixEvalFile file
+      evalResult `seq` assertFailure $ file ++ " should not evaluate.\nThe evaluation result was `" ++ evalResult ++ "`."
+
+nixEvalFile :: FilePath -> IO (NValue IO)
+nixEvalFile file =  do
+  parseResult <- parseNixFile file
+  case parseResult of
+    Failure err        -> error $ "Parsing failed for file `" ++ file ++ "`.\n" ++ show err
+    Success expression -> evalTopLevelExpr expression
+