concur-core (empty) → 0.1.0.0

raw patch · 10 files changed

+313/−0 lines, 10 filesdep +basedep +freedep +mtlsetup-changed

Dependencies added: base, free, mtl, natural-transformation, stm, transformers

Files

• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• concur-core.cabal +48/−0
• src/Concur/Core.hs +6/−0
• src/Concur/Core/Notify.hs +44/−0
• src/Concur/Core/Types.hs +130/−0
• src/Control/MonadSTM.hs +16/−0
• src/Control/MultiAlternative.hs +13/−0
• src/Control/ShiftMap.hs +23/−0

@@ -0,0 +1,30 @@+Copyright (C) 2017 Anupam Jain++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 Anupam Jain 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.

@@ -0,0 +1,1 @@+# concur-core

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

@@ -0,0 +1,48 @@+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 17db59d45076972dd7ba6d55b12cc5b23efd0eece58a6a855284b6f1f7e8fff8++name:                concur-core+version:             0.1.0.0+synopsis:            A client side web UI framework for Haskell. Core framework.+description:         A client side web UI framework for Haskell. Core framework.+homepage:            https://github.com/ajnsit/concur#readme+bug-reports:         https://github.com/ajnsit/concur/issues+license:             BSD3+license-file:        LICENSE+author:              Anupam Jain+maintainer:          ajnsit@gmail.com+copyright:           2017 (C) All Rights Reserved.+category:            Web+build-type:          Simple+cabal-version:       >= 1.10+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://github.com/ajnsit/concur++library+  ghc-options: -Wall -ferror-spans+  default-language: Haskell2010+  hs-source-dirs:+      src+  exposed-modules:+      Concur.Core+      Concur.Core.Types+      Concur.Core.Notify+      Control.MonadSTM+      Control.ShiftMap+      Control.MultiAlternative+  other-modules:+      Paths_concur_core+  build-depends:+      base >=4.7 && <5+    , free >=4.12+    , mtl >=2.2+    , natural-transformation >=0.4+    , stm >=2.4+    , transformers >=0.5

@@ -0,0 +1,6 @@+module Concur.Core+  ( module X+  ) where++import Concur.Core.Types as X+import Concur.Core.Notify as X

@@ -0,0 +1,44 @@+module Concur.Core.Notify+  ( Notify+  , fetch+  , await+  , notify+  , newNotify+  , newNotifyIO+  ) where++import           Control.Concurrent.STM (STM, TVar, newTVar, newTVarIO,+                                         readTVar, retry, writeTVar)+import           Control.Monad          (void)++-- TODO: Use Weak TVar pointers as appropriate+newtype Notify a = Notify (TVar (Maybe a))++fetch :: Notify a -> STM (Maybe a)+fetch (Notify v) = tryTakeTVar v++await :: Notify a -> STM a+await (Notify v) = takeTVar v++notify :: Notify a -> a -> STM ()+notify (Notify v) a = void (writeTVar v (Just a))++newNotify :: STM (Notify a)+newNotify = Notify <$> newTVar Nothing++newNotifyIO :: IO (Notify a)+newNotifyIO = Notify <$> newTVarIO Nothing++takeTVar :: TVar (Maybe a) -> STM a+takeTVar t = do+  m <- readTVar t+  case m of+    Nothing -> retry+    Just a  -> do writeTVar t Nothing; return a++tryTakeTVar :: TVar (Maybe a) -> STM (Maybe a)+tryTakeTVar t = do+  m <- readTVar t+  case m of+    Nothing -> return Nothing+    Just a  -> do writeTVar t Nothing; return (Just a)

@@ -0,0 +1,130 @@+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TupleSections              #-}+module Concur.Core.Types+  ( Widget(..)+  , continue+  , widget+  , display+  , mapView+  , wrapView+  , Suspend(..)+  , SuspendF(..)+  , Effect+  , effect+  , awaitViewAction+  , MultiAlternative(..)+  , loadWithIO+  , remoteWidget+  , unsafeBlockingIO+  ) where++import           Concur.Core.Notify       (Notify, await, newNotify, newNotifyIO, notify)+import           Control.Applicative      (Alternative, empty, (<|>))+import           Control.Concurrent       (forkIO)+import           Control.Concurrent.STM   (STM, atomically, retry)+import           Control.Monad            (MonadPlus (..))+import           Control.Monad.Free       (Free (..), hoistFree, liftF)+import           Control.Monad.IO.Class   (MonadIO, liftIO)+import           Control.MonadSTM         (MonadSTM (..))+import           Control.MultiAlternative (MultiAlternative, orr, never)++newtype Widget v a = Widget { suspend :: Free (Suspend v) a }+  deriving (Functor, Applicative, Monad)++data SuspendF v a = SuspendF { view :: v, cont :: Effect a }+  deriving Functor++newtype Suspend v a = Suspend { unSuspend :: IO (SuspendF v a) }+  deriving Functor++type Effect a = STM (Maybe a)++continue :: Suspend v a -> Widget v a+continue = Widget . liftF++widget :: v -> Effect a -> Widget v a+widget v r = continue $ Suspend $ return $ SuspendF v r++display :: v -> Widget v a+display v = widget v retry++-- Change the view of a Widget+mapView :: (u -> v) -> Widget u a -> Widget v a+mapView f (Widget w) = Widget $ go w+  where+    go = hoistFree g+    g (Suspend io) = Suspend $ fmap h io+    h (SuspendF v c) = SuspendF (f v) c++-- Generic widget view wrapper+wrapView :: Applicative f => (u -> v) -> Widget u a -> Widget (f v) a+wrapView f = mapView (pure . f)++-- A pure effect+effect :: v -> STM a -> Widget v a+effect v m = widget v $ Just <$> m++instance Monoid v => MonadSTM (Widget v) where+  liftSTM = effect mempty++-- | IMPORTANT: Blocking IO is dangerous as it can block the entire UI from updating.+--   It should only be used for *very* quick running IO actions like creating MVars.+unsafeBlockingIO :: Monoid v => IO a -> Widget v a+unsafeBlockingIO io = continue $ Suspend $ fmap (SuspendF mempty . return . Just) io++-- This is a safe use for blockingIO, and is exported+awaitViewAction :: (Notify a -> v) -> Widget v a+awaitViewAction f = continue $ Suspend $ do+  n <- newNotifyIO+  return $ SuspendF (f n) (fmap Just (await n))++loadWithIO :: v -> IO a -> Widget v a+loadWithIO v io = continue $ Suspend $ do+  n <- newNotifyIO+  _ <- forkIO $ io >>= atomically . notify n+  return $ SuspendF v (Just <$> await n)++-- Make a Widget, which can be pushed to remotely+remoteWidget :: (MultiAlternative m, MonadSTM m, Monad m) => m b -> (a -> m b) -> STM (a -> m (), m b)+remoteWidget d f = do+  var <- newNotify+  return (proxy var, wid var d)+  where+    proxy var = \a -> liftSTM $ notify var a+    wid var ui = orr [Left <$> ui, Right <$> (liftSTM $ await var)] >>= either return (wid var . f)++instance Monoid v => MonadIO (Widget v) where+  liftIO = loadWithIO mempty++-- IMPORTANT NOTE: This Alternative instance is NOT the same one as that for Free.+-- That one simply uses Alternative for Suspend. But that one isn't sufficient for us.+-- Verify laws:+--         Right distributivity (of <*>):  (f <|> g) <*> a = (f <*> a) <|> (g <*> a)+--         Right absorption (for <*>):  empty <*> a = empty+--         Left distributivity (of fmap):  f <$> (a <|> b) = (f <$> a) <|> (f <$> b)+--  OK     Left absorption (for fmap):  f <$> empty = empty+instance Monoid v => Alternative (Widget v) where+  empty = never+  f <|> g = orr [f,g]++instance Monoid v => MultiAlternative (Widget v) where+  never = display mempty+  orr = Widget . comb . map suspend+    where+      peelAllFree []           = Right []+      peelAllFree (Pure a : _) = Left a+      peelAllFree (Free s: fs) = fmap (s:) $ peelAllFree fs+      comb wfs = case peelAllFree wfs of+        Left a -> pure a+        Right fsio -> Free $ Suspend $ do+          fs <- mapM unSuspend fsio+          return $ SuspendF (mconcat $ map view fs) (merge $ map cont fs)+        where+          merge ws = do+            (i, me) <- foldl (\prev (i,w) -> prev <|> fmap (i,) w) retry $ zip [0..] ws+            return $ fmap (\e -> comb $ take i wfs ++ [e] ++ drop (i+1) wfs) me++-- The default instance derives from Alternative+instance Monoid v => MonadPlus (Widget v)

@@ -0,0 +1,16 @@+{-# LANGUAGE FlexibleInstances #-}+module Control.MonadSTM where++import           Control.Concurrent.STM (STM, atomically)+import           Control.Monad.Trans    (MonadTrans (..))++-- | Like `MonadIO` but for `STM` monad+-- `MonadBase` seemed too cumbersome for this.+class MonadSTM m where+  liftSTM :: STM a -> m a++instance MonadSTM IO where+  liftSTM = atomically++instance (MonadTrans t, Monad m, MonadSTM m) => MonadSTM (t m) where+  liftSTM = lift . liftSTM

@@ -0,0 +1,13 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE UndecidableInstances #-}+module Control.MultiAlternative where++import Control.Applicative (Alternative, empty, (<|>))++class MultiAlternative f where+  never :: f a+  orr :: [f a] -> f a++instance {-# OVERLAPPABLE #-} Alternative f => MultiAlternative f where+  never = empty+  orr = foldl (<|>) empty

@@ -0,0 +1,23 @@+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE TypeOperators         #-}+module Control.ShiftMap where++import           Control.Natural              (type (~>))++import           Control.Monad.State          (StateT, mapStateT)+import           Control.Monad.Trans.Identity (IdentityT, mapIdentityT)++-- | Mapping between Natural Transformations+class ShiftMap s t where+  shiftMap :: (s ~> s) -> (t ~> t)++instance ShiftMap m m where+  shiftMap = id++instance ShiftMap m (IdentityT m) where+  shiftMap = mapIdentityT++instance ShiftMap m (StateT s m) where+  shiftMap = mapStateT