Merge #925: Normal: reintroduce normalizeValueF

* Normal: reintroduce normalizeValueF
* Normal: opaque: show ("expr" -> "cycle")

Author: Anton-Latukha

ChangeLog.md

@@ -58,7 +58,7 @@
         -- was :: v -> (m v -> m v) -> m v
       ```
 
-  * [(link)](https://github.com/haskell-nix/hnix/pull/863/files) `Nix.Normal`: `normalizeValue` removed first functional argument that was passing the function that did the thunk forcing. Now function provides the thunk forcing. Now to normalize simply use `normalizeValue v`.
+  * [(link)](https://github.com/haskell-nix/hnix/pull/863/files) `Nix.Normal`: `normalizeValue` removed first functional argument that was passing the function that did the thunk forcing. Now function provides the thunk forcing. Now to normalize simply use `normalizeValue v`. Old implementation now is `normalizeValueF`.
 
   * [(link)](https://github.com/haskell-nix/hnix/pull/859/commits/8e043bcbda13ea4fd66d3eefd6da690bb3923edd) `Nix.Value.Equal`: `valueEqM`: freed from `RankNTypes: forall t f m .`.
 

src/Nix.hs

@@ -104,18 +104,21 @@ evaluateExpression
   -> (NValue t f m -> m a)
   -> NExprLoc
   -> m a
-evaluateExpression mpath evaluator handler expr = do
-  opts :: Options <- asks (view hasLens)
-  args <- traverse (traverse eval') $ fmap (second parseArg) (arg opts) <> fmap
-    (second mkStr)
-    (argstr opts)
-  evaluator mpath expr >>= \f ->
-    (\f' ->
-      processResult handler =<<
-        case f' of
-          NVClosure _ g -> g (argmap args)
-          _             -> pure f
-    ) =<< demand f
+evaluateExpression mpath evaluator handler expr =
+  do
+    opts :: Options <- asks $ view hasLens
+    args <-
+      (traverse . traverse)
+        eval'
+        $ (second parseArg <$> arg opts) <>
+          (second mkStr <$> argstr opts)
+    f <- evaluator mpath expr
+    f' <- demand f
+    val <-
+      case f' of
+        NVClosure _ g -> g $ argmap args
+        _             -> pure f
+    processResult handler val
  where
   parseArg s =
     either

src/Nix/Cited.hs

@@ -50,6 +50,10 @@ instance ComonadEnv [Provenance m v] (NCited m v) where
 $(makeLenses ''Provenance)
 $(makeLenses ''NCited)
 
+class HasCitations1 m v f where
+  citations1 :: f a -> [Provenance m v]
+  addProvenance1 :: Provenance m v -> f a -> f a
+
 class HasCitations m v a where
   citations :: a -> [Provenance m v]
   addProvenance :: Provenance m v -> a -> a
@@ -58,18 +62,14 @@ instance HasCitations m v (NCited m v a) where
   citations = _provenance
   addProvenance x (NCited p v) = NCited (x : p) v
 
-class HasCitations1 m v f where
-  citations1 :: f a -> [Provenance m v]
-  addProvenance1 :: Provenance m v -> f a -> f a
-
 instance HasCitations1 m v f
   => HasCitations m v (NValue' t f m a) where
   citations (NValue' f) = citations1 f
-  addProvenance x (NValue' f) = NValue' (addProvenance1 x f)
+  addProvenance x (NValue' f) = NValue' $ addProvenance1 x f
 
 instance (HasCitations1 m v f, HasCitations m v t)
   => HasCitations m v (NValue t f m) where
   citations (Pure t) = citations t
   citations (Free v) = citations v
-  addProvenance x (Pure t) = Pure (addProvenance x t)
-  addProvenance x (Free v) = Free (addProvenance x v)
+  addProvenance x (Pure t) = Pure $ addProvenance x t
+  addProvenance x (Free v) = Free $ addProvenance x v

src/Nix/Cited/Basic.hs

@@ -41,7 +41,7 @@ newtype Cited t f m a = Cited { getCited :: NCited m (NValue t f m) a }
 
 instance HasCitations1 m (NValue t f m) (Cited t f m) where
   citations1 (Cited c) = citations c
-  addProvenance1 x (Cited c) = Cited (addProvenance x c)
+  addProvenance1 x (Cited c) = Cited $ addProvenance x c
 
 instance ( Has e Options
          , Framed e m
@@ -58,7 +58,7 @@ instance ( Has e Options
     opts :: Options <- asks (view hasLens)
 
     bool
-      (fmap (Cited . NCited mempty) . thunk $ mv)
+      (Cited . NCited mempty <$> thunk mv)
       (do
         frames :: Frames <- asks (view hasLens)
 
@@ -72,7 +72,7 @@ instance ( Has e Options
             go _ = mempty
             ps = concatMap (go . frame) frames
 
-        fmap (Cited . NCited ps) . thunk $ mv
+        Cited . NCited ps <$> thunk mv
       )
       (thunks opts)
 

src/Nix/Effects/Derivation.hs

@@ -199,7 +199,7 @@ derivationParser = do
   _ <- ")"
   eof
 
-  let outputs = Map.fromList $ fmap (\(a, b, _, _) -> (a, b)) fullOutputs
+  let outputs = Map.fromList $ (\(a, b, _, _) -> (a, b)) <$> fullOutputs
   let (mFixed, hashMode) = parseFixed fullOutputs
   let name = "" -- FIXME (extract from file path ?)
   let useJson = ["__json"] == Map.keys env
@@ -239,7 +239,8 @@ derivationParser = do
 
 
 defaultDerivationStrict :: forall e t f m b. (MonadNix e t f m, MonadState (b, MS.HashMap Text Text) m) => NValue t f m -> m (NValue t f m)
-defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
+defaultDerivationStrict val = do
+    s <- fromValue @(AttrSet (NValue t f m)) val
     (drv, ctx) <- runWithStringContextT' $ buildDerivationWithContext s
     drvName <- makeStorePathName $ name drv
     let inputs = toStorePaths ctx
@@ -270,9 +271,9 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
 
     -- Memoize here, as it may be our last chance in case of readonly stores.
     drvHash <- Store.encodeInBase Store.Base16 <$> hashDerivationModulo drv'
-    modify (second (MS.insert drvPath drvHash))
+    modify $ second $ MS.insert drvPath drvHash
 
-    let outputsWithContext = Map.mapWithKey (\out path -> makeNixStringWithSingletonContext path (StringContext drvPath (DerivationOutput out))) (outputs drv')
+    let outputsWithContext = Map.mapWithKey (\out path -> makeNixStringWithSingletonContext path (StringContext drvPath $ DerivationOutput out)) (outputs drv')
         drvPathWithContext = makeNixStringWithSingletonContext drvPath (StringContext drvPath AllOutputs)
         attrSet = M.map nvStr $ M.fromList $ ("drvPath", drvPathWithContext): Map.toList outputsWithContext
     -- TODO: Add location information for all the entries.
@@ -303,18 +304,18 @@ defaultDerivationStrict = fromValue @(AttrSet (NValue t f m)) >=> \s -> do
 buildDerivationWithContext :: forall e t f m. (MonadNix e t f m) => AttrSet (NValue t f m) -> WithStringContextT m Derivation
 buildDerivationWithContext drvAttrs = do
     -- Parse name first, so we can add an informative frame
-    drvName     <- getAttr   "name"                      $ extractNixString >=> assertDrvStoreName
+    drvName     <- getAttr   "name"                      $ assertDrvStoreName <=< extractNixString
     withFrame' Info (ErrorCall $ "While evaluating derivation " <> show drvName) $ do
 
       useJson     <- getAttrOr "__structuredAttrs" False     pure
       ignoreNulls <- getAttrOr "__ignoreNulls"     False     pure
 
-      args        <- getAttrOr "args"              mempty  $ traverse (fromValue' >=> extractNixString)
+      args        <- getAttrOr "args"              mempty  $ traverse (extractNixString <=< fromValue')
       builder     <- getAttr   "builder"                     extractNixString
-      platform    <- getAttr   "system"                    $ extractNoCtx >=> assertNonNull
-      mHash       <- getAttrOr "outputHash"        mempty  $ extractNoCtx >=> (pure . pure)
-      hashMode    <- getAttrOr "outputHashMode"    Flat    $ extractNoCtx >=> parseHashMode
-      outputs     <- getAttrOr "outputs"           ["out"] $ traverse (fromValue' >=> extractNoCtx)
+      platform    <- getAttr   "system"                    $ assertNonNull <=< extractNoCtx
+      mHash       <- getAttrOr "outputHash"        mempty  $ (pure . pure) <=< extractNoCtx
+      hashMode    <- getAttrOr "outputHashMode"    Flat    $ parseHashMode <=< extractNoCtx
+      outputs     <- getAttrOr "outputs"           ["out"] $ traverse (extractNoCtx <=< fromValue')
 
       mFixedOutput <-
         maybe
@@ -356,7 +357,7 @@ buildDerivationWithContext drvAttrs = do
 
       pure $ Derivation { platform, builder, args, env,  hashMode, useJson
         , name = drvName
-        , outputs = Map.fromList $ fmap (, mempty) outputs
+        , outputs = Map.fromList $ (, mempty) <$> outputs
         , mFixed = mFixedOutput
         , inputs = (mempty, mempty) -- stub for now
         }

src/Nix/Eval.hs

@@ -172,7 +172,7 @@ eval (NAbs    params body) = do
   scope <- currentScopes :: m (Scopes m v)
   evalAbs params $ \arg k -> withScopes scope $ do
     args <- buildArgument params arg
-    pushScope args (k (withScopes scope . inform <$> args) body)
+    pushScope args $ k (withScopes scope . inform <$> args) body
 
 eval (NSynHole name) = synHole name
 
@@ -186,7 +186,7 @@ evalWithAttrSet aset body = do
   -- computed once.
   scope <- currentScopes :: m (Scopes m v)
   s     <- defer $ withScopes scope aset
-  let s' = (fmap fst . fromValue @(AttrSet v, AttrSet SourcePos)) =<< demand s
+  let s' = fst <$> (fromValue @(AttrSet v, AttrSet SourcePos) =<< demand s)
 
   pushWeakScope s' body
 
@@ -282,15 +282,15 @@ evalBinds recursive binds =
       res <-
         bool
           (traverse mkThunk s)
-          (loebM (encapsulate <$> s))
+          (loebM $ encapsulate <$> s)
           recursive
 
       pure (res, p)
 
    where
     mkThunk = defer . withScopes scope
 
-    encapsulate f attrs = mkThunk . pushScope attrs $ f
+    encapsulate f attrs = mkThunk $ pushScope attrs f
 
     insert (m, p) (path, pos, value) = attrSetAlter path pos m p value
 
@@ -305,19 +305,15 @@ evalBinds recursive binds =
           , fromMaybe pos (M.lookup k p')
           , demand v
           )
-        ) <$>
-        M.toList o'
+        ) <$> M.toList o'
 
   applyBindToAdt _ (NamedVar pathExpr finalValue pos) =
-    do
-      fmap
-        (\case
-          -- When there are no path segments, e.g. `${null} = 5;`, we don't
-          -- bind anything
-          ([], _, _) -> mempty
-          result     -> [result]
-        )
-        (processAttrSetKeys pathExpr)
+    (\case
+      -- When there are no path segments, e.g. `${null} = 5;`, we don't
+      -- bind anything
+      ([], _, _) -> mempty
+      result     -> [result]
+    ) <$> processAttrSetKeys pathExpr
 
    where
     processAttrSetKeys :: NAttrPath (m v) -> m ([Text], SourcePos, m v)
@@ -496,12 +492,12 @@ buildArgument params arg =
       This _
         | isVariadic -> Nothing
         | otherwise  -> pure $ const $ evalError @v $ ErrorCall $ "Unexpected parameter: " <> show k
-      These x _ -> pure (const (pure x))
+      These x _ -> pure $ const $ pure x
 
 addSourcePositions
   :: (MonadReader e m, Has e SrcSpan) => Transform NExprLocF (m a)
 addSourcePositions f v@(Fix (Compose (Ann ann _))) =
-  local (set hasLens ann) (f v)
+  local (set hasLens ann) $ f v
 
 addStackFrames
   :: forall v e m a
@@ -524,4 +520,4 @@ framedEvalExprLoc
   => NExprLoc
   -> m v
 framedEvalExprLoc =
-  adi (eval . annotated . getCompose) (addStackFrames @v . addSourcePositions)
+  adi (eval . annotated . getCompose) $ addStackFrames @v . addSourcePositions

src/Nix/Normal.hs

@@ -6,6 +6,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
 
 -- | Code for normalization (reduction into a normal form) of Nix expressions.
 -- Nix language allows recursion, so some expressions do not converge.
@@ -15,7 +16,9 @@ module Nix.Normal where
 import           Prelude            hiding ( force )
 import           Nix.Utils
 import           Control.Monad.Free        ( Free(..) )
-import           Data.Set
+import           Data.Set                  ( member
+                                           , insert
+                                           )
 import           Nix.Cited
 import           Nix.Frames
 import           Nix.String
@@ -56,9 +59,7 @@ normalizeValue v = run $ iterNValueM run go (fmap Free . sequenceNValue' run) v
     bool
       (do
         i <- ask
-        when (i > 2000)
-          $ fail "Exceeded maximum normalization depth of 2000 levels"
-        --  2021-02-22: NOTE: `normalizeValue` should be adopted to work without fliping of the force (f)
+        when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels"
         lifted (lifted $ \f -> f =<< force t) $ local succ . k
       )
       (pure $ pure t)
@@ -67,10 +68,57 @@ normalizeValue v = run $ iterNValueM run go (fmap Free . sequenceNValue' run) v
   seen t = do
     let tid = thunkId t
     lift $ do
-      res <- gets (member tid)
-      unless res $ modify (insert tid)
+      res <- gets $ member tid
+      unless res $ modify $ insert tid
       pure res
 
+-- 2021-05-09: NOTE: This seems a bit excessive. If these functorial versions are not used for recursion schemes - just free from it.
+-- | Normalization HOF (functorial) version of @normalizeValue@. Accepts the special thunk operating/forcing/nirmalizing function & internalizes it.
+normalizeValueF
+  :: forall e t m f
+   . ( Framed e m
+     , MonadThunk t m (NValue t f m)
+     , MonadDataErrorContext t f m
+     , Ord (ThunkId m)
+     )
+  => (forall r . t -> (NValue t f m -> m r) -> m r)
+  -> NValue t f m
+  -> m (NValue t f m)
+normalizeValueF f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
+ where
+  start = 0 :: Int
+  table = mempty
+
+  run :: ReaderT Int (StateT (Set (ThunkId m)) m) r -> m r
+  run = (`evalStateT` table) . (`runReaderT` start)
+
+  go
+    :: t
+    -> (  NValue t f m
+       -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
+       )
+    -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
+  go t k = do
+    b <- seen t
+    bool
+      (do
+        i <- ask
+        when (i > 2000) $ fail "Exceeded maximum normalization depth of 2000 levels"
+        lifted (lifted $ f t) $ local succ . k
+      )
+      (pure $ pure t)
+      b
+
+  seen t = do
+    let tid = thunkId t
+    lift $ do
+      res <- gets $ member tid
+      unless res $ modify $ insert tid
+      pure res
+
+-- | Normalize value.
+-- Detect cycles.
+-- If cycles were detected - put a stub on them.
 normalForm
   :: ( Framed e m
      , MonadThunk t m (NValue t f m)
@@ -83,6 +131,7 @@ normalForm
   -> m (NValue t f m)
 normalForm t = stubCycles <$> normalizeValue t
 
+-- | Monadic context of the result.
 normalForm_
   :: ( Framed e m
      , MonadThunk t m (NValue t f m)
@@ -91,8 +140,9 @@ normalForm_
      )
   => NValue t f m
   -> m ()
-normalForm_ t = void (normalizeValue t)
+normalForm_ t = void $ normalizeValue t
 
+-- | Detect cycles & stub them.
 stubCycles
   :: forall t f m
    . ( MonadDataContext f m
@@ -101,12 +151,17 @@ stubCycles
      )
   => NValue t f m
   -> NValue t f m
-stubCycles = flip iterNValue Free $ \t _ ->
-  Free
-    $ NValue'
-    $ Prelude.foldr (addProvenance1 @m @(NValue t f m)) cyc
-    $ reverse
-    $ citations @m @(NValue t f m) t
+stubCycles =
+  iterNValue
+    (\t _ ->
+      Free $
+        NValue' $
+          foldr
+            (addProvenance1 @m @(NValue t f m))
+            cyc
+            (reverse $ citations @m @(NValue t f m) t)
+    )
+    Free
  where
   Free (NValue' cyc) = opaque
 
@@ -122,7 +177,7 @@ removeEffects =
     (fmap Free . sequenceNValue' id)
 
 opaque :: Applicative f => NValue t f m
-opaque = nvStr $ makeNixStringWithoutContext "<expr>"
+opaque = nvStr $ makeNixStringWithoutContext "<cycle>"
 
 dethunk
   :: (MonadThunk t m (NValue t f m), MonadDataContext f m)