diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,7 @@ +# changelog + +## 0.1 + +2019-03-19 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2019, Commonwealth Scientific and Industrial Research Organisation +(CSIRO) ABN 41 687 119 230. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Data61 nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Counter.hs b/example/Counter.hs new file mode 100644 --- /dev/null +++ b/example/Counter.hs @@ -0,0 +1,26 @@ +{-# language FlexibleContexts, TypeFamilies #-} +module Main where + +import Reflex +import Reflex.Host.Basic + +import Control.Concurrent (threadDelay) +import Control.Monad.Fix (MonadFix) +import Control.Monad.IO.Class (liftIO) + +myNetwork :: (Reflex t, MonadHold t m, MonadFix m) => Event t () -> m (Dynamic t Int) +myNetwork eTick = count eTick + +myGuest :: BasicGuestConstraints t m => BasicGuest t m ((), Event t ()) +myGuest = do + (eTick, sendTick) <- newTriggerEvent + dCount <- myNetwork eTick + let + eCountUpdated = updated dCount + eQuit = () <$ ffilter (==5) eCountUpdated + repeatUntilQuit (threadDelay 1000000 *> sendTick ()) eQuit + performEvent_ $ liftIO . print <$> eCountUpdated + pure ((), eQuit) + +main :: IO () +main = basicHostWithQuit myGuest diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE RecursiveDo #-} +module Main ( + main + ) where + +import Control.Monad (void) +import Control.Monad.Trans (liftIO) + +import Reflex + +import Reflex.Host.Basic + +main :: IO () +main = basicHostWithQuit $ mdo + ePostBuild <- getPostBuild + eLine <- performEventAsync $ (\fn -> liftIO $ fn =<< getLine) <$ leftmost [void eMessage, ePostBuild] + + let + eMessage = ffilter (/= "quit") eLine + eQuit = void . ffilter (== "quit") $ eLine + + performEvent_ $ liftIO . putStrLn <$> eMessage + + pure ((), eQuit) diff --git a/reflex-basic-host.cabal b/reflex-basic-host.cabal new file mode 100644 --- /dev/null +++ b/reflex-basic-host.cabal @@ -0,0 +1,55 @@ +name: reflex-basic-host +version: 0.1 +license: BSD3 +license-file: LICENSE +author: Dave Laing +maintainer: dave.laing.80@gmail.com +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 +category: FRP +synopsis: A basic `reflex` host for backend work +description: A basic `reflex` host for backend work. + +tested-with: GHC == 8.0.2 + , GHC == 8.2.2 + , GHC == 8.4.4 + , GHC == 8.6.4 + +source-repository head + type: git + location: git@github.com/qfpl/reflex-basic-host.git + +library + exposed-modules: Reflex.Host.Basic + build-depends: base >=4.9 && <4.13 + , primitive >= 0.6 && < 0.7 + , ref-tf >= 0.4 && < 0.5 + , dependent-sum >= 0.4 && < 0.5 + , dependent-map >= 0.2 && < 0.3 + , mtl >= 2.2 && < 2.3 + , stm >= 2.4 && < 2.6 + , reflex >= 0.5 && < 0.6 + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 + +executable example + main-is: Main.hs + build-depends: base >=4.9 && <4.13 + , mtl >= 2.2 && < 2.3 + , reflex >= 0.5 && < 0.6 + , reflex-basic-host + hs-source-dirs: example + ghc-options: -Wall + default-language: Haskell2010 + +executable counter + main-is: Counter.hs + build-depends: base >=4.9 && <4.13 + , mtl >= 2.2 && < 2.3 + , reflex >= 0.5 && < 0.6 + , reflex-basic-host + hs-source-dirs: example + ghc-options: -Wall + default-language: Haskell2010 diff --git a/src/Reflex/Host/Basic.hs b/src/Reflex/Host/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Host/Basic.hs @@ -0,0 +1,236 @@ +{-| +Module : Reflex.Host.Basic +Copyright : (c) 2019 Commonwealth Scientific and Industrial Research Organisation (CSIRO) +License : BSD-3 +Maintainer : dave.laing.80@gmail.com + +'BasicGuest' provides instances that most `reflex` programs need: + +* 'MonadIO' +* 'MonadFix' +* 'MonadSample' +* 'MonadHold' +* 'NotReady' +* 'PostBuild' +* 'PerformEvent' — @'Performable' ('BasicGuest' t m)@ has 'MonadIO' +* 'TriggerEvent' +* 'Adjustable' + +For some simple usage examples, see + + +-} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} +module Reflex.Host.Basic ( + BasicGuest + , BasicGuestConstraints + , basicHostWithQuit + , basicHostForever + , repeatUntilQuit + ) where + +import Control.Monad (void, when, unless, forM_, forM) +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan (newChan, readChan) +import Data.Functor.Identity (Identity(..)) +import Data.Maybe (catMaybes, isJust) + +import Control.Monad.Trans (MonadIO(..), MonadTrans(..)) +import Control.Monad.Primitive (PrimMonad) +import Control.Monad.Ref (MonadRef(..)) +import Control.Monad.Fix (MonadFix) +import Data.IORef (newIORef, readIORef, writeIORef) + +import Control.Monad.STM (atomically) +import Control.Concurrent.STM.TVar (newTVar, writeTVar, readTVar) +import Control.Concurrent.STM.TMVar (newEmptyTMVar, takeTMVar, putTMVar) + +import Data.Dependent.Sum +import Reflex +import Reflex.Host.Class +import Reflex.NotReady.Class + +type BasicGuestConstraints t (m :: * -> *) = + ( MonadReflexHost t m + , MonadHold t m + , MonadSample t m + , Ref m ~ Ref IO + , MonadRef (HostFrame t) + , Ref (HostFrame t) ~ Ref IO + , MonadIO (HostFrame t) + , PrimMonad (HostFrame t) + , MonadIO m + , MonadFix m + ) + +newtype BasicGuest t (m :: * -> *) a = + BasicGuest { + unBasicGuest :: PostBuildT t (TriggerEventT t (PerformEventT t m)) a + } deriving (Functor, Applicative, Monad, MonadFix) + +instance (MonadIO m, ReflexHost t, MonadIO (HostFrame t)) => MonadIO (BasicGuest t m) where + liftIO = BasicGuest . liftIO + +instance ReflexHost t => MonadSample t (BasicGuest t m) where + {-# INLINABLE sample #-} + sample = BasicGuest . lift . sample + +instance (ReflexHost t, MonadHold t m) => MonadHold t (BasicGuest t m) where + {-# INLINABLE hold #-} + hold v0 = BasicGuest . lift . hold v0 + {-# INLINABLE holdDyn #-} + holdDyn v0 = BasicGuest . lift . holdDyn v0 + {-# INLINABLE holdIncremental #-} + holdIncremental v0 = BasicGuest . lift . holdIncremental v0 + {-# INLINABLE buildDynamic #-} + buildDynamic a0 = BasicGuest . lift . buildDynamic a0 + {-# INLINABLE headE #-} + headE = BasicGuest . lift . headE + +instance (Reflex t, ReflexHost t) => PostBuild t (BasicGuest t m) where + {-# INLINABLE getPostBuild #-} + getPostBuild = BasicGuest getPostBuild + +instance (Reflex t, ReflexHost t, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO) => TriggerEvent t (BasicGuest t m) where + {-# INLINABLE newTriggerEvent #-} + newTriggerEvent = BasicGuest $ lift newTriggerEvent + {-# INLINABLE newTriggerEventWithOnComplete #-} + newTriggerEventWithOnComplete = BasicGuest $ lift newTriggerEventWithOnComplete + {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-} + newEventWithLazyTriggerWithOnComplete = BasicGuest . lift . newEventWithLazyTriggerWithOnComplete + +instance (Reflex t, ReflexHost t, Ref m ~ Ref IO, MonadRef (HostFrame t), Ref (HostFrame t) ~ Ref IO, MonadIO (HostFrame t), PrimMonad (HostFrame t), MonadIO m) => PerformEvent t (BasicGuest t m) where + type Performable (BasicGuest t m) = HostFrame t + {-# INLINABLE performEvent_ #-} + performEvent_ = BasicGuest . lift . lift . performEvent_ + {-# INLINABLE performEvent #-} + performEvent = BasicGuest . lift . lift . performEvent + +instance (Reflex t, ReflexHost t, Ref m ~ Ref IO, MonadHold t m, PrimMonad (HostFrame t)) => Adjustable t (BasicGuest t m) where + {-# INLINABLE runWithReplace #-} + runWithReplace a0 a' = + BasicGuest $ runWithReplace (unBasicGuest a0) (fmap unBasicGuest a') + {-# INLINABLE traverseIntMapWithKeyWithAdjust #-} + traverseIntMapWithKeyWithAdjust f dm0 dm' = do + BasicGuest $ traverseIntMapWithKeyWithAdjust (\k v -> unBasicGuest (f k v)) dm0 dm' + {-# INLINABLE traverseDMapWithKeyWithAdjust #-} + traverseDMapWithKeyWithAdjust f dm0 dm' = do + BasicGuest $ traverseDMapWithKeyWithAdjust (\k v -> unBasicGuest (f k v)) dm0 dm' + {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-} + traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do + BasicGuest $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unBasicGuest (f k v)) dm0 dm' + + +instance (ReflexHost t) => NotReady t (BasicGuest t m) where + {-# INLINABLE notReadyUntil #-} + notReadyUntil _ = pure () + {-# INLINABLE notReady #-} + notReady = pure () + +-- | Run a 'BasicGuest' without a quit 'Event' +basicHostForever :: (forall t m. BasicGuestConstraints t m => BasicGuest t m a) + -> IO a +basicHostForever guest = basicHostWithQuit $ (\x -> (x, never)) <$> guest + +-- | Run a 'BasicGuest' +-- +-- The program will exit when the 'Event' returned by the 'BasicGuest' fires +basicHostWithQuit :: (forall t m. BasicGuestConstraints t m => BasicGuest t m (a, Event t ())) + -> IO a +basicHostWithQuit (BasicGuest guest) = do + events <- liftIO newChan + + rHasQuit <- liftIO $ newIORef False + + ((a, eQuit), FireCommand fire) <- liftIO $ runSpiderHost $ do + (((a, eQuit), postBuildTriggerRef), fc@(FireCommand fire)) <- hostPerformEventT $ do + (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef + pae <- runTriggerEventT (runPostBuildT guest postBuild) events + pure (pae, postBuildTriggerRef) + + hQuit <- subscribeEvent eQuit + + mPostBuildTrigger <- readRef postBuildTriggerRef + forM_ mPostBuildTrigger $ \postBuildTrigger -> do + lmQuit <- fire [postBuildTrigger :=> Identity ()] $ readEvent hQuit >>= sequence + when (any isJust lmQuit) $ + liftIO $ writeIORef rHasQuit True + + pure ((a, eQuit), fc) + + done <- liftIO . atomically $ newEmptyTMVar + let + loop = do + hasQuit <- liftIO $ readIORef rHasQuit + if hasQuit + then liftIO . atomically $ putTMVar done () + else do + ers <- readChan events + _ <- runSpiderHost $ do + hQuit <- subscribeEvent eQuit + mes <- liftIO $ forM ers $ \(EventTriggerRef er :=> TriggerInvocation x _) -> + fmap (\e -> e :=> Identity x) <$> readIORef er + + lmQuit <- fire (catMaybes mes) $ readEvent hQuit >>= sequence + when (any isJust lmQuit) $ + liftIO $ writeIORef rHasQuit True + + liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb + loop + + void . liftIO . forkIO $ loop + void . liftIO . atomically . takeTMVar $ done + + pure a + +-- | Augment a 'BasicGuest' with an action that is repeatedly run until +-- the provided event fires +-- +-- Example - providing a \'tick\' 'Event' to a network +-- +-- @ +-- myNetwork :: (Reflex t, MonadHold t m, MonadFix m) => Event t () -> m (Dynamic t Int) +-- myNetwork eTick = count eTick +-- +-- myGuest :: BasicGuestConstraints t m => BasicGuest t m ((), Event t ()) +-- myGuest = do +-- (eTick, sendTick) <- newTriggerEvent +-- dCount <- myNetwork eTick +-- let +-- eCountUpdated = updated dCount +-- eQuit = () <$ ffilter (==5) eCountUpdated +-- repeatUntilQuit eQuit (threadDelay 1000000 *> sendTick ()) +-- performEvent_ $ liftIO . print \<$\> eCountUpdated +-- pure ((), eQuit) +-- +-- main :: IO () +-- main = basicHostWithQuit myGuest +-- @ +repeatUntilQuit :: BasicGuestConstraints t m + => IO a -- ^ Action to repeatedly run + -> Event t () -- ^ 'Event' to stop the action + -> BasicGuest t m () +repeatUntilQuit act eQuit = do + ePostBuild <- getPostBuild + tHasQuit <- liftIO . atomically $ newTVar False + + let + loop = do + hasQuit <- liftIO . atomically $ readTVar tHasQuit + unless hasQuit $ do + void act + loop + + performEvent_ $ liftIO (void . forkIO $ loop) <$ ePostBuild + performEvent_ $ liftIO (atomically $ writeTVar tHasQuit True) <$ eQuit + + pure ()