Add checkExpr, which checks for errors in Nix expressions

This allows us to pass 10 more of the NixLanguageTests, so that after parsing
a file containing "x: y", we can report that y is undefined.

Nix/Eval.hs

@@ -5,11 +5,9 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
-module Nix.Eval (NValue, NValueF(..), ValueSet,
-                 MonadNix(..),
-                 evalExpr, tracingExprEval,
-                 builtin, builtin2,
-                 atomText, valueText,
+module Nix.Eval (NValue, NValueF(..), ValueSet, MonadNix(..),
+                 evalExpr, tracingExprEval, checkExpr,
+                 builtin, builtin2, atomText, valueText,
                  buildArgument) where
 
 import           Control.Arrow
@@ -346,3 +344,57 @@ evalSelector dyn = mapM evalKeyName where
   evalKeyName (DynamicKey k)
     | dyn       = fmap valueTextNoContext . runAntiquoted evalString id $ k
     | otherwise = error "dynamic attribute not allowed in this context"
+
+nullVal :: MonadNix m => m (NValue m)
+nullVal = return (Fix (NVConstant NNull) :: NValue m)
+
+-- | Evaluate an nix expression, with a given ValueSet as environment
+checkExpr :: MonadNix m => NExpr -> m ()
+checkExpr = cata check
+
+check :: forall m. MonadNix m => NExprF (m ()) -> m ()
+
+check (NSym var) = do
+    env <- currentScope
+    case Map.lookup var env of
+        Nothing -> error $ "Undefined variable: " ++ show var
+        Just _ -> return ()
+
+check (NRecSet binds) = do
+    env <- currentScope
+    rec evaledBinds <-
+            newScope ((nullVal <$ evaledBinds) `Map.union` env)
+                     (evalBinds True (fmap (fmap (const nullVal)) binds))
+    return ()
+
+check (NLet binds e) = do
+    env <- currentScope
+    rec evaledBinds <-
+            newScope ((nullVal <$ evaledBinds) `Map.union` env)
+                     (evalBinds True (fmap (fmap (const nullVal)) binds))
+    newScope ((nullVal <$ evaledBinds) `Map.union` env) e
+
+-- check (NWith scope e) = do
+--   env <- currentScope
+--   newScope ((nullVal <$ scope) `Map.union` env) e
+
+check (NAbs a b) = do
+    env <- currentScope
+    let extend f = do
+            env' <- currentScope
+            newScope (env' `Map.union` env) f
+    case fmap extend a of
+        Param name ->
+            newScope (Map.singleton name nullVal) (extend b)
+        ParamSet (FixedParamSet s) Nothing ->
+            newScope (nullVal <$ s) (extend b)
+        ParamSet (FixedParamSet s) (Just m) ->
+            newScope (Map.insert m nullVal (nullVal <$ s)) (extend b)
+        ParamSet (VariadicParamSet s) Nothing ->
+            newScope (nullVal <$ s) (extend b)
+        ParamSet (VariadicParamSet s) (Just m) ->
+            newScope (Map.insert m nullVal (nullVal <$ s)) (extend b)
+
+-- In order to check some of the other operations properly, we'd need static
+-- typing
+check _ = return ()

main/Main.hs

@@ -1,5 +1,6 @@
 module Main where
 
+import Control.Monad
 import Control.Monad.Trans.State
 import Nix.Builtins
 import Nix.Eval
@@ -13,6 +14,7 @@ data Options = Options
     { verbose    :: Bool
     , debug      :: Bool
     , evaluate   :: Bool
+    , check      :: Bool
     , filePath   :: Maybe FilePath
     , expression :: Maybe String
     }
@@ -30,6 +32,9 @@ mainOptions = Options
     <*> switch
         (   long "eval"
          <> help "Whether to evaluate, or just pretty-print")
+    <*> switch
+        (   long "check"
+         <> help "Whether to check for syntax errors after parsing")
     <*> optional (strOption
         (   short 'f'
          <> long "file"
@@ -52,16 +57,19 @@ main = do
 
     case eres of
         Failure err -> hPutStrLn stderr $ "Parse failed: " ++ show err
-        Success expr
-            | evaluate opts, debug opts -> do
-                  expr' <- tracingExprEval expr
-                  print =<< evalStateT (runCyclic expr') baseEnv
-            | evaluate opts ->
-                  print =<< evalTopLevelExprIO expr
-            | debug opts ->
-                  print expr
-            | otherwise ->
-                  displayIO stdout $ renderPretty 0.4 80 (prettyNix expr)
+        Success expr -> do
+            when (check opts) $
+                evalStateT (runCyclic (checkExpr expr)) baseEnv
+            case () of
+                () | evaluate opts, debug opts -> do
+                         expr' <- tracingExprEval expr
+                         print =<< evalStateT (runCyclic expr') baseEnv
+                   | evaluate opts ->
+                         print =<< evalTopLevelExprIO expr
+                   | debug opts ->
+                         print expr
+                   | otherwise ->
+                         displayIO stdout $ renderPretty 0.4 80 (prettyNix expr)
   where
     optsDef :: ParserInfo Options
     optsDef = info (helper <*> mainOptions)

tests/NixLanguageTests.hs

@@ -1,17 +1,13 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module NixLanguageTests (genTests) where
 
 import           Control.Arrow ((&&&))
 import           Control.Exception
-import           Control.Monad (filterM)
-import           Control.Monad.Fix
-import           Control.Monad.IO.Class
 import           Control.Monad.Trans.State
-import           Data.Fix
-import           Data.Functor.Identity
-import           Data.List (delete, intercalate, sort)
+import           Data.List (delete, sort)
 import           Data.List.Split (splitOn)
 import           Data.Map (Map)
 import qualified Data.Map as Map
@@ -20,15 +16,12 @@ import qualified Data.Text.IO as Text
 import           GHC.Exts
 import           Nix.Builtins
 import           Nix.Eval
-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           Test.Tasty
 import           Test.Tasty.HUnit
-import           Test.Tasty.TH
 
 {-
 From (git://nix)/tests/lang.sh we see that
@@ -55,31 +48,39 @@ groupBy key = Map.fromListWith (++) . map (key &&& pure)
 
 genTests :: IO TestTree
 genTests = do
-  testFiles <- sort . filter ((/= ".xml") . takeExtension) <$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang"
+  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
+  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
+    testType (fullpath, _files) = take 2 $ splitOn "-" $ takeFileName fullpath
+    mkTestGroup (kind, tests) =
+        testGroup (unwords 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 ()
+assertParse file = parseNixFile file >>= \case
+  Success expr -> evalStateT (runCyclic (checkExpr expr)) baseEnv
   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 ()
-  )
+assertParseFail file = do
+    eres <- parseNixFile file
+    catch (case eres of
+               Success expr -> do
+                   evalStateT (runCyclic (checkExpr expr)) baseEnv
+                   assertFailure $ "Unexpected success parsing `"
+                       ++ file ++ ":\nParsed value: " ++ show expr
+               Failure _ -> return ()) $ \(_ :: SomeException) ->
+        return ()
 
 assertLangOk :: FilePath -> Assertion
 assertLangOk file = do
@@ -89,7 +90,7 @@ assertLangOk file = do
       assertEqual "" expected $ Text.pack (actual ++ "\n")
 
 assertLangOkXml :: FilePath -> Assertion
-assertLangOkXml name = assertFailure $ "Not implemented"
+assertLangOkXml name = assertFailure $ "Not implemented: " ++ name
 
 assertEval :: [FilePath] -> Assertion
 assertEval files =
@@ -98,9 +99,9 @@ assertEval files =
     [".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
+    _ -> assertFailure $ "Unknown test type " ++ show files
   where
-    name = "data/nix/tests/lang/" ++ (the $ map takeBaseName files)
+    name = "data/nix/tests/lang/" ++ the (map takeBaseName files)
 
 assertEvalFail :: FilePath -> Assertion
 assertEvalFail file = catch eval (\(ErrorCall _) -> return ())