(#1040) Utils: add & use {isPresent, handlePresence}

main/Repl.hs

@@ -342,7 +342,7 @@ quit _ = liftIO Exit.exitSuccess
 -- | @:set@ command
 setConfig :: (MonadNix e t f m, MonadIO m) => Text -> Repl e t f m ()
 setConfig args =
-  list
+  handlePresence
     (liftIO $ Text.putStrLn "No option to set specified")
     (\ (x:_xs)  ->
       case filter ((==x) . helpSetOptionName) helpSetOptions of
@@ -393,7 +393,7 @@ completeFunc reversedPrev word
     listFiles word
 
   -- Attributes of sets in REPL context
-  | var : subFields <- Text.split (== '.') (fromString word) , not $ null subFields =
+  | var : subFields <- Text.split (== '.') (fromString word) , isPresent subFields =
     do
       state <- get
       maybe

src/Nix.hs

@@ -142,7 +142,7 @@ processResult h val =
  where
   processKeys :: [VarName] -> NValue t f m -> m a
   processKeys kys v =
-    list
+    handlePresence
       (h v)
       (\ ((k : ks) :: [VarName]) ->
         do

src/Nix/Builtins.hs

@@ -307,7 +307,7 @@ splitDrvName s =
   -- list
   breakAfterFirstItem :: (a -> Bool) -> [a] -> ([a], [a])
   breakAfterFirstItem f =
-    list
+    handlePresence
       mempty
       (\ (h : t) -> let (a, b) = break f t in (h : a, b))
   (namePieces, versionPieces) =
@@ -963,7 +963,7 @@ elemNix x = inHaskM (anyMNix $ valueEqM x)
  where
   anyMNix :: Monad m => (a -> m Bool) -> [a] -> m Bool
   anyMNix p =
-    list
+    handlePresence
       (pure False)
       (\ (x : xss) ->
         bool
@@ -1028,7 +1028,7 @@ genericClosureNix c =
               bool
                 (do
                   checkComparable k $
-                    list
+                    handlePresence
                       k
                       (\ (WValue j:_) -> j)
                       (S.toList ks)

src/Nix/Cited/Basic.hs

@@ -179,7 +179,7 @@ displayProvenance
   -> m a
   -> m a
 displayProvenance =
-  list
+  handlePresence
     id
     (\ (Provenance scope e@(AnnF s _) : _) ->
       withFrame Info $ ForcingExpr scope $ wrapExprLoc s e

src/Nix/Convert.hs

@@ -469,7 +469,7 @@ instance Convertible e t f m
         outputs = mkNixStringWithoutContext <$> nlcvOutputs nlcv
 
       ts :: [NValue t f m] <- traverseToValue outputs
-      list
+      handlePresence
         (pure Nothing)
         (fmap pure . toValue)
         ts

src/Nix/Eval.hs

@@ -241,7 +241,7 @@ attrSetAlter ks' pos m' p' val =
         )
         ((`M.lookup` m) k)
       )
-      (not $ null ks)
+      (isPresent ks)
    where
     insertVal :: m v -> (PositionSet, AttrSet (m v))
     insertVal v =
@@ -369,7 +369,7 @@ evalBinds isRecursive binds =
         -- Empty attrset - return a stub.
         (pure (mempty, nullPos, toValue @(AttrSet v, PositionSet) mempty) )
         (\ k ->
-          list
+          handlePresence
             -- No more keys in the attrset - return the result
             (pure ( one k, pos, finalValue ) )
             -- There are unprocessed keys in attrset - recurse appending the results
@@ -431,7 +431,7 @@ evalSelect aset attr =
       left
       (maybe
         left
-        (list
+        (handlePresence
           (pure . pure)
           (\ (y : ys) -> (extract (y :| ys) =<<))
           ks

src/Nix/Expr/Strings.hs

@@ -72,7 +72,7 @@ stripIndent xs =
  where
   pairWithLast ys =
     zip
-      (list
+      (handlePresence
         Nothing
         (pure . Unsafe.last)
         <$> inits ys
@@ -83,7 +83,7 @@ stripIndent xs =
   ls'       = dropSpaces minIndent <$> ls
 
   minIndent =
-    list
+    handlePresence
       0
       (minimum . (countSpaces . mergePlain <$>))
       (stripEmptyLines ls)

src/Nix/Expr/Types.hs

@@ -728,7 +728,7 @@ ekey keys pos f e@(Fix x)
         do
           let keys' = NE.toList keys
           (ks, rest) <- zip (inits keys') (tails keys')
-          list
+          handlePresence
             mempty
             (\ (j : js) ->
               do

src/Nix/Lint.hs

@@ -170,9 +170,9 @@ renderSymbolic =
   ) <=< unpackSymbolic
  where
   between a b c = a <> b <> c
-  parens = between "(" ")"
+  parens   = between "(" ")"
   brackets = between "[" "]"
-  braces = between "{" "}"
+  braces   = between "{" "}"
 
 -- This function is order and uniqueness preserving (of types).
 merge
@@ -204,7 +204,7 @@ merge context = go
     (TSet x       , TSet Nothing ) -> (one (TSet x) <>) <$> rest
     (TSet Nothing , TSet x       ) -> (one (TSet x) <>) <$> rest
     (TSet (Just l), TSet (Just r)) -> do
-      m <- sequenceA $ M.intersectionWith
+      hm <- sequenceA $ M.intersectionWith
         (\ i j ->
           do
             i'' <- demand =<< i
@@ -213,10 +213,10 @@ merge context = go
         )
         (pure <$> l)
         (pure <$> r)
-      bool
+      handlePresence
         id
-        ((one (TSet $ pure m) <>) <$>)
-        (not $ M.null m)
+        (const ((one (TSet $ pure hm) <>) <$>))
+        hm
         rest
 
     (TClosure{}, TClosure{}) ->
@@ -261,30 +261,32 @@ unify context (SV x) (SV y) = do
   x' <- readRef x
   y' <- readRef y
   case (x', y') of
-    (NAny, _) -> do
-      writeRef x y'
-      pure $ SV y
-    (_, NAny) -> do
-      writeRef y x'
-      pure $ SV x
-    (NMany xs, NMany ys) -> do
-      m <- merge context xs ys
-      bool
-        (do
-          let
-           nm = NMany m
-          writeRef x   nm
-          writeRef y   nm
-          packSymbolic nm
-        )
+    (NAny, _) ->
+      do
+        writeRef x y'
+        pure $ SV y
+    (_, NAny) ->
+      do
+        writeRef y x'
+        pure $ SV x
+    (NMany xs, NMany ys) ->
+      handlePresence
         (
-              -- x' <- renderSymbolic (Symbolic x)
-              -- y' <- renderSymbolic (Symbolic y)
+          -- x' <- renderSymbolic (Symbolic x)
+          -- y' <- renderSymbolic (Symbolic y)
           throwError $ ErrorCall "Cannot unify "
                   -- <> show x' <> " with " <> show y'
                   --  <> " in context: " <> show context
         )
-        (null m)
+        (\ m ->
+          do
+            let
+              nm = NMany m
+            writeRef x   nm
+            writeRef y   nm
+            packSymbolic nm
+        )
+        =<< merge context xs ys
 unify _ _ _ = error "The unexpected hath transpired!"
 
 -- These aren't worth defining yet, because once we move to Hindley-Milner,
@@ -323,19 +325,20 @@ instance MonadLint e m => MonadEval (Symbolic m) m where
   freeVariable var = symerr $ "Undefined variable '" <> coerce var <> "'"
 
   attrMissing ks ms =
-    evalError @(Symbolic m) $ ErrorCall $ toString $
+    evalError @(Symbolic m) . ErrorCall . toString $
       maybe
         ("Inheriting unknown attribute: " <> attr)
         (\ s ->  "Could not look up attribute " <> attr <> " in " <> show s)
         ms
    where
     attr = Text.intercalate "." $ NE.toList $ coerce ks
 
-  evalCurPos = do
-    f <- mkSymbolic $ one TPath
-    l <- mkSymbolic $ one $ TConstant $ one TInt
-    c <- mkSymbolic $ one $ TConstant $ one TInt
-    mkSymbolic $ one $ TSet (pure (M.fromList [("file", f), ("line", l), ("col", c)]))
+  evalCurPos =
+    do
+      f <- mkSymbolic $ one TPath
+      l <- mkSymbolic . one . TConstant $ one TInt
+      c <- mkSymbolic . one . TConstant $ one TInt
+      mkSymbolic . one . TSet . pure $ M.fromList [("file", f), ("line", l), ("col", c)]
 
   evalConstant c = mkSymbolic $ one $ fun c
    where

src/Nix/Pretty.hs

@@ -331,7 +331,7 @@ exprFNixDoc = \case
   NSynHole name -> simpleExpr $ pretty @Text ("^" <> coerce name)
  where
   prettyContainer h f t c =
-    list
+    handlePresence
       (simpleExpr (h <> t))
       (const $ simpleExpr $ group $ nest 2 $ vsep $ one h <> (f <$> c) <> one t)
       c
@@ -380,7 +380,7 @@ prettyProv
   -> NValue t f m
   -> Doc ann
 prettyProv wasThunk v =
-  list
+  handlePresence
     id
     (\ ps pv ->
       fillSep

src/Nix/Reduce.hs

@@ -383,7 +383,7 @@ pruneTree opts =
 
     NLet binds (Just body@(Ann _ x)) ->
       pure $
-        list
+        handlePresence
           x
           (`NLet` body)
           (mapMaybe pruneBinding binds)

src/Nix/Render/Frame.hs

@@ -50,7 +50,11 @@ renderFrames xss@(x : xs) =
       --  2021-10-22: NOTE: List reverse is completely conterproductive. `reverse` of list famously neest to traverse the whole list to take the last element
         | verbosity <= Informational -> (foldMap renderPosition (reverse xs) <>) <$> render1 x
         | otherwise -> foldMapM render1 (reverse xss)
-    pure $ list mempty vsep renderedFrames
+    pure $
+      handlePresence
+        mempty
+        vsep
+        renderedFrames
  where
   render1 :: NixFrame -> m [Doc ann1]
   render1 = renderFrame @v @t @f

src/Nix/String.hs

@@ -143,7 +143,7 @@ mkNixString = NixString
 
 -- | Returns True if the NixString has an associated context
 hasContext :: NixString -> Bool
-hasContext (NixString c _) = not $ null c
+hasContext (NixString c _) = isPresent c
 
 
 -- ** Getters
@@ -183,7 +183,7 @@ toStringContexts path = go
         mkLstCtxFor DirectPath cv { nlcvPath = False }
       NixLikeContextValue _    True _ ->
         mkLstCtxFor AllOutputs cv { nlcvAllOutputs = False }
-      NixLikeContextValue _    _    ls | not (null ls) ->
+      NixLikeContextValue _    _    ls | isPresent ls ->
         mkCtxFor . DerivationOutput <$> ls
       _ -> mempty
    where

src/Nix/Type/Infer.hs

@@ -635,8 +635,8 @@ inferType env ex =
         (Set.difference `on` Set.fromList)
           (Assumption.keys as )
           (       Env.keys env)
-    unless
-      (Set.null unbounds)
+    when
+      (isPresent unbounds)
       $ typeError $ UnboundVariables $ ordNub $ Set.toList unbounds
 
     inferState <- get
@@ -765,9 +765,10 @@ runSolver (Solver s) =
  where
   report :: [a] -> [TypeError] -> Either [TypeError] [a]
   report xs e =
-    if null xs
-      then Left (ordNub e)
-      else pure xs
+    handlePresence
+      (Left $ ordNub e)
+      pure
+      xs
 
 -- ** Instances
 
@@ -829,7 +830,7 @@ nextSolvable = fromJust . find solvable . pickFirstOne
   solvable (EqConst{}     , _) = True
   solvable (ExpInstConst{}, _) = True
   solvable (ImpInstConst _t1 ms t2, cs) =
-    Set.null $ (ms `Set.difference` ftv t2) `Set.intersection` atv cs
+    null $ (ms `Set.difference` ftv t2) `Set.intersection` atv cs
 
 solve :: forall m . MonadState InferState m => [Constraint] -> Solver m Subst
 solve [] = stub

src/Nix/Utils.hs

@@ -19,8 +19,9 @@ module Nix.Utils
   , whenTrue
   , whenFalse
   , whenJust
+  , isPresent
+  , handlePresence
   , whenText
-  , list
   , free
 
   , Path(..)
@@ -207,24 +208,25 @@ whenJust =
     mempty
 {-# inline whenJust #-}
 
--- | Analog for @bool@ or @maybe@, for list-like cons structures.
-list
-  :: Foldable t
-  => b -> (t a -> b) -> t a -> b
-list e f l =
+isPresent :: Foldable t => t a -> Bool
+isPresent = not . null
+
+
+-- | 'maybe'-like eliminator, for foldable empty/inhabited structures.
+handlePresence :: Foldable t => b -> (t a -> b) -> t a -> b
+handlePresence d f t =
   bool
-    (f l)
-    e
-    (null l)
-{-# inline list #-}
+    d
+    (f t)
+    (isPresent t)
 
 whenText
   :: a -> (Text -> a) -> Text -> a
 whenText e f t =
   bool
-    (f t)
     e
-    (Text.null t)
+    (f t)
+    (not $ Text.null t)
 
 -- | Lambda analog of @maybe@ or @either@ for Free monad.
 free :: (a -> b) -> (f (Free f a) -> b) -> Free f a -> b