Merge #968: upd Recurcivity data type

Author: Anton-Latukha

src/Nix/Eval.hs

@@ -147,14 +147,14 @@ eval (NList l           ) =
     lst <- traverse (defer @v @m . withScopes @v scope) l
     toValue lst
 
-eval (NSet NNonRecursive binds) =
+eval (NSet NonRecursive binds) =
   do
-    attrSet <- evalBinds False $ desugarBinds (eval . NSet NNonRecursive) binds
+    attrSet <- evalBinds False $ desugarBinds (eval . NSet NonRecursive) binds
     toValue attrSet
 
-eval (NSet NRecursive binds) =
+eval (NSet Recursive binds) =
   do
-    attrSet <- evalBinds True $ desugarBinds (eval . NSet NNonRecursive) binds
+    attrSet <- evalBinds True $ desugarBinds (eval . NSet NonRecursive) binds
     toValue attrSet
 
 eval (NLet binds body    ) =

src/Nix/Expr/Shorthands.hs

@@ -98,10 +98,10 @@ mkParamset :: [(Text, Maybe NExpr)] -> Bool -> Params NExpr
 mkParamset params variadic = ParamSet params variadic mempty
 
 mkRecSet :: [Binding NExpr] -> NExpr
-mkRecSet = Fix . NSet NRecursive
+mkRecSet = Fix . NSet Recursive
 
 mkNonRecSet :: [Binding NExpr] -> NExpr
-mkNonRecSet = Fix . NSet NNonRecursive
+mkNonRecSet = Fix . NSet NonRecursive
 
 mkLets :: [Binding NExpr] -> NExpr -> NExpr
 mkLets bindings = Fix . NLet bindings
@@ -177,11 +177,11 @@ letE varName varExpr = letsE [(varName, varExpr)]
 
 -- | Make an attribute set (non-recursive).
 attrsE :: [(Text, NExpr)] -> NExpr
-attrsE pairs = Fix $ NSet NNonRecursive $ uncurry bindTo <$> pairs
+attrsE pairs = Fix $ NSet NonRecursive $ uncurry bindTo <$> pairs
 
 -- | Make an attribute set (recursive).
 recAttrsE :: [(Text, NExpr)] -> NExpr
-recAttrsE pairs = Fix $ NSet NRecursive $ uncurry bindTo <$> pairs
+recAttrsE pairs = Fix $ NSet Recursive $ uncurry bindTo <$> pairs
 
 -- | Logical negation.
 mkNot :: NExpr -> NExpr

src/Nix/Expr/Types.hs

@@ -399,13 +399,13 @@ $(deriveOrd1  ''Binding)
 $(makeTraversals ''Binding)
 
 
--- ** @NRecordType@
+-- ** @Recursivity@
 
--- | 'NRecordType' distinguishes between recursive and non-recursive attribute
+-- | Distinguishes between recursive and non-recursive. Mainly for attribute
 -- sets.
-data NRecordType
-  = NNonRecursive  -- ^ >     { ... }
-  | NRecursive     -- ^ > rec { ... }
+data Recursivity
+  = NonRecursive  -- ^ >     { ... }
+  | Recursive     -- ^ > rec { ... }
   deriving
     ( Eq, Ord, Enum, Bounded, Generic
     , Typeable, Data, NFData, Serialise, Binary, ToJSON, FromJSON
@@ -483,11 +483,11 @@ data NExprF r
   -- ^ A list literal.
   --
   -- > NList [x,y]                                 ~  [ x y ]
-  | NSet !NRecordType ![Binding r]
+  | NSet !Recursivity ![Binding r]
   -- ^ An attribute set literal
   --
-  -- > NSet NRecursive    [NamedVar x y _]         ~  rec { x = y; }
-  -- > NSet NNonRecursive [Inherit Nothing [x] _]  ~  { inherit x; }
+  -- > NSet Recursive    [NamedVar x y _]         ~  rec { x = y; }
+  -- > NSet NonRecursive [Inherit Nothing [x] _]  ~  { inherit x; }
   | NLiteralPath !FilePath
   -- ^ A path expression, which is evaluated to a store path. The path here
   -- can be relative, in which case it's evaluated relative to the file in
@@ -652,7 +652,7 @@ ekey
   => NonEmpty Text
   -> SourcePos
   -> Lens' (Fix g) (Maybe (Fix g))
-ekey keys pos f e@(Fix x) | (NSet NNonRecursive xs, ann) <- fromNExpr x =
+ekey keys pos f e@(Fix x) | (NSet NonRecursive xs, ann) <- fromNExpr x =
   case go xs of
     ((v, []      ) : _) -> fromMaybe e <$> f (pure v)
     ((v, r : rest) : _) -> ekey (r :| rest) pos f v
@@ -662,7 +662,7 @@ ekey keys pos f e@(Fix x) | (NSet NNonRecursive xs, ann) <- fromNExpr x =
         e
         (\ v ->
           let entry = NamedVar (StaticKey <$> keys) v pos in
-          Fix $ toNExpr ( NSet NNonRecursive $ [entry] <> xs, ann )
+          Fix $ toNExpr ( NSet NonRecursive $ [entry] <> xs, ann )
         )
       <$>
         f Nothing

src/Nix/Expr/Types/Annotated.hs

@@ -206,7 +206,7 @@ pattern NSym_ ann x = AnnFP ann (NSym x)
 pattern NList_ :: SrcSpan -> [r] -> NExprLocF r
 pattern NList_ ann x = AnnFP ann (NList x)
 
-pattern NSet_ :: SrcSpan -> NRecordType -> [Binding r] -> NExprLocF r
+pattern NSet_ :: SrcSpan -> Recursivity -> [Binding r] -> NExprLocF r
 pattern NSet_ ann recur x = AnnFP ann (NSet recur x)
 
 pattern NLiteralPath_ :: SrcSpan -> FilePath -> NExprLocF r

src/Nix/Parser.hs

@@ -265,7 +265,7 @@ nixLet = annotateLocation1
   -- Let expressions `let {..., body = ...}' are just desugared
   -- into `(rec {..., body = ...}).body'.
   letBody    = (\x -> NSelect x (StaticKey "body" :| mempty) Nothing) <$> aset
-  aset       = annotateLocation1 $ NSet NRecursive <$> braces nixBinders
+  aset       = annotateLocation1 $ NSet Recursive <$> braces nixBinders
 
 nixIf :: Parser NExprLoc
 nixIf = annotateLocation1
@@ -472,7 +472,7 @@ keyName = dynamicKey <+> staticKey
 nixSet :: Parser NExprLoc
 nixSet = annotateLocation1 ((isRec <*> braces nixBinders) <?> "set")
  where
-  isRec = (reserved "rec" $> NSet NRecursive <?> "recursive set") <+> pure (NSet NNonRecursive)
+  isRec = (reserved "rec" $> NSet Recursive <?> "recursive set") <+> pure (NSet NonRecursive)
 
 parseNixFile :: MonadFile m => FilePath -> m (Result NExpr)
 parseNixFile =

src/Nix/Pretty.hs

@@ -212,9 +212,9 @@ exprFNixDoc = \case
   NStr      str  -> simpleExpr $ prettyString str
   NList xs ->
     prettyContainer "[" (wrapParens appOpNonAssoc) "]" xs
-  NSet NNonRecursive xs ->
+  NSet NonRecursive xs ->
     prettyContainer "{" prettyBind "}" xs
-  NSet NRecursive xs ->
+  NSet Recursive xs ->
     prettyContainer "rec {" prettyBind "}" xs
   NAbs args body ->
     leastPrecedence $
@@ -318,7 +318,7 @@ valueToExpr = iterNValueByDiscardWith thk (Fix . phi)
   phi (NVConstant' a     ) = NConstant a
   phi (NVStr'      ns    ) = NStr $ DoubleQuoted [Plain (stringIgnoreContext ns)]
   phi (NVList'     l     ) = NList l
-  phi (NVSet'      s    p) = NSet NNonRecursive
+  phi (NVSet'      s    p) = NSet NonRecursive
     [ NamedVar (StaticKey k :| mempty) v (fromMaybe nullPos (M.lookup k p))
     | (k, v) <- toList s
     ]

src/Nix/Reduce.hs

@@ -220,7 +220,7 @@ reduce base@(NSelect_ _ _ attrs _)
     n@(NamedVar (a' :| _) _ _) | a' == a -> pure n
     _ -> findBind xs attrs
   -- Follow the attrpath recursively in sets.
-  inspectSet (NSet_ _ NNonRecursive binds) attrs = case findBind binds attrs of
+  inspectSet (NSet_ _ NonRecursive binds) attrs = case findBind binds attrs of
     Just (NamedVar _ e _) -> case NE.uncons attrs of
       (_, Just attrs) -> inspectSet (unFix e) attrs
       _               -> pure e
@@ -231,7 +231,7 @@ reduce base@(NSelect_ _ _ attrs _)
 
 -- | Reduce a set by inlining its binds outside of the set
 --   if none of the binds inherit the super set.
-reduce e@(NSet_ ann NNonRecursive binds) =
+reduce e@(NSet_ ann NonRecursive binds) =
   do
     let
       usesInherit =
@@ -244,13 +244,13 @@ reduce e@(NSet_ ann NNonRecursive binds) =
 
     bool
       (Fix <$> sequence e)
-      (clearScopes @NExprLoc $ Fix . NSet_ ann NNonRecursive <$> traverse sequence binds)
+      (clearScopes @NExprLoc $ Fix . NSet_ ann NonRecursive <$> traverse sequence binds)
       usesInherit
 
 -- Encountering a 'rec set' construction eliminates any hope of inlining
 -- definitions.
-reduce (NSet_ ann NRecursive binds) =
-  clearScopes @NExprLoc $ Fix . NSet_ ann NRecursive <$> traverse sequence binds
+reduce (NSet_ ann Recursive binds) =
+  clearScopes @NExprLoc $ Fix . NSet_ ann Recursive <$> traverse sequence binds
 
 -- Encountering a 'with' construction eliminates any hope of inlining
 -- definitions.

src/Nix/TH.hs

@@ -17,38 +17,51 @@ import           Nix.Parser
 
 quoteExprExp :: String -> ExpQ
 quoteExprExp s = do
-  expr <-
-    either
-      (fail . show)
-      pure
-      (parseNixText $ toText s)
+  expr <- parseExpr s
   dataToExpQ
-    (const Nothing `extQ` metaExp (freeVars expr) `extQ` (pure . (TH.lift :: Text -> Q Exp)))
+    (extQOnFreeVars metaExp expr `extQ` (pure . (TH.lift :: Text -> Q Exp)))
     expr
 
 quoteExprPat :: String -> PatQ
 quoteExprPat s = do
-  expr <-
-    either
-      (fail . show)
-      pure
-      (parseNixText $ toText s)
+  expr <- parseExpr s
   dataToPatQ
-    (const Nothing `extQ` metaPat (freeVars expr))
+    (extQOnFreeVars metaPat expr)
     expr
 
+-- | Helper function.
+extQOnFreeVars
+  :: ( Typeable b
+    , Typeable loc
+    )
+  => ( Set VarName
+    -> loc
+    -> Maybe q
+    )
+  -> NExpr
+  -> b
+  -> Maybe q
+extQOnFreeVars f e = extQ (const Nothing) (f $ freeVars e)
+
+parseExpr :: (MonadFail m, ToText a) => a -> m NExpr
+parseExpr s =
+  either
+    (fail . show)
+    pure
+    (parseNixText $ toText s)
+
 freeVars :: NExpr -> Set VarName
 freeVars e = case unFix e of
   (NConstant    _               ) -> mempty
   (NStr         string          ) -> mapFreeVars string
   (NSym         var             ) -> one var
   (NList        list            ) -> mapFreeVars list
-  (NSet   NNonRecursive bindings) -> bindFreeVars bindings
-  (NSet   NRecursive    bindings) -> Set.difference (bindFreeVars bindings) (bindDefs bindings)
+  (NSet   NonRecursive  bindings) -> bindFreeVars bindings
+  (NSet   Recursive     bindings) -> diffBetween bindFreeVars bindDefs bindings
   (NLiteralPath _               ) -> mempty
   (NEnvPath     _               ) -> mempty
   (NUnary       _    expr       ) -> freeVars expr
-  (NBinary      _    left right ) -> ((<>) `on` freeVars) left right
+  (NBinary      _    left right ) -> collectFreeVars left right
   (NSelect      expr path orExpr) ->
     Set.unions
       [ freeVars expr
@@ -69,18 +82,22 @@ freeVars e = case unFix e of
       )
   (NLet         bindings expr   ) ->
     freeVars expr <>
-    Set.difference
-      (bindFreeVars bindings)
-      (bindDefs  bindings)
+    diffBetween bindFreeVars bindDefs bindings
   (NIf          cond th   el    ) -> Set.unions $ freeVars <$> [cond, th, el]
   -- Evaluation is needed to find out whether x is a "real" free variable in `with y; x`, we just include it
   -- This also makes sense because its value can be overridden by `x: with y; x`
-  (NWith        set  expr       ) -> ((<>) `on` freeVars) set expr
-  (NAssert      assertion expr  ) -> ((<>) `on` freeVars) assertion expr
+  (NWith        set  expr       ) -> collectFreeVars set expr
+  (NAssert      assertion expr  ) -> collectFreeVars assertion expr
   (NSynHole     _               ) -> mempty
 
  where
 
+  diffBetween :: (a -> Set VarName) -> (a -> Set VarName) -> a -> Set VarName
+  diffBetween g f b = Set.difference (g b) (f b)
+
+  collectFreeVars :: NExpr -> NExpr -> Set VarName
+  collectFreeVars = (<>) `on` freeVars
+
   bindDefs :: Foldable t => t (Binding NExpr) -> Set VarName
   bindDefs = foldMap bind1Def
    where

tests/NixLanguageTests.hs

@@ -77,14 +77,14 @@ genTests = do
     <$> globDir1 (compile "*-*-*.*") "data/nix/tests/lang"
   let testsByName = groupBy (takeFileName . dropExtensions) testFiles
   let testsByType = groupBy testType (Map.toList testsByName)
-  let testGroups  = fmap mkTestGroup (Map.toList testsByType)
+  let testGroups  = mkTestGroup <$> Map.toList testsByType
   pure $ localOption (mkTimeout 2000000) $ testGroup
     "Nix (upstream) language tests"
     testGroups
  where
   testType (fullpath, _files) = take 2 $ splitOn "-" $ takeFileName fullpath
   mkTestGroup (kind, tests) =
-    testGroup (String.unwords kind) $ fmap (mkTestCase kind) tests
+    testGroup (String.unwords kind) $ mkTestCase kind <$> tests
   mkTestCase kind (basename, files) = testCase (takeFileName basename) $ do
     time <- liftIO getCurrentTime
     let opts = defaultOptions time