├── project.clj └── source ├── tutorial1.lux └── tutorial1 ├── core.lux ├── server ├── core.lux ├── css.lux ├── host.lux └── html.lux ├── state.lux ├── ui.lux └── util.lux /project.clj: -------------------------------------------------------------------------------- 1 | (defproject lux/tutorial1 "0.1.0-SNAPSHOT" 2 | :plugins [[com.github.luxlang/lein-luxc "0.5.0"]] 3 | :dependencies [[io.vertx/vertx-web "3.0.0"]] 4 | :source-paths ["source"] 5 | :lux {:program "tutorial1"} 6 | ) 7 | -------------------------------------------------------------------------------- /source/tutorial1.lux: -------------------------------------------------------------------------------- 1 | ## Copyright (c) Eduardo Julian. All rights reserved. 2 | ## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. 3 | ## If a copy of the MPL was not distributed with this file, 4 | ## You can obtain one at http://mozilla.org/MPL/2.0/. 5 | 6 | (;module: 7 | lux 8 | (lux (control monad 9 | eq) 10 | (data (struct [list #* "" Functor Fold]) 11 | [text "Text/" Eq] 12 | [number "Int/" Codec] 13 | ["E" error #*] 14 | [product] 15 | text/format) 16 | [compiler] 17 | (macro ["s" syntax #+ Syntax syntax:]) 18 | (codata [io #- run]) 19 | host 20 | (concurrency [promise #+ Promise Monad]) 21 | [cli #+ program:]) 22 | (. ["&&" core] 23 | ["&&;" state] 24 | ["&&;" util] 25 | ["&&;" ui] 26 | (server ["&&server" core] 27 | ["&&server-host" host]) 28 | )) 29 | 30 | (syntax: (?? default input) 31 | {#;doc "A simple macro for providing default values to Error-producing expressions."} 32 | (do @ 33 | [g!_ (compiler;gensym "") 34 | g!output (compiler;gensym "")] 35 | (wrap (list (` (case (~ input) 36 | (#E;Error (~ g!_)) 37 | (~ default) 38 | 39 | (#E;Success (~ g!output)) 40 | (~ g!output) 41 | )) 42 | )) 43 | )) 44 | 45 | ## [Program] 46 | (def: (handler state req) 47 | (-> &&state;App-State &&server;Request-Handler) 48 | (let [(^slots [#&&server;request-method 49 | #&&server;request-uri 50 | #&&server;request-headers 51 | #&&server;request-params 52 | #&&server;request-body]) req] 53 | (if (Text/= &&util;css-path request-uri) 54 | ## Serve CSS style-sheet if route matches. 55 | (:: Monad wrap (&&server;css-response &&ui;css)) 56 | ## Otherwise, some functionality is required. 57 | (do Monad 58 | [#let [## When visiting some URL, I need to figure out from 59 | ## where did the user come from, because to add a task 60 | ## to the TODO list, you must POST it to your current 61 | ## route (whatever it may be). 62 | referer (?? &&util;default-referer 63 | (&&server;get-header "Referer" request-headers)) 64 | same-url? (Text/= (format &&util;default-host request-uri) referer)] 65 | succeded? (?? (wrap false) 66 | (case request-uri 67 | (^~ &&util;toggle-path) 68 | (do Monad 69 | [id' (&&server;get-param "id" request-params) 70 | id (Int/decode id')] 71 | (wrap (promise;future (&&state;toggle-task (int-to-nat id) state)))) 72 | 73 | (^~ &&util;delete-path) 74 | (do Monad 75 | [id' (&&server;get-param "id" request-params) 76 | id (Int/decode id')] 77 | (wrap (promise;future (&&state;delete-task (int-to-nat id) state)))) 78 | 79 | (^~ &&util;clear-completed-path) 80 | (do Monad 81 | [] 82 | (wrap (promise;future (&&state;clear-completed state)))) 83 | 84 | _ ## else 85 | (do Monad 86 | [task-desc (&&server;get-param "todo" request-params)] 87 | (if (Text/= "" task-desc) 88 | ## Don't add empty tasks. 89 | (wrap (:: Monad wrap true)) 90 | (wrap (if same-url? 91 | (promise;future (&&state;add-task task-desc state)) 92 | (:: Monad wrap true)))) 93 | ))) 94 | show-clear-completed? (promise;future (&&ui;show-clear-completed? state)) 95 | ## Get all the currently-available tasks. 96 | tasks (promise;future (&&state;get-task-list state)) 97 | #let [num-tasks-left (|> tasks 98 | (filter (. &&state;active-task? product;right)) 99 | size) 100 | ## Figure out the filter from the URL. 101 | display-filter (case request-uri 102 | (^~ &&util;all-path) #&&ui;All 103 | (^~ &&util;active-path) #&&ui;Active 104 | (^~ &&util;completed-path) #&&ui;Completed 105 | _ #&&ui;All) 106 | ## Figure out which tasks to render. 107 | tasks-to-show (&&ui;filter-tasks display-filter tasks) 108 | ## The rendered tasks page. 109 | output-page (&&ui;page$ (&&ui;todo$ show-clear-completed? num-tasks-left display-filter tasks-to-show))]] 110 | (wrap (if (and succeded? 111 | (not same-url?)) 112 | (&&server;redirect referer) 113 | (&&server;html-response output-page))))) 114 | )) 115 | 116 | (program: args 117 | (do Monad 118 | [## Initialize app-state. 119 | app-state &&state;gen-state 120 | ## Deploy Vert.x server. 121 | _ (&&server-host;deploy-server &&util;server-port (handler app-state))] 122 | (wrap (log! "Server is running!")))) 123 | -------------------------------------------------------------------------------- /source/tutorial1/core.lux: -------------------------------------------------------------------------------- 1 | ## Copyright (c) Eduardo Julian. All rights reserved. 2 | ## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. 3 | ## If a copy of the MPL was not distributed with this file, 4 | ## You can obtain one at http://mozilla.org/MPL/2.0/. 5 | 6 | (;module: 7 | lux) 8 | 9 | ## [Types] 10 | (type: #export Task 11 | {#completed? Bool 12 | #description Text}) 13 | -------------------------------------------------------------------------------- /source/tutorial1/server/core.lux: -------------------------------------------------------------------------------- 1 | ## Copyright (c) Eduardo Julian. All rights reserved. 2 | ## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. 3 | ## If a copy of the MPL was not distributed with this file, 4 | ## You can obtain one at http://mozilla.org/MPL/2.0/. 5 | 6 | (;module: 7 | lux 8 | (lux (control monad) 9 | (data maybe 10 | [text "Text/" Eq] 11 | [number "Int/" Codec] 12 | text/format 13 | error 14 | (struct [list "" Functor] 15 | [array #+ Array])) 16 | host 17 | [compiler] 18 | (macro [ast] 19 | ["s" syntax #+ Syntax syntax:]) 20 | (concurrency [promise #+ Promise])) 21 | (.. ["&;" html] 22 | ["&;" css]) 23 | ) 24 | 25 | ## [Host] 26 | (jvm-import java.lang.String 27 | (getBytes [] Byte-Array)) 28 | 29 | ## [Types] 30 | (type: #export HTTP-Method 31 | #GET 32 | #POST 33 | #PUT 34 | #DELETE 35 | #HEAD 36 | #PATCH 37 | #CONNECT 38 | #OPTIONS 39 | #TRACE) 40 | 41 | (type: #export Port 42 | Nat) 43 | 44 | (type: #export HTTP-Status 45 | Nat) 46 | 47 | (type: #export HTTP-Headers 48 | (List [Text Text])) 49 | 50 | (type: #export HTTP-Params 51 | (List [Text Text])) 52 | 53 | (type: #export HTTP-Body 54 | Byte-Array) 55 | 56 | (type: #export URL 57 | Text) 58 | 59 | (type: #export URI 60 | Text) 61 | 62 | (type: #export HTTP-Request 63 | {#request-method HTTP-Method 64 | #request-uri URI 65 | #request-headers HTTP-Headers 66 | #request-params HTTP-Params 67 | #request-body HTTP-Body}) 68 | 69 | (type: #export HTTP-Response 70 | {#response-status HTTP-Status 71 | #response-headers HTTP-Headers 72 | #response-body HTTP-Body}) 73 | 74 | (type: #export Request-Handler 75 | (-> HTTP-Request (Promise HTTP-Response))) 76 | 77 | ## [Values] 78 | (def: #export empty-headers 79 | HTTP-Headers 80 | (list)) 81 | 82 | ## [Syntax] 83 | (syntax: #export (headers [headers (s;record (s;some (s;seq s;text s;any)))]) 84 | (wrap (list (` (list (~@ (map (: (-> [Text AST] AST) 85 | (lambda [[key val]] 86 | (` [(~ (ast;text key)) (~ val)]))) 87 | headers))))))) 88 | 89 | ## [Values] 90 | (def: empty-response-body (String.getBytes [] "")) 91 | 92 | (def: #export (add-header name value headers) 93 | (-> Text Text HTTP-Headers HTTP-Headers) 94 | (#;Cons [name value] headers)) 95 | 96 | (do-template [ ] 97 | [(def: #export ( value) 98 | (-> HTTP-Response) 99 | (let [value-bytes (String.getBytes [] value)] 100 | {#response-status +200 101 | #response-headers (|> empty-headers 102 | (add-header "Content-Length" (Int/encode (nat-to-int (array-length value-bytes)))) 103 | (add-header "Content-Type" )) 104 | #response-body value-bytes}))] 105 | 106 | [html-response &html;Html "text/html"] 107 | [css-response &css;CSS "text/css"] 108 | ) 109 | 110 | (def: #export (redirect to) 111 | (-> URL HTTP-Response) 112 | {#response-status +307 113 | #response-headers (|> empty-headers 114 | (add-header "Content-Length" "0") 115 | (add-header "Content-Type" "text/html") 116 | (add-header "Location" to)) 117 | #response-body empty-response-body}) 118 | 119 | (def: #export (HTTP-Method$ name) 120 | (-> Text (Maybe HTTP-Method)) 121 | (case name 122 | "GET" (#;Some #GET) 123 | "POST" (#;Some #POST) 124 | "PUT" (#;Some #PUT) 125 | "DELETE" (#;Some #DELETE) 126 | "HEAD" (#;Some #HEAD) 127 | "PATCH" (#;Some #PATCH) 128 | "CONNECT" (#;Some #CONNECT) 129 | "TRACE" (#;Some #TRACE) 130 | "OPTIONS" (#;Some #OPTIONS) 131 | _ #;None)) 132 | 133 | (def: #export (param-exists? name) 134 | (-> Text HTTP-Params Bool) 135 | (list;any? (lambda [[k v]] (Text/= name k)))) 136 | 137 | (do-template [ ] 138 | [(def: #export ( name data) 139 | (-> Text (Error Text)) 140 | (case (list;find (lambda [[k v]] 141 | (Text/= name k)) 142 | data) 143 | (#;Some [k value]) 144 | (#;Right value) 145 | 146 | #;None 147 | (#;Left (format " not found: " name))))] 148 | 149 | [get-header HTTP-Headers "Header"] 150 | [get-param HTTP-Params "Parameter"] 151 | ) 152 | -------------------------------------------------------------------------------- /source/tutorial1/server/css.lux: -------------------------------------------------------------------------------- 1 | ## Copyright (c) Eduardo Julian. All rights reserved. 2 | ## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. 3 | ## If a copy of the MPL was not distributed with this file, 4 | ## You can obtain one at http://mozilla.org/MPL/2.0/. 5 | 6 | (;module: 7 | lux 8 | (lux (control ["M" monad]) 9 | (data [text "Text/" Monoid] 10 | text/format 11 | (struct [list #* "" Functor Fold])) 12 | [compiler] 13 | (macro ["s" syntax #+ Syntax syntax:] 14 | [ast]))) 15 | 16 | ## [Types] 17 | (type: #export Selector 18 | Text) 19 | 20 | (type: #export Style 21 | {#;doc "The properties associated with a CSS selector."} 22 | (List [Text Text])) 23 | 24 | (type: #export Css-Rule Text) 25 | 26 | (type: #export Rule-Set (List Css-Rule)) 27 | 28 | (type: #export CSS Text) 29 | 30 | ## [Syntax] 31 | (def: style^ 32 | (Syntax (List [Text AST])) 33 | (s;record (s;some (s;seq s;text s;any)))) 34 | 35 | (syntax: #export (style [style style^]) 36 | (wrap (list (` (: Style 37 | (list (~@ (map (: (-> [Text AST] AST) 38 | (lambda [[key val]] 39 | (` [(~ (ast;text key)) (~ val)]))) 40 | style)))))))) 41 | 42 | ## [Functions] 43 | (def: (style->text style) 44 | (-> Style Text) 45 | (|> style 46 | (map (lambda [[key val]] (format key ": " val))) 47 | (text;join-with "; "))) 48 | 49 | (def: #export (rule' selector style children) 50 | (-> Selector Style Rule-Set Rule-Set) 51 | (let [selector-prefix (format selector " ")] 52 | (list& (format selector-prefix "{" (style->text style) "}") 53 | (map (Text/append selector-prefix) children)))) 54 | 55 | (syntax: #export (rule [selector s;any] style [children (s;some s;any)]) 56 | (let [style' (case style 57 | [_ (#;RecordS _)] 58 | (` (style (~ style))) 59 | 60 | _ 61 | style)] 62 | (wrap (list (` (rule' (~ selector) (~ style') ((get@ #M;join Monad) (list (~@ children))))))))) 63 | 64 | (def: #export (css rules) 65 | (-> Rule-Set CSS) 66 | (text;join-with "\n" rules)) 67 | -------------------------------------------------------------------------------- /source/tutorial1/server/host.lux: -------------------------------------------------------------------------------- 1 | ## Copyright (c) Eduardo Julian. All rights reserved. 2 | ## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. 3 | ## If a copy of the MPL was not distributed with this file, 4 | ## You can obtain one at http://mozilla.org/MPL/2.0/. 5 | 6 | (;module: 7 | lux 8 | (lux (control monad) 9 | (codata [io #- run]) 10 | (data maybe 11 | [text] 12 | text/format 13 | (struct [list "" Functor Fold "List/" Monoid])) 14 | host 15 | (concurrency promise)) 16 | (.. (core #as &))) 17 | 18 | ## [Host] 19 | (jvm-import java.lang.Object 20 | (toString [] String)) 21 | 22 | (jvm-import io.vertx.core.Verticle) 23 | 24 | (jvm-import io.vertx.core.http.HttpMethod) 25 | 26 | (jvm-import (io.vertx.core.Handler a)) 27 | 28 | (jvm-import io.vertx.core.buffer.Buffer 29 | (#static buffer [Byte-Array] Buffer) 30 | (getBytes [] Byte-Array)) 31 | 32 | (jvm-import (java.util.Map$Entry k v) 33 | (getKey [] k) 34 | (getValue [] v)) 35 | 36 | (jvm-import (java.util.Iterator e) 37 | (hasNext [] boolean) 38 | (next [] e)) 39 | 40 | (jvm-import (java.lang.Iterable e) 41 | (iterator [] (java.util.Iterator e))) 42 | 43 | (jvm-import #long (java.util.List e) 44 | (size [] int) 45 | (get [int] e)) 46 | 47 | (jvm-import #long (java.util.Set e)) 48 | 49 | (jvm-import io.vertx.core.MultiMap 50 | (add [String String] MultiMap) 51 | (entries [] (java.util.List (Map$Entry String String))) 52 | (names [] (java.util.Set String))) 53 | 54 | (jvm-import io.vertx.core.http.HttpServerResponse 55 | (headers [] MultiMap) 56 | (setStatusCode [int] HttpServerResponse) 57 | (write [Buffer] HttpServerResponse) 58 | (end [] void)) 59 | 60 | (jvm-import io.vertx.core.http.HttpServerRequest 61 | (method [] HttpMethod) 62 | (uri [] String) 63 | (headers [] MultiMap) 64 | (params [] MultiMap) 65 | (formAttributes [] MultiMap) 66 | (response [] #io HttpServerResponse) 67 | (bodyHandler [(Handler Buffer)] HttpServerRequest) 68 | (setExpectMultipart [boolean] HttpServerRequest)) 69 | 70 | (jvm-import io.vertx.core.http.HttpServer 71 | (listen [int] #io HttpServer) 72 | (requestHandler [(Handler HttpServerRequest)] #io HttpServer)) 73 | 74 | (jvm-import io.vertx.core.Vertx 75 | (#static vertx [] #io Vertx) 76 | (createHttpServer [] #io HttpServer) 77 | (deployVerticle [Verticle] #io void)) 78 | 79 | (jvm-import io.vertx.core.Future) 80 | 81 | (jvm-import io.vertx.core.AbstractVerticle) 82 | 83 | ## [Functions] 84 | (def: (extract-param entries idx) 85 | (-> (java.util.List (Map$Entry Text Text)) Int [Text Text]) 86 | (let [entry (java.util.List.get [idx] entries)] 87 | [(Map$Entry.getKey [] entry) (Map$Entry.getValue [] entry)])) 88 | 89 | (do-template [ ] 90 | [(def: ( req) 91 | (-> HttpServerRequest ) 92 | (let [entries (|> req ( []) (MultiMap.entries []))] 93 | (map (extract-param entries) 94 | (list;i.range 0 (i.dec (java.util.List.size [] entries))))))] 95 | 96 | [get-headers HttpServerRequest.headers &;HTTP-Headers] 97 | [get-query-params HttpServerRequest.params &;HTTP-Params] 98 | [get-form-params HttpServerRequest.formAttributes &;HTTP-Params] 99 | ) 100 | 101 | (def: (get-params req) 102 | (-> HttpServerRequest &;HTTP-Params) 103 | (List/append (get-query-params req) (get-form-params req))) 104 | 105 | (def: (respond! response request) 106 | (-> &;HTTP-Response HttpServerRequest (IO Unit)) 107 | (do Monad 108 | [#let [(^slots [#&;response-status #&;response-headers #&;response-body]) response] 109 | $response (HttpServerRequest.response [] request) 110 | #let [_ (HttpServerResponse.setStatusCode [(nat-to-int response-status)] $response) 111 | mm (fold (: (-> [Text Text] MultiMap MultiMap) 112 | (lambda [pair headers] (MultiMap.add pair headers))) 113 | (HttpServerResponse.headers [] $response) 114 | response-headers) 115 | _ (HttpServerResponse.write [(Buffer.buffer [response-body])] $response) 116 | _ (HttpServerResponse.end [] $response)]] 117 | (wrap []))) 118 | 119 | (def: (iterator->list iter) 120 | (All [a] (-> (Iterator a) (List a))) 121 | (if (Iterator.hasNext [] iter) 122 | (#;Cons (Iterator.next [] iter) 123 | (iterator->list iter)) 124 | #;Nil)) 125 | 126 | (def: (request$ req body) 127 | (-> HttpServerRequest &;HTTP-Body &;HTTP-Request) 128 | {#&;request-method (|> req (HttpServerRequest.method []) (Object.toString []) &;HTTP-Method$ (default #&;OPTIONS)) 129 | #&;request-uri (let [raw-uri (HttpServerRequest.uri [] req)] 130 | (default raw-uri 131 | (do Monad 132 | [[uri params] (text;split-with "?" raw-uri)] 133 | (wrap uri)))) 134 | #&;request-headers (get-headers req) 135 | #&;request-params (get-params req) 136 | #&;request-body body}) 137 | 138 | (def: (body-handler k) 139 | (-> (-> Buffer (Promise Unit)) (Handler Buffer)) 140 | (object [(Handler Buffer)] 141 | [] 142 | ((Handler A) (handle [body A]) void 143 | (exec (k body) 144 | [])) 145 | )) 146 | 147 | (def: (http-handler server) 148 | (-> &;Request-Handler (Handler HttpServerRequest)) 149 | (object [(Handler HttpServerRequest)] 150 | [] 151 | ((Handler A) (handle [vreq A]) void 152 | (exec (|> vreq 153 | (HttpServerRequest.setExpectMultipart [true]) 154 | (HttpServerRequest.bodyHandler 155 | [(body-handler (lambda [body'] 156 | (do Monad 157 | [#let [body (Buffer.getBytes [] body') 158 | request (request$ vreq body)] 159 | response (server request) 160 | _ (future (respond! response vreq))] 161 | (wrap []) 162 | )))])) 163 | [])))) 164 | 165 | (def: (verticle$ port server-fun vertx) 166 | (-> &;Port &;Request-Handler Vertx Verticle) 167 | (object AbstractVerticle [] 168 | [] 169 | (AbstractVerticle (start [start Future]) void 170 | (exec (io;run (do Monad 171 | [http-server (Vertx.createHttpServer [] vertx) 172 | _ (HttpServer.requestHandler [(http-handler server-fun)] http-server)] 173 | (HttpServer.listen [(nat-to-int port)] http-server))) 174 | [])) 175 | 176 | (AbstractVerticle (stop [stop Future]) void #throws [java.lang.Exception] 177 | (log! "Verticle stopped!")))) 178 | 179 | (def: #export (deploy-server port handler) 180 | (-> &;Port &;Request-Handler (IO Unit)) 181 | (do Monad 182 | [vertx (Vertx.vertx [])] 183 | (Vertx.deployVerticle [(verticle$ port handler vertx)] 184 | vertx))) 185 | -------------------------------------------------------------------------------- /source/tutorial1/server/html.lux: -------------------------------------------------------------------------------- 1 | ## Copyright (c) Eduardo Julian. All rights reserved. 2 | ## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. 3 | ## If a copy of the MPL was not distributed with this file, 4 | ## You can obtain one at http://mozilla.org/MPL/2.0/. 5 | 6 | (;module: 7 | lux 8 | (lux (control monad) 9 | (data [text] 10 | text/format 11 | (struct [list "" Functor Fold])) 12 | [compiler] 13 | (macro ["s" syntax #+ Syntax syntax:] 14 | [ast]))) 15 | 16 | ## [Types] 17 | (type: #export Html Text) 18 | 19 | (type: #export Attributes 20 | {#;doc "Attributes for an HTML tag."} 21 | (List [Text Text])) 22 | 23 | ## [Syntax] 24 | (def: attributes^ 25 | (Syntax (List [Text AST])) 26 | (s;record (s;some (s;seq s;text s;any)))) 27 | 28 | (syntax: #export (attrs [attrs attributes^]) 29 | {#;doc "Macro for turning simple record-syntax with text-tags into HTML tag attributes."} 30 | (wrap (list (` (: Attributes 31 | (list (~@ (map (: (-> [Text AST] AST) 32 | (lambda [[key val]] 33 | (` [(~ (ast;text key)) (~ val)]))) 34 | attrs)))))))) 35 | 36 | (syntax: #export (%tag% [name s;local-symbol]) 37 | {#;doc "Given the name of a tag-macro, generates it's text form."} 38 | (wrap (list (ast;text name)))) 39 | 40 | (syntax: #export (%tag-func-name% [name s;local-symbol]) 41 | {#;doc "Given the name of a tag-macro, generates the name for a tag-function."} 42 | (wrap (list (ast;symbol ["" (format name "'")])))) 43 | 44 | ## [Functions] 45 | (def: (attrs->text attrs) 46 | (-> Attributes Text) 47 | (|> attrs 48 | (map (lambda [[key val]] (format key "=" "\"" val "\""))) 49 | (text;join-with " "))) 50 | 51 | (def: #export (node name attrs children) 52 | {#;doc "Generates the HTML for a node."} 53 | (-> Text Attributes (List Html) Html) 54 | (format "<" name " " (attrs->text attrs) ">" (text;join-with " " children) "")) 55 | 56 | (do-template [] 57 | [(let% [ (%tag-func-name% )] 58 | ## Simple functions to avoid calling 'node' directly. 59 | (def: #export 60 | (node (%tag% ))) 61 | 62 | ## These macros just simplify HTML construction by saving people 63 | ## from having to constantly call the attrs macro and passing 64 | ## children lists. 65 | (syntax: #export ( attrs [children (s;some s;any)]) 66 | (let [attrs' (case attrs 67 | [_ (#;RecordS _)] 68 | (` (attrs (~ attrs))) 69 | 70 | _ 71 | attrs)] 72 | (wrap (list (` ( (~ attrs') (list (~@ children)))))))))] 73 | 74 | ## Head 75 | [head] 76 | [meta] 77 | [link] 78 | [title] 79 | ## Body 80 | [body] 81 | [div] 82 | [span] 83 | [a] 84 | [form] 85 | [input] 86 | ) 87 | -------------------------------------------------------------------------------- /source/tutorial1/state.lux: -------------------------------------------------------------------------------- 1 | ## Copyright (c) Eduardo Julian. All rights reserved. 2 | ## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. 3 | ## If a copy of the MPL was not distributed with this file, 4 | ## You can obtain one at http://mozilla.org/MPL/2.0/. 5 | 6 | (;module: 7 | lux 8 | (lux (control monad 9 | eq) 10 | (data maybe 11 | [product] 12 | [number] 13 | (struct [list "" Functor] 14 | [dict])) 15 | (codata [io #- run]) 16 | host 17 | (concurrency [stm])) 18 | (.. ["&" core])) 19 | 20 | ## [Types] 21 | (type: #export App-State 22 | {#;doc "The next-ID for a task, and the collection of tasks."} 23 | (stm;Var [Nat (dict;Dict Nat &;Task)])) 24 | 25 | (type: #export App-Data 26 | {#;doc "App-data, as can be rendered onto HTML."} 27 | (List [Nat &;Task])) 28 | 29 | ## [Values] 30 | (def: #export gen-state 31 | {#;doc "A procedure for generating an initial app-state."} 32 | (IO App-State) 33 | (io (stm;var [+0 (dict;new number;Hash)]))) 34 | 35 | (do-template [ ] 36 | [(def: #export 37 | (-> &;Task Bool) 38 | (|>. (get@ #&;completed?) 39 | )) 40 | 41 | (def: #export 42 | (-> App-Data Nat) 43 | (|>. (list;filter (|>. product;right )) 44 | list;size))] 45 | 46 | [num-active-tasks active-task? not] 47 | [num-completed-tasks completed-task? id] 48 | ) 49 | 50 | (def: #export (get-task-list !state) 51 | (-> App-State (IO App-Data)) 52 | (do Monad 53 | [[next-id data] (stm;read! !state)] 54 | (wrap (list;sort (lambda [[idl _] [idr _]] (n.< idl idr)) 55 | (dict;entries data))))) 56 | 57 | (def: #export (add-task task-desc !state) 58 | (-> Text App-State (IO Bool)) 59 | (do Monad 60 | [[next-id data] (stm;read! !state) 61 | #let [task {#&;completed? false 62 | #&;description task-desc} 63 | data' (dict;put next-id task data)] 64 | _ (stm;write! [(n.inc next-id) data'] 65 | !state)] 66 | (wrap true))) 67 | 68 | (def: #export (toggle-task idx !state) 69 | (-> Nat App-State (IO Bool)) 70 | (do Monad 71 | [[next-id data] (stm;read! !state)] 72 | (case (dict;get idx data) 73 | (#;Some task) 74 | (do @ 75 | [#let [data' (dict;put idx (update@ #&;completed? not task) data)] 76 | _ (stm;write! [next-id data'] !state)] 77 | (wrap true)) 78 | 79 | #;None 80 | (:: Monad wrap false)))) 81 | 82 | (def: #export (delete-task idx !state) 83 | (-> Nat App-State (IO Bool)) 84 | (do Monad 85 | [[next-id data] (stm;read! !state)] 86 | (case (dict;get idx data) 87 | (#;Some task) 88 | (do @ 89 | [_ (stm;write! [next-id (dict;remove idx data)] !state)] 90 | (wrap true)) 91 | 92 | #;None 93 | (:: Monad wrap false)))) 94 | 95 | (def: #export (clear-completed state) 96 | (-> App-State (IO Bool)) 97 | (do Monad 98 | [task-list (get-task-list state) 99 | _ (|> task-list 100 | list;reverse 101 | (mapM @ 102 | (: (-> [Nat &;Task] (IO Bool)) 103 | (lambda [[idx task]] 104 | (if (completed-task? task) 105 | (delete-task idx state) 106 | (wrap true))))))] 107 | (wrap true))) 108 | -------------------------------------------------------------------------------- /source/tutorial1/ui.lux: -------------------------------------------------------------------------------- 1 | ## Copyright (c) Eduardo Julian. All rights reserved. 2 | ## This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0. 3 | ## If a copy of the MPL was not distributed with this file, 4 | ## You can obtain one at http://mozilla.org/MPL/2.0/. 5 | 6 | (;module: 7 | lux 8 | (lux (control monad 9 | eq) 10 | (data maybe 11 | text/format 12 | [product] 13 | (struct [list "" Fold "List/" Monad])) 14 | (codata io) 15 | host) 16 | (.. ["&" core] 17 | ["&;" state] 18 | ["&;" util] 19 | (server ["&;" html] 20 | ["&;" css]))) 21 | 22 | ## [Types] 23 | (type: #export Display-Filter 24 | {#;doc "Models the different filter views."} 25 | #All 26 | #Active 27 | #Completed) 28 | 29 | ## [Structs] 30 | (struct: _ (Eq Display-Filter) 31 | (def: (= x y) 32 | (case [x y] 33 | (^template [] 34 | [ ] 35 | true) 36 | ([#All] [#Active] [#Completed]) 37 | 38 | _ 39 | false))) 40 | 41 | ## [Values] 42 | (def: #export css 43 | {#;doc "The entire CSS style-sheet for the UI."} 44 | &css;CSS 45 | (&css;css 46 | (List/join 47 | (list (&css;rule "body" 48 | {"font" "14px 'Helvetica Neue', Helvetica, Arial, sans-serif" 49 | "line-height" "1.4em" 50 | "background" "#f5f5f5" 51 | "color" "#4d4d4d" 52 | "min-width" "230px" 53 | "max-width" "550px" 54 | "margin" "0 auto" 55 | "-webkit-font-smoothing" "antialiased" 56 | "-moz-font-smoothing" "antialiased" 57 | "font-smoothing" "antialiased" 58 | "font-weight" "300"}) 59 | (&css;rule ".todo" 60 | {"background" "#fff" 61 | "margin" "130px 0 40px 0" 62 | "position" "relative" 63 | "box-shadow" "0 2px 4px 0 rgba(0, 0, 0, 0.2), 0 25px 50px 0 rgba(0, 0, 0, 0.1)"} 64 | (&css;rule "> .header" 65 | {"display" "block"} 66 | (&css;rule "> .new-task-form" 67 | {"display" "block" 68 | "margin-top" "0em"} 69 | (&css;rule "> .new-task-input" 70 | {"padding" "16px 16px 16px 60px" 71 | "border" "none" 72 | "width" "85%" 73 | "background" "rgba(0, 0, 0, 0.003)" 74 | } 75 | ) 76 | (&css;rule "> .new-task-submit" 77 | {"background-color" "inherit" 78 | "border" "none" 79 | "font-weight" "bold" 80 | "font-size" "1.25em" 81 | "cursor" "pointer"} 82 | )) 83 | ) 84 | (&css;rule "> .task-list" 85 | {"border-top" "1px solid #e6e6e6" 86 | "margin" "0" 87 | "padding" "0"} 88 | (&css;rule "> .task" 89 | {"position" "relative" 90 | "font-size" "24px" 91 | "border-bottom" "1px solid #ededed"} 92 | (&css;rule "> .completed-toggle" 93 | {"color" "#ededed" 94 | "text-decoration" "none"}) 95 | (&css;rule "> .task-description" 96 | {"white-space" "pre-line" 97 | "word-break" "break-all" 98 | "line-height" "1.2"}) 99 | (&css;rule "> .delete-button" 100 | {"color" "#af5b5e" 101 | "text-decoration" "none" 102 | "float" "right" 103 | "margin-top" "0.125em" 104 | "margin-right" "0.5em" 105 | })) 106 | (&css;rule "> .task.completed" 107 | {} 108 | (&css;rule "> .completed-toggle" 109 | {"color" "#bddad5"}) 110 | (&css;rule "> .task-description" 111 | {"color" "#d9d9d9" 112 | "text-decoration" "line-through"}) 113 | )) 114 | (&css;rule "> .footer" 115 | {"color" "#777" 116 | "padding" "10px 15px" 117 | "height" "20px" 118 | "text-align" "center" 119 | "border-top" "1px solid #e6e6e6"} 120 | (&css;rule "> .tasks-left" 121 | {"float" "left" 122 | "text-align" "left"}) 123 | (&css;rule "> .filters" 124 | {"margin" "0" 125 | "padding" "0" 126 | "position" "absolute" 127 | "right" "0" 128 | "left" "0"} 129 | (&css;rule "> .filter" 130 | {"color" "inherit" 131 | "margin" "3px" 132 | "padding" "3px 7px" 133 | "text-decoration" "none" 134 | "border" "1px solid transparent" 135 | "border-radius" "3px"}) 136 | (&css;rule "> .filter.active" 137 | {"border-color" "rgba(175, 47, 47, 0.2)"})) 138 | (&css;rule "> .clear-completed" 139 | {"float" "right" 140 | "position" "relative" 141 | "line-height" "20px" 142 | "text-decoration" "none" 143 | "cursor" "pointer" 144 | "position" "relative" 145 | "color" "inherit"})) 146 | ) 147 | )))) 148 | 149 | (def: (task-button$ path css-class label idx) 150 | (-> Text Text Text Nat &html;Html) 151 | (&html;a {"class" css-class 152 | "href" (format path "?id=" (%i (nat-to-int idx)))} 153 | label)) 154 | 155 | (def: done-label Text "☑") ## check-mark 156 | (def: not-done-label Text "☐") ## no-entry sign 157 | (def: delete-label Text "❌") ## X-mark 158 | 159 | (def: (task$ [task-idx task]) 160 | (-> [Nat &;Task] &html;Html) 161 | (let [(^slots [#&;completed? #&;description]) task] 162 | (&html;div {"class" (format "task" (if completed? " completed" ""))} 163 | (task-button$ &util;toggle-path 164 | "completed-toggle" 165 | (if completed? done-label not-done-label) 166 | task-idx) 167 | (&html;span {"class" "task-description"} 168 | description) 169 | (task-button$ &util;delete-path 170 | "delete-button" 171 | delete-label 172 | task-idx)))) 173 | 174 | (def: new-task-form$ 175 | &html;Html 176 | (&html;form {"class" "new-task-form" 177 | "method" "post" 178 | "action" "/"} 179 | (&html;input {"class" "new-task-input" 180 | "type" "text" 181 | "name" "todo" 182 | "placeholder" "What needs to be done?"}) 183 | (&html;input {"class" "new-task-submit" 184 | "type" "submit" 185 | "value" "Submit"}))) 186 | 187 | (def: (tasks-left$ amount) 188 | (-> Nat &html;Html) 189 | (&html;span {"class" "tasks-left"} 190 | (format (%i (nat-to-int amount)) " items left"))) 191 | 192 | (def: (filters$ active) 193 | (-> Display-Filter &html;Html) 194 | (let [(^open) Eq] 195 | (let% [ (do-template [