├── .gitignore ├── README.md ├── bower.json ├── docs ├── app.js ├── dialog.css └── index.html ├── package.json ├── src ├── Components │ ├── Details.purs │ ├── Dialog.purs │ ├── Home.purs │ └── Router │ │ ├── Component.purs │ │ └── Query.purs ├── Control │ └── Monad.purs ├── DSL │ ├── Dialog.purs │ ├── Navigation.purs │ ├── Server.purs │ └── State.purs ├── Main.purs └── Server │ └── ServerAPI.purs └── test └── Main.purs /.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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Purescript Halogen Example 2 | Sample Halogen app with a few DSLs implemented as the application's reader monad. 3 | 4 | The overview presented here has some simplified examples. You will find some of the types 5 | presented here have less arguments / constructors / etc. than the actual types used in the 6 | source code. 7 | 8 | You can check out the result [here](https://vladciobanu.github.io/purescript-halogen-example/index.html). 9 | 10 | ## Purpose 11 | This repository aims to be an example of how to use an application monad with `Halogen` in order 12 | to create a DSL that can be used inside the component's `eval`. 13 | 14 | In this repository, you'll find examples for DLS's that allow you to: 15 | - read some static environment (through `MonadAsk`) 16 | - navigate to different routes, along with a routing component 17 | - read or modify the global state of the application 18 | - run queries on a (dummy) server API 19 | - trigger the root component to show a dialog box and execute commands depending on action taken 20 | 21 | ## Our application's DSLs 22 | Each DSL is expressed as a `typeclass`. These DSLs can define any number of functions, each of 23 | which should return a monadic result. For example, our `Navigation` DSL is defined as: 24 | 25 | ```purescript 26 | class Monad m <= NavigationDSL m where 27 | navigate :: Route -> m Unit 28 | ``` 29 | 30 | The `navigate` function will most likely incur a side-effect, so we express that by returning `m Unit`. 31 | 32 | In order to be able to use these DSLs in `Halogen`, we need to lift these operations to its monad, which is `HalogenM`: 33 | 34 | ```purescript 35 | instance navigationDSLHalogenM :: NavigationDSL m => NavigationDSL (HalogenM s f g p o m) where 36 | navigate = lift <<< navigate 37 | ``` 38 | 39 | What this basically says is that whenever you use `navigate` within a HalogenM context, we will 40 | lift the DSL to the inner-monad `m`, which means we'll need to have an instance ourselves. 41 | 42 | ## The Reader Pattern 43 | We will be using the __ReaderT pattern_. If you have not used `ReaderT` before, please go through 44 | [The ReaderT design pattern](https://www.fpcomplete.com/blog/2017/06/readert-design-pattern) post. 45 | 46 | The _env_ type we are using is 47 | 48 | ```purescript 49 | type Environment = 50 | { token :: APIToken 51 | , push :: PushType -> Effect Unit 52 | , answer :: Int 53 | , state :: Ref GlobalState 54 | } 55 | ``` 56 | 57 | These are needed for all the various DSLs we are using. Specifically, the `ServerDSL` uses the `token`, 58 | `NavigationDSL` and `DialogDSL` use the `push` field to request a route change or displaying the dialog box, 59 | and the global `StateDSL` uses `state`. 60 | 61 | ## Our application's monad 62 | We can define our monad as: 63 | 64 | ```purescript 65 | newtype ExampleM a = ExampleM (ReaderT Environment Aff a) 66 | ``` 67 | 68 | We can now derive instances for `Functor`, `Apply`, `Applicative`, `Bind`, `Monad`, `MonadEffect`, 69 | and `MonadAff` for free. 70 | 71 | We also need the `NavigationDSL` instance for `ExampleM`: 72 | 73 | ```purescript 74 | instance navigationDSLExampleM :: NavigationDSL ExampleM where 75 | navigate route = ExampleM do 76 | env <- ask 77 | liftEffect $ env.push $ PushRoute route 78 | ``` 79 | 80 | We basically use our environment's `push` to send the new route to the event listener. 81 | 82 | ## Natural transform run 83 | Halogen needs to know how to effectively run our monad, which is expressed by its `hoist` 84 | function: 85 | 86 | ```purescript 87 | hoist 88 | :: forall h f i o m m' 89 | . Bifunctor h 90 | => Functor m' 91 | => (m ~> m') 92 | -> Component h f i o m 93 | -> Component h f i o m' 94 | ``` 95 | 96 | What this does, basically, is given a component that runs under monad `m` and a way to go 97 | from `m` to `m'` (through the natural transform `m ~> m'`), then we can construct the 98 | component that runs under monad `m'`. 99 | 100 | It's also worth noting that `runUI` assumes a component that runs under the `Aff` monad, 101 | so that means `m'` needs to be `Aff`. And since `m` is our own monad, `ExampleM`, it 102 | follows we will write: 103 | 104 | ```purescript 105 | runExampleM :: forall a. ExampleM a -> Environment -> Aff a 106 | runExampleM m env = runReaderT (unwrap m) env 107 | ``` 108 | 109 | All that remains is somehow figure out how to do the route change through an `Eff` or `Aff`. 110 | Which brings us to... 111 | 112 | ## Signaling back to main 113 | Some of our DSLs might need to signal back to main. The basic idea is we create a new event in 114 | `main` and we pass the function that can `push` to this event in the `environment` to our 115 | `runExampleM` transform. This means we'll have a way of sending messages to our `main`. 116 | 117 | Back in `main`, we'll have to handle them somehow. And since we also create the root component 118 | there, we could use its driver's query to send actions to that component. 119 | 120 | Back in main: 121 | 122 | ```purescript 123 | main = HA.runHalogenAff do 124 | body <- HA.awaitBody 125 | state <- liftEffect $ Ref.new 0 126 | event <- liftEffect create 127 | let environment = 128 | { token: APIToken secretKey 129 | , answer: 42 130 | , state 131 | , push: event.push 132 | } 133 | 134 | let router' = H.hoist (flip runExampleM environment) R.component 135 | driver <- runUI router' unit body 136 | liftEffect $ subscribe event.event (handler driver) 137 | ``` 138 | 139 | We omitted the definition for `handler` for brevity. You can check the `Main.purs` file for details. 140 | The main idea is we create the `environment`, which has everything `ExampleM` needs to run everything 141 | we care about. 142 | 143 | The `handler` function sends messages to the `router` (the main Halogen component), depending on its 144 | input (one message is for changing the current route, and the other is for showing a dialog box). 145 | 146 | ## MonadAsk 147 | `MonadAsk` allows us to get the current environment. This is initialized in `main` and 148 | passed down to our `runExampleM` function. 149 | 150 | ## StateDSL 151 | Unfortunately, we can't use `MonadState` because `HalogenM` already has an instance for it 152 | for each component's state. We need to define our own state monad, and one way is presented 153 | in the `StateDSL` class. 154 | 155 | ## ServerAPI 156 | We have a dummy `API` method in the `Example.Server.ServerAPI` module, but it could 157 | be a function that does an `Ajax` request just as well. We assume our API needs a 158 | token, but our DSL does not ask for it. 159 | 160 | ## ShowDialog 161 | This is an example where we pass `actions` as our `ExampleM` monad. Basically, we 162 | want our root component to show a dialog with a custom set of buttons. Each of 163 | these buttons has an action that will run under `ExampleM`, which means it can run 164 | all the DSLs that we define. 165 | 166 | The way this works is we initially send these actions as the dialog options, 167 | under any monad `m`. The `ExampleM` instance for `DialogDSL` assumes 168 | both the monad that it runs under and the monad used to run the actions 169 | is `ExampleM`. It transforms the options to `Aff` and pushes them to the `router` 170 | through the handler stored in the `environment`. 171 | 172 | ## Parallel 173 | @thomashoneyman kindly contributed a version which enables parallel computations 174 | to the application's monad. You can [check it out in this PR](https://github.com/vladciobanu/purescript-halogen-example/pull/9). 175 | -------------------------------------------------------------------------------- /bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "purescript-halogen-example", 3 | "ignore": [ 4 | "**/.*", 5 | "node_modules", 6 | "bower_components", 7 | "output" 8 | ], 9 | "dependencies": { 10 | "purescript-prelude": "^4.0.1", 11 | "purescript-console": "^4.1.0", 12 | "purescript-halogen": "^4.0.0", 13 | "purescript-behaviors": "^7.0.0" 14 | }, 15 | "devDependencies": { 16 | "purescript-psci-support": "^4.0.0" 17 | } 18 | } 19 | -------------------------------------------------------------------------------- /docs/dialog.css: -------------------------------------------------------------------------------- 1 | body { 2 | font-family: sans-serif; 3 | max-width: 800px; 4 | margin: auto; 5 | } 6 | 7 | .ps-modal { 8 | /* This way it could be display flex or grid or whatever also. */ 9 | display: block; 10 | 11 | /* Probably need media queries here */ 12 | width: 600px; 13 | max-width: 100%; 14 | 15 | height: 400px; 16 | max-height: 100%; 17 | 18 | position: fixed; 19 | 20 | z-index: 100; 21 | 22 | left: 50%; 23 | top: 50%; 24 | 25 | transform: translate(-50%, -50%); 26 | 27 | /* If known, negative margins are probably better (less chance of blurry text). */ 28 | /* margin: -200px 0 0 -200px; */ 29 | 30 | background: white; 31 | box-shadow: 0 0 60px 10px rgba(0, 0, 0, 0.9); 32 | } 33 | 34 | .guts { 35 | position: absolute; 36 | top: 0; 37 | left: 0; 38 | width: 100%; 39 | height: 100%; 40 | overflow: auto; 41 | padding: 20px 50px 20px 20px; 42 | } 43 | 44 | .guts ul { 45 | position: absolute; 46 | bottom: 50px; 47 | margin: 0 auto; 48 | width: 400px; 49 | left: 100px; 50 | padding: 0 0; 51 | } 52 | 53 | .guts ul li { 54 | list-style: none; 55 | } 56 | 57 | .ps-closed { 58 | display: none; 59 | } 60 | 61 | .ps-modal-overlay { 62 | position: fixed; 63 | top: 0; 64 | left: 0; 65 | width: 100%; 66 | height: 100%; 67 | z-index: 50; 68 | 69 | background: rgba(0, 0, 0, 0.6); 70 | } 71 | 72 | .ps-btn { 73 | text-decoration: none; 74 | color: #fff; 75 | background-color: #7bd317; 76 | text-align: center; 77 | letter-spacing: 1px; 78 | cursor: pointer; 79 | user-select: none; 80 | 81 | border: none; 82 | border-radius: 10px; 83 | display: block; 84 | height: 44px; 85 | line-height: 44px; 86 | font-size: 22px; 87 | outline: 0; 88 | padding: 0 2rem; 89 | text-transform: uppercase; 90 | 91 | margin-top: 30px; 92 | margin-bottom: 10px; 93 | width: 100%; 94 | } 95 | -------------------------------------------------------------------------------- /docs/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | Halogen Example - Application Monad 5 | 6 | 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "private": true, 3 | "scripts": { 4 | "build": "pulp build --to docs/app.js", 5 | "watch": "pulp --watch build --to docs/app.js" 6 | } 7 | } -------------------------------------------------------------------------------- /src/Components/Details.purs: -------------------------------------------------------------------------------- 1 | module Example.Component.Details 2 | ( component 3 | , Query (..) 4 | ) where 5 | 6 | import Control.Monad.Reader (ask) 7 | import Control.Monad.Reader.Class (class MonadAsk) 8 | import Data.Int (fromString) 9 | import Data.Maybe (Maybe(..), maybe) 10 | import Data.NaturalTransformation (type (~>)) 11 | import Example.Component.Router.Query (Route(..)) 12 | import Example.Control.Monad (GlobalState) 13 | import Example.DSL.Dialog (class DialogDSL, showDialog) 14 | import Example.DSL.Navigation (class NavigationDSL, navigate) 15 | import Example.DSL.State (class StateDSL, getState, setState) 16 | import Halogen as H 17 | import Halogen.HTML as HH 18 | import Halogen.HTML.Events as HE 19 | import Halogen.HTML.Properties as HP 20 | import Prelude (Unit, Void, bind, const, discard, identity, pure, show, unit, ($), (<>)) 21 | 22 | data Query a 23 | = Initialize a 24 | | ValueChanged String a 25 | | UpdateValue a 26 | | GotoHome a 27 | 28 | -- | `answer` is in our Environment / MonadAsk 29 | -- | `secret` is the global `StateDSL` 30 | type State = 31 | { answer :: Int 32 | , secret :: Int 33 | } 34 | 35 | component :: ∀ env m 36 | . MonadAsk { answer :: Int | env } m 37 | => StateDSL GlobalState m 38 | => DialogDSL m m 39 | => NavigationDSL m 40 | => H.Component HH.HTML Query Unit Void m 41 | component = 42 | H.lifecycleComponent 43 | { initialState: const { answer: 0, secret: 0 } 44 | , render 45 | , eval 46 | , initializer: Just (H.action Initialize) 47 | , finalizer: Nothing 48 | , receiver: const Nothing 49 | } 50 | where 51 | 52 | render :: State -> H.ComponentHTML Query 53 | render st = 54 | HH.div_ 55 | [ HH.h1_ [ HH.text $ "The answer is " <> show st.answer ] 56 | , HH.div_ 57 | [ HH.text "Change secret number: " 58 | , HH.input 59 | [ HP.type_ HP.InputNumber 60 | , HP.value $ show st.secret 61 | , HE.onValueInput (HE.input ValueChanged) 62 | ] 63 | ] 64 | , HH.button 65 | [ HE.onClick (HE.input_ UpdateValue) ] 66 | [ HH.text "Update" ] 67 | , HH.button 68 | [ HE.onClick (HE.input_ GotoHome) ] 69 | [ HH.text "Go to home" ] 70 | ] 71 | 72 | eval :: Query ~> H.ComponentDSL State Query Void m 73 | eval (Initialize next) = do 74 | env <- ask 75 | n <- getState 76 | H.put { answer: env.answer, secret: n } 77 | pure next 78 | eval (ValueChanged val next) = do 79 | let num = fromString val 80 | H.modify_ \st -> st { secret = maybe st.secret identity num } 81 | pure next 82 | eval (UpdateValue next) = do 83 | localState <- H.get 84 | showDialog 85 | { title: "Confirmation" 86 | , message: "Are you sure you want to update the value?" 87 | , actions: 88 | [ { name: "Yes" 89 | , action: updateValue localState.secret 90 | } 91 | , { name: "Nevermind" 92 | , action: pure unit 93 | } 94 | ] 95 | } 96 | pure next 97 | 98 | where 99 | 100 | updateValue :: Int -> m Unit 101 | updateValue = setState 102 | 103 | eval (GotoHome next) = do 104 | navigate Home 105 | pure next 106 | -------------------------------------------------------------------------------- /src/Components/Dialog.purs: -------------------------------------------------------------------------------- 1 | -- | 2 | module Example.Component.Dialog 3 | ( component 4 | , Query(..) 5 | , DialogResult(..) 6 | , DialogOptionsLite 7 | ) where 8 | 9 | import Data.Array (mapWithIndex) 10 | import Data.Maybe (Maybe(..)) 11 | import Halogen as H 12 | import Halogen.HTML as HH 13 | import Halogen.HTML.Events as HE 14 | import Halogen.HTML.Properties as HP 15 | import Prelude (type (~>), const, discard, identity, pure, ($), (<<<)) 16 | 17 | type DialogOptionsLite = 18 | { title :: String 19 | , message :: String 20 | , actions :: Array String 21 | } 22 | 23 | data Query a = CloseDialog Int a 24 | 25 | data DialogResult = DialogResult Int 26 | 27 | type State = DialogOptionsLite 28 | 29 | component :: ∀ m. H.Component HH.HTML Query DialogOptionsLite DialogResult m 30 | component 31 | = H.component 32 | { initialState: identity 33 | , render 34 | , eval 35 | , receiver: const Nothing 36 | } 37 | 38 | where 39 | 40 | render :: State -> H.ComponentHTML Query 41 | render dialogOptions = 42 | HH.div_ 43 | [ HH.div 44 | [ HP.class_ (H.ClassName "ps-modal") ] 45 | [ HH.div 46 | [ HP.class_ (H.ClassName "guts") ] 47 | [ HH.h2_ [ HH.text dialogOptions.title ] 48 | , HH.p_ [ HH.text dialogOptions.message ] 49 | , HH.ul_ (mapWithIndex renderAction dialogOptions.actions) 50 | ] 51 | ] 52 | , HH.div 53 | [ HP.class_ (H.ClassName "ps-modal-overlay") ] 54 | [ ] 55 | ] 56 | 57 | where 58 | 59 | renderAction :: Int -> String -> H.ComponentHTML Query 60 | renderAction i a = 61 | HH.li_ 62 | [ HH.button 63 | [ HE.onClick (HE.input_ (CloseDialog i)) 64 | , HP.class_ (H.ClassName "ps-btn") 65 | ] 66 | [ HH.text a ] 67 | ] 68 | 69 | eval :: Query ~> H.ComponentDSL State Query DialogResult m 70 | eval (CloseDialog idx next) = do 71 | H.raise <<< DialogResult $ idx 72 | pure next 73 | -------------------------------------------------------------------------------- /src/Components/Home.purs: -------------------------------------------------------------------------------- 1 | module Example.Component.Home 2 | ( component 3 | , Query (..) 4 | ) where 5 | 6 | import Data.Either (either) 7 | import Data.Maybe (Maybe(..)) 8 | import Data.NaturalTransformation (type (~>)) 9 | import Example.Component.Router.Query (Route(..)) 10 | import Example.Control.Monad (GlobalState) 11 | import Example.DSL.Navigation (class NavigationDSL, navigate) 12 | import Example.DSL.Server (class ServerDSL, getGreeting) 13 | import Example.DSL.State (class StateDSL, getState) 14 | import Halogen as H 15 | import Halogen.HTML as HH 16 | import Halogen.HTML.Events as HE 17 | import Prelude (Unit, Void, bind, const, discard, identity, pure, show, ($)) 18 | 19 | data Query a 20 | = Initialize a 21 | | GotoDetails a 22 | 23 | -- | The secret number is stored in our global state. 24 | -- | We can change it in the `Details` page. 25 | -- | 26 | -- | The greeting is obtained through our server "api". 27 | type State = 28 | { secretNumber :: Maybe Int 29 | , greeting :: String 30 | } 31 | 32 | component :: ∀ m 33 | . StateDSL GlobalState m 34 | => ServerDSL m 35 | => NavigationDSL m 36 | => H.Component HH.HTML Query Unit Void m 37 | component = 38 | H.lifecycleComponent 39 | { initialState: const { secretNumber: Nothing, greeting: "" } 40 | , render 41 | , eval 42 | , initializer: Just (H.action Initialize) 43 | , finalizer: Nothing 44 | , receiver: const Nothing 45 | } 46 | where 47 | 48 | render :: State -> H.ComponentHTML Query 49 | render st = 50 | HH.div_ 51 | [ HH.h1_ [ HH.text st.greeting ] 52 | , HH.div_ [ HH.text $ showSecretNumber st.secretNumber ] 53 | , HH.button 54 | [ HE.onClick (HE.input_ GotoDetails) ] 55 | [ HH.text "Go to details" ] 56 | ] 57 | 58 | where 59 | 60 | showSecretNumber :: Maybe Int -> String 61 | showSecretNumber Nothing = "Not loaded yet" 62 | showSecretNumber (Just n) = show n 63 | 64 | -- | We are able to use `getState`, `getGreeting` and `navigate` here 65 | -- | from our app's DSLs / free monad because we assert that `m` 66 | -- | implements `StateDSL`, `ServerDSL`, and `NavigationDSL`. 67 | eval :: Query ~> H.ComponentDSL State Query Void m 68 | eval (Initialize next) = do 69 | number <- getState 70 | greetingResult <- getGreeting 71 | let greeting = either (const "error") identity greetingResult 72 | H.put { secretNumber: Just number, greeting: greeting } 73 | pure next 74 | eval (GotoDetails next) = do 75 | navigate Details 76 | pure next 77 | -------------------------------------------------------------------------------- /src/Components/Router/Component.purs: -------------------------------------------------------------------------------- 1 | module Example.Component.Router 2 | ( component 3 | ) where 4 | 5 | import Control.Monad.Reader.Class (class MonadAsk) 6 | import Data.Array ((!!)) 7 | import Data.Either.Nested (Either3) 8 | import Data.Functor.Coproduct.Nested (Coproduct3) 9 | import Data.Maybe (Maybe(..)) 10 | import Data.NaturalTransformation (type (~>)) 11 | import Effect.Aff (Aff) 12 | import Effect.Aff.Class (class MonadAff) 13 | import Example.Component.Details as Details 14 | import Example.Component.Dialog (DialogOptionsLite) 15 | import Example.Component.Dialog as Dialog 16 | import Example.Component.Home as Home 17 | import Example.Component.Router.Query (Query(..), Route(..)) 18 | import Example.Control.Monad (GlobalState) 19 | import Example.DSL.Dialog (class DialogDSL, ActionOptions, DialogOptions) 20 | import Example.DSL.Navigation (class NavigationDSL) 21 | import Example.DSL.Server (class ServerDSL) 22 | import Example.DSL.State (class StateDSL) 23 | import Halogen as H 24 | import Halogen.Component.ChildPath as CP 25 | import Halogen.HTML as HH 26 | import Halogen.HTML.Events as HE 27 | import Prelude (Unit, Void, absurd, bind, const, discard, map, pure, unit) 28 | 29 | 30 | -- | Query algebra for direct children of the router component, represented as 31 | -- | a Coproduct. 32 | type ItemQuery = Coproduct3 Dialog.Query Home.Query Details.Query 33 | 34 | -- | Slot type for router items. 35 | type ItemSlot = Either3 Unit Unit Unit 36 | 37 | -- | Internal state for the Router component. 38 | type State = 39 | { route :: Route 40 | , dialogOptions :: Maybe (DialogOptions Aff) 41 | } 42 | 43 | -- | Router component. 44 | component :: ∀ env m 45 | . MonadAsk { answer :: Int | env } m 46 | => StateDSL GlobalState m 47 | => ServerDSL m 48 | => DialogDSL m m 49 | => NavigationDSL m 50 | => MonadAff m 51 | => H.Component HH.HTML Query Unit Void m 52 | component 53 | = H.parentComponent 54 | { initialState: const { route: Home, dialogOptions: Nothing } 55 | , render 56 | , eval 57 | , receiver: const Nothing 58 | } 59 | where 60 | 61 | render :: State -> H.ParentHTML Query ItemQuery ItemSlot m 62 | render { route, dialogOptions } = 63 | HH.div_ 64 | [ renderRoute route 65 | , renderDialog dialogOptions 66 | ] 67 | 68 | where 69 | 70 | renderRoute :: Route -> H.ParentHTML Query ItemQuery ItemSlot m 71 | renderRoute = case _ of 72 | Home -> HH.slot' CP.cp2 unit Home.component unit absurd 73 | Details -> HH.slot' CP.cp3 unit Details.component unit absurd 74 | 75 | renderDialog :: Maybe (DialogOptions Aff) -> H.ParentHTML Query ItemQuery ItemSlot m 76 | renderDialog Nothing = 77 | HH.text "" 78 | renderDialog (Just opts) = 79 | HH.slot' CP.cp1 unit Dialog.component (shred opts) (HE.input HandleDialogResult) 80 | 81 | shred :: ∀ n. DialogOptions n -> DialogOptionsLite 82 | shred opts = { title: opts.title, message: opts.message, actions: map getAction opts.actions } 83 | 84 | getAction :: ∀ n. ActionOptions n -> String 85 | getAction ao = ao.name 86 | 87 | eval :: Query ~> H.ParentDSL State Query ItemQuery ItemSlot Void m 88 | eval (ShowDialog opts next) = do 89 | H.modify_ _ { dialogOptions = Just opts } 90 | pure next 91 | eval (HandleDialogResult (Dialog.DialogResult idx) next) = do 92 | st <- H.get 93 | case st.dialogOptions of 94 | Nothing -> pure unit 95 | Just opts -> do 96 | let maybeAction = opts.actions !! idx 97 | case maybeAction of 98 | Nothing -> pure unit 99 | Just action -> do 100 | H.liftAff action.action 101 | H.modify_ _ { dialogOptions = Nothing } 102 | pure unit 103 | pure unit 104 | pure next 105 | eval (Goto route next) = do 106 | H.modify_ _ { route = route } 107 | pure next 108 | -------------------------------------------------------------------------------- /src/Components/Router/Query.purs: -------------------------------------------------------------------------------- 1 | module Example.Component.Router.Query 2 | ( Route (..) 3 | , Query (..) 4 | ) where 5 | 6 | import Effect.Aff (Aff) 7 | import Example.Component.Dialog (DialogResult) 8 | import Example.DSL.Dialog (DialogOptions) 9 | import Prelude (class Eq, class Ord) 10 | 11 | data Route 12 | = Home 13 | | Details 14 | 15 | derive instance eqRoute :: Eq Route 16 | derive instance ordRoute :: Ord Route 17 | 18 | data Query a 19 | = Goto Route a 20 | | ShowDialog (DialogOptions Aff) a 21 | | HandleDialogResult DialogResult a 22 | -------------------------------------------------------------------------------- /src/Control/Monad.purs: -------------------------------------------------------------------------------- 1 | module Example.Control.Monad where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Reader (ask, asks, runReaderT) 6 | import Control.Monad.Reader.Class (class MonadAsk) 7 | import Control.Monad.Reader.Trans (ReaderT) 8 | import Data.Newtype (class Newtype, unwrap) 9 | import Effect (Effect) 10 | import Effect.Aff (Aff) 11 | import Effect.Aff.Class (class MonadAff, liftAff) 12 | import Effect.Class (class MonadEffect, liftEffect) 13 | import Effect.Ref (Ref) 14 | import Effect.Ref as Ref 15 | import Example.Component.Router.Query (Route) 16 | import Example.DSL.Dialog (class DialogDSL, DialogOptions, ActionOptions) 17 | import Example.DSL.Navigation (class NavigationDSL) 18 | import Example.DSL.Server (class ServerDSL) 19 | import Example.DSL.State (class StateDSL) 20 | import Example.Server.ServerAPI (APIToken, getGreetingImpl) 21 | import Type.Equality as TE 22 | 23 | -- | Our environment for `MonadAsk`. 24 | type Environment = 25 | { token :: APIToken 26 | , push :: PushType -> Effect Unit 27 | , answer :: Int 28 | , state :: Ref GlobalState 29 | } 30 | 31 | -- | Our state for `StateDSL`. 32 | type GlobalState = Int 33 | 34 | -- | Our environment will contain everything we need to implement our monad, so we use it 35 | -- | as our environment in a ReaderT monad stack. 36 | newtype ExampleM a = ExampleM (ReaderT Environment Aff a) 37 | derive instance newtypeExampleM :: Newtype (ExampleM a) _ 38 | 39 | -- | Helper unwrapping function. 40 | runExampleM :: forall a. ExampleM a -> Environment -> Aff a 41 | runExampleM m env = runReaderT (unwrap m) env 42 | 43 | -- | Free instances. 44 | derive newtype instance functorExampleM :: Functor ExampleM 45 | derive newtype instance applyExampleM :: Apply ExampleM 46 | derive newtype instance applicativeExampleM :: Applicative ExampleM 47 | derive newtype instance bindExampleM :: Bind ExampleM 48 | derive newtype instance monadExampleM :: Monad ExampleM 49 | derive newtype instance monadEffectExampleM :: MonadEffect ExampleM 50 | derive newtype instance monadAffExampleM :: MonadAff ExampleM 51 | 52 | -- | This is, in theory, just a trivial MonadAsk instance. 53 | -- | The only reason it looks a bit more complicated is PureScript does not allow us 54 | -- | to create instances for type synonyms (which includes row types), we have to use 55 | -- | a workaround with TypeEquals, asserting a type `e` is equal to our `Environment` 56 | -- | type synonym. 57 | instance monadAskExampleM :: TE.TypeEquals e Environment => MonadAsk e ExampleM where 58 | ask = ExampleM $ asks TE.from 59 | 60 | -- | Navigate will simply use the `push` part of our environment 61 | -- | to send the new route to the router through our event listener. 62 | instance navigationDSLExampleM :: NavigationDSL ExampleM where 63 | navigate route = ExampleM do 64 | env <- ask 65 | liftEffect $ env.push $ PushRoute route 66 | 67 | -- | Encode get/set state. We use the same trick as for `MonadAsk`, using 68 | -- | our environment's `state`. 69 | instance stateDSLExampleM :: TE.TypeEquals st GlobalState => StateDSL st ExampleM where 70 | getState = ExampleM do 71 | env <- ask 72 | liftEffect $ TE.from <$> Ref.read env.state 73 | 74 | modifyState f = ExampleM do 75 | env <- ask 76 | liftEffect $ Ref.modify_ (TE.to <<< f <<< TE.from) env.state 77 | 78 | -- | This is where we map `ServerDSL` to actual service calls, using the token 79 | -- | stored in our environment. 80 | instance serverDSLExampleM :: ServerDSL ExampleM where 81 | getGreeting = ExampleM do 82 | env <- ask 83 | liftAff $ getGreetingImpl env.token 84 | 85 | -- | `PushType` represents what kind of things we can push 86 | -- | to the `main` event handler. 87 | data PushType 88 | = PushRoute Route 89 | | PushShowDialog (DialogOptions Aff) 90 | 91 | -- | We need to convert our `DialogOptions` and `ActionOptions` 92 | -- | from `ExampleM` to `Aff`, then we push it through the 93 | -- | router using our event handler (similarly to how we do routing). 94 | instance dialogDSLExampleM :: DialogDSL ExampleM ExampleM where 95 | showDialog opts = ExampleM do 96 | env <- ask 97 | 98 | let runAction :: ActionOptions ExampleM -> ActionOptions Aff 99 | runAction a = a { action = runExampleM a.action env } 100 | 101 | runOptions :: DialogOptions ExampleM -> DialogOptions Aff 102 | runOptions d = d { actions = map runAction d.actions } 103 | 104 | liftEffect <<< env.push <<< PushShowDialog <<< runOptions $ opts 105 | -------------------------------------------------------------------------------- /src/DSL/Dialog.purs: -------------------------------------------------------------------------------- 1 | module Example.DSL.Dialog 2 | ( class DialogDSL 3 | , showDialog 4 | , DialogOptions 5 | , ActionOptions 6 | ) where 7 | 8 | import Halogen (HalogenM, lift) 9 | import Prelude (class Monad, Unit, (<<<)) 10 | 11 | -- | A dialog can have multiple `ActionOption`s. 12 | -- | Each has a `name` which appears on the button and an action encoded as 13 | -- | an `m Unit`. Initially, this will generally be `ExampleM`, which gets 14 | -- | translated to `Aff` inside the `runExampleM`. 15 | type ActionOptions m = 16 | { name :: String 17 | , action :: m Unit 18 | } 19 | 20 | -- | Dialog title, content and a list of actions. 21 | type DialogOptions m = 22 | { title :: String 23 | , message :: String 24 | , actions :: Array (ActionOptions m) 25 | } 26 | 27 | -- | Shows the dialog and return Unit under the current monad. 28 | class Monad m <= DialogDSL n m where 29 | showDialog :: DialogOptions n -> m Unit 30 | 31 | -- | We need a HalogenM instance in order to be able to use this DSL 32 | -- | within our component's `eval`. 33 | instance dialogDSLHalogenM :: DialogDSL n m => DialogDSL n (HalogenM s f g p o m) where 34 | showDialog = lift <<< showDialog 35 | -------------------------------------------------------------------------------- /src/DSL/Navigation.purs: -------------------------------------------------------------------------------- 1 | module Example.DSL.Navigation 2 | ( class NavigationDSL 3 | , navigate 4 | ) where 5 | 6 | 7 | import Example.Component.Router.Query (Route) 8 | import Halogen (HalogenM, lift) 9 | import Prelude (class Monad, Unit, (<<<)) 10 | 11 | -- | DSL for navigating to a route. 12 | class Monad m <= NavigationDSL m where 13 | navigate :: Route -> m Unit 14 | 15 | -- | We need a HalogenM instance in order to be able to use this DSL within 16 | -- | our component's `eval`. 17 | instance navigationDSLHalogenM :: NavigationDSL m => NavigationDSL (HalogenM s f g p o m) where 18 | navigate = lift <<< navigate 19 | -------------------------------------------------------------------------------- /src/DSL/Server.purs: -------------------------------------------------------------------------------- 1 | module Example.DSL.Server 2 | ( class ServerDSL 3 | , getGreeting 4 | ) where 5 | 6 | import Data.Either (Either) 7 | import Halogen (HalogenM, lift) 8 | import Prelude (class Monad) 9 | 10 | -- | Simple Server API DSL. If we have more server calls, we can just add to this 11 | -- | list here. As an alternative, please check `purescript-affjax-algebra`. 12 | -- | 13 | -- | The `getGreeting` implementation looks similar, but requires an `APIToken`. 14 | -- | We will provide this in our `runExample` transform instead of passing it around 15 | -- | everywhere in our components. 16 | class Monad m <= ServerDSL m where 17 | getGreeting :: m (Either String String) 18 | 19 | -- | We need a HalogenM instance in order to be able to use this DSL 20 | -- | within our component's `eval`. 21 | instance serverDSLHalogenM :: ServerDSL m => ServerDSL (HalogenM s f g p o m) where 22 | getGreeting = lift getGreeting 23 | -------------------------------------------------------------------------------- /src/DSL/State.purs: -------------------------------------------------------------------------------- 1 | module Example.DSL.State 2 | ( class StateDSL 3 | , getState 4 | , modifyState 5 | , setState 6 | ) where 7 | 8 | import Halogen (HalogenM, lift) 9 | import Prelude (class Monad, Unit, const, (<<<)) 10 | 11 | -- | Naïve state monad representation. For simplicity, we use two operations: 12 | -- | one for reading and one for writing. 13 | class Monad m <= StateDSL s m | m -> s where 14 | getState :: m s 15 | modifyState :: (s -> s) -> m Unit 16 | 17 | -- | We define a helper function for setting the state when we don't 18 | -- | care about the current state. 19 | setState :: ∀ s m. StateDSL s m => s -> m Unit 20 | setState = modifyState <<< const 21 | 22 | -- | We need a HalogenM instance in order to be able to use this DSL 23 | -- | within our component's `eval`. 24 | instance stateDSLHalogenM :: StateDSL s' m => StateDSL s' (HalogenM s f g p o m) where 25 | getState = lift getState 26 | modifyState = lift <<< modifyState 27 | -------------------------------------------------------------------------------- /src/Main.purs: -------------------------------------------------------------------------------- 1 | -- | Main entry point for the example app. 2 | module Main 3 | ( main 4 | ) where 5 | 6 | 7 | import Effect (Effect) 8 | import Effect.Aff (Aff, launchAff) 9 | import Effect.Class (liftEffect) 10 | import Effect.Ref as Ref 11 | import Example.Component.Router as R 12 | import Example.Component.Router.Query (Query(..)) 13 | import Example.Control.Monad (PushType(..), runExampleM) 14 | import Example.Server.ServerAPI (APIToken(..), secretKey) 15 | import FRP.Event (create, subscribe) 16 | import Halogen as H 17 | import Halogen.Aff as HA 18 | import Halogen.VDom.Driver (runUI) 19 | import Prelude (Unit, Void, bind, flip, pure, unit, ($), (<<<)) 20 | 21 | -- | This is where everything ties toghether. 22 | -- | We first make sure the prerequisites for running our app exist: 23 | -- | 24 | -- | `body`, the HTML element that will contain our app, 25 | -- | `state`, our application's state, as a `Ref Int` 26 | -- | `event`, our `behavior`, which allows us to push events back from our free monad, 27 | -- | `token`, as our API's secret / authentication token. 28 | -- | 29 | -- | We throw everything into our `environment`, which is passed to `runExampleM`. 30 | -- | We then transform (hoist) the router component from our `Example` monad 31 | -- | to a regular `Aff`-based component that goes into `runUI`. 32 | -- | 33 | -- | Finally, we `subscribe` to our event using `handler`. 34 | main :: Effect Unit 35 | main = HA.runHalogenAff do 36 | body <- HA.awaitBody 37 | state <- liftEffect $ Ref.new 0 38 | event <- liftEffect create 39 | let environment = 40 | { token: APIToken secretKey 41 | , answer: 42 42 | , state 43 | , push: event.push 44 | } 45 | 46 | let router' = H.hoist (flip runExampleM environment) R.component 47 | driver <- runUI router' unit body 48 | liftEffect $ subscribe event.event (handler driver) 49 | 50 | where 51 | 52 | -- | Using the component's `driver`, whenever we get a `PushType` value 53 | -- | from our runExample, we trigger an `action` in our `driver.query`. 54 | handler :: H.HalogenIO Query Void Aff -> PushType -> Effect Unit 55 | handler driver pt = do 56 | case pt of 57 | PushRoute route -> do 58 | _ <- launchAff $ driver.query <<< H.action <<< Goto $ route 59 | pure unit 60 | PushShowDialog opts -> do 61 | _ <- launchAff $ driver.query <<< H.action <<< ShowDialog $ opts 62 | pure unit 63 | -------------------------------------------------------------------------------- /src/Server/ServerAPI.purs: -------------------------------------------------------------------------------- 1 | module Example.Server.ServerAPI 2 | ( getGreetingImpl 3 | , secretKey 4 | , APIToken (..) 5 | ) where 6 | 7 | import Effect.Aff (Aff) 8 | import Data.Either (Either(..)) 9 | import Prelude (otherwise, pure, ($), (<<<), (==)) 10 | 11 | -- | This is supposed to represent an API token that is secret within the application. 12 | -- | It may very well be a token or any sort of resource we get from an authentication API. 13 | data APIToken = APIToken String 14 | 15 | -- | We hardcode this here since we're not really using any server API. 16 | secretKey :: String 17 | secretKey = "Secret-ey secret" 18 | 19 | -- | As most APIs, it requires some input, which we represent as an `APIToken`. We can test 20 | -- | this by replacing the token we send to `runExample` in `main`.. 21 | getGreetingImpl :: APIToken -> Aff (Either String String) 22 | getGreetingImpl (APIToken token) 23 | | token == secretKey = pure <<< pure $ "hello world" 24 | | otherwise = pure <<< Left $ "error" 25 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Effect.Console (log) 6 | 7 | main :: Effect Unit 8 | main = do 9 | log "You should add some tests." 10 | --------------------------------------------------------------------------------