packages feed

Shpadoinkle (empty) → 0.0.0.1

raw patch · 6 files changed

+680/−0 lines, 6 filesdep +basedep +jsaddledep +jsaddle-warpsetup-changed

Dependencies added: base, jsaddle, jsaddle-warp, text, unliftio

Files

+ CHANGELOG.md view
+ LICENSE view
@@ -0,0 +1,26 @@+Shpadoinkle, I think I know exactly what it means+Copyright © 2019 Isaac Shpaira+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.+
+ README.md view
@@ -0,0 +1,186 @@+# Shpadoinkle Core++Shpadoinkle is a programming model for UI development, oriented around simplicity,+performance, and ergonomics.++## The core concept++Is to model the user interface as a pure function from some model `a` to Html.+This is not a new idea in the slightest. Declaratively describing the view in terms+of the model through a data structure is the dominant approach in UI today. And+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`.++```haskell+view :: a -> Html+```++This might look something like.++```haskell+view :: Text -> Html+view username =+  H "div" [ ("class", "greeting") ] [ Text $ "Hi there!" <> username ]+```++## Events and effects++Which is all well and good, and something we might expect from a static renderer,+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 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.++```haskell+toggle :: Applicative m => Bool -> Html m Bool+toggle b = h "div" []+  [ text $ "Currently it's " <> if b then "ON" else "OFF"+  , h "button" [ listen "click" (not b) ] [ text "Toggle" ]+  ]+```++That's it, we have a stateful view. When the user click's on+the "Toggle" button the state will switch. Because we do a pure+state transition in this function, `m` need only be `Applicative`.+We could put `Identity` here if we wanted to, but keeping `m` general+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.++```haskell+toggle :: Bool -> Html IO Bool+toggle b = h "div" []+  [ text $ "Currently it's " <> if b then "ON" else "OFF"+  , h "button"+    [ listen' "click" $ do+        putStrLn "We toggled!"+        return $ not b+    ] [ text "Toggle" ]+  ]+```++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,++```haskell+newtype App a = App { runApp :: RIO (TVar Metrics) a }+  deriving (Functor, Applicative, Monad, MonadReader (TVar Metrics), MonadIO, MonadJSM)+++toggle :: Bool -> Html App Bool+toggle b = h "div" []+  [ text $ "Currently it's " <> if b then "ON" else "OFF"+  , h "button"+    [ listen' "click" $ do+        metrics <- ask+        liftIO $ do+          atomically . modifyTVar metrics $+            \m -> m { toggleCount = toggleCount m + 1 }+          putStrLn "We toggled!"+        return $ not b+    ] [ text "Toggle" ]+  ]+```++## Composing views++In Shpadoinkle we can compose views without impedance if the types match,+or are parametric. For example.++```haskell+hero :: Html m a+hero = h "h1" [] [ text "Online String Reverse" ]++input :: Html m Text+input = h "input" [ onInput id ] []++view :: Text -> Html m Text+view s = h "div" []+  [ hero  -- no impedance, this Html is fully generic+  , input -- no impedance, this Html has matching types `(Text ~ Text)`+  , text $ "Reversed: \"" <> reverse s <> "\""+  ]+```++If you have nesting, with different types,+we can resolve the mismatch using 'fmap' like so:++```haskell+input :: Html m Text+input = h "input" [ onInput id ] []++view :: (Int, Text) -> Html m (Int, Text)+view (i,t) = h "div" []++  -- here we update the `Text` side of the model+  -- with the value produced by `input`, and we+  -- increment the `Int` as well.+  [ (\t_ -> (i + 1, t_)) <$> input+  , text $ "Reversed: \"" <> reverse t <> "\""+  , text $ "you have reversed " <> pack (show i) <> " strings"+  ]+```++## The primitive++The Shpadoinkle programming model core primative is the `shpadoinkle` function.++```haskell+shpadoinkle+  :: (Shpadoinkle b m a, Territory t, Eq a) =>+  => (m ~> JSM) -> (t a -> b m ~> m) -- How to render+  -> a -> t a                        -- What is our model+  -> (a -> Html (b m) a)             -- What to render+  -> b m RawNode -> JSM ()           -- Actually render+```++This is the machine that runs a Shpadoinkle view. To run we need+the following ingredients.++### `m ~> JSM`++We need a _Natural Transformation_ from our `m` to `JSM`, so that+we can perform the needed JavaScript effects in JSM from the `m`+you provide.++### `t a -> b m ~> m`++This a function that takes a state container of some kind `t`,+and returns a _Natural Transformation_ from our Shpadoinkle backend `b`,+to our monad `m`. Backends kind of works like Monad Transformers, where+`b` wraps our Monad `m`, and needs to be unwrappable.++### `a`++This is the initial value of our model. This will be passed to our view+for the first render.++### `t a`++This is the state container `t` that will drive the view. When the state+changes, we should re-render the view. The semantic behind determing when+to do this, is upto you via the `Territory` type class. Typically this is+just a `TVar` as that is the provided cannonical implimentation.++### `a -> Html (b m) a`++This is the view function, you actual application to render. It takes+the model and returns the html to render, such that it's events produce the+same model.++### `b m RawNode`++This is the raw node we that will wrap our view. If you want the Shpadoinkle view+to be the entire page, then you want to pass `document.body` as this node.+You could use this to embed a Shpadoinkle application into another application,+(such a Reflex-dom or Miso).+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Shpadoinkle.cabal view
@@ -0,0 +1,46 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.32.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 10da3c85383218f41740193acb4c34930a64acde34c7328fd54d77b7b00b48ab++name:           Shpadoinkle+version:        0.0.0.1+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.+category:       Web+author:         Isaac Shapira+maintainer:     fresheyeball@protonmail.com+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://gitlab.com/fresheyeball/Shpadoinkle.git++library+  exposed-modules:+      Shpadoinkle+  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.13+    , jsaddle >=0.9.7 && <0.10+    , text >=1.2.3 && <1.3+    , unliftio >=0.2.12 && <0.3+  if impl(ghcjs)+    build-depends:+  else+    build-depends:+        jsaddle-warp >=0.9.7 && <0.10+  default-language: Haskell2010
+ Shpadoinkle.hs view
@@ -0,0 +1,420 @@+{-# 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.+-}++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+  ) 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