reflex-basic-host (empty) → 0.1

raw patch · 7 files changed

+381/−0 lines, 7 filesdep +basedep +dependent-mapdep +dependent-sumsetup-changed

Dependencies added: base, dependent-map, dependent-sum, mtl, primitive, ref-tf, reflex, reflex-basic-host, stm

Files

ChangeLog.md +7/−0
LICENSE +31/−0
Setup.hs +2/−0
example/Counter.hs +26/−0
example/Main.hs +24/−0
reflex-basic-host.cabal +55/−0
src/Reflex/Host/Basic.hs +236/−0

+ ChangeLog.md view

@@ -0,0 +1,7 @@+# changelog++## 0.1++2019-03-19++* Initial release

+ LICENSE view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ example/Counter.hs view

@@ -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

+ example/Main.hs view

@@ -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)

+ reflex-basic-host.cabal view

@@ -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

+ src/Reflex/Host/Basic.hs view

@@ -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+<https://github.com/qfpl/reflex-basic-host/tree/master/example the examples directory>++-}++{-# 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 ()