Transfoming force

ChangeLog.md

@@ -5,19 +5,23 @@
 
 * Breaking:
 
-  * [(link)](https://github.com/haskell-nix/hnix/pull/859/files#diff-ed4fba9b7db93932de22f4ef09d04b07a2ba88888e42207eb9abe6ff10b7ca2b) `Nix.Thunk`: `class MonadThunk t m a | t -> m, t -> a` : `force{,Eff}` unflipped the arguments. All their implementations got more straigh-forward to use and `force*`s now tail recurse.
-    * Simply flip the first two arguments for:
+  * [(link)](https://github.com/haskell-nix/hnix/pull/863/files) `Nix.Thunk`: `class MonadThunk t m a | t -> m, t -> a` : `force{,Eff}`. Moved the functional argument out of the function. Now it only accepts and forces thunk. Please use `=<< force t` or `<=< force` for the nice code. All their implementations got more straigh-forward to use and `force*`s now tail recurse.
       * `force`
-      * `forceEff`
       * `forceThunk`
+      * `forceEff`
       * `forceEffects`
+
+  * [(link)](https://github.com/haskell-nix/hnix/pull/859/files) `Nix.Thunk`: `class MonadThunk t m a | t -> m, t -> a` : unflipped the arguments. All their implementations got more straigh-forward to use and some functions now tail recurse.
+    * Simply flip the first two arguments for:
       * `further`
       * `furtherThunk`
     * Simply switch the 1<->3 arguments in:
       * `querryM`
       * `querryThunk`
 
-  * [(link)](https://github.com/haskell-nix/hnix/pull/862/files#diff-caa5d6592de00a0b23b2996143181d5cb60ebe00abcd0ba39b271caa764aa086) `Nix.Value.Monad`: `class MonadValue v m`: `demand` unflipped the arguments. All its implementations got more straigh-forward to use and `demand` now tail recurse.
+  * [(link)](https://github.com/haskell-nix/hnix/pull/862/files) `Nix.Value.Monad`: `class MonadValue v m`: `demand` unflipped the arguments. All its implementations got more straigh-forward to use and `demand` now tail recurse.
+
+  * [(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/859/commits/8e043bcbda13ea4fd66d3eefd6da690bb3923edd) `Nix.Value.Equal`: `valueEqM`: freed from `RankNTypes: forall t f m .`.
 

src/Nix/Cited/Basic.hs

@@ -85,24 +85,24 @@ instance ( Has e Options
   --   which does not capture the current stack frame information to provide
   --   it in a NixException, so we catch and re-throw it here using
   --   'throwError' from Frames.hs.
-  force :: (v -> m r) -> Cited u f m t -> m r
-  force f (Cited (NCited ps t)) =
+  force :: Cited u f m t -> m v
+  force (Cited (NCited ps t)) =
     catch go (throwError @ThunkLoop)
    where
     go = case ps of
-      [] -> force f t
+      [] -> force t
       Provenance scope e@(Compose (Ann s _)) : _ ->
-        withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force f t)
+        withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force t)
 
-  forceEff :: (v -> m r) -> Cited u f m t -> m r
-  forceEff f (Cited (NCited ps t)) = catch
+  forceEff :: Cited u f m t -> m v
+  forceEff (Cited (NCited ps t)) = catch
     go
     (throwError @ThunkLoop)
    where
     go = case ps of
-      [] -> forceEff f t
+      [] -> forceEff t
       Provenance scope e@(Compose (Ann s _)) : _ ->
-        withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff f t)
+        withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t)
 
   further :: (m v -> m v) -> Cited u f m t -> m (Cited u f m t)
   further f (Cited (NCited ps t)) = Cited . NCited ps <$> further f t

src/Nix/Convert.hs

@@ -24,6 +24,7 @@
 
 module Nix.Convert where
 
+import           Control.Monad                  ( (<=<) )
 import           Control.Monad.Free
 import           Data.ByteString
 import qualified Data.HashMap.Lazy             as M
@@ -77,10 +78,10 @@ instance ( Convertible e t f m
          )
   => FromValue a m (NValue t f m) where
   fromValueMay = demand $ \case
-    Pure t -> force fromValueMay t
+    Pure t -> fromValueMay =<< force t
     Free v -> fromValueMay v
   fromValue = demand $ \case
-    Pure t -> force fromValue t
+    Pure t -> fromValue =<< force t
     Free v -> fromValue v
 
 instance ( Convertible e t f m
@@ -91,14 +92,14 @@ instance ( Convertible e t f m
   fromValueMay (Deeper v) =
     demand
       (free
-        (force $ fromValueMay . Deeper)
+        ((fromValueMay . Deeper) <=< force)
         (fromValueMay . Deeper)
       )
       v
   fromValue (Deeper v) =
     demand
       (free
-        (force $ fromValue . Deeper)
+        ((fromValue . Deeper) <=< force)
         (fromValue . Deeper)
       )
       v

src/Nix/Lint.hs

@@ -287,7 +287,7 @@ instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)
   defer = fmap ST . thunk
 
   demand :: (Symbolic m -> m r) -> Symbolic m -> m r
-  demand f (ST v)= force (demand f) v
+  demand f (ST v)= (demand f) =<< force v
   demand f (SV v)= f (SV v)
 
 instance MonadLint e m => MonadEval (Symbolic m) m where

src/Nix/Normal.hs

@@ -26,6 +26,7 @@ import           Nix.String
 import           Nix.Thunk
 import           Nix.Value
 import           Nix.Utils
+import Data.Bool (bool)
 
 newtype NormalLoop t f m = NormalLoop (NValue t f m)
     deriving Show
@@ -40,10 +41,9 @@ normalizeValue
      , MonadDataErrorContext t f m
      , Ord (ThunkId m)
      )
-  => (forall r . (NValue t f m -> m r) -> t -> m r)
-  -> NValue t f m
+  => NValue t f m
   -> m (NValue t f m)
-normalizeValue f tnk = run $ iterNValueM run go (fmap Free . sequenceNValue' run) tnk
+normalizeValue v = run $ iterNValueM run go (fmap Free . sequenceNValue' run) v
  where
   start = 0 :: Int
   table = mempty
@@ -59,14 +59,16 @@ normalizeValue f tnk = run $ iterNValueM run go (fmap Free . sequenceNValue' run
     -> ReaderT Int (StateT (Set (ThunkId m)) m) (NValue t f m)
   go t k = do
     b <- seen t
-    if b
-      then pure $ pure t
-      else do
+    bool
+      (do
         i <- ask
         when (i > 2000)
           $ error "Exceeded maximum normalization depth of 2000 levels"
         --  2021-02-22: NOTE: `normalizeValue` should be adopted to work without fliping of the force (f)
-        lifted (lifted (`f` t)) $ local succ . k
+        lifted (lifted $ \f -> f =<< force t) $ local succ . k
+      )
+      (pure $ pure t)
+      b
 
   seen t = do
     let tid = thunkId t
@@ -85,7 +87,7 @@ normalForm
      )
   => NValue t f m
   -> m (NValue t f m)
-normalForm t = stubCycles <$> (force `normalizeValue` t)
+normalForm t = stubCycles <$> normalizeValue t
 
 normalForm_
   :: ( Framed e m
@@ -95,7 +97,7 @@ normalForm_
      )
   => NValue t f m
   -> m ()
-normalForm_ t = void (forceEff `normalizeValue` t)
+normalForm_ t = void (normalizeValue t)
 
 stubCycles
   :: forall t f m

src/Nix/Standard.hs

@@ -137,11 +137,11 @@ instance ( MonadAtomicRef m
   queryM :: (StdValue m -> m r) -> m r -> StdThunk m -> m r
   queryM f b x = queryM f b (_stdCited (_stdThunk x))
 
-  force :: (StdValue m -> m r) -> StdThunk m -> m r
-  force f t = force f (_stdCited $ _stdThunk t)
+  force :: StdThunk m -> m (StdValue m)
+  force t = force (_stdCited $ _stdThunk t)
 
-  forceEff :: (StdValue m -> m r) -> StdThunk m -> m r
-  forceEff f t = forceEff f (_stdCited $ _stdThunk t)
+  forceEff :: StdThunk m -> m (StdValue m)
+  forceEff t = forceEff (_stdCited $ _stdThunk t)
 
   further :: (m (StdValue m) -> m (StdValue m)) ->  StdThunk m -> m (StdThunk m)
   further f t = StdThunk . StdCited <$> further f (_stdCited $ _stdThunk t)
@@ -166,7 +166,7 @@ instance ( MonadAtomicRef m
     -> m r
   demand f v =
     free
-      (force (demand f))
+      ((demand f) <=< force)
       (const $ f v)
       v
 

src/Nix/Thunk.hs

@@ -49,8 +49,8 @@ class MonadThunkId m => MonadThunk t m a | t -> m, t -> a where
   thunkId  :: t -> ThunkId m
 
   queryM   :: (a -> m r) -> m r -> t -> m r
-  force    :: (a -> m r) -> t -> m r
-  forceEff :: (a -> m r) -> t -> m r
+  force    :: t -> m a
+  forceEff :: t -> m a
 
   -- | Modify the action to be performed by the thunk. For some implicits
   --   this modifies the thunk, for others it may create a new thunk.

src/Nix/Thunk/Basic.hs

@@ -74,44 +74,46 @@ queryThunk k n (Thunk _ active ref) = do
       pure res
 
 forceThunk
-  :: forall m v a
+  :: forall m v
    . (MonadVar m, MonadThrow m, MonadCatch m, Show (ThunkId m))
-  => (v -> m a)
-  -> NThunkF m v
-  -> m a
-forceThunk k (Thunk n active ref) = do
+  => NThunkF m v
+  -> m v
+forceThunk (Thunk n active ref) = do
   eres <- readVar ref
   case eres of
-    Computed v      -> k v
+    Computed v      -> pure v
     Deferred action -> do
       nowActive <- atomicModifyVar active (True, )
-      if nowActive
-        then throwM $ ThunkLoop $ show n
-        else do
+      bool
+        (do
           v <- catch action $ \(e :: SomeException) -> do
             _ <- atomicModifyVar active (False, )
             throwM e
           _ <- atomicModifyVar active (False, )
           writeVar ref (Computed v)
-          k v
+          pure v
+        )
+        (throwM $ ThunkLoop $ show n)
+        nowActive
 
 forceEffects :: MonadVar m
-  => (v -> m r)
-  -> NThunkF m v
-  -> m r
-forceEffects k (Thunk _ active ref) = do
+  => NThunkF m v
+  -> m v
+forceEffects (Thunk _ active ref) = do
   nowActive <- atomicModifyVar active (True, )
-  if nowActive
-    then pure $ error "Loop detected"
-    else do
+  bool
+    (do
       eres <- readVar ref
       case eres of
-        Computed v      -> k v
+        Computed v      -> pure v
         Deferred action -> do
           v <- action
           writeVar ref (Computed v)
           _ <- atomicModifyVar active (False, )
-          k v
+          pure v
+    )
+    (pure $ error "Loop detected")
+    nowActive
 
 furtherThunk :: MonadVar m
   => (m v -> m v)

src/Nix/Type/Infer.hs

@@ -430,12 +430,12 @@ instance MonadInfer m
   queryM f b (JThunk x) = queryM f b x
 
   -- If we have a thunk loop, we just don't know the type.
-  force f (JThunk t) = catch (force t f)
+  force (JThunk t) = catch (force f)
     $ \(_ :: ThunkLoop) ->
                            f =<< Judgment As.empty mempty <$> fresh
 
   -- If we have a thunk loop, we just don't know the type.
-  forceEff f (JThunk t) = catch (forceEff f t)
+  forceEff (JThunk t) = catch (forceEff t)
     $ \(_ :: ThunkLoop) ->
                            f =<< Judgment As.empty mempty <$> fresh
 -}

src/Nix/Value.hs

@@ -662,7 +662,7 @@ describeValue = \case
 showValueType :: (MonadThunk t m (NValue t f m), Comonad f)
   => NValue t f m
   -> m String
-showValueType (Pure t) = force showValueType t
+showValueType (Pure t) = showValueType =<< force t
 showValueType (Free (NValue (extract -> v))) =
   pure $ describeValue $ valueType v
 

src/Nix/Value/Equal.hs

@@ -142,22 +142,20 @@ valueEqM x@(Free _) (  Pure y) = thunkEqM ?? y =<< thunk (pure x)
 valueEqM (Free (NValue (extract -> x))) (Free (NValue (extract -> y))) =
   valueFEqM (compareAttrSetsM f valueEqM) valueEqM x y
  where
-  f m =
+  f =
     free
-      (force
-        (pure . \case
+      (pure . (\case
           NVStr s -> pure s
           _       -> mempty
-        )
+        ) <=< force
       )
       (pure . \case
         NVStr' s -> pure s
         _        -> mempty
       )
-      m
 
 thunkEqM :: (MonadThunk t m (NValue t f m), Comonad f) => t -> t -> m Bool
-thunkEqM lt rt = (`force` lt) $ \lv -> (`force` rt) $ \rv ->
+thunkEqM lt rt = (=<< force lt) $ \lv -> (=<< force rt) $ \rv ->
   let unsafePtrEq = case (lt, rt) of
         (thunkId -> lid, thunkId -> rid) | lid == rid -> pure True
         _ -> valueEqM lv rv