Backport serializable arrow

default.nix

@@ -1,7 +1,7 @@
 { mkDerivation, aeson, annotated-exception, async, base, bytestring
-, containers, directory, ekg-core, hedgehog, hspec, hspec-hedgehog
-, katip, lens, lens-aeson, lib, network, process, stm, text, time
-, unordered-containers, uuid, websockets
+, cereal, containers, directory, ekg-core, hedgehog, hspec
+, hspec-hedgehog, katip, lens, lens-aeson, lib, network, process
+, stm, text, time, unordered-containers, uuid, websockets
 }:
 mkDerivation {
   pname = "home-assistant-controller";
@@ -10,7 +10,7 @@ mkDerivation {
   isLibrary = true;
   isExecutable = true;
   libraryHaskellDepends = [
-    aeson annotated-exception async base bytestring containers
+    aeson annotated-exception async base bytestring cereal containers
     directory ekg-core katip lens lens-aeson network process stm text
     time unordered-containers uuid websockets
   ];

home-assistant-controller.cabal

@@ -96,6 +96,7 @@ library
                     , unordered-containers
                     , process
                     , directory
+                    , cereal
 
     -- Directories containing source files.
     hs-source-dirs:   src

src/AFRP.hs

@@ -35,19 +35,59 @@ module AFRP
   , debounce
   , currentTime
   , onEvent
+  , save
+  , load
   ) where
 
 import Control.Category (Category(..), (>>>))
 import Prelude hiding ((.), id)
-import Control.Arrow (Arrow(..), ArrowChoice(..), ArrowLoop(..))
+import Control.Arrow (Arrow(..), ArrowChoice(..))
 import Data.Time (UTCTime, NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime, utcToLocalTime)
-import Control.Monad.Fix (MonadFix (mfix))
 import Data.Either (fromLeft)
 import Data.Bool (bool)
 import Data.Monoid (Endo(..))
 import Data.UUID (UUID)
 import qualified Data.Set as S
 import qualified Data.Text as T
+import Data.Serialize (Get, Putter, runPut, Serialize (put), runGet)
+import qualified Data.ByteString as B
+import Control.Exception (IOException, handle, throwIO)
+import System.IO.Error (isDoesNotExistError)
+
+
+data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) }
+
+data State s = State {state :: !s, dirty :: !Bool}
+             deriving Functor
+
+
+instance Semigroup s => Semigroup (State s) where
+  s1 <> s2 = State (state s1 <> state s2) (dirty s1 || dirty s2)
+
+instance Monoid s => Monoid (State s) where
+  mempty = State mempty False
+
+instance Applicative State where
+  pure a = State a False
+  s1 <*> s2 = State
+      { state =
+          let a = state s2
+              f = state s1
+          in f a
+      , dirty = dirty s1 || dirty s2
+      }
+
+mergeState :: State s1 -> State s2 -> State (s1, s2)
+mergeState s1 s2 = (,) <$> s1 <*> s2
+
+
+mergeCodec :: Codec s -> Codec s1 -> Codec (s, s1)
+mergeCodec (Codec agetter aputter) (Codec bgetter bputter) = Codec (mergeGet agetter bgetter) (mergePut aputter bputter)
+  where
+    mergePut :: Putter s -> Putter s1 -> Putter (s, s1)
+    mergePut p1 p2 (s, s1) = p1 s >> p2 s1
+    mergeGet :: Get s -> Get s' -> Get (s, s')
+    mergeGet g1 g2 = (,) <$> g1 <*> g2
 
 data Pair a b = Pair !a !b
 
@@ -57,12 +97,150 @@ data Request = Request
   , requestTraceId :: !UUID
   } deriving (Show, Eq)
 
+
+data Auto m a b
+  = Fun (a -> b) -- Stateless variant, needed at least for 'id'
+  | forall s. Stateful !(Codec s) !(State s) !(State s -> a -> m (b, State s))  -- State is explicitly part of it
+
+
+instance Monad m => Functor (Auto m a) where
+  fmap f = \case
+    Fun x -> Fun $ f . x
+    Stateful codec s x -> Stateful codec s $ \s' a -> do
+      (a',s'') <- x s' a
+      pure (f a', s'')
+
+instance Monad m => Applicative (Auto m a) where
+  pure a = Fun (const a)
+  fa <*> fb =
+    case (fa,fb) of
+         (Fun af, Fun bf) -> Fun (af <*> bf)
+         (Stateful codec s af, Fun bf) -> Stateful codec s
+          (\s' x -> do
+           let a = bf x
+           (h, s'') <- af s' x
+           pure (h a, s'')
+          )
+         (Fun af, Stateful codec s bf) -> Stateful codec s
+          (\s' x -> do
+           (a, s'') <- bf s' x
+           let h = af x
+           pure (h a, s'')
+          )
+         (Stateful acodec as af, Stateful bcodec bs bf) -> Stateful (mergeCodec acodec bcodec) (mergeState as bs)
+          (\s' x -> do
+           (a, as') <- bf (snd <$> s') x
+           (h, bs') <- af (fst <$> s') x
+           pure (h a, mergeState bs' as')
+          )
+
+
+instance (Monad m, Semigroup b) => Semigroup (Auto m a b) where
+  fa <> fb =
+    case (fa,fb) of
+         (Fun af, Fun bf) -> Fun (af <> bf)
+         (Stateful codec s af, Fun bf) -> Stateful codec s
+           (\s' a -> do
+            (ab, s'') <- af s' a
+            let bb = bf a
+            pure (ab <> bb, s'')
+           )
+         (Fun af, Stateful codec s bf) -> Stateful codec s
+           (\s' a -> do
+            let ab = af a
+            (bb, s'') <- bf s' a
+            pure (ab <> bb, s'')
+           )
+         (Stateful acodec as af , Stateful bcodec bs bf) -> Stateful (mergeCodec acodec bcodec) (mergeState as bs)
+           (\s a -> do
+            (ab, as'') <- af (fst <$> s) a
+            (bb, bs'') <- bf (snd <$> s) a
+            pure (ab <> bb, mergeState as'' bs'')
+           )
+
+
+instance Monad m => Category (Auto m) where
+  id = Fun id
+  af . ag =
+    case (af, ag) of
+         (Fun f, Fun g) -> Fun (f . g)
+         (Stateful codec s f, Fun g) -> Stateful codec s (\s' -> f s' . g)
+         (Fun f, Stateful codec s g) -> Stateful codec s (\s' -> fmap (first f) . g s')
+         (Stateful fcodec fs f , Stateful gcodec gs g) ->
+           Stateful (mergeCodec fcodec gcodec) (mergeState fs gs) (\s a -> do
+                       (b, s') <- g (snd <$> s) a
+                       (c, s'') <- f (fst <$> s) b
+                       pure (c, mergeState s'' s'))
+
+
+
+instance Monad m => Arrow (Auto m) where
+  arr = Fun
+  first = \case
+    Fun f -> Fun $ first f
+    Stateful codec s f -> Stateful codec s $ \s' (b,d) -> do
+      (c, s'') <- f s' b
+      pure ((c,d), s'')
+
+instance Monad m => ArrowChoice (Auto m) where
+  left = \case
+    Fun f -> Fun $
+      \case
+        Left b -> Left $ f b
+        Right d -> Right d
+    Stateful codec s f -> Stateful codec s $ \s' -> \case
+      Right d -> pure (Right d, s')
+      Left b -> do
+        (c, s'') <- f s' b
+        pure (Left c, s'')
+
+serialize :: Auto m a b -> B.ByteString
+serialize = \case
+  Fun _ -> runPut $ put ()
+  Stateful Codec{putter} s _ -> runPut $ putter (state s)
+
+data DecodedAuto m a b
+  = Decoded (Auto m a b) -- decoded from serialized state
+  | FailDecode String (Auto m a b) -- gives back the original + errmsg
+
+deserialize :: B.ByteString -> Auto m a b -> DecodedAuto m a b
+deserialize bs = \case
+  Fun f -> Decoded (Fun f) -- no state to decode, success by default
+  Stateful codec s f ->
+    either
+      (\err -> FailDecode err (Stateful codec s f))
+      (\s' -> Decoded $ Stateful codec (pure s') f)
+      $ runGet (getter codec) bs
+
+save :: FilePath -> Auto m a b -> IO (Auto m a b)
+save path s
+  | isDirty s = do
+    _ <- B.writeFile path $ serialize s
+    pure $ cleanDirty s
+  | otherwise = pure s
+  where
+    cleanDirty :: Auto m a b -> Auto m a b
+    cleanDirty (Stateful codec s' f) = Stateful codec s'{dirty=False} f
+    cleanDirty a = a
+    isDirty :: Auto m a b -> Bool
+    isDirty (Stateful _ s' _) = dirty s'
+    isDirty _ = False
+
+
+load :: forall m a b. FilePath -> Auto m a b -> IO (DecodedAuto m a b)
+load path a = handle defaultOnMissingFile (flip deserialize a <$> B.readFile path)
+  where
+    defaultOnMissingFile :: IOException -> IO (DecodedAuto m a b)
+    defaultOnMissingFile e
+      | isDoesNotExistError e = pure $ FailDecode "State doesn't exist eyt" a
+      | otherwise = throwIO e
+
 -- | The set of entity ids an arrow subscribes to. Static: it does not
 -- change as the machine steps, so the runtime can read it once to build
 -- trigger subscriptions.
 data Mealy eff a b = Mealy
   { entities :: S.Set T.Text
-  , runMealy :: forall m. MonadFix m => (forall x. eff x -> m x) -> Request -> a -> m (Pair b (Mealy eff a b))
+  , runMealy :: forall m. Monad m => (forall x. eff x -> m x) -> Request -> a -> m (Pair b (Mealy eff a b))
   }