Shpadoinkle 0.1.0.0 → 0.2.0.0

raw patch · 7 files changed

+1219/−450 lines, 7 filesdep +categorydep +ghcjs-domdep +transformersdep ~basedep ~unliftioPVP ok

version bump matches the API change (PVP)

Dependencies added: category, ghcjs-dom, transformers

Dependency ranges changed: base, unliftio

API changes (from Hackage documentation)

Files

• Control/PseudoInverseCategory.hs +191/−0
• LICENSE +21/−20
• README.md +10/−9
• Shpadoinkle.cabal +11/−6
• Shpadoinkle.hs +5/−415
• Shpadoinkle/Continuation.hs +427/−0
• Shpadoinkle/Core.hs +554/−0

@@ -0,0 +1,191 @@+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE MultiParamTypeClasses #-}+++{-|+   A pseudo-inverse category is a category where every morphism has a pseudo-inverse.+-}+++module Control.PseudoInverseCategory (+  -- * Classes+  ToHask (..)+  , HasHaskFunctors (..)+  , PseudoInverseCategory (..)+  , PIArrow (..)+  , piswap+  , piassoc+  -- * EndoIso+  , EndoIso (..)+  , pimap+  ) where+++import qualified Control.Categorical.Functor as F+import           Control.Category+import           Data.Functor.Identity+import           Data.Tuple                  (swap)+import           Prelude                     hiding (id, (.))+++-- | A type satisfying this class is a functor from another category to Hask. Laws:+--+-- prop> piapply (f . g) = piapply f . piapply g+-- prop> piapply id = id+--+class Category a => ToHask a where+  piapply :: a x y -> x -> y+++-- | For any type @a@ satisfying this class, we can lift endofunctors of Hask into @a@.+--   This mapping should constitute a functor from one monoidal category of endofunctors+--   to the other. That statement defines the applicable laws, which are, in other words:+--+--   prop> fmapA id = id+--   prop> fmapA (f >>> g) = fmapA f >>> fmapA g+class Category a => HasHaskFunctors a where+  fmapA :: Functor f => a x y -> a (f x) (f y)+++-- | A pseudo-inverse category is a category where every morphism has a pseudo-inverse.+--  What this means is defined by the following laws (perhaps things can be removed+--  and perhaps things should be added):+--+-- prop> pipower 1 f = f+-- prop> pileft (pipower 0 f) = id+-- prop> piright (pipower 0 f) = id+-- prop> pipower (n+1) f = pileft f . pipower n f+-- prop> piinverse (piinverse f) = f+-- prop> f . piinverse f = piright (pipower 2 f)+-- prop> piinverse f . f = pileft (pipower 2 f)+-- prop> pileft (piright f) = piright (piright f) = piright f+-- prop> piright (pileft f) = pileft (pileft f) = pileft f+-- prop> piinverse (pileft f) = pileft f+-- prop> piinverse (piright f) = piright f+--+class Category a => PseudoInverseCategory a where+  -- | Apply a morphism /n/ times, /n/ >= 0.+  pipower :: Int -> a x y -> a x y++  -- | Change a morphism into an endomorphism of its domain.+  pileft :: a x y -> a x x++  -- | Change a morphism into an endomorphism of its codomain.+  piright :: a x y -> a y y++  -- | Pseudo-invert a morphism. The pseudo-inverse of a morphism may or may not+  --   be its inverse. @f@ is the inverse of @g@ means that @f.g = id = g.f@.+  --   If @f@ has an inverse, then @piinverse f@ may or may not be the inverse+  --   of @f@.+  piinverse :: a x y -> a y x+++-- | An analogue of the Arrow typeclass for pseudo-inverse categories. Laws:+--+-- prop> piiso id id = id+-- prop> piendo id = id+-- prop> piiso (f . g) (h . i) = piiso f h . piiso g i+-- prop> piendo (f . h) = piendo f . piendo h+-- prop> pifirst (piiso f g) = piiso (first f) (first g)+-- prop> pifirst (piendo f) = piendo (first f)+-- prop> pifirst (f . g) = pifirst f . pifirst g+-- prop> pisplit id g . pifirst f = pifirst f . pisplit id g+-- prop> piassoc . first (first f) = first f . piassoc+-- prop> pisecond f = piswap . pifirst f . piswap+-- prop> pisplit f g = pifirst f . pisecond g+-- prop> pifan f g = piiso (\b -> (b,b)) fst . pisplit f g+-- prop> piinverse (piiso f g) = piiso g f+-- prop> piinverse (piendo f) = piendo f+-- prop> piapply (piiso f g) = f+-- prop> piapply (piinverse (piiso f g)) = g+-- prop> piapply (piendo f) = f+--+class PseudoInverseCategory a => PIArrow a where+  -- | Create an arrow from an isomorphism (restricted version of arr).+  piiso :: (b -> c) -> (c -> b) -> a b c++  -- | Create an arrow from an endomorphism (restricted version of arr).+  piendo :: (b -> b) -> a b b++  -- | Apply an arrow to the first coordinate of a tuple.+  pifirst :: a b c -> a (b, d) (c, d)++  -- | Apply an arrow to the second coordinate of a tuple.+  pisecond :: a b c -> a (d, b) (d, c)++  -- | Combine two arrows to work in parallel on a tuple.+  pisplit :: a b c -> a d e -> a (b, d) (c, e)++  -- | Combine two arrows on the same input to output a tuple.+  pifan :: a b c -> a b d -> a b (c, d)+++-- | Every pseudo-inverse category has isomorphisms to swap the coordinates of a tuple.+piswap :: PIArrow a => a (b, c) (c, b)+piswap = piiso swap swap+++-- | Every pseudo-inverse category has isomorphisms to change the associativity of a 3-tuple.+piassoc :: PIArrow a => a ((b,c),d) (b,(c,d))+piassoc = piiso (\((x,y),z) -> (x,(y,z))) (\(x,(y,z)) -> ((x,y),z))+++-- | This is a pseudo-inverse category where a morphism is a composition of an endomorphism+--   on the domain and an isomorphism of the domain with the codomain.+--   The last two arguments are required to form an isomorphism, i.e. for all @EndoIso f g h@:+--+-- prop> g . h = id+-- prop> h . g = id+--+-- This category contains as objects all types in Hask and as morphisms all compositions+-- of endomorphisms and isomorphisms in Hask.+data EndoIso a b = EndoIso (a -> a) (a -> b) (b -> a)+++instance Category EndoIso where+  id = EndoIso id id id++  EndoIso i j k . EndoIso f g h = EndoIso (f . h . i . g) (j . g) (h . k)+++instance F.Functor EndoIso (->) Identity where+  map (EndoIso f g _) = Identity . g . f . runIdentity+++instance ToHask EndoIso where+  piapply (EndoIso f g _) = g.f+++pimap :: F.Functor EndoIso EndoIso f => EndoIso a b -> f a -> f b+pimap = (\(EndoIso f g _) -> g.f) . F.map+++instance HasHaskFunctors EndoIso where+  fmapA (EndoIso f g h) = EndoIso (fmap f) (fmap g) (fmap h)+++instance PseudoInverseCategory EndoIso where+  pipower n (EndoIso f g h)+    | n < 0 = error "pipower with n < 0"+    | n > 0 = let EndoIso f' _ _ = pipower (n-1) (EndoIso f g h) in EndoIso (f.f') g h+    | otherwise = EndoIso id g h+  pileft (EndoIso f _ _) = EndoIso f id id+  piright (EndoIso f g h) = EndoIso (g.f.h) id id+  piinverse (EndoIso f g h) = EndoIso (g.f.h) h g+++instance PIArrow EndoIso where+  piiso = EndoIso id+  piendo f = EndoIso f id id+  pifirst (EndoIso f g h) = EndoIso (\(x,y)->(f x,y)) (\(x,y)->(g x,y)) (\(x,y)->(h x,y))+  pisecond (EndoIso f g h) = EndoIso (\(x,y)->(x,f y)) (\(x,y)->(x,g y)) (\(x,y)->(x,h y))+  pisplit (EndoIso f g h) (EndoIso i j k) = EndoIso+    (\(x,y) -> (f x, i y))+    (\(x,y) -> (g x, j y))+    (\(x,y) -> (h x, k y))+  pifan (EndoIso f g h) (EndoIso i j _) = EndoIso+    (\x -> f (i x))+    (\x -> (g x, j x))+    (\(x,_) -> h x) -- it shouldn't matter which side we use to go back because we have isomorphisms+

@@ -1,26 +1,27 @@-Shpadoinkle, I think I know exactly what it means-Copyright © 2019 Isaac Shpaira+Shpadoinkle Core aka S11 Core+Copyright © 2020 Isaac Shapira All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:-1. Redistributions of source code must retain the above copyright-notice, this list of conditions and the following disclaimer.-2. 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.-3. Neither the name of the <`3:organization`> nor the-names of its contributors may be used to endorse or promote products-derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY <|2|> ''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 <|2|> 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.+ * 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 Shpadoinkle nor the names of its 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.

@@ -1,6 +1,7 @@ # Shpadoinkle Core  [![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/Shpadoinkle)+[![Haddock](https://img.shields.io/badge/haddock-master-informational)](https://shpadoinkle.org/core) [![BSD-3](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause) [![built with nix](https://img.shields.io/badge/built%20with-nix-41439a)](https://builtwithnix.org) [![Hackage](https://img.shields.io/hackage/v/Shpadoinkle.svg)](https://hackage.haskell.org/package/Shpadoinkle)@@ -18,13 +19,13 @@ for good reason.  If all we need is to render something based on some `a` we can have `Html` be a-simple data structure where `Html :: Type`.+simple data structure where `Html :: Type`:  ```haskell view :: a -> Html ``` -This might look something like.+This might look something like:  ```haskell view :: Text -> Html@@ -38,13 +39,13 @@ like Heist, or Blaze. Shpadoinkle handles this by allowing for `Html` to have two type variables associated with events, `Html :: (Type -> Type) -> Type -> Type`. -The first is typically some Monad you wish to use in response to events `m`, and+The first is typically some Monad you want to use in response to events `m`, and the second is the payload of those events, typically the model for your view `a`.  These variables in `Html m a` are strickly about event listeners, so any view that doesn't have event listeners should be parametic in both `m` and `a`. -Let's look at a toggle as an example.+look at a toggle as an example:  ```haskell toggle :: Applicative m => Bool -> Html m Bool@@ -61,7 +62,7 @@ helps our views compose.  But what if we need to do _more_? Well we can update our `m` to-have more functionality. Let's add some logging to the console.+have more functionality. We can add some logging to the console:  ```haskell toggle :: Bool -> Html IO Bool@@ -76,7 +77,7 @@ ```  What if we want to access some record of capabilities? Or update some-concurrent memory thing? Let's say we have an enterprise grade Monad,+concurrent memory thing? Let's say we have an enterprise grade Monad:  ```haskell newtype App a = App { runApp :: RIO (TVar Metrics) a }@@ -101,7 +102,7 @@ ## Composing views  In Shpadoinkle we can compose views without impedance if the types match,-or are parametric. For example.+or are parametric. For example:  ```haskell hero :: Html m a@@ -139,7 +140,7 @@  ## The primitive -The Shpadoinkle programming model core primative is the `shpadoinkle` function.+The Shpadoinkle programming model core primitive is the `shpadoinkle` function.  ```haskell shpadoinkle@@ -151,7 +152,7 @@ ```  This is the machine that runs a Shpadoinkle view. To run we need-the following ingredients.+the following ingredients:  ### `m ~> JSM` 

@@ -4,13 +4,12 @@ -- -- see: https://github.com/sol/hpack ----- hash: cbdf104b795cd247fe1f662be8c24a9e63783a992d023100eb8173ea9f90d527+-- hash: 1d3c55562c8448cd288523fb62cb616caa2a301fba5f92e2ac5b61a931143bbd  name:           Shpadoinkle-version:        0.1.0.0+version:        0.2.0.0 synopsis:       A programming model for declarative, high performance user interface.-description:    Shpadoinkle is a programming model for user interface development. It supports flexible, simple, declarative code by modeling user interface interactions as Coalgebras.-                This package implements the bare-bones core abstraction. By performing little work shpadoinkle is trivially high performance.+description:    Shpadoinkle is an abstract frontend programming model, with one-way data flow, and a single source of truth. This module provides a parsimonious implementation of Shpadoinkle with few implementation details. category:       Web author:         Isaac Shapira maintainer:     fresheyeball@protonmail.com@@ -27,17 +26,23 @@  library   exposed-modules:+      Control.PseudoInverseCategory       Shpadoinkle+      Shpadoinkle.Continuation+      Shpadoinkle.Core   other-modules:       Paths_Shpadoinkle   hs-source-dirs:       ./.   ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities   build-depends:-      base >=4.12.0 && <4.15+      base >=4.12.0 && <4.16+    , category >=0.2 && <0.3+    , ghcjs-dom >=0.9.4 && <0.20     , jsaddle >=0.9.7 && <0.20     , text >=1.2.3 && <1.3-    , unliftio >=0.2.12 && <0.3+    , transformers+    , unliftio   if impl(ghcjs)     build-depends:   else

@@ -1,421 +1,11 @@-{-# LANGUAGE AllowAmbiguousTypes    #-}-{-# LANGUAGE BangPatterns           #-}-{-# LANGUAGE CPP                    #-}-{-# LANGUAGE DataKinds              #-}-{-# LANGUAGE DeriveFunctor          #-}-{-# LANGUAGE ExplicitNamespaces     #-}-{-# LANGUAGE FlexibleContexts       #-}-{-# LANGUAGE FlexibleInstances      #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE GADTs                  #-}-{-# LANGUAGE LambdaCase             #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE RankNTypes             #-}-{-# LANGUAGE ScopedTypeVariables    #-}-{-# LANGUAGE StandaloneDeriving     #-}-{-# LANGUAGE TupleSections          #-}-{-# LANGUAGE TypeFamilies           #-}-{-# LANGUAGE TypeOperators          #-}-{-# LANGUAGE UndecidableInstances   #-}- {-|-   I think I know precisely what I mean.--   A frontend abstraction motivated by simplicity, performance, and egonomics.-   This module provides core abstractions and types with almost no implimentation details. IE no batteries included.-   You may use this model a la carte, build ontop of it, or include more Backend packages for additional batteries.--   Backend is focused on letting you build your frontend the way you want to. And so is as unopinionated as possible, beyond providing a concrete programming model.+  This module re-exports for convenience. -}  module Shpadoinkle-  ( Html (..), Prop (..), Props-  , mapHtml, mapProp, mapProps, mapChildren-  , Backend (..)-  , shpadoinkle, fullPage, fullPageJSM-  , Territory (..)-  , type (~>), Html'-  , RawNode (..), RawEvent (..)-  , h, text, flag-  , listener, listen, listenRaw, listen'-  , baked-  , props, children, name, textContent, injectProps-  , MonadJSM, JSM, liftJSM-  , newTVarIO, readTVarIO-  , runJSorWarp-  , runJSM, askJSM+  ( module Shpadoinkle.Core+  , module Shpadoinkle.Continuation   ) where --import           Data.Kind-import           Data.String-import           Data.Text-import           GHC.Conc                         (retry)-import           Language.Javascript.JSaddle-#ifndef ghcjs_HOST_OS-import           Language.Javascript.JSaddle.Warp-#endif-import           UnliftIO.Concurrent-import           UnliftIO.STM----- | This is the core type in Backend.--- The (Html m) 'Functor' is used to describe Html documents.--- Please note, this is NOT a the Virtual Dom used by Backend--- this type backs a DSL that is then /interpreted/ into Virual Dom--- by the backend of your choosing. Html comments are not supported.-data Html :: (Type -> Type) -> Type -> Type where-  -- | A standard node in the dom tree-  Node :: Text -> [(Text, Prop m o)] -> [Html m o] -> Html m o-  -- | If you can bake an element into a 'RawNode' you can embed it as a baked potato.-  -- Backend does not provide any state management or abstraction to deal with-  -- custom embeded content. It's own you to decide how and when this 'RawNode' will-  -- be updated. For example, if you wanted to embed a google map as a baked potato,-  -- and you are driving your Backend view with a 'TVar', you would need to build-  -- the 'RawNode' for this map /outside/ of your Backend view, and pass it in-  -- as an argument. The 'RawNode' is a reference you control.-  Potato :: JSM RawNode -> Html m o-  -- | The humble text node-  TextNode :: Text -> Html m o----- | Natural Transformation-type m ~> n = forall a. m a -> n a---- | A type alias to support scenarios where--- the view code event listeners are pure.-type Html' a = forall m. Applicative m => Html m a----- | If you can provide a Natural Transformation from one Monad to another--- you may change the action of @Html@-mapHtml :: Functor m => (m ~> n) -> Html m o -> Html n o-mapHtml f = \case-  Node t ps cs -> Node t (fmap (mapProp f) <$> ps) (mapHtml f <$> cs)-  Potato p -> Potato p-  TextNode t -> TextNode t----- | If you can provide a Natural Transformation from one Monad to another--- you may change the action of @Prop@-mapProp :: (m ~> n) -> Prop m o -> Prop n o-mapProp f = \case-  PListener g -> PListener (\x y -> f (g x y))-  PText t     -> PText t-  PFlag b     -> PFlag b----- | Transform the properites of some Node. This has no effect on @TextNode@s or @Potato@s-mapProps :: ([(Text, Prop m o)] -> [(Text, Prop m o)]) -> Html m o -> Html m o-mapProps f = \case-  Node t ps cs -> Node t (f ps) cs-  t -> t----- | Transform the children of some Node. This has no effect on @TextNode@s or @Potato@s-mapChildren :: ([Html m a] -> [Html m a]) -> Html m a -> Html m a-mapChildren f = \case-  Node t ps cs -> Node t ps (f cs)-  t -> t----- | Lens to props-props :: Applicative f => ([(Text, Prop m a)] -> f [(Text, Prop m a)]) -> Html m a -> f (Html m a)-props inj = \case-  Node t ps cs -> (\ps' -> Node t ps' cs) <$> inj ps-  t -> pure t----- | Lens to children-children :: Applicative f => ([Html m a] -> f [Html m a]) -> Html m a -> f (Html m a)-children inj = \case-  Node t ps cs -> Node t ps <$> inj cs-  t -> pure t----- | Lens to tag name-name :: Applicative f => (Text -> f Text) -> Html m a -> f (Html m a)-name inj = \case-  Node t ps cs -> (\t' -> Node t' ps cs) <$> inj t-  t -> pure t----- | Lens to content of @TextNode@s-textContent :: Applicative f => (Text -> f Text) -> Html m a -> f (Html m a)-textContent inj = \case-  TextNode t -> TextNode <$> inj t-  n -> pure n----- | Inject props into an existing @Node@-injectProps :: [(Text, Prop m o)] -> Html m o -> Html m o-injectProps ps html = case html of-  Node t ps' cs -> Node t (ps' ++ ps) cs-  x             -> x----- | JSX style @h@ constructor-h :: Text -> [(Text, Prop m o)] -> [Html m o] -> Html m o-h = Node-{-# INLINE h #-}---- | Construct a 'Potato' from a 'JSM' action producing a 'RawNode'-baked :: JSM RawNode -> Html m o-baked = Potato---- | Construct a 'TextNode'-text :: Text -> Html m o-text = TextNode---- | Construct a 'PFlag'-flag :: Bool -> Prop m o-flag = PFlag----- | Construct a simple 'PListener` that will perform an action.-listener :: m o -> Prop m o-listener = PListener . const . const---- | Construct a 'PListener' from it's 'Text' name a raw listener.-listenRaw :: Text -> (RawNode -> RawEvent -> m o) -> (Text, Prop m o)-listenRaw k = (,) k . PListener---- | Construct a 'PListener' from it's 'Text' name and a Monad action.-listen :: Text -> m o -> (Text, Prop m o)-listen k = listenRaw k . const . const---- | Construct a 'PListener' from it's 'Text' name and an ouput value.-listen' :: Applicative m => Text -> o -> (Text, Prop m o)-listen' k f = listen k $ pure f----- | @(Html m)@ is not a 'Monad', and not even 'Applicative', by design.-deriving instance Functor m => Functor (Html m)----- | Properties of a Dom node, Backend does not use attributes directly,--- but rather is focued on the more capable properties that may be set on a dom--- node in JavaScript. If you wish to add attributes, you may do so--- by setting its corrosponding property.-data Prop m o where-  -- | A text property-  PText :: Text -> Prop m o-  -- | Event listeners are provided with the 'RawNode' target, and the 'RawEvent', and may perform-  -- a Monadic action such as a side effect. This is the one and only place where you may-  -- introduce a custom Monadic action.-  PListener :: (RawNode -> RawEvent -> m o) -> Prop m o-  -- | A boolean property, works as a flag-  -- for example @("disabled", PFlag False)@ has no effect-  -- while @("disabled", PFlag True)@ will add the @disabled@ attribute-  PFlag :: Bool -> Prop m o----- | Props are also merely 'Functor's not 'Monad's and not 'Applicative' by design.-deriving instance Functor m => Functor (Prop m)---- | Type alias for convenience. Typing out the nested brackets is tiresome.-type Props m o = [(Text, Prop m o)]----- | Strings are overload to html text nodes--- @---   "hiya" = TextNode "hiya"--- @-instance IsString (Html m o) where-  fromString = TextNode . pack-  {-# INLINE fromString #-}----- | Strings are overload as text props--- @---   ("id", "foo") = ("id", PText "foo")--- @-instance IsString (Prop m o) where-  fromString = PText . pack-  {-# INLINE fromString #-}---- | Strings are overload as the class property--- @---   "active" = ("className", PText "active")--- @-instance {-# OVERLAPPING #-} IsString [(Text, Prop m o)] where-  fromString = pure . ("className", ) . PText . pack-  {-# INLINE fromString #-}----- | A dom node reference.--- Useful for building baked potatoes, and binding a Backend view to the page-newtype RawNode  = RawNode  { unRawNode  :: JSVal }--- | A raw event object reference-newtype RawEvent = RawEvent { unRawEvent :: JSVal }-instance ToJSVal   RawNode where toJSVal   = return . unRawNode-instance FromJSVal RawNode where fromJSVal = return . Just . RawNode----- |--- patch raw Nothing >=> patch raw Nothing = patch raw Nothing---- | The Backend class describes a backend that can render 'Html'.--- Backends are generally Monad Transformers @b@ over some Monad @m@.-class Backend b m a | b m -> a where-  -- | VNode type family allows backends to have their own Virtual Dom.-  -- As such we can change out the rendering of our Backend view-  -- with new backends without updating our view logic.-  type VNode b m-  -- | A backend must be able to interpret 'Html' into its own internal Virtual Dom-  interpret-    :: (m ~> JSM)-    -- ^ Natural transformation for some @m@ to 'JSM'.-    -- This is how Backend get access to 'JSM' to perform the rendering side effect-    -> Html (b m) a-    -- ^ 'Html' to interpret-    -> b m (VNode b m)-    -- ^ Effect producing the Virtual Dom representation--  -- | A backend must be able to patch the 'RawNode' containing the view, with a-  -- new view if the Virtual Dom changed.-  patch-    :: RawNode-    -- ^ The container for rendering the Backend view.-    -> Maybe (VNode b m)-    -- ^ Perhaps there is a previous Virtual Dom for use to diff. Will be 'Nothing' on the first run.-    -> VNode b m-    -- ^ New Virtual Dom to render.-    -> b m (VNode b m)-    -- ^ Effect producing and updated virtual dom. This is not needed by all backends.-    -- Some JavaScript based backends need to do this for the next tick. Regardless whatever-    -- 'VNode' the effect produces will be passed as the previous Virtual Dom on the next render.--  -- | A backend may perform some inperative setup steps-  setup :: JSM () -> b m ()----- | Shpadoinkling requires a Territory, such as Colorado Territory.--- This class provides for the state container. As such you may use any--- type you wish where this semantic can be implimented.-class Territory s where-  -- | How do we update the state?-  writeUpdate :: s a -> (a -> JSM a) -> JSM ()-  -- | When should consider a state updated? This is akin to React's component should update thing.-  -- The idea is to provide a semantic for when we consider the model to have changed.-  shouldUpdate :: Eq a => (b -> a -> JSM b) -> b -> s a -> JSM ()-  -- | Create a new territory-  createTerritory :: a -> JSM (s a)----- | Cannoncal default implimentation of 'Territory' is just a 'TVar'.--- However there is nothing stopping your from writing your own alternative--- for a @Dynamic t@ from Reflex Dom, or some JavaScript based container.-instance Territory TVar where-  writeUpdate x f = do-    a <- f =<< readTVarIO x-    atomically $ writeTVar x a-  {-# INLINE writeUpdate #-}--  shouldUpdate sun prev model = do-    i' <- readTVarIO model-    p  <- createTerritory i'-    () <$ forkIO (go prev p)-    where-      go x p = do-        a <- atomically $ do-          new' <- readTVar model-          old  <- readTVar p-          if new' == old then retry else new' <$ writeTVar p new'-        y <- sun x a-        go y p--  createTerritory = newTVarIO-  {-# INLINE createTerritory #-}----- | The core view instantiation function.--- This combines a backend, a territory, and a model--- and renders the Backend view to the page.-shpadoinkle-  :: forall b m a t-   . Backend b m a => Territory t => Eq a-  => (m ~> JSM)-  -- ^ how to be get to JSM?-  -> (t a -> b m ~> m)-  -- ^ What backend are we running?-  -> a-  -- ^ what is the initial state?-  -> t a-  -- ^ how can we know when to update?-  -> (a -> Html (b m) a)-  -- ^ how should the html look?-  -> b m RawNode-  -- ^ where do we render?-  -> JSM ()-shpadoinkle toJSM toM initial model view stage = do-  let-    j :: b m ~> JSM-    j = toJSM . toM model--    go :: RawNode -> VNode b m -> a -> JSM (VNode b m)-    go c n a = do-      !m  <- j $ interpret toJSM (view a)-      j $ patch c (Just n) m--  j . setup $ do-    c <- j stage-    n <- j $ interpret toJSM (view initial)-    _ <- shouldUpdate (go c) n model-    _ <- j $ patch c Nothing n :: JSM (VNode b m)-    return ()---- | Wrapper around @shpadoinkle@ for full page apps--- that do not need outside control of the territory-fullPage-  :: Backend b m a => Territory t => Eq a-  => (m ~> JSM)-  -- ^ how do we get to JSM?-  -> (t a -> b m ~> m)-  -- ^ What backend are we running?-  -> a-  -- ^ what is the initial state?-  -> (a -> Html (b m) a)-  -- ^ how should the html look?-  -> b m RawNode-  -- ^ where do we render?-  -> JSM ()-fullPage g f i view getStage = do-  model <- createTerritory i-  shpadoinkle g f i model view getStage-{-# INLINE fullPage #-}----- | Wrapper around @shpadoinkle@ for full page apps--- that do not need outside control of the territory--- where actions are performed directly in JSM.------ This set of assumptions is extremely common when starting--- a new project.-fullPageJSM-  :: Backend b JSM a => Territory t => Eq a-  => (t a -> b JSM ~> JSM)-  -- ^ What backend are we running?-  -> a-  -- ^ what is the initial state?-  -> (a -> Html (b JSM) a)-  -- ^ how should the html look?-  -> b JSM RawNode-  -- ^ where do we render?-  -> JSM ()-fullPageJSM = fullPage id-{-# INLINE fullPageJSM #-}----- | Start the program!------ For GHC or GHCjs. I saved your from using CPP directly. Your welcome.-runJSorWarp :: Int -> JSM () -> IO ()-#ifdef ghcjs_HOST_OS-runJSorWarp _ = id-{-# INLINE runJSorWarp #-}-#else-runJSorWarp = run-{-# INLINE runJSorWarp #-}-#endif+import           Shpadoinkle.Continuation+import           Shpadoinkle.Core

@@ -0,0 +1,427 @@+{-# LANGUAGE InstanceSigs          #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TupleSections         #-}+{-# LANGUAGE TypeFamilies          #-}+++{-|+  Shpadoinkle Continuation is the abstract structure of Shpadoinkle's event handling system.+  It allows for asynchronous effects in event handlers by providing a model for atomic updates+  of application state.+-}+++module Shpadoinkle.Continuation (+  -- * The Continuation Type+  Continuation (..)+  , runContinuation+  , done, pur, impur, kleisli, causes, contIso+  -- * The Class+  , Continuous (..)+  -- ** Hoist+  , hoist+  -- * Forgetting+  , voidC', voidC, forgetC, forgetC'+  -- * Lifts+  , liftC', liftCMay', liftC, liftCMay+  -- * Utilities+  -- ** Product+  , leftC', leftC, rightC', rightC+  -- ** Coproduct+  , eitherC', eitherC+  -- ** Maybe+  , maybeC', maybeC, comaybe, comaybeC', comaybeC+  -- * Updates+  , writeUpdate, shouldUpdate, constUpdate+  -- * Monad Transformer+  , ContinuationT (..), voidRunContinuationT, kleisliT, commit+  ) where+++import           Control.Arrow                 (first)+import qualified Control.Categorical.Functor   as F+import           Control.Monad                 (liftM2, void)+import           Control.Monad.Trans.Class+import           Control.PseudoInverseCategory+import           GHC.Conc                      (retry)+import           UnliftIO+import           UnliftIO.Concurrent+++-- | A Continuation builds up an+--   atomic state update incrementally in a series of stages. For each stage we perform+--   a monadic IO computation and we may get a pure state updating function. When+--   all of the stages have been executed we are left with a composition of the resulting+--   pure state updating functions, and this composition is applied atomically to the state.+--+--   Additionally, a Continuation stage may feature a Rollback action which cancels all state+--   updates generated so far but allows for further state updates to be generated based on+--   further monadic IO computation.+--+--   The functions generating each stage of the Continuation+--   are called with states which reflect the current state of the app, with all+--   the pure state updating functions generated so far having been+--   applied to it, so that each stage "sees" both the current state+--   (even if it changed since the start of computing the Continuation), and the updates made+--   so far, although those updates are not committed to the real state until the Continuation+--   finishes and they are all done atomically together.+data Continuation m a = Continuation (a -> a, a -> m (Continuation m a))+                      | Rollback (Continuation m a)+                      | Pure (a -> a)++++-- | A pure state updating function can be turned into a Continuation. This function+--   is here so that users of the Continuation API can do basic things without needing+--   to depend on the internal structure of the type.+pur :: (a -> a) -> Continuation m a+pur = Pure+++-- | A Continuation which doesn't touch the state and doesn't have any side effects+done :: Continuation m a+done = pur id+++-- | A monadic computation of a pure state updating function can be turned into a Continuation.+impur :: Monad m => m (a -> a) -> Continuation m a+impur m = Continuation . (id,) . const $ do+  f <- m+  return $ Continuation (f, const (return done))+++-- | This turns a Kleisli arrow for computing a Continuation into the Continuation which+--   reads the state, runs the monadic computation specified by the arrow on that state,+--   and runs the resulting Continuation.+kleisli :: (a -> m (Continuation m a)) -> Continuation m a+kleisli = Continuation . (id,)+++-- | A monadic computation can be turned into a Continuation which does not touch the state.+causes :: Monad m => m () -> Continuation m a+causes m = impur (m >> return id)+++-- | 'runContinuation' takes a 'Continuation' and a state value and runs the whole Continuation+--   as if the real state was frozen at the value given to 'runContinuation'. It performs all the+--   IO actions in the stages of the Continuation and returns a pure state updating function+--   which is the composition of all the pure state updating functions generated by the+--   non-rolled-back stages of the Continuation. If you are trying to update a 'Continuous'+--   territory, then you should probably be using 'writeUpdate' instead of 'runContinuation',+--   because 'writeUpdate' will allow each stage of the Continuation to see any extant updates+--   made to the territory after the Continuation started running.+runContinuation :: Monad m => Continuation m a -> a -> m (a -> a)+runContinuation = runContinuation' id+++runContinuation' :: Monad m => (a -> a) -> Continuation m a -> a -> m (a -> a)+runContinuation' f (Continuation (g, h)) x = do+  i <- h (f x)+  runContinuation' (g.f) i x+runContinuation' _ (Rollback f) x = runContinuation' id f x+runContinuation' f (Pure g) _ = return (g.f)+++-- | @f@ is a Functor to Hask from the category where the objects are+--   Continuation types and the morphisms are functions.+class Continuous f where+  mapC :: Functor m => Functor n => (Continuation m a -> Continuation n b) -> f m a -> f n b+++instance Continuous Continuation where+  mapC = id+++-- | Given a natural transformation, change a Continuation's underlying functor.+hoist :: Functor m => (forall b. m b -> n b) -> Continuation m a -> Continuation n a+hoist _ (Pure f) = Pure f+hoist f (Rollback r) = Rollback (hoist f r)+hoist f (Continuation (g, h)) = Continuation . (g,) $ \x -> f $ hoist f <$> h x+++-- | Apply a lens inside a Continuation to change the Continuation's type.+liftC' :: Functor m => (a -> b -> b) -> (b -> a) -> Continuation m a -> Continuation m b+liftC' f g (Pure h) = Pure (\x -> f (h (g x)) x)+liftC' f g (Rollback r) = Rollback (liftC' f g r)+liftC' f g (Continuation (h, i)) = Continuation (\x -> f (h (g x)) x, \x -> liftC' f g <$> i (g x))+++-- | Apply a traversal inside a Continuation to change the Continuation's type.+liftCMay' :: Applicative m => (a -> b -> b) -> (b -> Maybe a) -> Continuation m a -> Continuation m b+liftCMay' f g (Pure h)     = Pure $ \x -> maybe x (flip f x . h) $ g x+liftCMay' f g (Rollback r) = Rollback (liftCMay' f g r)+liftCMay' f g (Continuation (h, i)) =+  Continuation (\x -> maybe x (flip f x . h) $ g x, \x -> maybe (pure done) (fmap (liftCMay' f g) . i) $ g x)+++-- | Given a lens, change the value type of @f@ by applying the lens in the Continuations inside @f@.+liftC :: Functor m => Continuous f => (a -> b -> b) -> (b -> a) -> f m a -> f m b+liftC f g = mapC (liftC' f g)+++-- | Given a traversal, change the value of @f@ by apply the traversal in the Continuations inside @f@.+liftCMay :: Applicative m => Continuous f => (a -> b -> b) -> (b -> Maybe a) -> f m a -> f m b+liftCMay f g = mapC (liftCMay' f g)+++-- | Change a void continuation into any other type of Continuation.+voidC' :: Monad m => Continuation m () -> Continuation m a+voidC' f = Continuation . (id,) $ \_ -> do+  _ <- runContinuation f ()+  return done+++-- | Change the type of the f-embedded void Continuations into any other type of Continuation.+voidC :: Monad m => Continuous f => f m () -> f m a+voidC = mapC voidC'+++-- | Forget about the Continuations.+forgetC :: Monad m => Monad n => Continuous f => f m a -> f n b+forgetC = mapC (const done)+++-- | Forget about the Continuations without changing the monad. This can be easier on type inference compared to forgetC.+forgetC' :: Monad m => Continuous f => f m a -> f m b+forgetC' = forgetC+++--- | Change the type of a Continuation by applying it to the left coordinate of a tuple.+leftC' :: Functor m => Continuation m a -> Continuation m (a,b)+leftC' = liftC' (\x (_,y) -> (x,y)) fst+++-- | Change the type of @f@ by applying the Continuations inside @f@ to the left coordinate of a tuple.+leftC :: Functor m => Continuous f => f m a -> f m (a,b)+leftC = mapC leftC'+++-- | Change the type of a Continuation by applying it to the right coordinate of a tuple.+rightC' :: Functor m => Continuation m b -> Continuation m (a,b)+rightC' = liftC' (\y (x,_) -> (x,y)) snd+++-- | Change the value type of @f@ by applying the Continuations inside @f@ to the right coordinate of a tuple.+rightC :: Functor m => Continuous f => f m b -> f m (a,b)+rightC = mapC rightC'+++-- | Transform a Continuation to work on 'Maybe's. If it encounters 'Nothing', then it cancels itself.+maybeC' :: Applicative m => Continuation m a -> Continuation m (Maybe a)+maybeC' (Pure f) = (Pure (fmap f))+maybeC' (Rollback r) = Rollback (maybeC' r)+maybeC' (Continuation (f, g)) = Continuation . (fmap f,) $+  \case+    Just x -> maybeC' <$> g x+    Nothing -> pure (Rollback done)+++-- | Change the value type of @f@ by transforming the Continuations inside @f@ to work on 'Maybe's using maybeC'.+maybeC :: Applicative m => Continuous f => f m a -> f m (Maybe a)+maybeC = mapC maybeC'+++-- | Turn a @Maybe a@ updating function into an @a@ updating function which acts as+--   the identity function when the input function outputs 'Nothing'.+comaybe :: (Maybe a -> Maybe a) -> (a -> a)+comaybe f x = case f (Just x) of+  Nothing -> x+  Just y  -> y+++-- | Change the type of a Maybe-valued Continuation into the Maybe-wrapped type.+--   The resulting Continuation acts like the input Continuation except that+--   when the input Continuation would replace the current value with 'Nothing',+--   instead the current value is retained.+comaybeC' :: Functor m => Continuation m (Maybe a) -> Continuation m a+comaybeC' (Pure f) = Pure (comaybe f)+comaybeC' (Rollback r) = Rollback (comaybeC' r)+comaybeC' (Continuation (f,g)) = Continuation (comaybe f, fmap comaybeC' . g . Just)+++-- | Transform the Continuations inside @f@ using comaybeC'.+comaybeC :: Functor m => Continuous f => f m (Maybe a) -> f m a+comaybeC = mapC comaybeC'+++-- Just define these rather than introducing another dependency even though they are in either+mapLeft :: (a -> b) -> Either a c -> Either b c+mapLeft f (Left x)  = Left (f x)+mapLeft _ (Right x) = Right x+++mapRight :: (b -> c) -> Either a b -> Either a c+mapRight _ (Left x)  = Left x+mapRight f (Right x) = Right (f x)+++-- | Combine Continuations heterogeneously into coproduct Continuations.+--   The first value the Continuation sees determines which of the+--   two input Continuation branches it follows. If the coproduct Continuation+--   sees the state change to a different Either-branch, then it cancels itself.+--   If the state is in a different Either-branch when the Continuation+--   completes than it was when the Continuation started, then the+--   coproduct Continuation will have no effect on the state.+eitherC' :: Monad m => Continuation m a -> Continuation m b -> Continuation m (Either a b)+eitherC' f g = Continuation . (id,) $ \case+  Left x -> case f of+    Pure h -> return (Pure (mapLeft h))+    Rollback r -> return . Rollback $ eitherC' r done+    Continuation (h, i) -> do+      j <- i x+      return $ Continuation (mapLeft h, const . return $ eitherC' j (Rollback done))+  Right x -> case g of+    Pure h -> return (Pure (mapRight h))+    Rollback r -> return . Rollback $ eitherC' done r+    Continuation (h, i) -> do+      j <- i x+      return $ Continuation (mapRight h, const . return $ eitherC' (Rollback done) j)+++-- | Create a structure containing coproduct Continuations using two case+--   alternatives which generate structures containing Continuations of+--   the types inside the coproduct. The Continuations in the resulting+--   structure will only have effect on the state while it is in the branch+--   of the coproduct selected by the input value used to create the structure.+eitherC :: Monad m => Continuous f => (a -> f m a) -> (b -> f m b) -> Either a b -> f m (Either a b)+eitherC l _ (Left x)  = mapC (\c -> eitherC' c (pur id)) (l x)+eitherC _ r (Right x) = mapC (\c -> eitherC' (pur id) c) (r x)+++-- | Transform the type of a Continuation using an isomorphism.+contIso :: Functor m => (a -> b) -> (b -> a) -> Continuation m a -> Continuation m b+contIso f g (Continuation (h, i)) = Continuation (f.h.g, fmap (contIso f g) . i . g)+contIso f g (Rollback h) = Rollback (contIso f g h)+contIso f g (Pure h) = Pure (f.h.g)+++-- | @Continuation m@ is a Functor in the EndoIso category (where the objects+--   are types and the morphisms are EndoIsos).+instance Applicative m => F.Functor EndoIso EndoIso (Continuation m) where+  map (EndoIso f g h) =+    EndoIso (Continuation . (f,) . const . pure) (contIso g h) (contIso h g)+++-- | You can combine multiple Continuations homogeneously using the 'Monoid' typeclass+--   instance. The resulting Continuation will execute all the subcontinuations in parallel,+--   allowing them to see each other's state updates and roll back each other's updates,+--   applying all of the updates generated by all the subcontinuations atomically once+--   all of them are done.+instance Monad m => Semigroup (Continuation m a) where+  (Continuation (f, g)) <> (Continuation (h, i)) =+    Continuation (f.h, \x -> liftM2 (<>) (g x) (i x))+  (Continuation (f, g)) <> (Rollback h) =+    Rollback (Continuation (f, (\x -> liftM2 (<>) (g x) (return h))))+  (Rollback h) <> (Continuation (_, g)) =+    Rollback (Continuation (id, \x -> liftM2 (<>) (return h) (g x)))+  (Rollback f) <> (Rollback g) = Rollback (f <> g)+  (Pure f) <> (Pure g) = Pure (f.g)+  (Pure f) <> (Continuation (g,h)) = Continuation (f.g,h)+  (Continuation (f,g)) <> (Pure h) = Continuation (f.h,g)+  (Pure f) <> (Rollback g) = Continuation (f, const (return (Rollback g)))+  (Rollback f) <> (Pure _) = Rollback f+++-- | Since combining Continuations homogeneously is an associative operation,+--   and this operation has a unit element (done), Continuations are a 'Monoid'.+instance Monad m => Monoid (Continuation m a) where+  mempty = done+++writeUpdate' :: MonadUnliftIO m => (a -> a) -> TVar a -> (a -> m (Continuation m a)) -> m ()+writeUpdate' h model f = do+  i <- readTVarIO model+  m <- f (h i)+  case m of+    Continuation (g,gs) -> writeUpdate' (g.h) model gs+    Pure g -> atomically $ writeTVar model =<< g.h <$> readTVar model+    Rollback gs -> writeUpdate' id model (const (return gs))+++-- | Run a Continuation on a state variable. This may update the state.+--   This is a synchronous, non-blocking operation for pure updates,+--   and an asynchronous, non-blocking operation for impure updates.+writeUpdate :: MonadUnliftIO m => TVar a -> Continuation m a -> m ()+writeUpdate model = \case+  Continuation (f,g) -> void . forkIO $ writeUpdate' f model g+  Pure f -> atomically $ writeTVar model =<< f <$> readTVar model+  Rollback f -> writeUpdate model f+++-- | Execute a fold by watching a state variable and executing the next+--   step of the fold each time it changes.+shouldUpdate :: MonadUnliftIO m => Eq a => (b -> a -> m b) -> b -> TVar a -> m ()+shouldUpdate sun prev model = do+  i' <- readTVarIO model+  p  <- newTVarIO i'+  () <$ forkIO (go prev p)+  where+    go x p = do+      a <- atomically $ do+        new' <- readTVar model+        old  <- readTVar p+        if new' == old then retry else new' <$ writeTVar p new'+      y <- sun x a+      go y p+++-- | A monad transformer for building up a Continuation in a series of steps in a monadic computation+newtype ContinuationT model m a = ContinuationT+  { runContinuationT :: m (a, Continuation m model) }+++-- | This adds the given Continuation to the Continuation being built up in the monadic context+--   where this function is invoked.+commit :: Monad m => Continuation m model -> ContinuationT model m ()+commit = ContinuationT . return . ((),)+++-- | This turns a monadic computation to build up a Continuation into the Continuation which it+--   represents. The actions inside the monadic computation will be run when the Continuation+--   is run. The return value of the monadic computation will be discarded.+voidRunContinuationT :: Monad m => ContinuationT model m a -> Continuation m model+voidRunContinuationT m = Continuation . (id,) . const $ snd <$> runContinuationT m+++-- | This turns a function for building a Continuation in a monadic computation+--   which is parameterized by the current state of the model+--   into a Continuation which reads the current state of the model,+--   runs the resulting monadic computation, and runs the Continuation+--   resulting from that computation.+kleisliT :: Monad m => (model -> ContinuationT model m a) -> Continuation m model+kleisliT f = kleisli $ \x -> return . voidRunContinuationT $ f x+++instance Functor m => Functor (ContinuationT model m) where+  fmap f = ContinuationT . fmap (first f) . runContinuationT+++instance Monad m => Applicative (ContinuationT model m) where+  pure = ContinuationT . pure . (, done)++  ft <*> xt = ContinuationT $ do+    (f, fc) <- runContinuationT ft+    (x, xc) <- runContinuationT xt+    return (f x, fc <> xc)+++instance Monad m => Monad (ContinuationT model m) where+  return = ContinuationT . return . (, done)++  m >>= f = ContinuationT $ do+    (x, g) <- runContinuationT m+    (y, h) <- runContinuationT (f x)+    return (y, g <> h)+++instance MonadTrans (ContinuationT model) where+  lift = ContinuationT . fmap (, done)+++-- | Create an update to a constant value.+constUpdate :: a -> Continuation m a+constUpdate = pur . const+{-# INLINE constUpdate #-}

@@ -0,0 +1,554 @@+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE BangPatterns           #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE ExplicitNamespaces     #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE LambdaCase             #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TupleSections          #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+++{-|+   Shpadoinkle is an abstract frontend programming model, with one-way data flow, and a single source of truth.+   This module provides a parsimonious implementation of Shpadoinkle with few implementation details.+-}+++module Shpadoinkle.Core (+  -- * Base Types+  Html(..), Prop(..)+  -- ** Prop Constructors+  , textProp, listenerProp, flagProp+  -- *** Listeners+  , listenRaw, listen, listenM, listenM_, listenC, listener+  -- ** Html Constructors+  , h, baked, text+  -- ** Html Lenses+  , props, children, name, textContent+  -- ** Hoists+  , hoistHtml, hoistProp+  -- ** Catamorphisms+  , cataH, cataProp+  -- ** Utilities+  , mapProps, mapChildren, injectProps, eitherH+  -- * JSVal Wrappers+  , RawNode(..), RawEvent(..)+  -- * Backend Interface+  , Backend (..)+  , type (~>)+  -- * The Shpadoinkle Primitive+  , shpadoinkle+  -- ** Convenience Variants+  , runJSorWarp+  , fullPage+  , fullPageJSM+  , simple+  -- * Re-Exports+  , JSM, MonadJSM, TVar, newTVarIO, readTVarIO+  ) where+++import           Control.Arrow                    (second)+import qualified Control.Categorical.Functor      as F+import           Control.Category                 ((.))+import           Control.PseudoInverseCategory+import           Data.Functor.Identity+import           Data.Kind+import           Data.String+import           Data.Text+import           GHCJS.DOM.Types                  (JSM, MonadJSM)+import           Language.Javascript.JSaddle      (FromJSVal (..), JSVal,+                                                   ToJSVal (..))+import           Prelude                          hiding ((.))+import           UnliftIO.STM                     (TVar, newTVarIO, readTVarIO)+#ifndef ghcjs_HOST_OS+import           Language.Javascript.JSaddle.Warp (run)+#endif+++import           Shpadoinkle.Continuation+++-- | This is the core type in Backend.+-- Please note, this is NOT the Virtual DOM used by Backend.+-- This type backs a DSL that is then /interpreted/ into Virtual DOM+-- by the Backend of your choosing. HTML comments are not supported.+data Html :: (Type -> Type) -> Type -> Type where+  -- | A standard node in the DOM tree+  Node :: Text -> [(Text, Prop m a)] -> [Html m a] -> Html m a+  -- | If you can bake an element into a 'RawNode' then you can embed it as a baked potato.+  -- Backend does not provide any state management or abstraction to deal with+  -- custom embedded content; it's on you to decide how and when this 'RawNode' will+  -- be updated. For example, if you wanted to embed a Google map as a baked potato,+  -- and you are driving your Backend view with a 'TVar', you would need to build+  -- the 'RawNode' for this map /outside/ of your Backend view and pass it in+  -- as an argument. The 'RawNode' is a reference you control.+  Potato :: JSM RawNode -> Html m a+  -- | The humble text node+  TextNode :: Text -> Html m a+++-- | Properties of a DOM node. Backend does not use attributes directly,+-- but rather is focused on the more capable properties that may be set on a DOM+-- node in JavaScript. If you wish to add attributes, you may do so+-- by setting its corresponding property.+data Prop :: (Type -> Type) -> Type -> Type where+  -- | A text property+  PText :: Text -> Prop m a+  -- | Event listeners are provided with the 'RawNode' target, and the 'RawEvent', and may perform+  -- a monadic action such as a side effect. This is the one and only place where you may+  -- introduce a custom monadic action. The JSM to compute the Continuation must be+  -- synchronous and non-blocking; otherwise race conditions may result from a Pure+  -- Continuation which sets the state based on a previous state captured by the closure.+  -- Such Continuations must be executed synchronously during event propagation,+  -- and that may not be the case if the code to compute the Continuation of some+  -- listener is blocking.+  PListener :: (RawNode -> RawEvent -> JSM (Continuation m a)) -> Prop m a+  -- | A boolean property works as a flag:+  -- for example @("disabled", PFlag False)@ has no effect,+  -- while @("disabled", PFlag True)@ will add the @disabled@ attribute.+  PFlag :: Bool -> Prop m a+++-- | Construct a listener from its name and a simple monadic event handler.+listenM :: Monad m => Text -> m (a -> a) -> (Text, Prop m a)+listenM k = listenC k . impur+++-- | Construct a listener from its name and a simple stateless monadic event handler.+listenM_ :: Monad m => Text -> m () -> (Text, Prop m a)+listenM_ k = listenC k . causes+++-- | Type alias for convenience (typing out the nested brackets is tiresome)+type Props' m a = [(Text, Prop m a)]+++-- | If you can provide a Natural Transformation from one Functor to another+-- then you may change the action of 'Html'.+hoistHtml :: Functor m => (m ~> n) -> Html m a -> Html n a+hoistHtml f = \case+  Node t ps cs -> Node t (fmap (hoistProp f) <$> ps) (hoistHtml f <$> cs)+  Potato p -> Potato p+  TextNode t -> TextNode t+{-# INLINE hoistHtml #-}+++-- | If you can provide a Natural Transformation from one Functor to another+-- then you may change the action of 'Prop'.+hoistProp :: Functor m => (m ~> n) -> Prop m a -> Prop n a+hoistProp f = \case+  PListener g -> PListener (\x y -> hoist f <$> g x y)+  PText t     -> PText t+  PFlag b     -> PFlag b+{-# INLINE hoistProp #-}+++-- | Strings are overloaded as HTML text nodes:+-- @+--   "hiya" = TextNode "hiya"+-- @+instance IsString (Html m a) where+  fromString = TextNode . pack+  {-# INLINE fromString #-}+++-- | Strings are overloaded as text props:+-- @+--   ("id", "foo") = ("id", PText "foo")+-- @+instance IsString (Prop m a) where+  fromString = PText . pack+  {-# INLINE fromString #-}+++-- | @Html m@ is a functor in the EndoIso category, where the objects are+--   types and the morphisms are EndoIsos.+instance Monad m => F.Functor EndoIso EndoIso (Html m) where+  map (EndoIso f g i) = EndoIso (mapC . piapply $ map' (piendo f))+                                (mapC . piapply $ map' (piiso g i))+                                (mapC . piapply $ map' (piiso i g))+    where map' :: EndoIso a b -> EndoIso (Continuation m a) (Continuation m b)+          map' = F.map+  {-# INLINE map #-}+++-- | Prop is a functor in the EndoIso category, where the objects are types+--  and the morphisms are EndoIsos.+instance Monad m => F.Functor EndoIso EndoIso (Prop m) where+  map :: forall a b. EndoIso a b -> EndoIso (Prop m a) (Prop m b)+  map f = EndoIso id mapFwd mapBack+    where f' :: EndoIso (Continuation m a) (Continuation m b)+          f' = F.map f++          mapFwd (PText t)     = PText t+          mapFwd (PListener g) = PListener (\r e -> piapply f' <$> g r e)+          mapFwd (PFlag b)     = PFlag b++          mapBack (PText t) = PText t+          mapBack (PListener g) = PListener (\r e -> piapply (piinverse f') <$> g r e)+          mapBack (PFlag b) = PFlag b+  {-# INLINE map #-}+++-- | Given a lens, you can change the type of an Html by using the lens+--   to convert the types of the Continuations inside it.+instance Continuous Html where+  mapC f (Node t ps es) = Node t (unMapProps . mapC f $ MapProps ps) (mapC f <$> es)+  mapC _ (Potato p) = Potato p+  mapC _ (TextNode t) = TextNode t+  {-# INLINE mapC #-}+++-- | Newtype to deal with the fact that we can't make the typeclass instances+--   for Endofunctor EndoIso and Continuous using the Props type alias+newtype MapProps m a = MapProps { unMapProps :: Props' m a }+++-- | Props is a functor in the EndoIso category, where the objects are+--  types and the morphisms are EndoIsos.+instance Monad m => F.Functor EndoIso EndoIso (MapProps m) where+  map f = piiso MapProps unMapProps . fmapA (pisecond (F.map f)) . piiso unMapProps MapProps+  {-# INLINE map #-}+++-- | Given a lens, you can change the type of a Props by using the lens+--   to convert the types of the Continuations inside.+instance Continuous MapProps where+  mapC f = MapProps . fmap (second (mapC f)) . unMapProps+  {-# INLINE mapC #-}+++-- | Given a lens, you can change the type of a Prop by using the+--   lens to convert the types of the Continuations which it contains+--   if it is a listener.+instance Continuous Prop where+  mapC _ (PText t)     = PText t+  mapC f (PListener g) = PListener (\r e -> f <$> g r e)+  mapC _ (PFlag b)     = PFlag b+  {-# INLINE mapC #-}+++-- | Create a text property.+textProp :: Text -> Prop m a+textProp = PText+{-# INLINE textProp #-}+++-- | Create an event listener property.+listenerProp :: (RawNode -> RawEvent -> JSM (Continuation m a)) -> Prop m a+listenerProp f = PListener (\r e -> f r e)+{-# INLINE listenerProp #-}+++-- | Create a boolean property.+flagProp :: Bool -> Prop m a+flagProp = PFlag+{-# INLINE flagProp #-}+++-- | Transform a p-algebra into a p-catamorphism. This is like polymorphic pattern matching.+cataProp :: (Text -> b)+         -> ((RawNode -> RawEvent -> JSM (Continuation m a)) -> b)+         -> (Bool -> b)+         -> Prop m a -> b+cataProp f g h' = \case+  PText t -> f t+  PListener l -> g l+  PFlag b -> h' b+++-- | Construct an HTML element JSX-style.+h :: Text -> [(Text, Prop m a)] -> [Html m a] -> Html m a+h = Node+{-# INLINE h #-}+++-- | Construct a 'Potato' from a 'JSM' action producing a 'RawNode'.+baked :: JSM RawNode -> Html m a+baked = Potato+{-# INLINE baked #-}+++-- | Construct a text node.+text :: Text -> Html m a+text = TextNode+{-# INLINE text #-}+++-- | Lens to props+props :: Applicative f => ([(Text, Prop m a)] -> f [(Text, Prop m a)]) -> Html m a -> f (Html m a)+props inj = \case+  Node t ps cs -> (\ps' -> Node t ps' cs) <$> inj ps+  t -> pure t+{-# INLINE props #-}+++-- | Lens to children+children :: Applicative f => ([Html m a] -> f [Html m a]) -> Html m a -> f (Html m a)+children inj = \case+  Node t ps cs -> Node t ps <$> inj cs+  t -> pure t+{-# INLINE children #-}+++-- | Lens to tag name+name :: Applicative f => (Text -> f Text) -> Html m a -> f (Html m a)+name inj = \case+  Node t ps cs -> (\t' -> Node t' ps cs) <$> inj t+  t -> pure t+{-# INLINE name #-}+++-- | Lens to content of 'TextNode's+textContent :: Applicative f => (Text -> f Text) -> Html m a -> f (Html m a)+textContent inj = \case+  TextNode t -> TextNode <$> inj t+  n -> pure n+{-# INLINE textContent #-}+++-- | Construct an HTML element out of heterogeneous alternatives.+eitherH :: Monad m => (a -> Html m a) -> (b -> Html m b) -> Either a b -> Html m (Either a b)+eitherH = eitherC+{-# INLINE eitherH #-}+++-- | Fold an HTML element, i.e. transform an h-algebra into an h-catamorphism.+cataH :: (Text -> [(Text, Prop m a)] -> [b] -> b)+      -> (JSM RawNode -> b)+      -> (Text -> b)+      -> Html m a -> b+cataH f g h' = \case+  Node t ps cs -> f t ps (cataH f g h' <$> cs)+  Potato p -> g p+  TextNode t -> h' t+++-- | Natural Transformation+type m ~> n = forall a. m a -> n a+++-- | A DOM node reference.+-- Useful for building baked potatoes and binding a Backend view to the page+newtype RawNode  = RawNode  { unRawNode  :: JSVal }+instance ToJSVal   RawNode where toJSVal   = return . unRawNode+instance FromJSVal RawNode where fromJSVal = return . Just . RawNode+++-- | A raw event object reference+newtype RawEvent = RawEvent { unRawEvent :: JSVal }+instance ToJSVal   RawEvent where toJSVal   = return . unRawEvent+instance FromJSVal RawEvent where fromJSVal = return . Just . RawEvent+++-- | Strings are overloaded as the class property:+-- @+--   "active" = ("className", PText "active")+-- @+instance {-# OVERLAPPING #-} IsString [(Text, Prop m a)] where+  fromString = pure . ("className", ) . textProp . pack+  {-# INLINE fromString #-}+++-- | Construct a simple listener property that will perform an action.+listener :: Continuation m a -> Prop m a+listener = listenerProp . const . const . return+{-# INLINE listener #-}+++-- | Construct a listener from its name and an event handler.+listenRaw :: Text -> (RawNode -> RawEvent -> JSM (Continuation m a)) -> (Text, Prop m a)+listenRaw k = (,) k . listenerProp+{-# INLINE listenRaw #-}+++-- | Construct a listener from its name and an event handler.+listenC :: Text -> Continuation m a -> (Text, Prop m a)+listenC k = listenRaw k . const . const . return+{-# INLINE listenC #-}+++-- | Construct a listener from its 'Text' name and an output value.+listen :: Text -> a -> (Text, Prop m a)+listen k = listenC k . constUpdate+{-# INLINE listen #-}+++-- | Transform the properties of some Node. This has no effect on 'TextNode's or 'Potato'es.+mapProps :: ([(Text, Prop m a)] -> [(Text, Prop m a)]) -> Html m a -> Html m a+mapProps f = runIdentity . props (Identity . f)+{-# INLINE mapProps #-}+++-- | Transform the children of some Node. This has no effect on 'TextNode's or 'Potato'es.+mapChildren :: ([Html m a] -> [Html m a]) -> Html m a -> Html m a+mapChildren f = runIdentity . children (Identity . f)+{-# INLINE mapChildren #-}+++-- | Inject props into an existing 'Node'.+injectProps :: [(Text, Prop m a)] -> Html m a -> Html m a+injectProps ps = mapProps (++ ps)+{-# INLINE injectProps #-}+++-- | The Backend class describes a backend that can render 'Html'.+-- Backends are generally Monad Transformers @b@ over some Monad @m@.+--+-- prop> patch raw Nothing >=> patch raw Nothing = patch raw Nothing+class Backend b m a | b m -> a where+  -- | VNode type family allows backends to have their own Virtual DOM.+  -- As such we can change out the rendering of our Backend view+  -- with new backends without updating our view logic.+  type VNode b m+  -- | A backend must be able to interpret 'Html' into its own internal Virtual DOM.+  interpret+    :: (m ~> JSM)+    -- ^ Natural transformation for some @m@ to 'JSM'+    -- (this is how a Backend gets access to 'JSM' to perform the rendering side effects)+    -> Html (b m) a+    -- ^ 'Html' to interpret+    -> b m (VNode b m)+    -- ^ Effect producing the Virtual DOM representation++  -- | A Backend must be able to patch the 'RawNode' containing the view, with a+  -- new view if the Virtual DOM changed.+  patch+    :: RawNode+    -- ^ The container for rendering the Backend view+    -> Maybe (VNode b m)+    -- ^ Perhaps there is a previous Virtual DOM to diff against. The value will be 'Nothing' on the first run.+    -> VNode b m+    -- ^ New Virtual DOM to render+    -> b m (VNode b m)+    -- ^ Effect producing an updated Virtual DOM. This is not needed by all backends.+    -- Some JavaScript-based backends need to do this for the next tick. Regardless, whatever+    -- 'VNode' the effect produces will be passed as the previous Virtual DOM on the next render.++  -- | A Backend may perform some imperative setup steps.+  setup :: JSM () -> JSM ()+++-- | The core view instantiation function+-- combines a backend, a territory, and a model+-- and renders the Backend view to the page.+shpadoinkle+  :: forall b m a+   . Backend b m a => Monad (b m) => Eq a+  => (m ~> JSM)+  -- ^ How to get to JSM?+  -> (TVar a -> b m ~> m)+  -- ^ What backend are we running?+  -> a+  -- ^ What is the initial state?+  -> TVar a+  -- ^ How can we know when to update?+  -> (a -> Html (b m) a)+  -- ^ How should the HTML look?+  -> b m RawNode+  -- ^ Where do we render?+  -> JSM ()+shpadoinkle toJSM toM initial model view stage = do+  let+    j :: b m ~> JSM+    j = toJSM . toM model++    go :: RawNode -> VNode b m -> a -> JSM (VNode b m)+    go c n a = j $ do+      !m  <- interpret toJSM (view a)+      patch c (Just n) m++  setup @b @m @a $ do+    (c,n) <- j $ do+      c <- stage+      n <- interpret toJSM (view initial)+      _ <- patch c Nothing n+      return (c,n)+    _ <- shouldUpdate (go c) n model+    return ()+++-- | Wrapper around 'shpadoinkle' for full page apps+-- that do not need outside control of the territory+fullPage+  :: Backend b m a => Monad (b m) => Eq a+  => (m ~> JSM)+  -- ^ How do we get to JSM?+  -> (TVar a -> b m ~> m)+  -- ^ What backend are we running?+  -> a+  -- ^ What is the initial state?+  -> (a -> Html (b m) a)+  -- ^ How should the html look?+  -> b m RawNode+  -- ^ Where do we render?+  -> JSM ()+fullPage g f i view getStage = do+  model <- newTVarIO i+  shpadoinkle g f i model view getStage+{-# INLINE fullPage #-}+++-- | 'fullPageJSM' is a wrapper around 'shpadoinkle'+-- for full page apps that do not need outside control+-- of the territory, where actions are performed directly in JSM.+--+-- This set of assumptions is extremely common when starting+-- a new project.+fullPageJSM+  :: Backend b JSM a => Monad (b JSM) => Eq a+  => (TVar a -> b JSM ~> JSM)+  -- ^ What backend are we running?+  -> a+  -- ^ What is the initial state?+  -> (a -> Html (b JSM) a)+  -- ^ How should the html look?+  -> b JSM RawNode+  -- ^ Where do we render?+  -> JSM ()+fullPageJSM = fullPage id+{-# INLINE fullPageJSM #-}+++-- | Start the program!+--+-- This function works in GHC and GHCjs. I saved you from using C preprocessor directly. You're welcome.+runJSorWarp :: Int -> JSM () -> IO ()+#ifdef ghcjs_HOST_OS+runJSorWarp _ = id+{-# INLINE runJSorWarp #-}+#else+runJSorWarp = run+{-# INLINE runJSorWarp #-}+#endif+++-- | Simple app+--+-- (a good starting place)+simple+  :: Backend b JSM a => Monad (b JSM) => Eq a+  => (TVar a -> b JSM ~> JSM)+  -- ^ What backend are we running?+  -> a+  -- ^ what is the initial state?+  -> (a -> Html (b JSM) a)+  -- ^ how should the html look?+  -> b JSM RawNode+  -- ^ where do we render?+  -> JSM ()+simple = fullPageJSM+{-# INLINE simple #-}