Merge remote-tracking branch 'origin/master' into pending

hnix.cabal

@@ -623,6 +623,7 @@ test-suite hnix-tests
       ParserTests
       PrettyParseTests
       PrettyTests
+      ReduceExprTests
       TestCommon
       Paths_hnix
   hs-source-dirs:

src/Nix/Reduce.hs

@@ -124,10 +124,13 @@ reduce :: forall e m.
             MonadState (HashMap FilePath NExprLoc) m)
        => NExprLocF (m NExprLoc) -> m NExprLoc
 
+-- | Reduce the variable to its value if defined.
+--   Leave it as it is otherwise.
 reduce (NSym_ ann var) = lookupVar var <&> \case
     Nothing -> Fix (NSym_ ann var)
     Just v  -> v
 
+-- | Reduce binary and integer negation.
 reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of
     (NNeg, Fix (NConstant_ cann (NInt n))) ->
         return $ Fix $ NConstant_ cann (NInt (negate n))
@@ -135,6 +138,12 @@ reduce (NUnary_ uann op arg) = arg >>= \x -> case (op, x) of
         return $ Fix $ NConstant_ cann (NBool (not b))
     _ -> return $ Fix $ NUnary_ uann op x
 
+-- | Reduce function applications.
+--
+--     * Reduce an import to the actual imported expression.
+--
+--     * Reduce a lambda function by adding its name to the local
+--       scope and recursively reducing its body. 
 reduce (NBinary_ bann NApp fun arg) = fun >>= \case
     f@(Fix (NSym_ _ "import")) -> arg >>= \case
         -- Fix (NEnvPath_     pann origPath) -> staticImport pann origPath
@@ -147,6 +156,7 @@ reduce (NBinary_ bann NApp fun arg) = fun >>= \case
 
     f -> Fix . NBinary_ bann NApp f <$> arg
 
+-- | Reduce an integer addition to its result.
 reduce (NBinary_ bann op larg rarg) = do
     lval <- larg
     rval <- rarg
@@ -155,10 +165,41 @@ reduce (NBinary_ bann op larg rarg) = do
             return $ Fix (NConstant_ ann (NInt (x + y)))
         _ -> pure $ Fix $ NBinary_ bann op lval rval
 
--- reduce (NSelect aset attr alt) = do
+-- | Reduce a select on a Set by substituing the set to the selected value.
+--
+-- Before applying this reduction, we need to ensure that:
+--
+--   1. The selected expr is indeed a set.
+--   2. The selection AttrPath is a list of StaticKeys.
+--   3. The selected AttrPath exists in the set.
+reduce base@(NSelect_ _ _ attrs _)
+    | sAttrPath $ NE.toList attrs = do
+      (NSelect_ _ aset attrs _) <- sequence base
+      inspectSet (unFix aset) attrs
+    | otherwise = sId
+  where
+    sId = Fix <$> sequence base
+    -- The selection AttrPath is composed of StaticKeys.
+    sAttrPath (StaticKey _:xs) = sAttrPath xs
+    sAttrPath []               = True
+    sAttrPath _                = False
+    -- Find appropriate bind in set's binds.
+    findBind [] _                = Nothing
+    findBind (x:xs) attrs@(a:|_) = case x of
+        n@(NamedVar (a':|_) _ _) | a' == a -> Just n
+        _                                  -> findBind xs attrs
+    -- Follow the attrpath recursively in sets.
+    inspectSet (NSet_ _ binds) attrs = case findBind binds attrs of
+       Just (NamedVar _ e _) -> case NE.uncons attrs of 
+               (_,Just attrs) -> inspectSet (unFix e) attrs
+               _              -> pure e
+       _ -> sId
+    inspectSet _ _ = sId
 
 -- reduce (NHasAttr aset attr) =
 
+-- | Reduce a set by inlining its binds outside of the set
+--   if none of the binds inherit the super set.
 reduce e@(NSet_ ann binds) = do
     let usesInherit = flip any binds $ \case
             Inherit {} -> True
@@ -178,6 +219,8 @@ reduce (NRecSet_ ann binds) =
 reduce (NWith_ ann scope body) =
     clearScopes @NExprLoc $ fmap Fix $ NWith_ ann <$> scope <*> body
 
+-- | Reduce a let binds section by pushing lambdas,
+--   constants and strings to the body scope.
 reduce (NLet_ ann binds body) = do
     s <- fmap (M.fromList . catMaybes) $ forM binds $ \case
         NamedVar (StaticKey name :| []) def _pos -> def >>= \case
@@ -202,10 +245,14 @@ reduce (NLet_ ann binds body) = do
   --           go (M.insert name v m) xs
   --       _ -> go m xs
 
+-- | Reduce an if to the relevant path if
+--   the condition is a boolean constant.
 reduce e@(NIf_ _ b t f) = b >>= \case
     Fix (NConstant_ _ (NBool b')) -> if b' then t else f
     _ -> Fix <$> sequence e
 
+-- | Reduce an assert atom to its encapsulated
+--   symbol if the assertion is a boolean constant.
 reduce e@(NAssert_ _ b body) = b >>= \case
     Fix (NConstant_ _ (NBool b')) | b' -> body
     _ -> Fix <$> sequence e

tests/Main.hs

@@ -26,6 +26,7 @@ import           Nix.Value
 import qualified NixLanguageTests
 import qualified ParserTests
 import qualified PrettyTests
+import qualified ReduceExprTests
 -- import qualified PrettyParseTests
 import           System.Directory
 import           System.Environment
@@ -98,7 +99,8 @@ main = do
       | isJust hpackTestsEnv ] ++
     [ ParserTests.tests
     , EvalTests.tests
-    , PrettyTests.tests ] ++
+    , PrettyTests.tests
+    , ReduceExprTests.tests] ++
     -- [ PrettyParseTests.tests
     --     (fromIntegral (read (fromMaybe "0" prettyTestsEnv) :: Int)) ] ++
     [ evalComparisonTests ] ++

tests/ReduceExprTests.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+module ReduceExprTests (tests) where
+import Data.Fix
+import Test.Tasty
+import Test.Tasty.HUnit
+
+import Nix.Atoms
+import Nix.Expr.Types
+import Nix.Expr.Types.Annotated
+import Nix.Parser
+import Nix.Reduce (reduceExpr)
+
+
+tests :: TestTree
+tests = testGroup "Expr Reductions"
+    [ testCase "Non nested NSelect on set should be reduced" $ 
+        cmpReduceResult selectBasic selectBasicExpect,
+      testCase "Nested NSelect on set should be reduced" $ 
+        cmpReduceResult selectNested selectNestedExpect,
+      testCase "Non nested NSelect with incorrect attrpath shouldn't be reduced" $ 
+        shouldntReduce selectIncorrectAttrPath,
+      testCase "Nested NSelect with incorrect attrpath shouldn't be reduced" $ 
+        shouldntReduce selectNestedIncorrectAttrPath 
+    ]
+
+assertSucc :: Result a -> IO a
+assertSucc (Success a) = pure a
+assertSucc (Failure d) = assertFailure $ show d
+
+cmpReduceResult :: Result NExprLoc -> NExpr -> Assertion 
+cmpReduceResult r e = do
+    r <- assertSucc r
+    r <- stripAnnotation <$> reduceExpr Nothing r
+    r @?= e
+
+shouldntReduce :: Result NExprLoc -> Assertion
+shouldntReduce r = do
+    r <- assertSucc r
+    rReduced <- reduceExpr Nothing r
+    r @?= rReduced
+
+selectBasic :: Result NExprLoc
+selectBasic = parseNixTextLoc "{b=2;a=42;}.a"
+
+selectBasicExpect :: NExpr
+selectBasicExpect = Fix . NConstant $ NInt 42
+
+selectNested :: Result NExprLoc
+selectNested = parseNixTextLoc "{a={b=2;a=42;};b={a=2;};}.a.a"
+
+selectNestedExpect :: NExpr
+selectNestedExpect = Fix . NConstant $ NInt 42
+
+selectIncorrectAttrPath :: Result NExprLoc
+selectIncorrectAttrPath = parseNixTextLoc "{a=42;}.b"
+
+selectNestedIncorrectAttrPath :: Result NExprLoc
+selectNestedIncorrectAttrPath = parseNixTextLoc "{a={a=42;};}.a.b"