├── .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 | 
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 |
--------------------------------------------------------------------------------