purescript(reverse-state): feat: working reverse state

Signed-off-by: prescientmoon <git@moonythm.dev>

purescript/reverse-state/src/BackwardsState.purs

@@ -0,0 +1,51 @@
+module BackwardsState where
+
+import Prelude
+import Control.MonadFix (class MonadFix, mfix)
+import Data.Lazy (Lazy, force)
+import Data.Lazy as Lazy
+import Data.Newtype as Newtype
+import Data.Profunctor.Strong (first)
+import Data.Tuple (Tuple(..))
+
+newtype BackwardsState s m a
+  = BackwardsState (Lazy s -> m (Tuple a (Lazy s)))
+
+runBackwardsState :: forall s m a. Functor m => BackwardsState s m a -> Lazy s -> m (Tuple a s)
+runBackwardsState (BackwardsState run) s = run s <#> map force
+
+put :: forall s m. Monad m => s -> BackwardsState s m Unit
+put s = BackwardsState \old -> pure $ Tuple unit (pure s)
+
+putLazy :: forall s m. Monad m => Lazy s -> BackwardsState s m Unit
+putLazy s = BackwardsState \old -> pure $ Tuple unit s
+
+get :: forall m s. Monad m => BackwardsState s m (Lazy s)
+get = BackwardsState \s -> pure $ Tuple s s
+
+modify :: forall m s. Monad m => (s -> s) -> BackwardsState s m Unit
+modify f = BackwardsState \s -> pure $ Tuple unit (f <$> s)
+
+derive instance newtypeBackwardsState :: Newtype.Newtype (BackwardsState s m a) _
+
+instance functorBS ∷ Functor m => Functor (BackwardsState s m) where
+  map = first >>> map >>> compose >>> Newtype.over BackwardsState
+
+instance applicativeBackwardsState :: MonadFix m => Applicative (BackwardsState s m) where
+  pure a = BackwardsState (\s -> pure $ Tuple a s)
+
+instance applyBackwardsState :: MonadFix m => Apply (BackwardsState s m) where
+  apply = ap
+
+instance bindBackwardsState :: MonadFix m => Bind (BackwardsState s m) where
+  bind (BackwardsState run) f =
+    BackwardsState \state ->
+      _.results
+        <$> mfix \lazy -> do
+            (Tuple presentValue presentState) <-
+              run
+                $ Lazy.defer \_ -> force $ _.future $ lazy unit
+            (Tuple futureValue futureState) <- Newtype.unwrap (f presentValue) state
+            pure { results: Tuple futureValue presentState, future: futureState }
+
+instance monadBackwardsState :: MonadFix m => Monad (BackwardsState s m)

purescript/reverse-state/src/Control/MonadFix.js

@@ -0,0 +1,33 @@
+/* global exports, require */
+"use strict";
+
+//////////////////////////////////////////////////////////////////
+// ATTRIBUTION
+// monad-fix package is not on pursuit, so copied this file from -
+// https://github.com/zrho/purescript-monad-fix/
+//////////////////////////////////////////////////////////////////
+
+// module Control.MonadFix
+
+var message = "Control.MonadFix: Premature access to result of fixpoint computation."
+
+// fixEffect :: forall eff a. ((Unit -> a) -> Eff eff a) -> Eff eff a
+exports.fixEffect = function(f) {
+    return function() {
+        var result = null;
+        var ready = false;
+
+        result = f(function(u) {
+            if (!ready) throw new Error(message);
+            return result;
+        })();
+
+        ready = true;
+        return result;
+    }
+}
+
+// fixPure :: forall a. ((Unit -> a) -> a) -> a
+exports.fixPure = function(f) {
+    return exports.fixEffect(function(a) { return function () { return f(a); }})();
+}

purescript/reverse-state/src/Control/MonadFix.purs

@@ -0,0 +1,50 @@
+module Control.MonadFix where
+
+------------------------------------------------------------------
+-- ATTRIBUTION
+-- monad-fix package is not on pursuit, so copied this file from -
+-- https://github.com/zrho/purescript-monad-fix/
+------------------------------------------------------------------
+
+import Prelude
+
+import Control.Monad.RWS.Trans (RWST(..), RWSResult(..), runRWST)
+import Control.Monad.Reader.Trans (ReaderT(..), runReaderT)
+import Control.Monad.State.Trans (StateT(..), runStateT)
+import Control.Monad.Writer.Trans (WriterT(..), runWriterT)
+import Data.Identity (Identity(..))
+import Data.Newtype (unwrap)
+import Data.Tuple (fst)
+import Effect (Effect)
+
+foreign import fixEffect :: forall a. ((Unit -> a) -> Effect a) -> Effect a
+foreign import fixPure :: forall a. ((Unit -> a) -> a) -> a
+
+-- | Type class for monads that support fixpoints.
+-- |
+-- | `mfix f` runs `f` once with the eventual result of `f` as input. Make sure
+-- | not to apply the supplied function until the computation returned; else
+-- | a dynamic error will be thrown.
+class (Monad m) <= MonadFix m where
+  mfix :: forall a. ((Unit -> a) -> m a) -> m a
+
+instance monadFixRWST :: (Monoid w, MonadFix m) => MonadFix (RWST r w s m) where
+  mfix f = RWST \r s -> mfix \t -> runRWST (f \u -> case t u of RWSResult _ a _ -> a) r s
+
+instance monadFixIdentity :: MonadFix Identity where
+  mfix = Identity <<< fixPure <<< (unwrap <<< _)
+
+instance monadFixEff :: MonadFix Effect where
+  mfix = fixEffect
+
+instance monadFixFunction :: MonadFix (Function r) where
+  mfix f r = fixPure (flip f r)
+
+instance monadFixReaderT :: (MonadFix m) => MonadFix (ReaderT r m) where
+  mfix f = ReaderT \r -> mfix (flip runReaderT r <<< f)
+
+instance monadFixStateT :: (MonadFix m) => MonadFix (StateT s m) where
+  mfix f = StateT \s -> mfix (flip runStateT s <<< f <<< (fst <<< _))
+
+instance monadFixWriterT :: (MonadFix m, Monoid w) => MonadFix (WriterT w m) where
+  mfix f = WriterT $ mfix (runWriterT <<< f <<< (fst <<< _))

purescript/reverse-state/src/Fix.purs

@@ -1,120 +0,0 @@
-module Fix where
-
-import Prelude
-import Control.Lazy (fix)
-import Data.Either (Either(..))
-import Data.Lazy (defer)
-import Data.Lazy as Lazy
-import Data.Symbol (class IsSymbol)
-import Data.Traversable (sequence)
-import Data.Tuple (Tuple)
-import Prim.Row as Row
-import Run (FProxy, Run, SProxy(..), VariantF)
-import Run as Run
-import Undefined (undefined)
-
-data BackwardsState s a
-  = BackwardsState (s -> s) (s -> a)
-
-derive instance functorBS ∷ Functor (BackwardsState s)
-
-type BACKWARDS_STATE s
-  = FProxy (BackwardsState s)
-
-_backwardsState ∷ SProxy "backwardsState"
-_backwardsState = SProxy
-
-liftBackwardsState ∷ forall s a r. BackwardsState s a → Run ( backwardsState ∷ BACKWARDS_STATE s | r ) a
-liftBackwardsState = liftBackwardsStateAt _backwardsState
-
-liftBackwardsStateAt ∷
-  forall t state a r label.
-  IsSymbol label ⇒
-  Row.Cons label (BACKWARDS_STATE state) t r ⇒
-  SProxy label →
-  BackwardsState state a →
-  Run r a
-liftBackwardsStateAt = Run.lift
-
-runBackwardsStateAt ::
-  forall label state rowWithState row a.
-  IsSymbol label ⇒
-  Row.Cons label (BACKWARDS_STATE state) row rowWithState ⇒
-  SProxy label →
-  state →
-  Run rowWithState a →
-  Run row (Tuple state a)
-runBackwardsStateAt sym = undefined
-  where
-  handle ::
-    forall b.
-    VariantF rowWithState
-      (Run rowWithState b) ->
-    Either (BackwardsState state (Run rowWithState b)) (VariantF row (Run rowWithState b))
-  handle = Run.on sym Left Right
-
-  mkLoop ::
-    forall result acc b.
-    ( acc ->
-      (BackwardsState state (Run rowWithState b)) ->
-      Run row result
-    ) ->
-    (acc -> b -> result) -> acc -> Run rowWithState b -> Run row result
-  mkLoop handleState handleResult accumulated r = case Run.peel r of
-    Left peeled → case handle peeled of
-      Left bs → handleState accumulated bs
-      Right a' → Run.send a' >>= mkLoop handleState handleResult accumulated
-    Right result → pure $ handleResult accumulated result
-
-  loopState :: Lazy.Lazy state -> Run rowWithState Unit -> Run row (Lazy.Lazy state)
-  loopState = mkLoop handleState handleResult
-    where
-    {-
-        past = ...
-        present <- mkState future
-        future <- mkState past
-    -}
-    handleState :: state -> BackwardsState state (Run rowWithState Unit) -> Run row (Lazy.Lazy state)
-    handleState state (BackwardsState mkState mkValue) =
-      sequence do
-        (futureState :: Run _ _) <-
-          fix \m -> do
-            (futureState :: Run _ _) <- m
-            let
-              value :: Run _ _
-              value = mkValue <$> futureState
-
-              state' :: Run _ (Lazy.Lazy state)
-              state' = value >>= loopState state
-            pure
-            state'
-        pure (mkState <$> futureState)
-
-    handleResult = const
-
-  --     case Run.peel r of
-  --   Left a → case handle a of
-  --     Left (BackwardsState mkState _) → do
-  --       resultState <- loopState state
-  --       pure (mkState futureState)
-  --     Right a' → b >>= f
-  --       where
-  --       f = runBackwardsStateAt sym s
-  --       b = Run.send a'
-  --   Right a → pure (Tuple s a)
-  --   loop :: state -> Run rowWithState a -> Run row (Tuple state a)
-  --   loop s r = case Run.peel r of
-  --     Left a → case handle a of
-  --       Left (BackwardsState mkState mkValue) → do
-  --         let
-  --           value = mkValue resultState
-  --         (Tuple resultState resultValue) <- loop s value
-  --         pure $ Tuple (mkState futureState) resultValue
-  --       Right a' → b >>= f
-  --         where
-  --         f :: Run rowWithState a -> Run row (Tuple state a)
-  --         f = runBackwardsStateAt sym s
-  --         b :: Run row (Run rowWithState a)
-  --         b = Run.send a'
-  --     Right a → pure (Tuple s a)
-  a = 3

purescript/reverse-state/src/Main.purs

@@ -1,10 +1,30 @@
 module Main where
 
 import Prelude
-
+import BackwardsState (BackwardsState, get, modify, put, runBackwardsState)
+import Control.Monad.Reader (Reader, runReader)
+import Data.Lazy (Lazy, force)
+import Data.Tuple (fst, snd)
 import Effect (Effect)
+import Effect.Class.Console (logShow)
 import Effect.Console (log)
 
+type LabM a
+  = BackwardsState Int (Reader String) (Lazy a)
+
+state :: LabM Int
+state = do
+  future <- get -- 4
+  modify \a -> a * 2
+  future' <- get -- 2
+  put 2
+  pure future
+
 main :: Effect Unit
 main = do
-  log "🍝"
+  let
+    r = flip runReader "env" $ runBackwardsState state $ pure 0
+  log "State:"
+  logShow (snd r)
+  log "Result:"
+  logShow (force $ fst r)