optimization by class MonadThunk arguments order

ChangeLog.md

@@ -5,6 +5,20 @@
 
 * 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:
+      * `force`
+      * `forceEff`
+      * `forceThunk`
+      * `forceEffects`
+      * `further`
+      * `furtherThunk`
+    * Simply switch the 1<->3 arguments in:
+      * `querryM`
+      * `querryThunk`
+
+  * [(link)](https://github.com/haskell-nix/hnix/pull/859/commits/8e043bcbda13ea4fd66d3eefd6da690bb3923edd) `Nix.Value.Equal`: `valueEqM`: freed from `RankNTypes: forall t f m .`.
+
   * [(link)](https://github.com/haskell-nix/hnix/pull/802/commits/529095deaf6bc6b102fe5a3ac7baccfbb8852e49#) `Nix.Strings`: all `hacky*` functions replaced with lawful implemetations, because of that all functions become lawful - dropped the `principled` suffix from functions:
     * `Nix.String`:
         ```haskell

src/Nix/Cited/Basic.hs

@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE InstanceSigs #-}
 
 module Nix.Cited.Basic where
 
@@ -52,6 +53,8 @@ instance ( Has e Options
          , MonadCatch m
          )
   => MonadThunk (Cited u f m t) m v where
+
+  thunk :: m v -> m (Cited u f m t)
   thunk mv = do
     opts :: Options <- asks (view hasLens)
 
@@ -72,29 +75,34 @@ instance ( Has e Options
         fmap (Cited . NCited ps) . thunk $ mv
       else fmap (Cited . NCited mempty) . thunk $ mv
 
+  thunkId :: Cited u f m t -> ThunkId m
   thunkId (Cited (NCited _ t)) = thunkId @_ @m t
 
-  queryM (Cited (NCited _ t)) = queryM t
+  queryM :: (v -> m r) -> m r -> Cited u f m t -> m r
+  queryM f m (Cited (NCited _ t)) = queryM f m t
 
   -- | The ThunkLoop exception is thrown as an exception with MonadThrow,
   --   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 (Cited (NCited ps t)) f =
+  force :: (v -> m r) -> Cited u f m t -> m r
+  force f (Cited (NCited ps t)) =
     catch go (throwError @ThunkLoop)
    where
     go = case ps of
-      [] -> force t f
+      [] -> force f t
       Provenance scope e@(Compose (Ann s _)) : _ ->
-        withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force t f)
+        withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (force f t)
 
-  forceEff (Cited (NCited ps t)) f = catch
+  forceEff :: (v -> m r) -> Cited u f m t -> m r
+  forceEff f (Cited (NCited ps t)) = catch
     go
     (throwError @ThunkLoop)
    where
     go = case ps of
-      [] -> forceEff t f
+      [] -> forceEff f t
       Provenance scope e@(Compose (Ann s _)) : _ ->
-        withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff t f)
+        withFrame Info (ForcingExpr scope (wrapExprLoc s e)) (forceEff f t)
 
-  further (Cited (NCited ps t)) f = Cited . NCited ps <$> further t f
+  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

@@ -77,10 +77,10 @@ instance ( Convertible e t f m
          )
   => FromValue a m (NValue t f m) where
   fromValueMay = flip demand $ \case
-    Pure t -> force t fromValueMay
+    Pure t -> force fromValueMay t
     Free v -> fromValueMay v
   fromValue = flip demand $ \case
-    Pure t -> force t fromValue
+    Pure t -> force fromValue t
     Free v -> fromValue v
 
 instance ( Convertible e t f m
@@ -89,10 +89,10 @@ instance ( Convertible e t f m
          )
   => FromValue a m (Deeper (NValue t f m)) where
   fromValueMay (Deeper v) = demand v $ \case
-    Pure t -> force t (fromValueMay . Deeper)
+    Pure t -> force (fromValueMay . Deeper) t
     Free v -> fromValueMay (Deeper v)
   fromValue (Deeper v) = demand v $ \case
-    Pure t -> force t (fromValue . Deeper)
+    Pure t -> force (fromValue . Deeper) t
     Free v -> fromValue (Deeper v)
 
 instance Convertible e t f m

src/Nix/Lint.hs

@@ -12,6 +12,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE InstanceSigs #-}
 
 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
 {-# OPTIONS_GHC -Wno-missing-methods #-}
@@ -265,8 +266,12 @@ instance ToValue (AttrSet (Symbolic m), AttrSet SourcePos) m (Symbolic m) where
 
 instance (MonadThunkId m, MonadAtomicRef m, MonadCatch m)
   => MonadValue (Symbolic m) m where
+
+  defer :: m (Symbolic m) -> m (Symbolic m)
   defer = fmap ST . thunk
-  demand (ST v) f = force v (flip demand f)
+
+  demand :: Symbolic m -> (Symbolic m -> m r) -> m r
+  demand (ST v) f = force (`demand` f) v
   demand (SV v) f = f (SV v)
 
 instance MonadLint e m => MonadEval (Symbolic m) m where

src/Nix/Normal.hs

@@ -40,10 +40,10 @@ normalizeValue
      , MonadDataErrorContext t f m
      , Ord (ThunkId m)
      )
-  => (forall r . t -> (NValue t f m -> m r) -> m r)
+  => (forall r . (NValue t f m -> m r) -> t -> m r)
   -> NValue t f m
   -> m (NValue t f m)
-normalizeValue f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
+normalizeValue f tnk = run $ iterNValueM run go (fmap Free . sequenceNValue' run) tnk
  where
   start = 0 :: Int
   table = mempty
@@ -60,12 +60,13 @@ normalizeValue f = run . iterNValueM run go (fmap Free . sequenceNValue' run)
   go t k = do
     b <- seen t
     if b
-      then pure $ Pure t
+      then pure $ pure t
       else do
         i <- ask
         when (i > 2000)
           $ error "Exceeded maximum normalization depth of 2000 levels"
-        lifted (lifted (f t)) $ local succ . k
+        --  2021-02-22: NOTE: `normalizeValue` should be adopted to work without fliping of the force (f)
+        lifted (lifted (`f` t)) $ local succ . k
 
   seen t = do
     let tid = thunkId t
@@ -84,7 +85,7 @@ normalForm
      )
   => NValue t f m
   -> m (NValue t f m)
-normalForm = fmap stubCycles . normalizeValue force
+normalForm t = stubCycles <$> (force `normalizeValue` t)
 
 normalForm_
   :: ( Framed e m
@@ -94,7 +95,7 @@ normalForm_
      )
   => NValue t f m
   -> m ()
-normalForm_ = void <$> normalizeValue forceEff
+normalForm_ t = void (forceEff `normalizeValue` t)
 
 stubCycles
   :: forall t f m
@@ -120,7 +121,8 @@ removeEffects
 removeEffects =
   iterNValueM
     id
-    (`queryM` pure opaque)
+    --  2021-02-25: NOTE: Please, unflip this up the stack
+    (\ t f -> queryM f (pure opaque) t)
     (fmap Free . sequenceNValue' id)
 
 opaque :: Applicative f => NValue t f m
@@ -130,4 +132,4 @@ dethunk
   :: (MonadThunk t m (NValue t f m), MonadDataContext f m)
   => t
   -> m (NValue t f m)
-dethunk t = queryM t (pure opaque) removeEffects
+dethunk t = queryM removeEffects (pure opaque) t

src/Nix/Standard.hs

@@ -11,6 +11,7 @@
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE InstanceSigs #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -125,12 +126,24 @@ instance ( MonadAtomicRef m
          , MonadThunkId m
          )
   => MonadThunk (StdThunk m) m (StdValue m) where
-  thunk   = fmap (StdThunk . StdCited) . thunk
+
+  thunk :: m (StdValue m) -> m (StdThunk m)
+  thunk v = StdThunk . StdCited <$> thunk v
+
+  thunkId :: StdThunk m -> ThunkId m
   thunkId = thunkId . _stdCited . _stdThunk
-  queryM x b f = queryM (_stdCited (_stdThunk x)) b f
-  force    = force . _stdCited . _stdThunk
-  forceEff = forceEff . _stdCited . _stdThunk
-  further  = (fmap (StdThunk . StdCited) .) . further . _stdCited . _stdThunk
+
+  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)
+
+  forceEff :: (StdValue m -> m r) -> StdThunk m -> m r
+  forceEff f t = forceEff f (_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)
 
 instance ( MonadAtomicRef m
          , MonadCatch m
@@ -139,13 +152,28 @@ instance ( MonadAtomicRef m
          , MonadThunkId m
          )
   => MonadValue (StdValue m) m where
-  defer = fmap Pure . thunk
-
-  demand (Pure v) f = force v (flip demand f)
+  defer
+    :: m (StdValue m)
+    -> m (StdValue m)
+  defer = fmap pure . thunk
+
+  demand
+    :: StdValue m
+    -> ( StdValue m
+      -> m r
+      )
+    -> m r
+  demand (Pure v) f = force (`demand` f) v
   demand (Free v) f = f (Free v)
 
-  inform (Pure t) f = Pure <$> further t f
-  inform (Free v) f = Free <$> bindNValue' id (flip inform f) v
+  inform
+    :: StdValue m
+    -> ( m (StdValue m)
+      -> m (StdValue m)
+      )
+    -> m (StdValue m)
+  inform (Pure t) f = Pure <$> further f t
+  inform (Free v) f = Free <$> bindNValue' id (`inform` f) v
 
 {------------------------------------------------------------------------}
 

src/Nix/Thunk.hs

@@ -41,20 +41,20 @@ instance MonadThunkId m => MonadThunkId (StateT s m) where
   type ThunkId (StateT s m) = ThunkId m
 
 class MonadThunkId m => MonadThunk t m a | t -> m, t -> a where
-  thunk :: m a -> m t
+  thunk    :: m a -> m t
 
   -- | Return an identifier for the thunk unless it is a pure value (i.e.,
   --   strictly an encapsulation of some 'a' without any additional
   --   structure). For pure values represented as thunks, returns mempty.
-  thunkId :: t -> ThunkId m
+  thunkId  :: t -> ThunkId m
 
-  queryM :: t -> m r -> (a -> m r) -> m r
-  force :: t -> (a -> m r) -> m r
-  forceEff :: t -> (a -> m r) -> m r
+  queryM   :: (a -> m r) -> m r -> t -> m r
+  force    :: (a -> m r) -> t -> m r
+  forceEff :: (a -> m r) -> t -> m r
 
   -- | Modify the action to be performed by the thunk. For some implicits
   --   this modifies the thunk, for others it may create a new thunk.
-  further :: t -> (m a -> m a) -> m t
+  further  :: (m a -> m a) -> t -> m t
 
 newtype ThunkLoop = ThunkLoop String -- contains rendering of ThunkId
   deriving Typeable

src/Nix/Thunk/Basic.hs

@@ -16,6 +16,7 @@ import           Control.Monad.Catch
 
 import           Nix.Thunk
 import           Nix.Var
+import Data.Bool (bool)
 
 data Deferred m v = Deferred (m v) | Computed v
     deriving (Functor, Foldable, Traversable)
@@ -46,26 +47,39 @@ buildThunk action = do
   freshThunkId <- freshId
   Thunk freshThunkId <$> newVar False <*> newVar (Deferred action)
 
-queryThunk :: MonadVar m => NThunkF m v -> m a -> (v -> m a) -> m a
-queryThunk (Thunk _ active ref) n k = do
-  nowActive <- atomicModifyVar active (True, )
-  if nowActive
-    then n
-    else do
+--  2021-02-25: NOTE: Please, look into thread handling of this.
+-- Locking system was not implemented at the time.
+-- How query operates? Is it normal that query on request if the thunk is locked - returns the thunk
+-- and when the value calculation is deferred - returns the thunk, it smells fishy.
+-- And because the query's impemetation are not used, only API - they pretty much could survive being that fishy.
+queryThunk :: MonadVar m
+  => (v -> m a)
+  -> m a
+  -> NThunkF m v
+  -> m a
+queryThunk k n (Thunk _ active ref) = do
+  thunkIsAvaliable <- not <$> atomicModifyVar active (True, )
+  bool
+    n
+    go
+    thunkIsAvaliable
+   where
+    go = do
       eres <- readVar ref
-      res  <- case eres of
-        Computed v -> k v
-        _          -> n
+      res  <-
+        case eres of
+          Computed v   -> k v
+          Deferred _mv -> n
       _ <- atomicModifyVar active (False, )
       pure res
 
 forceThunk
   :: forall m v a
    . (MonadVar m, MonadThrow m, MonadCatch m, Show (ThunkId m))
-  => NThunkF m v
-  -> (v -> m a)
+  => (v -> m a)
+  -> NThunkF m v
   -> m a
-forceThunk (Thunk n active ref) k = do
+forceThunk k (Thunk n active ref) = do
   eres <- readVar ref
   case eres of
     Computed v      -> k v
@@ -81,8 +95,11 @@ forceThunk (Thunk n active ref) k = do
           writeVar ref (Computed v)
           k v
 
-forceEffects :: MonadVar m => NThunkF m v -> (v -> m r) -> m r
-forceEffects (Thunk _ active ref) k = do
+forceEffects :: MonadVar m
+  => (v -> m r)
+  -> NThunkF m v
+  -> m r
+forceEffects k (Thunk _ active ref) = do
   nowActive <- atomicModifyVar active (True, )
   if nowActive
     then pure $ error "Loop detected"
@@ -96,8 +113,11 @@ forceEffects (Thunk _ active ref) k = do
           _ <- atomicModifyVar active (False, )
           k v
 
-furtherThunk :: MonadVar m => NThunkF m v -> (m v -> m v) -> m (NThunkF m v)
-furtherThunk t@(Thunk _ _ ref) k = do
+furtherThunk :: MonadVar m
+  => (m v -> m v)
+  -> NThunkF m v
+  -> m (NThunkF m v)
+furtherThunk k t@(Thunk _ _ ref) = do
   _ <- atomicModifyVar ref $ \x -> case x of
     Computed _ -> (x, x)
     Deferred d -> (Deferred (k d), x)