reflex-dom-retractable (empty) → 0.1.0.0

raw patch · 9 files changed

+463/−0 lines, 9 filesdep +basedep +containersdep +jsaddlesetup-changed

Dependencies added: base, containers, jsaddle, mtl, reflex, reflex-dom

Files

CHANGELOG.md +4/−0
LICENSE +7/−0
README.md +37/−0
Setup.hs +2/−0
reflex-dom-retractable.cabal +44/−0
src/Reflex/Dom/Retractable.hs +17/−0
src/Reflex/Dom/Retractable/Class.hs +156/−0
src/Reflex/Dom/Retractable/Trans.hs +48/−0
src/Reflex/Dom/Retractable/Trans/Internal.hs +148/−0

+ CHANGELOG.md view

@@ -0,0 +1,4 @@+0.1.0.0+=======++* Initial release.

+ LICENSE view

@@ -0,0 +1,7 @@+Copyright 2019 Investment Solutions AG++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ README.md view

@@ -0,0 +1,37 @@+Small library that implements "back" button feature for reflex-dom widgets.+The core idea of the library is to have reusable widget that maintains history+of switches and is decoupled from actual implementation of switching widgets.++The library doesn't use platform specific parts like connection to Android+system back button or browser back button, but provides functions to bind them+into your retractable frontend.++Example of usage:++``` haskell+import Control.Monad+import Reflex.Dom+import Reflex.Dom.Retractable++main :: IO ()+main = mainWidget $ runRetract frontend++frontend :: (MonadWidget t m, MonadRetract t m) => m ()+frontend = void $ retractStack $ pageA 42++pageA :: (MonadWidget t m, MonadRetract t m) => Int -> m ()+pageA n = do+   e <- button "Go page B"+   void $ nextWidget $ ffor e $ const Retractable {+       retractableNext = pageB $ n + 1+     , retractablePrev = Just $ pure $ pageA n+     }++pageB :: (MonadWidget t m, MonadRetract t m) => Int -> m ()+pageB n = do+  e <- button "Go page A"+  void $ nextWidget $ ffor e $ const  Retractable {+       retractableNext = pageA $ n + 1+     , retractablePrev = Just $ pure $ pageB n+     }+```

+ Setup.hs view

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

+ reflex-dom-retractable.cabal view

@@ -0,0 +1,44 @@+name:                reflex-dom-retractable+version:             0.1.0.0+synopsis:            Routing and retractable back button for reflex-dom+description:         Library that automates widget switches and back button retract stack. See README.md+Stability:           Experimental+category:            Reflex, FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface+build-type:          Simple+cabal-version:       >=1.10+license:             MIT+license-file:        LICENSE+copyright:           2019 Investment Solutions AG+author:              Anton Gushcha, Aminion, Vladimir Krutkin, Levon Oganyan+maintainer:          Anton Gushcha <ncrashed@protonmail.com>, Vladimir Krutkin <krutkinvs@gmail.com>+extra-source-files:+  README.md+  CHANGELOG.md++library+  hs-source-dirs:      src+  exposed-modules:+    Reflex.Dom.Retractable+    Reflex.Dom.Retractable.Class+    Reflex.Dom.Retractable.Trans+    Reflex.Dom.Retractable.Trans.Internal+  build-depends:+      base                 >= 4.7      && < 4.12+    , containers           >= 0.5      && < 0.7+    , jsaddle              >= 0.9      && < 0.10+    , mtl                  >= 2.1      && < 2.3+    , reflex               >= 0.4      && < 0.7+    , reflex-dom           >= 0.4      && < 0.7+  default-language:    Haskell2010+  default-extensions:+    DataKinds+    DeriveGeneric+    FlexibleInstances+    GeneralizedNewtypeDeriving+    LambdaCase+    MultiParamTypeClasses+    RankNTypes+    ScopedTypeVariables+    StandaloneDeriving+    TypeFamilies+    UndecidableInstances

+ src/Reflex/Dom/Retractable.hs view

@@ -0,0 +1,17 @@+-- |+-- Module      : Reflex.Dom.Retractable+-- Copyright   : (c) 2019 Investment Solutions AG+-- License     : MIT+-- Maintainer  : ncrashed@protonmail.com+-- Stability   : unstable+-- Portability : non-portable+--+-- Small library that implements back button feature for reflex-dom widgets.+-- See "Reflex.Dom.Retractable.Trans" for usage examples.+module Reflex.Dom.Retractable(+    module Reflex.Dom.Retractable.Class+  , module Reflex.Dom.Retractable.Trans+  ) where++import Reflex.Dom.Retractable.Class+import Reflex.Dom.Retractable.Trans

+ src/Reflex/Dom/Retractable/Class.hs view

@@ -0,0 +1,156 @@+-- |+-- Module      : Reflex.Dom.Retractable.Class+-- Copyright   : (c) 2019 Investment Solutions AG+-- License     : MIT+-- Maintainer  : ncrashed@protonmail.com+-- Stability   : unstable+-- Portability : non-portable+--+-- Tagless final interface to the retractable stack of widgets. To use the API+-- drop `retractStack` into your code where you want to display widgets with+-- history. For instance, turn all your frontend into retractable widget:+--+-- @+-- import Control.Monad+-- import Reflex.Dom+-- import Reflex.Dom.Retractable.Class+--+-- frontend :: (MonadWidget t m, MonadRetract t m) => m ()+-- frontend = void $ retractStack $ pageA 42+--+-- pageA :: (MonadWidget t m, MonadRetract t m) => Int -> m ()+-- pageA n = do+--    e <- button "Go page B"+--    void $ nextWidget $ ffor e $ const Retractable {+--        retractableNext = pageB $ n + 1+--      , retractablePrev = Just $ pure $ pageA n+--      }+--+-- pageB :: (MonadWidget t m, MonadRetract t m) => Int -> m ()+-- pageB n = do+--   e <- button "Go page A"+--   void $ nextWidget $ ffor e $ const  Retractable {+--        retractableNext = pageA $ n + 1+--      , retractablePrev = Just $ pure $ pageB n+--      }+-- @+--+module Reflex.Dom.Retractable.Class(+    Retractable(..)+  , morphRetractable+  , MonadRetract(..)+  , retractStack+  ) where++import Control.Monad.Fix+import Control.Monad.Reader+import Data.Sequence (Seq)+import GHC.Generics (Generic)+import Reflex+import Reflex.Network++import qualified Data.Sequence as S++-- | Information about widget that attaches information how to return to the+-- widget.+data Retractable t m = Retractable {+  -- | Which widget we are switching in+  retractableNext :: m ()+  -- | Possible return to the current widget. 'Nothing' means that the+  -- current widget is not rembered in retract stack and is forgoten.+  -- Dynamic allows to save internal state of widget on return.+, retractablePrev :: Maybe (Dynamic t (m ()))+} deriving (Generic)++-- | Helper to transform underlying monad in `Retractable`+morphRetractable :: Reflex t => (forall a . n a -> m a) -> Retractable t n -> Retractable t m+morphRetractable f (Retractable next prev) = Retractable (f next) (fmap f <$> prev)++-- | Defines context of widget that can switch control to next widget+-- and can be returned back with preserving of state.+class (MonadHold t m, MonadFix m, Reflex t, Adjustable t m) => MonadRetract t m where+  -- | Switch current widget to the next widget. Returns event that fires+  -- when the switching is about to happen.+  nextWidget :: Event t (Retractable t m) -> m (Event t ())++  -- | Switch to previous widget in stack. Returns event that fires+  -- when the switchin is about to happen.+  retract :: Event t () -> m (Event t ())++  -- | Wipe retract history to the given amount of items (or all if `Nothing` is passed).+  -- Returns event that fires when the history was changed.+  wipeRetract :: Event t (Maybe Int) -> m (Event t ())++  -- | Get event that fires when any of input events in `nextWidget` is triggered.+  -- It's used for implementation of retractable stack.+  nextWidgetEvent :: m (Event t (Retractable t m))++  -- | Get event that fires when any of input events in `retract` is triggered.+  -- It's used for implementation of retractable stack.+  retractEvent :: m (Event t ())++  -- | Get event that fires when any of input events in `wipeRetract` is triggered.+  -- It's used for implementation of retractable stack.+  wipeRetractEvent :: m (Event t (Maybe Int))++  -- | Get current stack of widget history+  getRetractStack :: m (Dynamic t [Retractable t m])++  -- | Execute subcomputation with given widget history. Affects results of `getRetractStack`.+  withRetractStack :: Dynamic t [Retractable t m] -> m a -> m a++-- | Helper ADT to merge actions with retractable stack+data StackAction t m = StackPush (Retractable t m) | StackPop | StackWipe (Maybe Int)++-- | All body of the widget will be rerendered when some subcomputation emits switching event.+-- Plug the function somewhere close to the root of your reflex frontend and use functions from+-- `MonadRetract` class to control switching content of the widget.+retractStack :: forall t m . MonadRetract t m => m () -> m (Event t ())+retractStack ma = do+  nextE <- fmap StackPush <$> nextWidgetEvent+  backE <- fmap (const StackPop) <$> retractEvent+  wipeE <- fmap StackWipe <$> wipeRetractEvent+  let actionE = leftmost [nextE, backE, wipeE]+  let go :: StackAction t m -> [Retractable t m] -> [Retractable t m]+      go a rs = case a of+        StackPush r -> maybe rs (const $ r : rs) $ retractablePrev r+        StackPop -> drop 1 rs+        StackWipe Nothing -> []+        StackWipe (Just i) -> drop i rs+  stackD :: Dynamic t [Retractable t m] <- foldDyn go [] actionE+  resD <- withRetractStack stackD $ networkHold ma $ flip push actionE $ \case+    StackPush r -> pure . Just $ retractableNext r+    StackPop -> do+      rs <- sample . current $ stackD+      case rs of+        (r : _) | Just maD <- retractablePrev r -> fmap Just . sample . current $ maD+        _ -> pure . Just $ ma+    StackWipe _ -> pure Nothing+  pure $ updated resD++instance MonadRetract t m => MonadRetract t (ReaderT r m) where+  nextWidget e = do+    r <- ask+    lift $ nextWidget (morphRetractable (flip runReaderT r) <$> e)+  {-# INLINE nextWidget #-}+  retract = lift . retract+  {-# INLINE retract #-}+  wipeRetract = lift . wipeRetract+  {-# INLINE wipeRetract #-}+  nextWidgetEvent = do+    e <- lift nextWidgetEvent+    pure $ morphRetractable lift <$> e+  {-# INLINE nextWidgetEvent #-}+  retractEvent = lift retractEvent+  {-# INLINE retractEvent #-}+  wipeRetractEvent = lift wipeRetractEvent+  {-# INLINE wipeRetractEvent #-}+  getRetractStack = do+    st <- lift getRetractStack+    pure $ fmap (morphRetractable lift) <$> st+  {-# INLINE getRetractStack #-}+  withRetractStack st ma = do+    r <- ask+    let st' = fmap (morphRetractable (flip runReaderT r)) <$> st+    lift $ withRetractStack st' (runReaderT ma r)+  {-# INLINE withRetractStack #-}

+ src/Reflex/Dom/Retractable/Trans.hs view

@@ -0,0 +1,48 @@+-- |+-- Module      : Reflex.Dom.Retractable.Trans+-- Copyright   : (c) 2019 Investment Solutions AG+-- License     : MIT+-- Maintainer  : ncrashed@protonmail.com+-- Stability   : unstable+-- Portability : non-portable+--+-- Plug-in implementation for `MonadRetract` using wrapper around `ReaderT`.+--+-- Example of use:+--+-- @+-- import Control.Monad+-- import Reflex.Dom+-- import Reflex.Dom.Retractable+--+-- main :: IO ()+-- main = mainWidget $ runRetract frontend+--+-- frontend :: (MonadWidget t m, MonadRetract t m) => m ()+-- frontend = void $ retractStack $ pageA 42+--+-- pageA :: (MonadWidget t m, MonadRetract t m) => Int -> m ()+-- pageA n = do+--    e <- button "Go page B"+--    void $ nextWidget $ ffor e $ const Retractable {+--        retractableNext = pageB $ n + 1+--      , retractablePrev = Just $ pure $ pageA n+--      }+--+-- pageB :: (MonadWidget t m, MonadRetract t m) => Int -> m ()+-- pageB n = do+--   e <- button "Go page A"+--   void $ nextWidget $ ffor e $ const  Retractable {+--        retractableNext = pageA $ n + 1+--      , retractablePrev = Just $ pure $ pageB n+--      }+-- @+module Reflex.Dom.Retractable.Trans(+    RetractT+  , RetractEnv+  , newRetractEnv+  , runRetractT+  , runRetract+  ) where++import Reflex.Dom.Retractable.Trans.Internal

+ src/Reflex/Dom/Retractable/Trans/Internal.hs view

@@ -0,0 +1,148 @@+-- |+-- Module      : Reflex.Dom.Retractable.Trans.Internal+-- Copyright   : (c) 2019 Investment Solutions AG+-- License     : MIT+-- Maintainer  : ncrashed@protonmail.com+-- Stability   : unstable+-- Portability : non-portable+--+-- Plug-in implementation for `MonadRetract` using wrapper around `ReaderT`.+-- Internal module, implementation details can be changed at any moment.+module Reflex.Dom.Retractable.Trans.Internal where++import Control.Monad.Reader+import Control.Monad.State.Strict+import GHC.Generics+import Language.Javascript.JSaddle.Types+import Reflex+import Reflex.Dom+import Reflex.Dom.Retractable.Class++-- | Helper to simplify types in `RetractEnv`+type RetractableT t m = Retractable t (RetractT t m)++-- | Internal state of retractable widget+data RetractEnv t m = RetractEnv+  { renvNextFire     :: !(RetractableT t m -> IO ())+  , renvNextEvent    :: !(Event t (RetractableT t m))+  , renvRetractFire  :: !(IO ())+  , renvRetractEvent :: !(Event t ())+  , renvWipeFire     :: !(Maybe Int -> IO ())+  , renvWipeEvent    :: !(Event t (Maybe Int))+  , renvStack        :: !(Dynamic t [RetractableT t m])+  } deriving (Generic)++-- | Allocate new environment for `RetracT`.+newRetractEnv :: (Reflex t, TriggerEvent t m) => m (RetractEnv t m)+newRetractEnv = do+  (nextE, nextFire) <- newTriggerEvent+  (retrE, retrFire) <- newTriggerEvent+  (wipeE, wipeFire) <- newTriggerEvent+  pure RetractEnv {+      renvNextFire     = nextFire+    , renvNextEvent    = nextE+    , renvRetractFire  = retrFire ()+    , renvRetractEvent = retrE+    , renvWipeFire     = wipeFire+    , renvWipeEvent    = wipeE+    , renvStack        = pure []+    }++-- | Plug-in implementation of `MonadRetract`.+newtype RetractT t m a = RetractT { unRetractT :: ReaderT (RetractEnv t m) m a }+  deriving (Functor, Applicative, Monad, Generic, MonadFix)++deriving instance PostBuild t m => PostBuild t (RetractT t m)+deriving instance NotReady t m => NotReady t (RetractT t m)+deriving instance PerformEvent t m => PerformEvent t (RetractT t m)+deriving instance TriggerEvent t m => TriggerEvent t (RetractT t m)+deriving instance MonadHold t m => MonadHold t (RetractT t m)+deriving instance MonadSample t m => MonadSample t (RetractT t m)+deriving instance DomBuilder t m => DomBuilder t (RetractT t m)+deriving instance MonadIO m => MonadIO (RetractT t m)+deriving instance MonadJSM m => MonadJSM (RetractT t m)+deriving instance (Group q, Additive q, Query q, Eq q, MonadQuery t q m, Monad m) => MonadQuery t q (RetractT t m)+deriving instance (Monoid w, DynamicWriter t w m) => DynamicWriter t w (RetractT t m)+deriving instance (Monoid w, MonadBehaviorWriter t w m) => MonadBehaviorWriter t w (RetractT t m)+deriving instance (Semigroup w, EventWriter t w m) => EventWriter t w (RetractT t m)+deriving instance (Requester t m) => Requester t (RetractT t m)++instance MonadTrans (RetractT t) where+  lift = RetractT . lift+  {-# INLINABLE lift #-}++instance MonadReader e m => MonadReader e (RetractT t m) where+  ask = lift ask+  {-# INLINABLE ask #-}+  local f (RetractT ma) = RetractT $ do+    r <- ask+    lift $ local f $ runReaderT ma r+  {-# INLINABLE local #-}++instance MonadState s m => MonadState s (RetractT t m) where+  get = lift get+  {-# INLINABLE get #-}+  put = lift . put+  {-# INLINABLE put #-}++instance Adjustable t m => Adjustable t (RetractT t m) where+  runWithReplace a0 a' = do+    r <- RetractT ask+    lift $ runWithReplace (runRetractT a0 r) $ fmap (`runRetractT` r) a'+  {-# INLINABLE runWithReplace #-}+  traverseIntMapWithKeyWithAdjust f dm0 dm' = do+    r <- RetractT ask+    lift $ traverseIntMapWithKeyWithAdjust (\k v -> runRetractT (f k v) r) dm0 dm'+  {-# INLINABLE traverseIntMapWithKeyWithAdjust #-}+  traverseDMapWithKeyWithAdjust f dm0 dm' = do+    r <- RetractT ask+    lift $ traverseDMapWithKeyWithAdjust (\k v -> runRetractT (f k v) r) dm0 dm'+  {-# INLINABLE traverseDMapWithKeyWithAdjust #-}+  traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do+    r <- RetractT ask+    lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runRetractT (f k v) r) dm0 dm'+  {-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}++-- | Execute retractable widget with given environment.+runRetractT :: RetractT t m a -> RetractEnv t m -> m a+runRetractT (RetractT ma) e = runReaderT ma e+{-# INLINEABLE runRetractT #-}++-- | Simplified version of `runRetractT`+runRetract :: (Reflex t, TriggerEvent t m) => RetractT t m a -> m a+runRetract ma = do+  re <- newRetractEnv+  runRetractT ma re+{-# INLINABLE runRetract #-}++instance (PerformEvent t m, MonadHold t m, Adjustable t m, MonadFix m, MonadIO (Performable m))+  => MonadRetract t (RetractT t m) where+  nextWidget e = do+    fire <- RetractT $ asks renvNextFire+    performEvent $ fmap (liftIO . fire) e+  {-# INLINEABLE nextWidget #-}++  retract e = do+    fire <- RetractT $ asks renvRetractFire+    performEvent $ (liftIO fire) <$ e+  {-# INLINEABLE retract #-}++  wipeRetract e = do+    fire <- RetractT $ asks renvWipeFire+    performEvent $ fmap (liftIO . fire) e+  {-# INLINEABLE wipeRetract #-}++  nextWidgetEvent = RetractT $ asks renvNextEvent+  {-# INLINABLE nextWidgetEvent #-}++  retractEvent = RetractT $ asks renvRetractEvent+  {-# INLINABLE retractEvent #-}++  wipeRetractEvent = RetractT $ asks renvWipeEvent+  {-# INLINABLE wipeRetractEvent #-}++  getRetractStack = RetractT $ asks renvStack+  {-# INLINEABLE getRetractStack #-}++  withRetractStack st (RetractT ma) = RetractT $ local (\r -> r { renvStack = st }) ma+  {-# INLINEABLE withRetractStack #-}