├── .envrc ├── .gitignore ├── README.md ├── demo.gif ├── examples ├── .gitignore ├── cattron │ ├── index.html │ └── src │ │ ├── CatTron │ │ ├── State.purs │ │ └── UI.purs │ │ └── Main.purs ├── packages.dhall ├── reducer │ ├── index.html │ └── src │ │ ├── Main.purs │ │ └── Reducer │ │ ├── State.purs │ │ └── UI.purs ├── routing │ ├── index.html │ └── src │ │ ├── Main.purs │ │ └── Routing │ │ ├── Router.purs │ │ ├── State.purs │ │ ├── State │ │ └── Types.purs │ │ └── UI.purs ├── spago.dhall ├── todomvc │ ├── index.html │ └── src │ │ ├── Main.purs │ │ └── TodoMVC │ │ ├── State.purs │ │ └── UI.purs └── transactionalform │ ├── index.html │ └── src │ ├── Main.purs │ └── TransactionalForm │ ├── State.purs │ └── UI.purs ├── index.html ├── nix ├── sources.json └── sources.nix ├── package-lock.json ├── package.json ├── packages.dhall ├── scripts ├── mkDocs.fish └── mkExample.fish ├── shell.nix ├── spago.dhall ├── src ├── Data │ ├── Profunctor │ │ └── Optics.purs │ └── Record │ │ ├── Append.purs │ │ ├── Choose.purs │ │ └── Extras.purs ├── Snap.purs └── Snap │ ├── Component.purs │ ├── Component │ └── SYTC.purs │ ├── React.purs │ ├── React │ ├── Component.purs │ ├── Snapper.purs │ └── Target.purs │ ├── Snapper.purs │ └── Target.purs └── test └── Main.purs /.envrc: -------------------------------------------------------------------------------- 1 | use nix 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago 11 | /.cache 12 | /bundle/ 13 | /dist 14 | /docs 15 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `purescript-snap` 2 | 3 | An approach to user interfaces based in denotational design. 4 | 5 | ![demo](./demo.gif) 6 | 7 | # Running the TodoMVC example 8 | 9 | Run: `npm run todomvc` 10 | -------------------------------------------------------------------------------- /demo.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mcneissue/purescript-snap/7b1f91dfe5c6b42cd3c5961801e74d157ce62e34/demo.gif -------------------------------------------------------------------------------- /examples/.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago 11 | /.cache 12 | /bundle/ 13 | /dist -------------------------------------------------------------------------------- /examples/cattron/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Cat Viewer 9000 7 | 8 | 9 | 10 |
11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /examples/cattron/src/CatTron/State.purs: -------------------------------------------------------------------------------- 1 | module Examples.CatTron.State where 2 | 3 | import Prelude 4 | 5 | import Affjax (printError, Error) 6 | import Affjax as AX 7 | import Affjax.ResponseFormat (json) 8 | import Data.Argonaut (Json, decodeJson, (.:), JsonDecodeError) 9 | import Data.Either (Either(..), either) 10 | import Data.Generic.Rep (class Generic) 11 | import Data.Generic.Rep.Show (genericShow) 12 | import Effect.AVar (AVar) 13 | import Effect.Aff (Aff) 14 | import Effect.Aff.Class (class MonadAff) 15 | import Snap (Snapper') 16 | import Snap.React (affSnapper_) 17 | import Data.Bifunctor as Bifunctor 18 | 19 | data State = Loading | Error String | Gif String 20 | 21 | derive instance eqState :: Eq State 22 | derive instance genericState :: Generic State _ 23 | 24 | instance showState :: Show State where 25 | show = genericShow 26 | 27 | initialState :: State 28 | initialState = Loading 29 | 30 | topic :: String 31 | topic = "cats" 32 | 33 | randomGifUrl :: Aff (Either String String) 34 | randomGifUrl = do 35 | r <- (map <<< map) _.body $ AX.get json $ baseUrl <> topic 36 | pure $ either (Left <<< printError) decodeImageUrl r 37 | 38 | where 39 | baseUrl = "https://api.giphy.com/v1/gifs/random?api_key=dc6zaTOxFJmzC&tag=" 40 | 41 | decodeImageUrl :: Json -> Either String String 42 | decodeImageUrl s = Bifunctor.lmap show $ do 43 | obj <- decodeJson s 44 | dat <- obj .: "data" 45 | url <- dat .: "image_url" 46 | pure url 47 | 48 | snapper :: forall m. MonadAff m => AVar Unit -> m (Snapper' m State) 49 | snapper = affSnapper_ initialState 50 | -------------------------------------------------------------------------------- /examples/cattron/src/CatTron/UI.purs: -------------------------------------------------------------------------------- 1 | module Examples.CatTron.UI where 2 | 3 | import Prelude 4 | 5 | import Data.Either (either) 6 | import Data.Time.Duration (Milliseconds(..)) 7 | import Effect (Effect) 8 | import Effect.Aff (Aff, delay, forkAff) 9 | import Effect.Class (liftEffect) 10 | import Examples.CatTron.State (State(..), randomGifUrl) 11 | import React.Basic (JSX) 12 | import React.Basic.DOM as R 13 | import React.Basic.Events (handler_) 14 | import Snap.React.Component ((|-), (|<), (|=)) 15 | import Snap.Component.SYTC (Cmp', Cmp) 16 | import Snap.Component.SYTC as C 17 | 18 | loadGif :: Aff State 19 | loadGif = do 20 | delay $ Milliseconds $ 1000.0 21 | result <- randomGifUrl 22 | pure $ either Error Gif result 23 | 24 | reload :: forall s. Cmp Effect JSX s State 25 | reload set _ = R.button |= { onClick } |- R.text "MOAR" 26 | where 27 | onClick = handler_ $ set Loading 28 | 29 | view :: forall u. Cmp Effect JSX State u 30 | view _ Loading = R.p |- R.text "Loading..." 31 | view _ (Error s) = R.p |- R.text ("Error: " <> s) 32 | view _ (Gif src) = R.img { src } 33 | 34 | component :: Cmp' Effect JSX State 35 | component = C.ado 36 | r <- reload 37 | v <- view 38 | in R.div |< 39 | [ R.h1 |< 40 | [ R.text "CatTron 9000 Cat Gif Viewing Device" ] 41 | , R.div |- r 42 | , R.div |- v 43 | ] 44 | 45 | app :: Cmp' Effect (Aff JSX) State 46 | app set s = do 47 | when (s == Loading) load 48 | pure $ component set s 49 | where 50 | load = void $ forkAff $ loadGif >>= set >>> liftEffect 51 | -------------------------------------------------------------------------------- /examples/cattron/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Examples.CatTron.Main where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (maybe) 6 | import Effect (Effect) 7 | import Effect.Aff (error, launchAff_) 8 | import Effect.Aff.AVar as AVar 9 | import Effect.Exception (throwException) 10 | import Examples.CatTron.State (snapper) 11 | import Examples.CatTron.UI (app) 12 | import Snap (encapsulate, snap) 13 | import Snap.Component.SYTC (contraHoist, map) as C 14 | import Snap.React (reactTargetM) 15 | import Web.DOM (Element) 16 | import Web.DOM.NonElementParentNode (getElementById) 17 | import Web.HTML (window) 18 | import Web.HTML.HTMLDocument (toNonElementParentNode) 19 | import Web.HTML.Window (document) 20 | 21 | -- Finding the DOM element we're going to render everything onto 22 | element :: Effect Element 23 | element = do 24 | mc <- window >>= document <#> toNonElementParentNode >>= getElementById "container" 25 | maybe (throwException (error "Couldn't find root element")) pure mc 26 | 27 | main :: Effect Unit 28 | main = do 29 | -- Find the DOM element and create an Ref to hold the application state 30 | e <- element 31 | launchAff_ $ do 32 | av <- AVar.empty 33 | -- Create the state manager and target from the resources above 34 | snapper <- snapper av 35 | let target = reactTargetM e av 36 | let cmp = C.map join $ encapsulate snapper $ C.contraHoist launchAff_ $ app 37 | -- Snap everything together 38 | snap cmp target 39 | -------------------------------------------------------------------------------- /examples/packages.dhall: -------------------------------------------------------------------------------- 1 | let upstream = ../packages.dhall 2 | 3 | let snap = ../spago.dhall 4 | 5 | let additions = 6 | { snap = 7 | { dependencies = snap.dependencies 8 | , version = snap.version 9 | , repo = snap.repository 10 | } 11 | } 12 | 13 | in upstream // additions 14 | -------------------------------------------------------------------------------- /examples/reducer/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Reducer Example 7 | 8 | 9 | 10 |
11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /examples/reducer/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Examples.Reducer.Main where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (maybe) 6 | import Effect (Effect) 7 | import Effect.Aff (error, launchAff_) 8 | import Effect.Aff.AVar as AVar 9 | import Effect.Exception (throwException) 10 | import Examples.Reducer.State (snapper) 11 | import Examples.Reducer.UI (app) 12 | import Snap (encapsulate, snap) 13 | import Snap.React (reactTargetM) 14 | import Web.DOM (Element) 15 | import Web.DOM.NonElementParentNode (getElementById) 16 | import Web.HTML (window) 17 | import Web.HTML.HTMLDocument (toNonElementParentNode) 18 | import Web.HTML.Window (document) 19 | 20 | -- Finding the DOM element we're going to render everything onto 21 | element :: Effect Element 22 | element = do 23 | mc <- window >>= document <#> toNonElementParentNode >>= getElementById "container" 24 | maybe (throwException (error "Couldn't find root element")) pure mc 25 | 26 | main :: Effect Unit 27 | main = do 28 | -- Find the DOM element and create an Ref to hold the application state 29 | e <- element 30 | launchAff_ $ do 31 | av <- AVar.empty 32 | -- Create the state manager and target from the resources above 33 | snapper <- snapper av 34 | let cmp = encapsulate snapper app 35 | let target = reactTargetM e av 36 | -- Snap everything together 37 | snap cmp target 38 | -------------------------------------------------------------------------------- /examples/reducer/src/Reducer/State.purs: -------------------------------------------------------------------------------- 1 | module Examples.Reducer.State where 2 | 3 | import Prelude 4 | 5 | import Data.Either.Nested (type (\/)) 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Profunctor.Monoidal ((|&)) 8 | import Data.Tuple.Nested (type (/\)) 9 | import Effect.AVar (AVar) 10 | import Effect.Aff (Milliseconds(..), delay, forkAff, Fiber, Aff) 11 | import Effect.Aff.Class (class MonadAff, liftAff) 12 | import Snap (Snapper) 13 | import Snap.React.Snapper (affSnapper) 14 | 15 | data DelayerAction 16 | = Load (DelayerAction -> Aff Unit) 17 | | Loaded String 18 | 19 | data CounterAction 20 | = Increment 21 | | Decrement 22 | 23 | type Action = CounterAction \/ DelayerAction 24 | 25 | type State = Int /\ Maybe String 26 | 27 | counterSnapper :: forall m. 28 | MonadAff m => 29 | AVar Unit -> m (Snapper m CounterAction Int) 30 | counterSnapper = affSnapper reducer init 31 | where 32 | init = 0 33 | reducer Increment x = pure $ x + 1 34 | reducer Decrement x = pure $ x - 1 35 | 36 | affDelay :: forall a. Number -> Aff a -> Aff (Fiber a) 37 | affDelay t a = forkAff $ delay (Milliseconds t) *> a 38 | 39 | delayerSnapper :: forall m. 40 | MonadAff m => 41 | AVar Unit -> m (Snapper m DelayerAction (Maybe String)) 42 | delayerSnapper = affSnapper reducer init 43 | where 44 | init = Just "Click the button to launch a delayed request" 45 | reducer (Load put) _ = liftAff $ do 46 | _ <- affDelay 1000.0 $ put (Loaded "Delayed request completed.") 47 | pure Nothing 48 | reducer (Loaded s) _ = pure $ Just s 49 | 50 | snapper :: forall m. MonadAff m => AVar Unit -> m (Snapper m Action State) 51 | snapper av = (|&) <$> counterSnapper av <*> delayerSnapper av 52 | -------------------------------------------------------------------------------- /examples/reducer/src/Reducer/UI.purs: -------------------------------------------------------------------------------- 1 | module Examples.Reducer.UI where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either(..)) 6 | import Data.Maybe (Maybe, fromMaybe) 7 | import Data.Tuple (fst, snd) 8 | import Effect (Effect) 9 | import Effect.Aff (Aff, launchAff_) 10 | import Examples.Reducer.State (CounterAction(..), DelayerAction(..), State) 11 | import React.Basic (JSX) 12 | import React.Basic.DOM as R 13 | import Snap.Component.SYTC (Cmp) 14 | import Snap.Component.SYTC as C 15 | import Snap.React.Component ((|<), (|-)) 16 | import Snap.React.Component as RC 17 | 18 | app :: Cmp Aff JSX State (Either CounterAction DelayerAction) 19 | app = C.ado 20 | cntr <- fromEffCmp $ counter # C.dimap fst Left 21 | dlyr <- delayer # C.dimap snd Right 22 | in R.div |< [ cntr, dlyr ] 23 | 24 | counter :: Cmp Effect JSX Int CounterAction 25 | counter = C.ado 26 | inc <- RC.button # C.rmap (const Increment) 27 | dec <- RC.button # C.rmap (const Decrement) 28 | txt <- RC.text # C.lcmap show 29 | in R.div 30 | |< [ inc |- R.text "+" 31 | , txt 32 | , dec |- R.text "-" 33 | ] 34 | 35 | delayer :: Cmp Aff JSX (Maybe String) DelayerAction 36 | delayer put = go put 37 | where 38 | go = C.ado 39 | load <- fromEffCmp $ RC.button # C.rmap (const $ Load put) 40 | txt <- RC.text # C.lcmap (fromMaybe "Loading...") 41 | in R.div 42 | |< [ load |- R.text "Click Me" 43 | , txt 44 | ] 45 | 46 | fromEffCmp :: forall v s u. Cmp Effect v s u -> Cmp Aff v s u 47 | fromEffCmp = C.contraHoist launchAff_ 48 | -------------------------------------------------------------------------------- /examples/routing/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Example Viewer 7 | 8 | 9 | 10 | 11 | 12 |
13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /examples/routing/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Examples.Routing.Main where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (maybe) 6 | import Effect (Effect) 7 | import Effect.AVar (AVar) 8 | import Effect.Aff (error, launchAff_) 9 | import Effect.Aff.AVar (put) 10 | import Effect.Aff.AVar as AVar 11 | import Effect.Class (liftEffect) 12 | import Effect.Exception (throwException) 13 | import Examples.Routing.State (snapper) 14 | import Examples.Routing.UI (app) 15 | import Routing.Hash (foldHashes) 16 | import Snap (encapsulate, snap) 17 | import Snap.Component.SYTC (map) as C 18 | import Snap.React (reactTargetM) 19 | import Web.DOM (Element) 20 | import Web.DOM.NonElementParentNode (getElementById) 21 | import Web.HTML (window) 22 | import Web.HTML.HTMLDocument (toNonElementParentNode) 23 | import Web.HTML.Window (document) 24 | 25 | -- Finding the DOM element we're going to render everything onto 26 | element :: Effect Element 27 | element = do 28 | mc <- window >>= document <#> toNonElementParentNode >>= getElementById "container" 29 | maybe (throwException (error "Couldn't find root element")) pure mc 30 | 31 | subscribeHash :: AVar Unit -> Effect Unit 32 | subscribeHash av = void $ foldHashes (\_ _ -> launchAff_ $ put unit av) (const $ pure unit) 33 | 34 | main :: Effect Unit 35 | main = do 36 | -- Find the DOM element and create an Ref to hold the application state 37 | e <- element 38 | launchAff_ $ do 39 | av <- AVar.empty 40 | -- Create the state manager and target from the resources above 41 | s <- snapper av 42 | let cmp = C.map join $ encapsulate s app 43 | let target = reactTargetM e av 44 | liftEffect $ subscribeHash av 45 | -- Snap everything together 46 | snap cmp target 47 | -------------------------------------------------------------------------------- /examples/routing/src/Routing/Router.purs: -------------------------------------------------------------------------------- 1 | module Examples.Routing.Router where 2 | 3 | import Prelude hiding ((/)) 4 | 5 | import Data.Generic.Rep (class Generic) 6 | import Data.Generic.Rep.Show (genericShow) 7 | import Data.Lens (Iso', re, (^.)) 8 | import Data.Profunctor (dimap) 9 | import Data.Record.Choose (getField, hasField) 10 | import Data.Symbol (SProxy(..)) 11 | import Examples.Routing.State.Types (Route) 12 | import Partial.Unsafe (unsafeCrashWith) 13 | import Routing.Duplex (RouteDuplex', print, root) 14 | import Routing.Duplex.Generic (noArgs, sum) 15 | import Routing.Duplex.Generic.Syntax ((/)) 16 | 17 | data Route' 18 | = Root 19 | | CatTron 20 | | Reducer 21 | | TodoMvc 22 | | Transactional 23 | 24 | derive instance genericRoute :: Generic Route' _ 25 | derive instance eqRoute :: Eq Route' 26 | 27 | instance showRoute :: Show Route' where 28 | show = genericShow 29 | 30 | convert :: Iso' Route Route' 31 | convert = dimap (bwd <<< getField) fwd 32 | where 33 | fwd Root = hasField (SProxy :: _ "root") 34 | fwd CatTron = hasField (SProxy :: _ "cattron") 35 | fwd Reducer = hasField (SProxy :: _ "reducer") 36 | fwd TodoMvc = hasField (SProxy :: _ "todomvc") 37 | fwd Transactional = hasField (SProxy :: _ "transact") 38 | 39 | bwd "root" = Root 40 | bwd "cattron" = CatTron 41 | bwd "reducer" = Reducer 42 | bwd "todomvc" = TodoMvc 43 | bwd "transact" = Transactional 44 | bwd x = unsafeCrashWith x 45 | 46 | parser :: RouteDuplex' Route 47 | parser = convert $ root $ sum 48 | { "Root": noArgs 49 | , "CatTron": "cattron" / noArgs 50 | , "Reducer": "reducer" / noArgs 51 | , "TodoMvc": "todomvc" / noArgs 52 | , "Transactional": "transactional" / noArgs 53 | } 54 | 55 | urlFor :: Route' -> String 56 | urlFor r = "/#" <> print parser (r ^. re convert) 57 | -------------------------------------------------------------------------------- /examples/routing/src/Routing/State.purs: -------------------------------------------------------------------------------- 1 | module Examples.Routing.State (module Examples.Routing.State, module ST) where 2 | 3 | import Prelude 4 | 5 | import Data.Profunctor.Monoidal (mono) 6 | import Data.Profunctor.Traverse (sequenceSplice) 7 | import Data.Variant (Variant) 8 | import Effect.AVar (AVar) 9 | import Effect.Aff (Aff) 10 | import Effect.Class (liftEffect) 11 | import Examples.CatTron.State as CatTron 12 | import Examples.Reducer.State as Reducer 13 | import Examples.Routing.Router (parser) 14 | import Examples.Routing.State.Types (Update, State) 15 | import Examples.Routing.State.Types as ST 16 | import Examples.TodoMVC.State as TodoMvc 17 | import Examples.TransactionalForm.State as Transactional 18 | import Snap (Snapper, hoist) 19 | import Snap.React (route) 20 | 21 | snapper :: AVar Unit -> Aff (Snapper Aff (Variant Update) (Record State)) 22 | snapper av = ado 23 | nav <- pure $ hoist liftEffect $ route parser 24 | root <- pure $ mono 25 | todomvc <- TodoMvc.snapper av 26 | cattron <- CatTron.snapper av 27 | transact <- Transactional.snapper av 28 | reducer <- Reducer.snapper av 29 | in 30 | sequenceSplice { nav, root, todomvc, cattron, transact, reducer } 31 | -------------------------------------------------------------------------------- /examples/routing/src/Routing/State/Types.purs: -------------------------------------------------------------------------------- 1 | module Examples.Routing.State.Types where 2 | 3 | import Prelude 4 | 5 | import Data.Either.Nested (type (\/)) 6 | import Data.Record.Choose (HasField) 7 | import Examples.CatTron.State as CatTron 8 | import Examples.Reducer.State as Reducer 9 | import Examples.TodoMVC.State as TodoMvc 10 | import Examples.TransactionalForm.State as Transactional 11 | import Routing.Duplex.Parser (RouteError) 12 | import Type.Row (type (+)) 13 | 14 | type PageState r = 15 | ( root :: Unit 16 | , todomvc :: TodoMvc.App 17 | , cattron :: CatTron.State 18 | , transact :: Transactional.State 19 | , reducer :: Reducer.State 20 | | r 21 | ) 22 | 23 | type Route = HasField (PageState ()) 24 | 25 | type PageUpdate r = 26 | ( root :: Void 27 | , todomvc :: TodoMvc.App 28 | , cattron :: CatTron.State 29 | , transact :: Transactional.State 30 | , reducer :: Reducer.Action 31 | | r 32 | ) 33 | 34 | type State = PageState + ( nav :: RouteError \/ Route ) 35 | type Update = PageUpdate + ( nav :: Route ) 36 | -------------------------------------------------------------------------------- /examples/routing/src/Routing/UI.purs: -------------------------------------------------------------------------------- 1 | module Examples.Routing.UI where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either(..)) 6 | import Data.Newtype (un) 7 | import Data.Profunctor.Traverse (sequenceDemux) 8 | import Data.Record.Choose (choose) 9 | import Data.Symbol (SProxy(..)) 10 | import Data.Tuple.Nested ((/\)) 11 | import Data.Variant (Variant, expand, inj) 12 | import Effect.Aff (Aff, launchAff_) 13 | import Examples.CatTron.UI (app) as CatTron 14 | import Examples.Reducer.UI (app) as Reducer 15 | import Examples.Routing.Router (urlFor) 16 | import Examples.Routing.Router as Router 17 | import Examples.Routing.State (PageState, PageUpdate, State, Update) 18 | import Examples.Routing.State.Types (Route) 19 | import Examples.TodoMVC.UI (app) as TodoMvc 20 | import Examples.TransactionalForm.UI (app) as Transactional 21 | import React.Basic (JSX) 22 | import React.Basic.DOM as R 23 | import Record (delete) 24 | import Routing.Duplex.Parser (RouteError) 25 | import Snap.Component (ρ) 26 | import Snap.Component.SYTC (Cmp, contraHoist, (||)) 27 | import Snap.Component.SYTC as C 28 | import Snap.React.Component ((|-), (|<), (|=)) 29 | 30 | links :: JSX 31 | links = R.ul |< map toLink ls 32 | where 33 | toLink (n /\ a) = R.li |- R.a |= { href: a } |- R.text n 34 | ls = 35 | [ "CatTron 9000 Cat Gif Viewing Device" /\ urlFor Router.CatTron 36 | , "Reducers" /\ urlFor Router.Reducer 37 | , "TodoMVC" /\ urlFor Router.TodoMvc 38 | , "Transactional Forms" /\ urlFor Router.Transactional 39 | ] 40 | 41 | root :: forall m s u. Cmp m JSX s u 42 | root _ _ = 43 | R.div 44 | |< [ R.h1 45 | |- R.text "Examples" 46 | , links 47 | ] 48 | 49 | -- TODO: Make this redirect after a bit 50 | _404 :: Cmp Aff (Aff JSX) RouteError Route 51 | _404 put err = pure $ R.text $ "Invalid route: \"" <> show err <> "\". Redirecting in 5 seconds..." 52 | 53 | page :: Cmp Aff (Aff JSX) (Variant (PageState ())) (Variant (PageUpdate ())) 54 | page = un ρ $ sequenceDemux 55 | { root: ρ $ root # C.map pure 56 | , todomvc: ρ $ TodoMvc.app # C.map pure # contraHoist launchAff_ 57 | , cattron: ρ $ CatTron.app # contraHoist launchAff_ 58 | , transact: ρ $ Transactional.app # C.map pure # contraHoist launchAff_ 59 | , reducer: ρ $ Reducer.app # C.map pure 60 | } 61 | 62 | app :: Cmp Aff (Aff JSX) (Record State) (Variant Update) 63 | app = C.dimap f g $ _404 || page 64 | where 65 | f { nav: Left err } = Left err 66 | f x@{ nav: Right route } = Right $ choose route $ delete (SProxy :: _ "nav") x 67 | 68 | g (Left route) = inj (SProxy :: _ "nav") route 69 | g (Right x) = expand x 70 | -------------------------------------------------------------------------------- /examples/spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | -} 5 | { name = "snap-examples" 6 | , dependencies = [ "console", "effect", "psci-support", "snap" ] 7 | , packages = ./packages.dhall 8 | , sources = [ "./**/*.purs" ] 9 | } 10 | -------------------------------------------------------------------------------- /examples/todomvc/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Template • TodoMVC 7 | 8 | 9 | 10 | 11 | 12 |
13 | 14 | 20 | 21 | 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /examples/todomvc/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Examples.TodoMVC.Main where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (maybe) 6 | import Effect (Effect) 7 | import Effect.Aff (error, launchAff_) 8 | import Effect.Aff.AVar as AVar 9 | import Effect.Exception (throwException) 10 | import Examples.TodoMVC.State (snapper) 11 | import Examples.TodoMVC.UI (app) 12 | import Snap (encapsulate, snap) 13 | import Snap.React (reactTargetM) 14 | import Snap.Component.SYTC (contraHoist) 15 | import Web.DOM (Element) 16 | import Web.DOM.NonElementParentNode (getElementById) 17 | import Web.HTML (window) 18 | import Web.HTML.HTMLDocument (toNonElementParentNode) 19 | import Web.HTML.Window (document) 20 | 21 | -- Finding the DOM element we're going to render everything onto 22 | element :: Effect Element 23 | element = do 24 | mc <- window >>= document <#> toNonElementParentNode >>= getElementById "container" 25 | maybe (throwException (error "Couldn't find root element")) pure mc 26 | 27 | main :: Effect Unit 28 | main = do 29 | -- Find the DOM element and create an Ref to hold the application state 30 | e <- element 31 | launchAff_ $ do 32 | av <- AVar.empty 33 | -- Create the state manager and target from the resources above 34 | snapper <- snapper av 35 | let target = reactTargetM e av 36 | -- Snap everything together 37 | snap (encapsulate snapper $ contraHoist launchAff_ $ app) target 38 | -------------------------------------------------------------------------------- /examples/todomvc/src/TodoMVC/State.purs: -------------------------------------------------------------------------------- 1 | module Examples.TodoMVC.State where 2 | 3 | import Prelude 4 | 5 | import Data.Generic.Rep (class Generic) 6 | import Data.Lens as L 7 | import Data.Lens.Record (prop) 8 | import Data.Lens.Record.Extra (extractedBy) 9 | import Data.Maybe (Maybe(..), isJust) 10 | import Data.Profunctor (dimap, lcmap) 11 | import Data.Profunctor.Optics (Transactional, isDirty) 12 | import Data.Symbol (SProxy(..)) 13 | import Effect.AVar (AVar) 14 | import Effect.Aff.Class (class MonadAff) 15 | import Kishimen (genericSumToVariant, variantToGenericSum) 16 | import Simple.JSON as JSON 17 | import Snap (Snapper') 18 | import Snap.React (affSnapper_, localstorage) 19 | import Snap.React.Component (InputState) 20 | import Snap.Snapper (absorbError, withDefaultState) 21 | 22 | -- TODO: 23 | -- 1. Set up routing stuff 24 | 25 | -- #### STATE 26 | 27 | -- The state corresponding to a todo item 28 | type Todo = 29 | { done :: Boolean 30 | , hovered :: Boolean 31 | , value :: String 32 | , modification :: Maybe String 33 | } 34 | 35 | type Todos = Array Todo 36 | 37 | data Filter = All | Active | Completed 38 | 39 | derive instance genericFilter :: Generic Filter _ 40 | derive instance eqFilter :: Eq Filter 41 | 42 | instance readForeignFilter :: JSON.ReadForeign Filter 43 | where 44 | readImpl = map variantToGenericSum <<< JSON.read' 45 | 46 | instance writeForeignFilter :: JSON.WriteForeign Filter 47 | where 48 | writeImpl = JSON.write <<< genericSumToVariant 49 | 50 | instance showFilter :: Show Filter where 51 | show All = "All" 52 | show Active = "Active" 53 | show Completed = "Completed" 54 | 55 | shouldHide :: Filter -> Todo -> Boolean 56 | shouldHide All = const false 57 | shouldHide Active = _.done 58 | shouldHide Completed = not _.done 59 | 60 | className :: Filter -> Todo -> String 61 | className f t = 62 | (if isJust t.modification then " editing " else "") 63 | <> (if t.done then " completed " else "") 64 | <> (if (shouldHide f t) then " hidden " else "") 65 | 66 | type App = 67 | { newTodo :: InputState 68 | , todos :: Todos 69 | , filter :: Filter 70 | } 71 | 72 | -- Create a new todo 73 | createTodo :: String -> Todo 74 | createTodo = 75 | { value: _ 76 | , done: false 77 | , hovered: false 78 | , modification: Nothing 79 | } 80 | 81 | defaultNewTodo :: InputState 82 | defaultNewTodo = { focused: true, value: "" } 83 | 84 | -- Initial application state consists of three components 85 | initialState :: App 86 | initialState = { newTodo: defaultNewTodo, todos: [], filter: All } 87 | 88 | proxies :: 89 | { done :: SProxy "done" 90 | , filter :: SProxy "filter" 91 | , focused :: SProxy "focused" 92 | , hovered :: SProxy "hovered" 93 | , modification :: SProxy "modification" 94 | , newTodo :: SProxy "newTodo" 95 | , todos :: SProxy "todos" 96 | , value :: SProxy "value" 97 | } 98 | proxies = 99 | { done: SProxy :: _ "done" 100 | , hovered: SProxy :: _ "hovered" 101 | , modification: SProxy :: _ "modification" 102 | , value: SProxy :: _ "value" 103 | , focused: SProxy :: _ "focused" 104 | , newTodo: SProxy :: _ "newTodo" 105 | , todos: SProxy :: _ "todos" 106 | , filter: SProxy :: _ "filter" 107 | } 108 | 109 | _state :: L.Lens' Todo (Transactional String) 110 | _state = extractedBy { value: SProxy, modification: SProxy } 111 | 112 | _dirty :: L.Lens' Todo Boolean 113 | _dirty = isDirty >>> _state 114 | 115 | _done :: L.Lens' Todo Boolean 116 | _done = prop proxies.done 117 | 118 | _hovered :: L.Lens' Todo Boolean 119 | _hovered = prop proxies.hovered 120 | 121 | _modification :: L.Lens' Todo (Maybe String) 122 | _modification = prop proxies.modification 123 | 124 | _value :: L.Lens' Todo String 125 | _value = prop proxies.value 126 | 127 | _focused :: L.Lens' InputState Boolean 128 | _focused = prop proxies.focused 129 | 130 | _newTodo :: L.Lens' App InputState 131 | _newTodo = prop proxies.newTodo 132 | 133 | _todos :: L.Lens' App Todos 134 | _todos = prop proxies.todos 135 | 136 | _filter :: L.Lens' App Filter 137 | _filter = prop proxies.filter 138 | 139 | snapper :: forall m. MonadAff m => AVar Unit -> m (Snapper' m App) 140 | snapper av = do 141 | s1 <- affSnapper_ Nothing av 142 | s2 <- localstorage "todomvc" 143 | let 144 | s1' = absorbError $ lcmap Just s1 145 | s2' = absorbError $ dimap JSON.writeJSON (_ >>= JSON.readJSON_) s2 146 | 147 | pure $ withDefaultState initialState $ s1' <> s2' 148 | -------------------------------------------------------------------------------- /examples/todomvc/src/TodoMVC/UI.purs: -------------------------------------------------------------------------------- 1 | module Examples.TodoMVC.UI where 2 | 3 | import Prelude hiding (map,apply) 4 | 5 | import Data.Array (filter, snoc) as A 6 | import Data.Lens (_Just, traversed) 7 | import Data.Lens as L 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Newtype (unwrap) 10 | import Data.Profunctor as P 11 | import Data.Profunctor.Optics (all, by, countBy, partsOf) 12 | import Data.String (trim) 13 | import Effect (Effect) 14 | import Examples.TodoMVC.State (App, Filter(..), Todo, Todos) 15 | import Examples.TodoMVC.State (_dirty, _done, _filter, _hovered, _newTodo, _state, _todos, _value, className, createTodo, defaultNewTodo) as T 16 | import React.Basic (JSX) 17 | import React.Basic.DOM (a, div, footer, h1, header, label, li, section, span, strong, text, ul, input) as R 18 | import Snap.Component (PComponent(..), (#!)) 19 | import Snap.Component.SYTC (Cmp, Cmp', (<$>!), (<*>!), withered) 20 | import Snap.Component.SYTC as C 21 | import Snap.React.Component ((|-), (|<), (|=), (|~)) 22 | import Snap.React.Component as S 23 | 24 | -- #### UI 25 | 26 | -- TODO: Destroy input if value is empty 27 | -- The editor for todo items 28 | editor :: Cmp' Effect JSX Todo 29 | editor = C.ado 30 | t <- modificatons #! T._state 31 | f <- S.focused #! T._dirty 32 | in R.input |~ t.change |~ t.save |~ t.revert |~ f $ { className: "edit" } 33 | where 34 | modificatons = S.transacted 35 | { change: S.edited 36 | , save : S.enterPressed 37 | , revert: S.escapePressed 38 | } 39 | 40 | -- The renderer for todo items when they're not being edited 41 | -- Accepts some conditionally rendered content that will be 42 | -- shown when hovering the todo 43 | viewer :: Cmp' Effect (JSX -> JSX) Todo 44 | viewer = C.ado 45 | chck <- S.checkbox #! T._done 46 | text <- S.text #! T._value 47 | veil <- S.conditional #! T._hovered 48 | ckbl <- S.clicked #! P.rmap (const true) >>> T._dirty 49 | hvbl <- S.hovering #! T._hovered 50 | in 51 | \extra -> 52 | R.div 53 | |~ hvbl 54 | |= { className: "view" } 55 | |< [ chck { className: "toggle" } 56 | , R.label |~ ckbl |- text 57 | , veil extra 58 | ] 59 | 60 | -- A todo item 61 | -- Depending on the value of the "edit" field, shows an 62 | -- editor or a renderer. 63 | todo :: Cmp' Effect JSX (Maybe Todo) 64 | todo = C.ado 65 | ev <- editview #! _Just 66 | del <- S.button # C.handle_ (const Nothing) 67 | in ev $ del { className: "destroy" } 68 | where 69 | editor' = const <$>! editor 70 | editview = C.demux editor' viewer #! by (L.view T._dirty) 71 | 72 | -- An li wrapper around each todo with the appropriate classnames 73 | listItem :: forall u. Filter -> Cmp Effect (JSX -> JSX) (Maybe Todo) u 74 | listItem f = li 75 | where 76 | li _ Nothing _ = mempty 77 | li _ (Just t) v = R.li |= { className: T.className f t } |- v 78 | 79 | -- A list of todos, which can delete themselves from the list 80 | todos :: Cmp' Effect JSX App 81 | todos = C.do 82 | f <- C.echo #! T._filter 83 | tds <- (listItem f <*>! todo) #! T._todos <<< P.dimap unwrap PComponent withered 84 | C.pure $ R.ul 85 | |= { className: "todo-list" } 86 | |- tds 87 | 88 | -- A checkbox to control the state of all todo items 89 | allDone :: Cmp' Effect JSX Todos 90 | allDone = C.ado 91 | chk <- S.checkbox #! all >>> partsOf (traversed <<< T._done) 92 | in chk { id: "toggle-all", className: "toggle-all" } 93 | <> R.label 94 | |= { htmlFor: "toggle-all" } 95 | |- R.text "Mark all as complete" 96 | 97 | -- The header for the todo list 98 | header :: Cmp' Effect JSX App 99 | header = C.ado 100 | key <- S.enterPressed # C.handle_ addTodo 101 | inp <- S.input #! T._newTodo 102 | in R.header 103 | |= { className: "header" } 104 | |< [ R.h1 |- R.text "todos" 105 | , inp |~ key $ { className: "new-todo", placeholder: "What needs to be done?" } 106 | ] 107 | where 108 | addTodo s = 109 | let v = trim s.newTodo.value 110 | in if v == "" 111 | then s 112 | else s { todos = s.todos `A.snoc` T.createTodo v, newTodo = T.defaultNewTodo } 113 | 114 | itemCount :: forall u. Cmp Effect JSX Int u 115 | itemCount _ = go 116 | where 117 | wrap n s = R.strong |- R.text n <> R.text s 118 | go 0 = wrap "no" " items left" 119 | go 1 = wrap "one" " item left" 120 | go n = wrap (show n) " items left" 121 | 122 | url :: Filter -> String 123 | url All = "#/" 124 | url Active = "#/active" 125 | url Completed = "#/completed" 126 | 127 | anchor :: forall u. Cmp Effect (Filter -> JSX) Filter u 128 | anchor _ s f = a |= { href: url f } |- R.text (show f) 129 | where 130 | a | s == f = R.a |= { className: "selected" } 131 | | otherwise = R.a 132 | 133 | filters :: Cmp' Effect JSX Filter 134 | filters = C.ado 135 | a <- anchor 136 | all <- S.clicked # C.handle_ (const All) 137 | act <- S.clicked # C.handle_ (const Active) 138 | com <- S.clicked # C.handle_ (const Completed) 139 | in R.ul 140 | |= { className: "filters" } 141 | |< [ R.li |~ all |- a All 142 | , R.li |~ act |- a Active 143 | , R.li |~ com |- a Completed 144 | ] 145 | 146 | footer :: Cmp' Effect JSX App 147 | footer = C.ado 148 | count <- itemCount #! T._todos <<< countBy (not _.done) 149 | veil <- S.conditional #! T._todos <<< countBy _.done <<< P.lcmap (_ > 0) 150 | fltrs <- filters #! T._filter 151 | clear <- S.button 152 | # C.handle_ (A.filter $ not _.done) 153 | #! T._todos 154 | in R.footer 155 | |= { className: "footer" } 156 | |< [ R.span 157 | |= { className: "todo-count" } 158 | |- count 159 | , fltrs 160 | , veil 161 | $ clear 162 | |= { className: "clear-completed" } 163 | |- R.text "Clear completed" 164 | ] 165 | 166 | -- The overall application 167 | app :: Cmp' Effect JSX App 168 | app = C.ado 169 | veil <- S.conditional 170 | #! T._todos <<< 171 | countBy (const true) <<< 172 | P.lcmap (_ > 0) 173 | hdr <- header 174 | tds <- todos 175 | tgl <- allDone #! T._todos 176 | ftr <- footer 177 | dbg <- S.debug 178 | in R.section 179 | |= { className: "todoapp" } 180 | |< [ hdr 181 | , veil $ R.section 182 | |= { className: "main" } 183 | |< [ tgl 184 | , tds 185 | ] 186 | , veil $ ftr 187 | ] 188 | <> dbg 189 | -------------------------------------------------------------------------------- /examples/transactionalform/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Transactional forms 7 | 8 | 9 | 10 |
11 | 12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /examples/transactionalform/src/Main.purs: -------------------------------------------------------------------------------- 1 | module Examples.TransactionalForm.Main where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (maybe) 6 | import Effect (Effect) 7 | import Effect.Aff (error, launchAff_) 8 | import Effect.Aff.AVar as AVar 9 | import Effect.Exception (throwException) 10 | import Examples.TransactionalForm.State (snapper) 11 | import Examples.TransactionalForm.UI (app) 12 | import Snap (encapsulate, snap) 13 | import Snap.React (reactTargetM) 14 | import Snap.Component.SYTC (contraHoist) 15 | import Web.DOM (Element) 16 | import Web.DOM.NonElementParentNode (getElementById) 17 | import Web.HTML (window) 18 | import Web.HTML.HTMLDocument (toNonElementParentNode) 19 | import Web.HTML.Window (document) 20 | 21 | -- Finding the DOM element we're going to render everything onto 22 | element :: Effect Element 23 | element = do 24 | mc <- window >>= document <#> toNonElementParentNode >>= getElementById "container" 25 | maybe (throwException (error "Couldn't find root element")) pure mc 26 | 27 | main :: Effect Unit 28 | main = do 29 | -- Find the DOM element and create an Ref to hold the application state 30 | e <- element 31 | launchAff_ $ do 32 | av <- AVar.empty 33 | -- Create the state manager and target from the resources above 34 | snapper <- snapper av 35 | let target = reactTargetM e av 36 | let cmp = encapsulate snapper $ contraHoist launchAff_ $ app 37 | -- Snap everything together 38 | snap cmp target 39 | -------------------------------------------------------------------------------- /examples/transactionalform/src/TransactionalForm/State.purs: -------------------------------------------------------------------------------- 1 | module Examples.TransactionalForm.State where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Data.Profunctor.Optics (Transactional) 7 | import Effect.AVar (AVar) 8 | import Effect.Aff.Class (class MonadAff) 9 | import Snap (Snapper') 10 | import Snap.React (affSnapper_) 11 | 12 | type FormData = { name :: String, age :: Int } 13 | type State = Transactional { name :: String, age :: Int } 14 | 15 | initialState :: State 16 | initialState = 17 | { modification: Nothing 18 | , value: { name: "", age: 0 } 19 | } 20 | 21 | snapper :: forall m. MonadAff m => AVar Unit -> m (Snapper' m State) 22 | snapper = affSnapper_ initialState 23 | -------------------------------------------------------------------------------- /examples/transactionalform/src/TransactionalForm/UI.purs: -------------------------------------------------------------------------------- 1 | module Examples.TransactionalForm.UI where 2 | 3 | import Prelude 4 | 5 | import Data.Functor.Variant (SProxy(..)) 6 | import Data.Lens.Record (prop) 7 | import Effect (Effect) 8 | import Examples.TransactionalForm.State (FormData, State) 9 | import React.Basic (JSX) 10 | import React.Basic.DOM as R 11 | import Snap.Component ((#!)) 12 | import Snap.React.Component ((|<), (|~)) 13 | import Snap.React.Component as S 14 | import Snap.Component.SYTC (Cmp') 15 | import Snap.Component.SYTC as C 16 | 17 | form :: Cmp' Effect JSX FormData 18 | form = C.ado 19 | e <- S.edited #! prop (SProxy :: _ "name") 20 | c <- S.counter #! prop (SProxy :: _ "age") 21 | in R.div 22 | |< [ R.input |~ e $ {} 23 | , c 24 | ] 25 | 26 | app :: Cmp' Effect JSX State 27 | app = C.ado 28 | t <- S.transacted 29 | { change: form 30 | , revert: S.button 31 | , save: S.button 32 | } 33 | in t.change 34 | <> t.revert 35 | |< [ R.text "Revert" 36 | ] 37 | <> t.save 38 | |< [ R.text "Save" 39 | ] 40 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | Template • TodoMVC 7 | 8 | 9 | 10 | 11 | 12 |
13 | 14 | 20 | 21 | 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /nix/sources.json: -------------------------------------------------------------------------------- 1 | { 2 | "niv": { 3 | "branch": "master", 4 | "description": "Easy dependency management for Nix projects", 5 | "homepage": "https://github.com/nmattia/niv", 6 | "owner": "nmattia", 7 | "repo": "niv", 8 | "rev": "9d35b9e4837ab88517210b1701127612c260eccf", 9 | "sha256": "0q50xhnm8g2yfyakrh0nly4swyygxpi0a8cb9gp65wcakcgvzvdh", 10 | "type": "tarball", 11 | "url": "https://github.com/nmattia/niv/archive/9d35b9e4837ab88517210b1701127612c260eccf.tar.gz", 12 | "url_template": "https://github.com///archive/.tar.gz" 13 | }, 14 | "nixpkgs": { 15 | "branch": "release-20.03", 16 | "description": "Nix Packages collection", 17 | "homepage": "", 18 | "owner": "NixOS", 19 | "repo": "nixpkgs", 20 | "rev": "f702aab2d9cae14c554a4fa873a0665f99554fc9", 21 | "sha256": "15fzr98ymm64j9wc7slcrlikzgxq3znrmn6mnkz5kks01s9fff8q", 22 | "type": "tarball", 23 | "url": "https://github.com/NixOS/nixpkgs/archive/f702aab2d9cae14c554a4fa873a0665f99554fc9.tar.gz", 24 | "url_template": "https://github.com///archive/.tar.gz" 25 | }, 26 | "nixpkgs-unstable": { 27 | "branch": "nixpkgs-unstable", 28 | "description": "Nix Packages collection", 29 | "homepage": "", 30 | "owner": "NixOS", 31 | "repo": "nixpkgs", 32 | "rev": "cfed29bfcb28259376713005d176a6f82951014a", 33 | "sha256": "034m892hxygminkj326y7l3bp4xhx0v154jcmla7wdfqd23dk5xm", 34 | "type": "tarball", 35 | "url": "https://github.com/NixOS/nixpkgs/archive/cfed29bfcb28259376713005d176a6f82951014a.tar.gz", 36 | "url_template": "https://github.com///archive/.tar.gz" 37 | } 38 | } 39 | -------------------------------------------------------------------------------- /nix/sources.nix: -------------------------------------------------------------------------------- 1 | # This file has been generated by Niv. 2 | 3 | let 4 | 5 | # 6 | # The fetchers. fetch_ fetches specs of type . 7 | # 8 | 9 | fetch_file = pkgs: name: spec: 10 | let 11 | name' = sanitizeName name + "-src"; 12 | in 13 | if spec.builtin or true then 14 | builtins_fetchurl { inherit (spec) url sha256; name = name'; } 15 | else 16 | pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; 17 | 18 | fetch_tarball = pkgs: name: spec: 19 | let 20 | name' = sanitizeName name + "-src"; 21 | in 22 | if spec.builtin or true then 23 | builtins_fetchTarball { name = name'; inherit (spec) url sha256; } 24 | else 25 | pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; 26 | 27 | fetch_git = name: spec: 28 | let 29 | ref = 30 | if spec ? ref then spec.ref else 31 | if spec ? branch then "refs/heads/${spec.branch}" else 32 | if spec ? tag then "refs/tags/${spec.tag}" else 33 | abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; 34 | in 35 | builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; 36 | 37 | fetch_local = spec: spec.path; 38 | 39 | fetch_builtin-tarball = name: throw 40 | ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. 41 | $ niv modify ${name} -a type=tarball -a builtin=true''; 42 | 43 | fetch_builtin-url = name: throw 44 | ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. 45 | $ niv modify ${name} -a type=file -a builtin=true''; 46 | 47 | # 48 | # Various helpers 49 | # 50 | 51 | # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 52 | sanitizeName = name: 53 | ( 54 | concatMapStrings (s: if builtins.isList s then "-" else s) 55 | ( 56 | builtins.split "[^[:alnum:]+._?=-]+" 57 | ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) 58 | ) 59 | ); 60 | 61 | # The set of packages used when specs are fetched using non-builtins. 62 | mkPkgs = sources: system: 63 | let 64 | sourcesNixpkgs = 65 | import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; 66 | hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; 67 | hasThisAsNixpkgsPath = == ./.; 68 | in 69 | if builtins.hasAttr "nixpkgs" sources 70 | then sourcesNixpkgs 71 | else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then 72 | import {} 73 | else 74 | abort 75 | '' 76 | Please specify either (through -I or NIX_PATH=nixpkgs=...) or 77 | add a package called "nixpkgs" to your sources.json. 78 | ''; 79 | 80 | # The actual fetching function. 81 | fetch = pkgs: name: spec: 82 | 83 | if ! builtins.hasAttr "type" spec then 84 | abort "ERROR: niv spec ${name} does not have a 'type' attribute" 85 | else if spec.type == "file" then fetch_file pkgs name spec 86 | else if spec.type == "tarball" then fetch_tarball pkgs name spec 87 | else if spec.type == "git" then fetch_git name spec 88 | else if spec.type == "local" then fetch_local spec 89 | else if spec.type == "builtin-tarball" then fetch_builtin-tarball name 90 | else if spec.type == "builtin-url" then fetch_builtin-url name 91 | else 92 | abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; 93 | 94 | # If the environment variable NIV_OVERRIDE_${name} is set, then use 95 | # the path directly as opposed to the fetched source. 96 | replace = name: drv: 97 | let 98 | saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; 99 | ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; 100 | in 101 | if ersatz == "" then drv else ersatz; 102 | 103 | # Ports of functions for older nix versions 104 | 105 | # a Nix version of mapAttrs if the built-in doesn't exist 106 | mapAttrs = builtins.mapAttrs or ( 107 | f: set: with builtins; 108 | listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) 109 | ); 110 | 111 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 112 | range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); 113 | 114 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 115 | stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); 116 | 117 | # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 118 | stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); 119 | concatMapStrings = f: list: concatStrings (map f list); 120 | concatStrings = builtins.concatStringsSep ""; 121 | 122 | # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 123 | optionalAttrs = cond: as: if cond then as else {}; 124 | 125 | # fetchTarball version that is compatible between all the versions of Nix 126 | builtins_fetchTarball = { url, name ? null, sha256 }@attrs: 127 | let 128 | inherit (builtins) lessThan nixVersion fetchTarball; 129 | in 130 | if lessThan nixVersion "1.12" then 131 | fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 132 | else 133 | fetchTarball attrs; 134 | 135 | # fetchurl version that is compatible between all the versions of Nix 136 | builtins_fetchurl = { url, name ? null, sha256 }@attrs: 137 | let 138 | inherit (builtins) lessThan nixVersion fetchurl; 139 | in 140 | if lessThan nixVersion "1.12" then 141 | fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) 142 | else 143 | fetchurl attrs; 144 | 145 | # Create the final "sources" from the config 146 | mkSources = config: 147 | mapAttrs ( 148 | name: spec: 149 | if builtins.hasAttr "outPath" spec 150 | then abort 151 | "The values in sources.json should not have an 'outPath' attribute" 152 | else 153 | spec // { outPath = replace name (fetch config.pkgs name spec); } 154 | ) config.sources; 155 | 156 | # The "config" used by the fetchers 157 | mkConfig = 158 | { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null 159 | , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) 160 | , system ? builtins.currentSystem 161 | , pkgs ? mkPkgs sources system 162 | }: rec { 163 | # The sources, i.e. the attribute set of spec name to spec 164 | inherit sources; 165 | 166 | # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers 167 | inherit pkgs; 168 | }; 169 | 170 | in 171 | mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } 172 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "scripts": { 3 | "build": "spago build", 4 | "todomvc": "fish scripts/mkExample.fish Examples.TodoMVC.Main todomvc", 5 | "transactionalform": "fish scripts/mkExample.fish Examples.TransactionalForm.Main transactionalform", 6 | "cattron": "fish scripts/mkExample.fish Examples.CatTron.Main cattron", 7 | "reducer": "fish scripts/mkExample.fish Examples.Reducer.Main reducer", 8 | "routing": "fish scripts/mkExample.fish Examples.Routing.Main routing" 9 | }, 10 | "dependencies": { 11 | "react": "^16.13.1", 12 | "react-dom": "^16.13.1", 13 | "todomvc-app-css": "^2.3.0", 14 | "todomvc-common": "^1.0.5" 15 | }, 16 | "devDependencies": { 17 | "parcel-bundler": "^1.12.4", 18 | "purty": "^4.6.0" 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to your new Dhall package-set! 3 | 4 | Below are instructions for how to edit this file for most use 5 | cases, so that you don't need to know Dhall to use it. 6 | 7 | ## Warning: Don't Move This Top-Level Comment! 8 | 9 | Due to how `dhall format` currently works, this comment's 10 | instructions cannot appear near corresponding sections below 11 | because `dhall format` will delete the comment. However, 12 | it will not delete a top-level comment like this one. 13 | 14 | ## Use Cases 15 | 16 | Most will want to do one or both of these options: 17 | 1. Override/Patch a package's dependency 18 | 2. Add a package not already in the default package set 19 | 20 | This file will continue to work whether you use one or both options. 21 | Instructions for each option are explained below. 22 | 23 | ### Overriding/Patching a package 24 | 25 | Purpose: 26 | - Change a package's dependency to a newer/older release than the 27 | default package set's release 28 | - Use your own modified version of some dependency that may 29 | include new API, changed API, removed API by 30 | using your custom git repo of the library rather than 31 | the package set's repo 32 | 33 | Syntax: 34 | Replace the overrides' "{=}" (an empty record) with the following idea 35 | The "//" or "⫽" means "merge these two records and 36 | when they have the same value, use the one on the right:" 37 | ------------------------------- 38 | let override = 39 | { packageName = 40 | upstream.packageName // { updateEntity1 = "new value", updateEntity2 = "new value" } 41 | , packageName = 42 | upstream.packageName // { version = "v4.0.0" } 43 | , packageName = 44 | upstream.packageName // { repo = "https://www.example.com/path/to/new/repo.git" } 45 | } 46 | ------------------------------- 47 | 48 | Example: 49 | ------------------------------- 50 | let overrides = 51 | { halogen = 52 | upstream.halogen // { version = "master" } 53 | , halogen-vdom = 54 | upstream.halogen-vdom // { version = "v4.0.0" } 55 | } 56 | ------------------------------- 57 | 58 | ### Additions 59 | 60 | Purpose: 61 | - Add packages that aren't already included in the default package set 62 | 63 | Syntax: 64 | Replace the additions' "{=}" (an empty record) with the following idea: 65 | ------------------------------- 66 | let additions = 67 | { "package-name" = 68 | mkPackage 69 | [ "dependency1" 70 | , "dependency2" 71 | ] 72 | "https://example.com/path/to/git/repo.git" 73 | "tag ('v4.0.0') or branch ('master')" 74 | , "package-name" = 75 | mkPackage 76 | [ "dependency1" 77 | , "dependency2" 78 | ] 79 | "https://example.com/path/to/git/repo.git" 80 | "tag ('v4.0.0') or branch ('master')" 81 | , etc. 82 | } 83 | ------------------------------- 84 | 85 | Example: 86 | ------------------------------- 87 | let additions = 88 | { benchotron = 89 | mkPackage 90 | [ "arrays" 91 | , "exists" 92 | , "profunctor" 93 | , "strings" 94 | , "quickcheck" 95 | , "lcg" 96 | , "transformers" 97 | , "foldable-traversable" 98 | , "exceptions" 99 | , "node-fs" 100 | , "node-buffer" 101 | , "node-readline" 102 | , "datetime" 103 | , "now" 104 | ] 105 | "https://github.com/hdgarrood/purescript-benchotron.git" 106 | "v7.0.0" 107 | } 108 | ------------------------------- 109 | -} 110 | 111 | let mkPackage = 112 | https://raw.githubusercontent.com/purescript/package-sets/psc-0.13.0-20190626/src/mkPackage.dhall sha256:0b197efa1d397ace6eb46b243ff2d73a3da5638d8d0ac8473e8e4a8fc528cf57 113 | 114 | let upstream = 115 | https://github.com/purescript/package-sets/releases/download/psc-0.13.8-20201007/packages.dhall sha256:35633f6f591b94d216392c9e0500207bb1fec42dd355f4fecdfd186956567b6b 116 | 117 | let overrides = 118 | { effect = 119 | upstream.effect 120 | // { repo = "https://github.com/mcneissue/purescript-effect.git" 121 | , version = "semigroup" 122 | } 123 | } 124 | 125 | let additions = 126 | { record-optics-extra = 127 | let manifest = 128 | https://raw.githubusercontent.com/mcneissue/purescript-record-optics-extra/v0.1.0/spago.dhall sha256:eb00c7cd61401d760b4645899b8d692e623caa475653ded7b8a6dafe2d15e292 129 | 130 | in mkPackage 131 | manifest.dependencies 132 | "https://github.com/mcneissue/purescript-record-optics-extra.git" 133 | "v0.1.0" 134 | , profunctor-traverse = 135 | let manifest = 136 | https://raw.githubusercontent.com/mcneissue/purescript-profunctor-traverse/v0.1.0/spago.dhall sha256:7136013475629bdb7a1e260a218eee5ed51b3cbb79d3ee82ef82db57a2f42a1b 137 | 138 | in mkPackage 139 | manifest.dependencies 140 | "https://github.com/mcneissue/purescript-profunctor-traverse.git" 141 | "v0.1.0" 142 | , profunctor-extra = 143 | let manifest = 144 | https://raw.githubusercontent.com/mcneissue/purescript-profunctor-extra/v0.1.0/spago.dhall sha256:9052f2ac1e76d2d564da57333276ad2d7e83c8ff0b21d94dbebacfe5dce42489 145 | 146 | in mkPackage 147 | manifest.dependencies 148 | "https://github.com/mcneissue/purescript-profunctor-extra.git" 149 | "v0.1.0" 150 | } 151 | 152 | in upstream // overrides // additions 153 | -------------------------------------------------------------------------------- /scripts/mkDocs.fish: -------------------------------------------------------------------------------- 1 | set root (realpath (dirname (status --current-filename)))/.. 2 | set currentBranch (git branch --show-current) 3 | set msg "Generated docs "(date "+%m/%d/%y %T")" for branch $currentBranch" 4 | 5 | git checkout gh-pages 6 | or exit 7 | 8 | echo Deleting old documentation in $root/docs 9 | 10 | rm -rf $root/docs 11 | 12 | cd $root/examples 13 | spago docs 14 | 15 | echo Copying generated documentation to $root/docs 16 | rsync -a $root/examples/generated-docs/html/ $root/docs/ 17 | 18 | git add -f $root/docs/. 19 | 20 | git commit -m $msg 21 | and git push 22 | 23 | git checkout $currentBranch 24 | -------------------------------------------------------------------------------- /scripts/mkExample.fish: -------------------------------------------------------------------------------- 1 | set root (realpath (dirname (status --current-filename)))/.. 2 | cd $root/examples 3 | spago bundle-app --main $argv[1] --to $root/bundle/$argv[2]/bundle.js 4 | cd $root 5 | npx parcel $root/examples/$argv[2]/index.html 6 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | sources = import ./nix/sources.nix; 3 | pkgs = import sources.nixpkgs-unstable {}; 4 | in 5 | pkgs.mkShell { 6 | buildInputs = with pkgs; [ 7 | purescript 8 | nodejs 9 | spago 10 | fish 11 | ]; 12 | } 13 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | -} 5 | { sources = 6 | [ "src/**/*.purs", "test/**/*.purs" ] 7 | , name = 8 | "snap" 9 | , dependencies = 10 | [ "effect" 11 | , "console" 12 | , "profunctor-lenses" 13 | , "react" 14 | , "react-basic" 15 | , "react-basic-dom" 16 | , "avar" 17 | , "variant" 18 | , "typelevel-prelude" 19 | , "heterogeneous" 20 | , "const" 21 | , "record" 22 | , "record-optics-extra" 23 | , "filterable" 24 | , "debug" 25 | , "type-equality" 26 | , "affjax" 27 | , "argonaut" 28 | , "routing-duplex" 29 | , "routing" 30 | , "profunctor-traverse" 31 | , "profunctor-extra" 32 | , "web-storage" 33 | , "simple-json" 34 | , "kishimen" 35 | ] 36 | , packages = 37 | ./packages.dhall 38 | , version = "v0.1.0" 39 | , repository = "https://github.com/mcneissue/purescript-snap" 40 | } 41 | -------------------------------------------------------------------------------- /src/Data/Profunctor/Optics.purs: -------------------------------------------------------------------------------- 1 | module Data.Profunctor.Optics where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.State (get, runState) 6 | import Data.Array (zipWith) 7 | import Data.Either (Either(..), either) 8 | import Data.Filterable (class Filterable, filter) 9 | import Data.Foldable (class Foldable, and, length) 10 | import Data.Lens (Iso', Lens, Lens', Traversal, lens, set, traverseOf, view, (^..)) 11 | import Data.List ((!!)) 12 | import Data.List as L 13 | import Data.Maybe (Maybe(..), fromMaybe, isJust) 14 | import Data.Profunctor (class Profunctor, dimap, lcmap) 15 | import Data.Tuple (fst) 16 | 17 | partsOf :: forall s t a. Traversal s t a a -> Lens s t (L.List a) (L.List a) 18 | partsOf t = lens (_ ^.. t) (\s as -> fst $ flip runState 0 $ traverseOf t (go as) s) 19 | where 20 | go as a = do 21 | i <- get 22 | pure $ case as !! i of 23 | Nothing -> a 24 | Just a' -> a' 25 | 26 | by :: forall a. (a -> Boolean) -> Iso' a (Either a a) 27 | by f = dimap (\v -> if f v then Left v else Right v) (either identity identity) 28 | 29 | all :: 30 | forall t a. 31 | Functor t => 32 | Foldable t => 33 | HeytingAlgebra a => 34 | Eq a => 35 | Lens' (t a) a 36 | all = lens and (\s b -> if and s == b then s else b <$ s) 37 | 38 | overArray :: forall s t a b. Lens s t a b -> Lens (Array s) (Array t) (Array a) (Array b) 39 | overArray l = lens (map $ view l) (zipWith $ flip (set l)) 40 | 41 | type Getter s a = forall p x. Profunctor p => p a x -> p s x 42 | 43 | countBy :: forall f x. Filterable f => Foldable f => (x -> Boolean) -> Getter (f x) Int 44 | countBy p = lcmap (filter p >>> length) 45 | 46 | data Edit s = Change s | Save | Revert 47 | type Transactional s = { value :: s, modification :: Maybe s } 48 | 49 | atomically :: forall s. Lens (Transactional s) (Transactional s) s (Edit s) 50 | atomically = lens view (flip update) 51 | where 52 | view { value, modification } = fromMaybe value modification 53 | update (Change v) { value, modification } = { value, modification: Just v } 54 | update Revert { value, modification } = { value, modification: Nothing } 55 | update Save s@{ value, modification } = { value: view s, modification: Nothing } 56 | 57 | isDirty :: forall s. Lens' (Transactional s) Boolean 58 | isDirty = lens view (flip update) 59 | where 60 | view { modification } = isJust modification 61 | update true { value, modification } = { value, modification: Just $ fromMaybe value modification } 62 | update false { value, modification } = { value, modification: Nothing } 63 | -------------------------------------------------------------------------------- /src/Data/Record/Append.purs: -------------------------------------------------------------------------------- 1 | module Data.Record.Append where 2 | 3 | import Prelude 4 | 5 | import Data.Functor.Variant (SProxy(..)) 6 | import Data.Symbol (class IsSymbol) 7 | import Prim.Row as Row 8 | import Prim.RowList (kind RowList) 9 | import Prim.RowList as RowList 10 | import Record as Record 11 | import Type.Prelude (class RowToList, RLProxy(..)) 12 | 13 | -- @natefaubion in the #purescript room came up with this much simpler implementation of squishy append for records 14 | -- https://gist.github.com/natefaubion/d2a6f1965fdaa01f0eb49bd753ccaa4a 15 | 16 | class AppendRecord r1 r2 r3 | r1 r2 -> r3, r2 r3 -> r1, r1 r3 -> r2 where 17 | append :: { | r1 } -> { | r2 } -> { | r3 } 18 | 19 | instance appendRecordImpl :: 20 | ( Row.Union r1 r2 rx 21 | , RowToList rx rl 22 | , AppendRowList rl r1 r2 () r3 23 | , Row.Union r3 rx r4 24 | , Row.Nub r4 r5 25 | ) => 26 | AppendRecord r1 r2 r5 where 27 | append a b = 28 | Record.nub (Record.union (appendRL (RLProxy :: RLProxy rl) {} a b) (Record.union a b)) 29 | 30 | class AppendRowList (rl :: RowList) r1 r2 ri ro | rl r1 r2 ri -> ro where 31 | appendRL :: RLProxy rl -> { | ri } -> { | r1 } -> { | r2 } -> { | ro } 32 | 33 | instance appendRowList1 :: 34 | ( AppendRowList rest r1 r2 ri' ro 35 | , IsSymbol sym 36 | , Row.Lacks sym ri 37 | , Row.Cons sym a ri ri' 38 | , Row.Cons sym a rx1 r1 39 | , Row.Cons sym a rx2 r2 40 | , Semigroup a 41 | ) => 42 | AppendRowList (RowList.Cons sym a (RowList.Cons sym a rest)) r1 r2 ri ro where 43 | appendRL _ ri a b = 44 | appendRL 45 | (RLProxy :: RLProxy rest) 46 | (Record.insert sym (Record.get sym a <> Record.get sym b) ri :: { | ri' }) 47 | a b 48 | where 49 | sym = SProxy :: SProxy sym 50 | else instance appendRowList2 :: 51 | ( AppendRowList rest r1 r2 ri ro 52 | ) => 53 | AppendRowList (RowList.Cons sym a rest) r1 r2 ri ro where 54 | appendRL _ ri a b = 55 | appendRL (RLProxy :: RLProxy rest) ri a b 56 | else instance appendRowList3 :: 57 | AppendRowList RowList.Nil r1 r2 ri ri where 58 | appendRL _ ri _ _ = ri 59 | -------------------------------------------------------------------------------- /src/Data/Record/Choose.purs: -------------------------------------------------------------------------------- 1 | module Data.Record.Choose (HasField, hasField, getField, choose) where 2 | 3 | import Prelude 4 | 5 | import Data.Symbol (class IsSymbol, SProxy, reflectSymbol) 6 | import Data.Variant (Variant) 7 | import Data.Variant.Internal (VariantRep(..)) 8 | import Prim.Row (class Cons) 9 | import Record.Unsafe (unsafeGet) 10 | import Unsafe.Coerce (unsafeCoerce) 11 | 12 | newtype HasField (r :: # Type) = HasField String 13 | 14 | hasField :: forall s a r' r. IsSymbol s => Cons s a r' r => SProxy s -> HasField r 15 | hasField s = HasField $ reflectSymbol s 16 | 17 | getField :: forall r. HasField r -> String 18 | getField (HasField s) = s 19 | 20 | choose :: forall r. HasField r -> Record r -> Variant r 21 | choose (HasField k) r = coerceV $ VariantRep { type: k, value: unsafeGet k r } 22 | where 23 | coerceV :: forall a. VariantRep a -> Variant r 24 | coerceV = unsafeCoerce 25 | -------------------------------------------------------------------------------- /src/Data/Record/Extras.purs: -------------------------------------------------------------------------------- 1 | module Data.Record.Extras where 2 | 3 | import Prim.Row (class Lacks, class Cons) 4 | import Data.Symbol (SProxy, class IsSymbol) 5 | import Record (insert) 6 | 7 | singleton :: forall s v r. 8 | IsSymbol s => 9 | Lacks s () => 10 | Cons s v () r => 11 | SProxy s -> v -> { | r } 12 | singleton s v = insert s v {} 13 | -------------------------------------------------------------------------------- /src/Snap.purs: -------------------------------------------------------------------------------- 1 | module Snap (module Snap, module C, module S, module T) where 2 | 3 | import Prelude 4 | 5 | import Snap.Component as C 6 | import Snap.Snapper as S 7 | import Snap.Target as T 8 | 9 | import Snap.Component.SYTC (Cmp) 10 | import Snap.Snapper (Snapper(..)) 11 | import Snap.Target (Target(..)) 12 | 13 | encapsulate :: forall m v s u x y. Functor m => Snapper m u s -> Cmp m v s u -> Cmp m (m v) x y 14 | encapsulate (Snapper { get, put }) cmp _ _ = get <#> cmp put 15 | 16 | snap :: forall m v x 17 | . Monad m 18 | => Cmp m v Unit Void 19 | -> Target m v 20 | -> m x 21 | snap cmp t = loop t 22 | where 23 | v = cmp absurd unit 24 | loop (Target render) = do 25 | t' <- render v 26 | loop t' 27 | -------------------------------------------------------------------------------- /src/Snap/Component.purs: -------------------------------------------------------------------------------- 1 | module Snap.Component where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either) 6 | import Data.Newtype (class Newtype, un, under) 7 | import Data.Profunctor (class Profunctor) 8 | import Data.Profunctor.Choice (class Choice) 9 | import Data.Profunctor.Lazy (class Lazy) 10 | import Data.Profunctor.Monoidal (class Monoidal, class Semigroupal, class Unital) 11 | import Data.Profunctor.Strong (class Strong) 12 | import Data.Tuple (Tuple) 13 | import Data.Tuple.Nested ((/\)) 14 | import Snap.Component.SYTC (Cmp) 15 | import Snap.Component.SYTC as C 16 | 17 | -- Profunctor wrapper 18 | newtype PComponent m v s u 19 | = PComponent (Cmp m v s u) 20 | 21 | derive instance newtypeComponent :: Newtype (PComponent m v s u) _ 22 | 23 | ρ :: forall m v s u. Cmp m v s u -> PComponent m v s u 24 | ρ = PComponent 25 | 26 | type PComponent' m v s 27 | = PComponent m v s s 28 | 29 | instance componentLazy :: Lazy (PComponent m v) where 30 | defer f = ρ $ actual (un ρ <<< f) 31 | where 32 | actual = C.defer 33 | 34 | instance semigroupComponent :: Semigroup v => Semigroup (PComponent m v s u) where 35 | append a b = ρ $ actual (un ρ a) (un ρ b) 36 | where 37 | actual = C.append 38 | 39 | instance monoidComponent :: Monoid v => Monoid (PComponent m v s u) where 40 | mempty = ρ actual 41 | where 42 | actual = C.mempty 43 | 44 | instance profunctorComponent :: Profunctor (PComponent m v) where 45 | dimap f g cmp = ρ $ actual f g (un ρ cmp) 46 | where 47 | actual = C.dimap 48 | 49 | instance strongComponent :: Strong (PComponent m v) where 50 | first = ρ <<< actual <<< un ρ 51 | where 52 | actual = C.first 53 | second = ρ <<< actual <<< un ρ 54 | where 55 | actual = C.second 56 | 57 | instance choiceComponent :: Monoid v => Choice (PComponent m v) where 58 | left = ρ <<< actual <<< un ρ 59 | where 60 | actual = C.left 61 | right = ρ <<< actual <<< un ρ 62 | where 63 | actual = C.right 64 | 65 | instance eetSemigroupal :: Semigroupal (->) Either Either Tuple (PComponent m v) where 66 | pzip (f /\ g) = ρ $ actual (un ρ f) (un ρ g) 67 | where 68 | actual = C.demux 69 | 70 | instance eetUnital :: Unital (->) Void Void Unit (PComponent m v) where 71 | punit _ = ρ actual 72 | where 73 | actual = C.initial 74 | 75 | instance eetMonoidal :: Monoidal (->) Either Void Either Void Tuple Unit (PComponent m v) 76 | 77 | instance tetSemigroupal :: Semigroup v => Semigroupal (->) Tuple Either Tuple (PComponent m v) where 78 | pzip (f /\ g) = ρ $ actual (un ρ f) (un ρ g) 79 | where 80 | actual = C.switch 81 | 82 | instance tetUnital :: Monoid v => Unital (->) Unit Void Unit (PComponent m v) where 83 | punit _ = ρ actual 84 | where 85 | actual = C.poly 86 | 87 | instance tetMonoidal :: Monoid v => Monoidal (->) Tuple Unit Either Void Tuple Unit (PComponent m v) 88 | 89 | focus :: forall m v s u x y. Newtype x y => (PComponent m v s u -> x) -> Cmp m v s u -> y 90 | focus = under ρ 91 | 92 | infixl 1 focus as $! 93 | 94 | flippedFocus :: forall m v s u x y. Newtype x y => Cmp m v s u -> (PComponent m v s u -> x) -> y 95 | flippedFocus = flip focus 96 | 97 | infixl 1 flippedFocus as #! 98 | 99 | -- Monad wrapper 100 | newtype MComponent s u m v 101 | = MComponent (Cmp m v s u) 102 | 103 | derive instance newtypeMComponent :: Newtype (MComponent s u m v) _ 104 | 105 | μ :: forall s u m v. Cmp m v s u -> MComponent s u m v 106 | μ = MComponent 107 | 108 | instance functorMComponent :: Functor (MComponent s u m) where 109 | map f = μ <<< actual f <<< un μ 110 | where 111 | actual = C.map 112 | 113 | instance applyMComponent :: Apply (MComponent s u m) where 114 | apply fab fa = μ $ un μ fab `actual` un μ fa 115 | where 116 | actual = C.apply 117 | 118 | instance bindMComponent :: Bind (MComponent s u m) where 119 | bind ma amb = μ $ (un μ ma) `actual` (amb >>> un μ) 120 | where 121 | actual = C.bind 122 | 123 | instance applicativeMComponent :: Applicative (MComponent s u m) where 124 | pure = μ <<< actual 125 | where 126 | actual = C.pure 127 | 128 | newtype CComponent m s u c a b 129 | = CComponent (Cmp m (c a b) s u) 130 | 131 | derive instance newtypeCComponent :: Newtype (CComponent m s u c a b) _ 132 | 133 | -- Category wrapper 134 | κ :: forall m s u c a b. Cmp m (c a b) s u -> CComponent m s u c a b 135 | κ = CComponent 136 | 137 | instance semigroupoidCComponent :: Semigroupoid c => Semigroupoid (CComponent m s u c) where 138 | compose bc ab = κ $ actual (un κ bc) (un κ ab) 139 | where 140 | actual = C.compose 141 | 142 | instance categoryMComponent :: Category c => Category (CComponent m u s c) where 143 | identity = κ $ actual 144 | where 145 | actual = C.identity 146 | -------------------------------------------------------------------------------- /src/Snap/Component/SYTC.purs: -------------------------------------------------------------------------------- 1 | module Snap.Component.SYTC where 2 | 3 | import Control.Applicative (class Applicative) 4 | import Control.Apply (lift2) as A 5 | import Control.Category (class Category, class Semigroupoid, (<<<), (>>>)) 6 | import Data.Compactable (compact, class Compactable) 7 | import Data.Either (Either(..), either) 8 | import Data.Eq ((==)) 9 | import Data.FoldableWithIndex (foldMapWithIndex, class FoldableWithIndex) 10 | import Data.FunctorWithIndex (mapWithIndex, class FunctorWithIndex) 11 | import Data.Functor.Compose (Compose(..)) 12 | import Data.Maybe (Maybe(..)) 13 | import Data.Newtype (un) 14 | import Data.Tuple (Tuple(..), curry, fst, snd, swap, uncurry) 15 | import Data.Tuple.Nested (type (/\), (/\)) 16 | import Prelude (Unit, unit, class Semigroup, class Monoid, class Eq, (<>), ($), (>>=), flip, const, Void, absurd) 17 | import Prelude as P 18 | 19 | type Cmp m v s u 20 | = (u -> m Unit) -> s -> v 21 | 22 | type Cmp' m v s 23 | = Cmp m v s s 24 | 25 | -- Lazy2 26 | defer :: forall m v s u. (Unit -> Cmp m v s u) -> Cmp m v s u 27 | defer f set s = f unit set s 28 | 29 | -- Semigroup 30 | append :: forall m v s u. Semigroup v => Cmp m v s u -> Cmp m v s u -> Cmp m v s u 31 | append = (<>) 32 | 33 | -- Monoid 34 | mempty :: forall m v s u. Monoid v => Cmp m v s u 35 | mempty = P.mempty 36 | 37 | -- Profunctor 38 | dimap :: forall m v a' a b b'. (a' -> a) -> (b -> b') -> Cmp m v a b -> Cmp m v a' b' 39 | dimap f g cmp u s = cmp (u <<< g) (f s) 40 | 41 | lcmap :: forall m v s s' u. (s -> s') -> Cmp m v s' u -> Cmp m v s u 42 | lcmap f = dimap f P.identity 43 | 44 | rmap :: forall m v s u u'. (u -> u') -> Cmp m v s u -> Cmp m v s u' 45 | rmap = dimap P.identity 46 | 47 | -- Strong 48 | first :: forall m v s u c. Cmp m v s u -> Cmp m v (Tuple s c) (Tuple u c) 49 | first cmp u s = let c = snd s in cmp (u <<< flip Tuple c) (fst s) 50 | 51 | second :: forall m v s u c. Cmp m v s u -> Cmp m v (Tuple c s) (Tuple c u) 52 | second = dimap swap swap <<< first 53 | 54 | -- Choice 55 | left :: forall m v s u c. Monoid v => Cmp m v s u -> Cmp m v (Either s c) (Either u c) 56 | left cmp set = either (cmp $ set <<< Left) (const P.mempty) 57 | 58 | right :: forall m v s u c. Monoid v => Cmp m v s u -> Cmp m v (Either c s) (Either c u) 59 | right = dimap flipEither flipEither <<< left 60 | where 61 | flipEither :: forall a b. Either a b -> Either b a 62 | flipEither (Left x) = Right x 63 | flipEither (Right x) = Left x 64 | 65 | -- Contrahoistable 66 | contraHoist :: forall v s u m n. (n Unit -> m Unit) -> Cmp m v s u -> Cmp n v s u 67 | contraHoist f cmp set s = cmp (f <<< set) s 68 | 69 | -- Functor 70 | map :: forall m u s a b. (a -> b) -> Cmp m a s u -> Cmp m b s u 71 | map = compose2 72 | where 73 | compose2 = (<<<) <<< (<<<) 74 | 75 | infixl 4 map as <$>! 76 | 77 | mapFlipped :: forall m u s a b. Cmp m a s u -> (a -> b) -> Cmp m b s u 78 | mapFlipped = flip map 79 | 80 | infixr 4 mapFlipped as <#>! 81 | 82 | -- Apply 83 | apply :: forall m u s a b. Cmp m (a -> b) s u -> Cmp m a s u -> Cmp m b s u 84 | apply = lift2 ($) 85 | 86 | infixl 4 apply as <*>! 87 | 88 | lift2 :: forall m s u a b c. (a -> b -> c) -> Cmp m a s u -> Cmp m b s u -> Cmp m c s u 89 | lift2 f c1 c2 = un Compose $ A.lift2 f (Compose c1) (Compose c2) 90 | 91 | -- Applicative 92 | pure :: forall m v s u. v -> Cmp m v s u 93 | pure v _ _ = v 94 | 95 | -- Bind, Monad 96 | -- NB: All this currying/uncurrying nonsense is going on because I can't figure out 97 | -- a way to express (without newtype overhead) that fn2.bind = (readert fn).bind 98 | bind :: forall m s u a b. Cmp m a s u -> (a -> Cmp m b s u) -> Cmp m b s u 99 | bind c f = curry $ (uncurry c) >>= (f >>> uncurry) 100 | 101 | infixl 1 bind as >>=! 102 | 103 | -- Semigroupoid 104 | compose :: forall m s u c x y z. Semigroupoid c => Cmp m (c y z) s u -> Cmp m (c x y) s u -> Cmp m (c x z) s u 105 | compose = lift2 (<<<) 106 | 107 | infixl 9 compose as << Cmp m (c x y) s u -> Cmp m (c y z) s u -> Cmp m (c x z) s u 110 | composeFlipped = flip compose 111 | 112 | infixr 9 composeFlipped as >>>! 113 | 114 | -- Category 115 | identity :: forall m s u c x. Category c => Cmp m (c x x) s u 116 | identity = pure P.identity 117 | 118 | -- Contrafilterable 119 | lcmapMaybe :: forall m v s s' u. Monoid v => (s -> Maybe s') -> Cmp m v s' u -> Cmp m v s u 120 | lcmapMaybe p cmp put s = case p s of 121 | Nothing -> P.mempty 122 | Just s' -> cmp put s' 123 | 124 | -- Demux 125 | demux :: forall m v a b c d. Cmp m v a b -> Cmp m v c d -> Cmp m v (Either a c) (Either b d) 126 | demux f g set = either (f $ set <<< Left) (g $ set <<< Right) 127 | 128 | infixr 4 demux as || 129 | 130 | -- Demuxative 131 | initial :: forall m v a. Cmp m v Void a 132 | initial = const absurd 133 | 134 | -- Switch 135 | switch :: forall m v s s' u u'. Semigroup v => Cmp m v s u -> Cmp m v s' u' -> Cmp m v (Tuple s s') (Either u u') 136 | switch c c' set (Tuple s s') = c (set <<< Left) s <> c' (set <<< Right) s' 137 | 138 | infixr 5 switch as &| 139 | 140 | -- Switchable 141 | poly :: forall m v s u. Monoid v => Cmp m v s u 142 | poly = mempty 143 | 144 | -- Codemux 145 | codemux :: forall m v s1 s2 u1 u2. Applicative m => Monoid v => Cmp m v (Either s1 s2) (Either u1 u2) -> (Cmp m v s1 u1 /\ Cmp m v s2 u2) 146 | codemux cmp = cmp1 /\ cmp2 147 | where 148 | cmp1 put s = cmp (either put (const $ P.pure unit)) (Left s) 149 | cmp2 put s = cmp (either (const $ P.pure unit) put) (Right s) 150 | 151 | -- Random stuff 152 | handle :: forall m v s u. (u -> s -> s) -> Cmp m v s u -> Cmp' m v s 153 | handle f c set s = c (flip f s >>> set) s 154 | 155 | handle_ :: forall m v s u. (s -> s) -> Cmp m v s u -> Cmp' m v s 156 | handle_ f = handle (const f) 157 | 158 | when :: forall m v s u. Applicative m => (u -> Boolean) -> Cmp m v s u -> Cmp m v s u 159 | when f c set = c set' 160 | where 161 | set' u = if f u then set u else P.pure unit 162 | 163 | echo :: forall m s u. Cmp m s s u 164 | echo _ s = s 165 | 166 | withered :: forall i f m v x 167 | . Eq i 168 | => FoldableWithIndex i f 169 | => FunctorWithIndex i f 170 | => Compactable f 171 | => Monoid v 172 | => Cmp' m v (Maybe x) -> Cmp' m v (f x) 173 | withered cmp u s = foldMapWithIndex (\k -> cmp (go k) <<< Just) s 174 | where 175 | go k mx = u $ compact $ mapWithIndex (\i x -> if k == i then mx else Just x) s 176 | 177 | -------------------------------------------------------------------------------- /src/Snap/React.purs: -------------------------------------------------------------------------------- 1 | module Snap.React (module Snap.React, module C, module S, module T) where 2 | 3 | import Snap.React.Component as C 4 | import Snap.React.Snapper as S 5 | import Snap.React.Target as T 6 | -------------------------------------------------------------------------------- /src/Snap/React/Component.purs: -------------------------------------------------------------------------------- 1 | module Snap.React.Component where 2 | 3 | import Prelude 4 | 5 | import Data.Functor.Variant (SProxy(..)) 6 | import Data.Lens.Record (prop) 7 | import Data.Maybe (Maybe, maybe) 8 | import Data.Profunctor as P 9 | import Data.Profunctor.Optics (Edit(..), Transactional, atomically) 10 | import Data.Record.Append (class AppendRecord) 11 | import Data.Record.Append as RO 12 | import Data.Record.Extras as RE 13 | import Data.Symbol (class IsSymbol) 14 | import Effect (Effect) 15 | import Effect.Aff.Compat (EffectFn1) 16 | import Prim.Row (class Cons, class Lacks, class Union) 17 | import React.Basic (JSX) as R 18 | import React.Basic.DOM (button, div, img, input, text) as R 19 | import React.Basic.DOM (Props_button, Props_input, Props_img) 20 | import React.Basic.DOM.Events (key, targetChecked, targetValue) as R 21 | import React.Basic.Events (EventFn, SyntheticEvent) 22 | import React.Basic.Events (handler, handler_) as R 23 | import Record as RD 24 | import Snap.Component ((#!), ($!)) 25 | import Snap.Component.SYTC (Cmp, Cmp') 26 | import Snap.Component.SYTC as C 27 | 28 | -- Some convenience things 29 | unionWith :: forall p q r. Union p q r => Record q -> Record p -> Record r 30 | unionWith = flip RD.union 31 | 32 | infixl 7 unionWith as :+: 33 | 34 | infixl 7 compose as |~ 35 | 36 | setProps :: forall a b c x. Union a b c => (Record c -> x) -> Record b -> Record a -> x 37 | setProps f v = f <<< unionWith v 38 | 39 | infixl 7 setProps as |= 40 | 41 | setChildren :: forall x. ({ children :: Array R.JSX } -> x) -> Array R.JSX -> x 42 | setChildren f cs = f { children: cs } 43 | 44 | infixr 6 setChildren as |< 45 | 46 | setChild :: forall x. ({ children :: Array R.JSX } -> x) -> R.JSX -> x 47 | setChild f c = setChildren f [c] 48 | 49 | infixr 6 setChild as |- 50 | 51 | -- Extensible components 52 | type Affordance r s u = forall ri ro. AppendRecord ri r ro => Cmp Effect ({ | ri } -> { | ro }) s u 53 | type Affordance' r s = Affordance r s s 54 | 55 | -- Graft a boolean state to whether a particular element is hovered 56 | hovering :: forall s. 57 | Affordance 58 | ( onMouseLeave :: EffectFn1 SyntheticEvent Unit 59 | , onMouseOver :: EffectFn1 SyntheticEvent Unit ) 60 | s Boolean 61 | hovering set _ = flip RO.append { onMouseOver, onMouseLeave } 62 | where 63 | onMouseOver = R.handler_ $ set true 64 | onMouseLeave = R.handler_ $ set false 65 | 66 | -- Emit unit values in response to click events on an element 67 | clicked :: forall s. 68 | Affordance 69 | ( onClick :: EffectFn1 SyntheticEvent Unit ) 70 | s Unit 71 | clicked set _ = flip RO.append { onClick } 72 | where 73 | onClick = R.handler_ $ set unit 74 | 75 | -- Graft a boolean state to whether a particular element is focused 76 | -- TODO: Make this properly settable (right now we just ignore s) 77 | focused :: forall s. 78 | Affordance 79 | ( onBlur :: EffectFn1 SyntheticEvent Unit 80 | , onFocus :: EffectFn1 SyntheticEvent Unit ) 81 | s Boolean 82 | focused set _ = flip RO.append { onFocus, onBlur } 83 | where 84 | onFocus = R.handler_ $ set true 85 | onBlur = R.handler_ $ set false 86 | 87 | -- An affordance for things that have some state that can be modified 88 | -- through some event 89 | altered :: forall attr attr' k e. 90 | -- The part of the attribute dictionary that models the input element's value 91 | IsSymbol k => 92 | Lacks k () => 93 | Cons k e () attr => 94 | 95 | -- The rest of the attribute dictionary 96 | AppendRecord 97 | attr 98 | ( onChange :: EffectFn1 SyntheticEvent Unit ) 99 | attr' => 100 | 101 | SProxy k -> 102 | EventFn SyntheticEvent (Maybe e) -> 103 | Affordance' attr' e 104 | altered k e set s ri = RO.append ri (RO.append (RE.singleton k s) { onChange }) 105 | where 106 | onChange = R.handler e $ maybe (pure unit) set 107 | 108 | edited :: 109 | Affordance 110 | ( onChange :: EffectFn1 SyntheticEvent Unit 111 | , value :: String ) 112 | String String 113 | edited = altered _value R.targetValue 114 | where 115 | _value = SProxy :: SProxy "value" 116 | 117 | checked :: 118 | Affordance 119 | ( onChange :: EffectFn1 SyntheticEvent Unit 120 | , checked :: Boolean ) 121 | Boolean Boolean 122 | checked = altered _checked R.targetChecked 123 | where 124 | _checked = SProxy :: SProxy "checked" 125 | 126 | -- Emit characters in response to keypress events on an element 127 | keypressed :: forall s. 128 | Affordance 129 | ( onKeyUp :: EffectFn1 SyntheticEvent Unit ) 130 | s String 131 | keypressed set _ = flip RO.append { onKeyUp } 132 | where 133 | onKeyUp = R.handler R.key $ maybe (pure unit) set 134 | 135 | type Keypress = forall s. 136 | Affordance 137 | ( onKeyUp :: EffectFn1 SyntheticEvent Unit ) 138 | s String 139 | 140 | -- Some common keypresses you might want to look for 141 | enterPressed :: Keypress 142 | enterPressed = keypressed # C.when ((==) "Enter") 143 | 144 | escapePressed :: Keypress 145 | escapePressed = keypressed # C.when ((==) "Escape") 146 | 147 | tabPressed :: Keypress 148 | tabPressed = keypressed # C.when ((==) "Tab") 149 | 150 | -- Given 151 | -- 152 | -- 1. change: an affordance that emits values 153 | -- 2. revert: an affordance that emits anything 154 | -- 3. save: an affordance that emits anything 155 | -- 156 | -- produces an affordance that emits transactional edits of the given value 157 | transacted :: forall vr vs vc s m. 158 | { revert :: Cmp m vr s _ 159 | , save :: Cmp m vs s _ 160 | , change :: Cmp' m vc s 161 | | _ 162 | } -> 163 | Cmp' m { revert :: vr, save :: vs, change :: vc } (Transactional s) 164 | transacted { change, save, revert } = atomically $! C.ado 165 | c <- change #! P.rmap Change 166 | s <- save #! P.rmap (const Save) 167 | r <- revert #! P.rmap (const Revert) 168 | in { change: c, save: s, revert: r } 169 | 170 | -- A button that accepts no state and emits unit values 171 | button :: forall s ri ro x. 172 | AppendRecord ri ( onClick :: EffectFn1 SyntheticEvent Unit ) ro => 173 | Union ro x Props_button => 174 | Cmp Effect ({ | ri } -> R.JSX) s Unit 175 | button = C.ado 176 | c <- clicked 177 | in R.button |~ c 178 | 179 | -- A text node that displays a string and never emits 180 | text :: forall m u. Cmp m R.JSX String u 181 | text _ = R.text 182 | 183 | -- A counter that manages a number 184 | counter :: Cmp' Effect R.JSX Int 185 | counter = C.ado 186 | inc <- button # C.handle_ (_ + 1) 187 | dec <- button # C.handle_ (_ - 1) 188 | txt <- text # C.lcmap show 189 | in R.div 190 | |< [ inc |- R.text "+" 191 | , txt 192 | , dec |- R.text "-" 193 | ] 194 | 195 | type InputState 196 | = { focused :: Boolean, value :: String } 197 | 198 | -- An input that manages a boolean value representing whether it is focused, 199 | -- and a string value representing its contents 200 | input :: forall a b c. 201 | AppendRecord a 202 | ( onBlur :: EffectFn1 SyntheticEvent Unit 203 | , onFocus :: EffectFn1 SyntheticEvent Unit ) 204 | b => 205 | AppendRecord b 206 | ( onChange :: EffectFn1 SyntheticEvent Unit 207 | , value :: String ) 208 | c => 209 | Union c _ Props_input => 210 | Cmp' Effect ({ | a } -> R.JSX) { focused :: Boolean, value :: String } 211 | input = C.ado 212 | focus <- focused #! prop (SProxy :: SProxy "focused") 213 | change <- edited #! prop (SProxy :: SProxy "value") 214 | in R.input |~ change |~ focus 215 | 216 | -- A checkbox that manages a boolean 217 | checkbox :: forall a b c. 218 | AppendRecord a 219 | ( onChange :: EffectFn1 SyntheticEvent Unit 220 | , checked :: Boolean ) 221 | b => 222 | Union b ( type :: String ) c => 223 | Union c _ Props_input => 224 | Cmp' Effect ({ | a } -> R.JSX) Boolean 225 | checkbox = C.ado 226 | change <- checked 227 | in R.input |= { type: "checkbox" } |~ change 228 | where 229 | _checked = SProxy :: SProxy "checked" 230 | 231 | -- An img tag that accepts a URL and never emits 232 | img :: forall a b x u. 233 | Union a ( src :: String) b => 234 | Union b x Props_img => 235 | Cmp Effect ({ | a } -> R.JSX) String u 236 | img _ src = R.img |= { src } 237 | 238 | -- A component that accepts a boolean and renders a provided 239 | -- element if it is true 240 | conditional :: forall m u. Cmp m (R.JSX -> R.JSX) Boolean u 241 | conditional _ = if _ then identity else const mempty 242 | 243 | -- Wrapper around text that can be attached to show-able things 244 | debug :: forall m s u. Show s => Cmp m R.JSX s u 245 | debug = C.lcmap show text 246 | -------------------------------------------------------------------------------- /src/Snap/React/Snapper.purs: -------------------------------------------------------------------------------- 1 | module Snap.React.Snapper where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either) 6 | import Data.Maybe (Maybe) 7 | import Data.Profunctor (dimap) 8 | import Effect.AVar (AVar) 9 | import Effect.Aff.AVar as AVar 10 | import Effect.Aff.Class (class MonadAff, liftAff) 11 | import Effect.Class (class MonadEffect, liftEffect) 12 | import Effect.Ref (Ref) 13 | import Effect.Ref as Ref 14 | import Routing.Duplex (RouteDuplex, parse, print) 15 | import Routing.Duplex.Parser (RouteError) 16 | import Routing.Hash (getHash, setHash) 17 | import Snap (reduced) 18 | import Snap.Snapper (Snapper(..), Snapper') 19 | import Web.HTML (window) 20 | import Web.HTML.Window (localStorage) 21 | import Web.Storage.Storage as Storage 22 | 23 | refSnapper :: forall s m. 24 | MonadAff m => 25 | Ref s -> AVar Unit -> Snapper m s s 26 | refSnapper ref sync = Snapper { get, put } 27 | where 28 | get = liftEffect $ Ref.read ref 29 | put u = do 30 | liftEffect $ Ref.write u ref 31 | _ <- liftAff $ AVar.put unit sync 32 | pure unit 33 | 34 | affSnapper :: forall m u s. 35 | MonadAff m => 36 | (u -> s -> m s) -> s -> AVar Unit -> m (Snapper m u s) 37 | affSnapper red s sync = do 38 | r <- liftEffect $ Ref.new s 39 | pure $ reduced red $ refSnapper r sync 40 | 41 | affSnapper_ :: forall m s. 42 | MonadAff m => 43 | s -> AVar Unit -> m (Snapper m s s) 44 | affSnapper_ = affSnapper $ \s _ -> pure s 45 | 46 | url :: forall m. 47 | MonadEffect m => 48 | Snapper' m String 49 | url = Snapper { get: liftEffect $ getHash, put: liftEffect <<< setHash } 50 | 51 | route :: forall m i o. 52 | MonadEffect m => 53 | RouteDuplex i o -> Snapper m i (Either RouteError o) 54 | route r = dimap (print r) (parse r) $ url 55 | 56 | localstorage :: forall m. 57 | MonadEffect m => 58 | String -> m (Snapper m String (Maybe String)) 59 | localstorage k = do 60 | w <- liftEffect $ window 61 | s <- liftEffect $ localStorage w 62 | pure $ Snapper { get: liftEffect $ Storage.getItem k s, put: \v -> liftEffect $ Storage.setItem k v s } 63 | -------------------------------------------------------------------------------- /src/Snap/React/Target.purs: -------------------------------------------------------------------------------- 1 | module Snap.React.Target where 2 | 3 | import Prelude 4 | 5 | import Data.Functor.Contravariant (cmap) 6 | import Effect.Aff.AVar (AVar) 7 | import Effect.Aff.AVar as AVar 8 | import Effect.Aff.Class (class MonadAff, liftAff) 9 | import Effect.Class (liftEffect) 10 | import React.Basic (JSX) as R 11 | import React.Basic.DOM (render) as R 12 | import Snap (Target(..)) 13 | import Web.DOM (Element) 14 | 15 | reactTarget :: forall m. MonadAff m => Element -> AVar Unit -> Target m R.JSX 16 | reactTarget e = cmap pure <<< reactTargetM e 17 | 18 | reactTargetM :: forall m. MonadAff m => Element -> AVar Unit -> Target m (m R.JSX) 19 | reactTargetM e sync = Target go 20 | where 21 | go v = do 22 | v' <- v 23 | liftEffect $ R.render v' e 24 | _ <- liftAff $ AVar.take sync 25 | pure $ Target go 26 | -------------------------------------------------------------------------------- /src/Snap/Snapper.purs: -------------------------------------------------------------------------------- 1 | module Snap.Snapper where 2 | 3 | import Prelude 4 | 5 | import Control.Alt (class Alt, (<|>)) 6 | import Control.Alternative (class Alternative, class Plus, empty) 7 | import Control.Apply (lift2) 8 | import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT) 9 | import Control.MonadPlus (class MonadPlus, class MonadZero) 10 | import Data.Either (Either(..), choose, either) 11 | import Data.Maybe (Maybe(..), fromMaybe) 12 | import Data.Profunctor (class Profunctor, dimap) 13 | import Data.Profunctor.Bimodule (class Bimodule, class LeftModule, class RightModule) 14 | import Data.Profunctor.Monoidal (class Monoidal, class Semigroupal, class Unital, poly, (&|)) 15 | import Data.Tuple (Tuple, fst, snd) 16 | import Data.Tuple.Nested ((/\)) 17 | 18 | newtype Snapper m u s = Snapper { put :: u -> m Unit, get :: m s } 19 | 20 | type Snapper' m s = Snapper m s s 21 | 22 | runSnapper :: forall m s u. Snapper m u s -> { put :: u -> m Unit, get :: m s } 23 | runSnapper (Snapper x) = x 24 | 25 | instance functorSnapper :: Functor m => Functor (Snapper m u) 26 | where 27 | map f (Snapper { put, get }) = Snapper $ { put, get: map f $ get } 28 | 29 | instance applySnapper :: Apply m => Apply (Snapper m u) 30 | where 31 | apply (Snapper { get: g1, put: p1 }) (Snapper { get: g2, put: p2 }) = Snapper { get: g1 <*> g2, put: \u -> p1 u *> p2 u } 32 | 33 | instance applicativeSnapper :: Applicative m => Applicative (Snapper m u) 34 | where 35 | pure s = Snapper { get: pure s, put: const $ pure unit } 36 | 37 | instance bindSnapper :: Bind m => Bind (Snapper m u) 38 | where 39 | bind (Snapper { get, put }) amb = Snapper $ { get: get >>= (\s -> (runSnapper $ amb s).get), put: put } 40 | 41 | instance monadSnapper :: Monad m => Monad (Snapper m u) 42 | 43 | instance profunctorSnapper :: Functor m => Profunctor (Snapper m) 44 | where 45 | dimap f g (Snapper { put, get }) = Snapper $ { get: map g get, put: put <<< f } 46 | 47 | instance ttSemigroupalSnapper :: Apply m => Semigroupal (->) Tuple Tuple Tuple (Snapper m) 48 | where 49 | pzip (Snapper { get: g1, put: p1 } /\ Snapper { get: g2, put: p2 }) = Snapper { get: lift2 (/\) g1 g2, put: \(x /\ y) -> lift2 (<>) (p1 x) (p2 y) } 50 | 51 | instance ttUnitalSnapper :: Applicative m => Unital (->) Unit Unit Unit (Snapper m) 52 | where 53 | punit _ = Snapper { get: pure unit, put: pure } 54 | 55 | instance ttMonoidalSnapepr :: Applicative m => Monoidal (->) Tuple Unit Tuple Unit Tuple Unit (Snapper m) 56 | 57 | instance etSemigroupalSnapper :: Apply m => Semigroupal (->) Either Tuple Tuple (Snapper m) 58 | where 59 | pzip (Snapper { get: g1, put: p1 } /\ Snapper { get: g2, put: p2 }) = Snapper { get: lift2 (/\) g1 g2, put: either p1 p2 } 60 | 61 | instance etUnitalSnapper :: Applicative m => Unital (->) Void Unit Unit (Snapper m) 62 | where 63 | punit _ = Snapper { get: pure unit, put: absurd } 64 | 65 | instance etMonoidalSnapper :: Applicative m => Monoidal (->) Either Void Tuple Unit Tuple Unit (Snapper m) 66 | 67 | instance leftModuleSnapper :: Functor m => LeftModule (->) Tuple Either (Snapper m) 68 | where 69 | lstrength (Snapper { get, put }) = Snapper { get: Left <$> get, put: put <<< fst } 70 | 71 | instance eeSemigroupalSnapper :: Alt m => Semigroupal (->) Either Either Tuple (Snapper m) 72 | where 73 | pzip (Snapper { get: g1, put: p1 } /\ Snapper { get: g2, put: p2 }) = Snapper { get: choose g1 g2, put: either p1 p2 } 74 | 75 | instance eeUnitalSnapper :: Plus m => Unital (->) Void Void Unit (Snapper m) 76 | where 77 | punit _ = Snapper { get: empty, put: absurd } 78 | 79 | instance eeMonoidalSnapper :: Plus m => Monoidal (->) Either Void Either Void Tuple Unit (Snapper m) 80 | 81 | instance rightModuleSnapper :: Functor m => RightModule (->) Tuple Either (Snapper m) 82 | where 83 | rstrength (Snapper { get, put }) = Snapper { get: Right <$> get, put: put <<< snd } 84 | 85 | instance teSemigroupalSnapper :: (Alt m, Apply m) => Semigroupal (->) Tuple Either Tuple (Snapper m) 86 | where 87 | pzip (Snapper { get: g1, put: p1 } /\ Snapper { get: g2, put: p2 }) = Snapper { get: choose g1 g2, put: \(u1 /\ u2) -> lift2 (<>) (p1 u1) (p2 u2) } 88 | 89 | instance teUnitalSnapper :: (Plus m, Applicative m) => Unital (->) Unit Void Unit (Snapper m) 90 | where 91 | punit _ = Snapper { get: empty, put: pure } 92 | 93 | instance teMonoidalSnapper :: (Plus m, Applicative m) => Monoidal (->) Tuple Unit Either Void Tuple Unit (Snapper m) 94 | 95 | instance semigroupSnapper :: (Alt m, Apply m) => Semigroup (Snapper m u s) 96 | where 97 | append s1 s2 = dimap (\s -> s /\ s) (either identity identity) $ s1 &| s2 98 | 99 | instance monoidSnapper :: (Plus m, Applicative m) => Monoid (Snapper m u s) 100 | where 101 | mempty = poly 102 | 103 | instance bimoduleSnapper :: Functor m => Bimodule (->) Tuple Either (Snapper m) 104 | 105 | hoist :: forall m n s u. (m ~> n) -> Snapper m s u -> Snapper n s u 106 | hoist n (Snapper { get, put }) = Snapper { get: n get, put: n <<< put } 107 | 108 | instance altSnapper :: Alt m => Alt (Snapper m u) 109 | where 110 | alt (Snapper { get: g1, put: p1 }) (Snapper { get: g2, put: p2 }) = Snapper { get: g1 <|> g2, put: \u -> p1 u <|> p2 u } 111 | 112 | instance plusSnapper :: Plus m => Plus (Snapper m u) 113 | where 114 | empty = Snapper { get: empty, put: const empty } 115 | 116 | instance alternativeSnapper :: Alternative m => Alternative (Snapper m u) 117 | 118 | instance monadZeroSnapper :: MonadZero m => MonadZero (Snapper m u) 119 | 120 | instance monadPlusSnapper :: MonadPlus m => MonadPlus (Snapper m u) 121 | 122 | reduced :: forall m u s. Bind m => (u -> s -> m s) -> Snapper' m s -> Snapper m u s 123 | reduced red (Snapper { get, put }) = Snapper { get: get, put: put' } 124 | where 125 | put' u = do 126 | s <- get 127 | s' <- red u s 128 | put s' 129 | 130 | absorbError :: forall m u s. Functor m => Snapper m u (Maybe s) -> Snapper (MaybeT m) u s 131 | absorbError (Snapper { get, put }) = Snapper { get: MaybeT get, put: MaybeT <<< map Just <<< put } 132 | 133 | withDefaultState :: forall m u s. Functor m => s -> Snapper (MaybeT m) u s -> Snapper m u s 134 | withDefaultState s (Snapper { get, put }) = Snapper { get: map (fromMaybe s) $ runMaybeT $ get, put: void <<< runMaybeT <<< put } 135 | -------------------------------------------------------------------------------- /src/Snap/Target.purs: -------------------------------------------------------------------------------- 1 | module Snap.Target where 2 | 3 | import Prelude 4 | 5 | import Data.Functor.Contravariant (class Contravariant, cmap) 6 | 7 | newtype Target m v = Target (v -> m (Target m v)) 8 | 9 | instance contravariantTarget :: Functor m => Contravariant (Target m) where 10 | cmap f (Target a) = Target \v -> cmap f <$> a (f v) 11 | 12 | hoistTarget :: forall m n v. Functor n => (m ~> n) -> Target m v -> Target n v 13 | hoistTarget n = go 14 | where 15 | go (Target t) = Target $ map go <<< n <<< t 16 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Effect.Console (log) 7 | 8 | main :: Effect Unit 9 | main = do 10 | log "🍝" 11 | log "You should add some tests." 12 | --------------------------------------------------------------------------------