Control the kitchen lights
This commit is contained in:
+56
-16
@@ -4,6 +4,7 @@
|
||||
module AFRP
|
||||
( Mealy(..)
|
||||
, Auto(..)
|
||||
, DecodedAuto(..)
|
||||
, eff
|
||||
, withEntities
|
||||
, Event(..)
|
||||
@@ -24,7 +25,9 @@ module AFRP
|
||||
, Pair(..)
|
||||
, Request(..)
|
||||
, SerializeUTCTime(..)
|
||||
, SerializeLocalTime(..)
|
||||
, edge
|
||||
, waitFor
|
||||
, duration
|
||||
, tag
|
||||
, isEvent
|
||||
@@ -44,13 +47,13 @@ module AFRP
|
||||
import Control.Category (Category(..), (>>>))
|
||||
import Prelude hiding ((.), id)
|
||||
import Control.Arrow (Arrow(..), ArrowChoice(..))
|
||||
import Data.Time (UTCTime (UTCTime), NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime, utcToLocalTime, Day (..), diffTimeToPicoseconds, picosecondsToDiffTime)
|
||||
import Data.Time (UTCTime (UTCTime), NominalDiffTime, diffUTCTime, addUTCTime, TimeZone, LocalTime (LocalTime), utcToLocalTime, Day (..), diffTimeToPicoseconds, picosecondsToDiffTime, TimeOfDay (TimeOfDay), diffLocalTime)
|
||||
import Data.Either (fromLeft)
|
||||
import Data.Bool (bool)
|
||||
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, get)
|
||||
import Data.Serialize (Get, Putter, Serialize (put), runGet, get)
|
||||
import qualified Data.ByteString as B
|
||||
import Control.Exception (IOException, handle, throwIO)
|
||||
import System.IO.Error (isDoesNotExistError)
|
||||
@@ -58,6 +61,9 @@ import GHC.Generics (Generic)
|
||||
import Data.Sequence (Seq, (|>))
|
||||
import qualified Data.Foldable as F
|
||||
import Control.Monad.IO.Class (MonadIO, liftIO)
|
||||
import Conduit (ConduitT, (.|))
|
||||
import qualified Data.Conduit.Cereal as CC
|
||||
import qualified Conduit as C
|
||||
|
||||
|
||||
data Codec s = Codec { getter :: !(Get s), putter :: !(Putter s) }
|
||||
@@ -203,10 +209,11 @@ instance Monad m => ArrowChoice (Auto m) where
|
||||
(c, s'') <- f s' req b
|
||||
pure (Left c, s'')
|
||||
|
||||
serialize :: Auto m a b -> B.ByteString
|
||||
|
||||
serialize :: Monad m => Auto eff a b -> ConduitT i B.ByteString m ()
|
||||
serialize = \case
|
||||
Fun _ -> runPut $ put ()
|
||||
Stateful Codec{putter} s _ -> runPut $ putter (state s)
|
||||
Fun _ -> CC.sourcePut (put ())
|
||||
Stateful Codec{putter} s _ -> CC.sourcePut (putter (state s))
|
||||
|
||||
data DecodedAuto m a b
|
||||
= Decoded (Auto m a b) -- decoded from serialized state
|
||||
@@ -221,10 +228,12 @@ deserialize bs = \case
|
||||
(\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
|
||||
-- Using conduit machinery as it handles the exception handling for me
|
||||
() <- C.runResourceT $ C.runConduit (serialize s .| C.sinkFileCautious path)
|
||||
pure $ cleanDirty s
|
||||
| otherwise = pure s
|
||||
where
|
||||
@@ -241,7 +250,7 @@ load path a = handle defaultOnMissingFile (flip deserialize a <$> B.readFile pat
|
||||
where
|
||||
defaultOnMissingFile :: IOException -> IO (DecodedAuto m a b)
|
||||
defaultOnMissingFile e
|
||||
| isDoesNotExistError e = pure $ FailDecode "State doesn't exist eyt" a
|
||||
| isDoesNotExistError e = pure $ FailDecode "State doesn't exist yet" a
|
||||
| otherwise = throwIO e
|
||||
|
||||
-- | The set of entity ids an arrow subscribes to. Static: it does not
|
||||
@@ -316,11 +325,6 @@ hold def = mapAccum step def id
|
||||
Event new -> new
|
||||
|
||||
|
||||
-- hold :: a -> Mealy eff (Event a) a
|
||||
-- hold a = Mealy mempty $ \_ _ -> \case
|
||||
-- Tick -> pure (Pair a (hold a))
|
||||
-- Event a' -> pure (Pair a' (hold a'))
|
||||
|
||||
events :: Mealy eff (Event a) (Either () a)
|
||||
events = arr $ \case
|
||||
Tick -> Left ()
|
||||
@@ -345,7 +349,7 @@ sample = arr (uncurry tag)
|
||||
|
||||
|
||||
preMapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b
|
||||
preMapAccum' f x extract = Stateful (Codec get put) (State x False) (\s _req a -> pure $ step s a)
|
||||
preMapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ step s a)
|
||||
where
|
||||
step :: State x -> a -> (b, State x)
|
||||
step s a = let s' = f (state s) a in (extract (state s), State s' (dirty s || state s /= s'))
|
||||
@@ -358,7 +362,7 @@ preMapAccum :: (Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Mealy ef
|
||||
preMapAccum step x extract = Mealy mempty $ \_nt -> preMapAccum' step x extract
|
||||
|
||||
mapAccum' :: forall m x a b. (Monad m, Eq x, Serialize x) => (x -> a -> x) -> x -> (x -> b) -> Auto m a b
|
||||
mapAccum' f x extract = Stateful (Codec get put) (State x False) (\s _req a -> pure $ step s a)
|
||||
mapAccum' f x extract = Stateful (Codec get put) (pure x) (\s _req a -> pure $ step s a)
|
||||
where
|
||||
step :: State x -> a -> (b, State x)
|
||||
step s a = let s' = f (state s) a in (extract s', State s' (dirty s || state s /= s'))
|
||||
@@ -402,6 +406,19 @@ instance Serialize SerializeUTCTime where
|
||||
time <- picosecondsToDiffTime <$> get
|
||||
pure $ SerializeUTCTime (UTCTime day time)
|
||||
|
||||
newtype SerializeLocalTime = SerializeLocalTime LocalTime
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Serialize SerializeLocalTime where
|
||||
put (SerializeLocalTime (LocalTime day time)) = do
|
||||
put (toModifiedJulianDay day)
|
||||
let TimeOfDay h m s = time
|
||||
put (h,m, toRational s)
|
||||
get = do
|
||||
day <- ModifiedJulianDay <$> get
|
||||
(h,m,s) <- get
|
||||
pure $ SerializeLocalTime (LocalTime day (TimeOfDay h m (fromRational s)))
|
||||
|
||||
delayEvent :: (Eq a, Serialize a) => NominalDiffTime -> Mealy eff (Event a) (Event a)
|
||||
delayEvent delay =
|
||||
mapAccumRequest step initial output
|
||||
@@ -483,7 +500,28 @@ edge =
|
||||
|
||||
|
||||
|
||||
data WaitingFor
|
||||
= Waiting
|
||||
| Pending { waitingForStart :: SerializeLocalTime, waitingForCurrent :: SerializeLocalTime }
|
||||
deriving (Show, Eq, Generic)
|
||||
|
||||
instance Serialize WaitingFor
|
||||
|
||||
waitFor :: NominalDiffTime -> Mealy eff Bool (Event ())
|
||||
waitFor delta =
|
||||
mapAccumRequest step Waiting extract >>> edge
|
||||
where
|
||||
extract :: WaitingFor -> Bool
|
||||
extract Waiting = False
|
||||
extract Pending{waitingForStart=SerializeLocalTime s, waitingForCurrent=SerializeLocalTime e} =
|
||||
e `diffLocalTime` s >= delta
|
||||
step :: Request -> WaitingFor -> Bool -> WaitingFor
|
||||
step _req _prev False = Waiting
|
||||
step req prev True =
|
||||
let now = SerializeLocalTime $ requestLocalTime req
|
||||
in case prev of
|
||||
Waiting -> Pending now now
|
||||
pending -> pending{waitingForCurrent = now}
|
||||
|
||||
duration :: forall eff a. Mealy eff a NominalDiffTime
|
||||
duration = mapAccumRequest go (Nothing @(SerializeUTCTime, SerializeUTCTime)) (maybe 0 delta)
|
||||
@@ -551,10 +589,12 @@ sliding size = mapAccum go [] id
|
||||
go acc (Event a) = let xs = acc ++ [a] in drop (max 0 (length xs - size)) xs
|
||||
|
||||
|
||||
requestLocalTime :: Request -> LocalTime
|
||||
requestLocalTime Request{requestTime, requestTimeZone} = utcToLocalTime requestTimeZone requestTime
|
||||
|
||||
currentTime :: Mealy eff a LocalTime
|
||||
currentTime = Mealy mempty $ \_nt -> Fun $ \Request{requestTime, requestTimeZone} _ ->
|
||||
utcToLocalTime requestTimeZone requestTime
|
||||
currentTime = Mealy mempty $ \_nt -> Fun $ \req _ ->
|
||||
requestLocalTime req
|
||||
|
||||
|
||||
stepAuto :: Monad m => Auto m a b -> Request -> a -> m (b, Auto m a b)
|
||||
|
||||
Reference in New Issue
Block a user