├── .gitignore ├── example ├── run.sh ├── client │ ├── HomepageStylesheet.elm │ ├── elm-package.json │ ├── App.elm │ └── Stylesheets.elm ├── elm-package.json └── server │ └── Main.elm ├── src ├── Http │ ├── Listeners.elm │ ├── Request.elm │ ├── Server.elm │ └── Response.elm └── Native │ └── Http.js ├── elm-package.json ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | example/*.js 2 | elm-stuff/ 3 | .DS_Store 4 | node_modules/ 5 | elm.js 6 | .comp 7 | -------------------------------------------------------------------------------- /example/run.sh: -------------------------------------------------------------------------------- 1 | elm make example/server/Main.elm --output=example/main.js 2 | echo "Elm.worker(Elm.Main);" >> example/main.js 3 | node example/main.js 4 | -------------------------------------------------------------------------------- /src/Http/Listeners.elm: -------------------------------------------------------------------------------- 1 | module Http.Listeners (on) where 2 | {-| Module for event listener helpers 3 | 4 | @docs on 5 | -} 6 | 7 | import Native.Http 8 | 9 | {-| Wrapper for creating even listeners 10 | -} 11 | on : String -> target -> Signal input 12 | on = Native.Http.on 13 | -------------------------------------------------------------------------------- /example/client/HomepageStylesheet.elm: -------------------------------------------------------------------------------- 1 | module HomepageStylesheet where 2 | 3 | import Stylesheets exposing (..) 4 | 5 | exports = 6 | css 7 | |%| body 8 | |-| backgroundColor (rgb 173 191 160) 9 | |-| boxSizing borderBox 10 | |-| padding 12 px 11 | -------------------------------------------------------------------------------- /example/client/elm-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "1.0.0", 3 | "summary": "helpful summary of your project, less than 80 characters", 4 | "repository": "https://github.com/USER/PROJECT.git", 5 | "license": "BSD3", 6 | "source-directories": [ 7 | "." 8 | ], 9 | "exposed-modules": [], 10 | "dependencies": { 11 | "elm-lang/core": "2.1.0 <= v < 3.0.0", 12 | "evancz/elm-html": "4.0.1 <= v < 5.0.0" 13 | }, 14 | "elm-version": "0.15.1 <= v < 0.16.0" 15 | } -------------------------------------------------------------------------------- /example/elm-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "1.0.0", 3 | "summary": "helpful summary of your project, less than 80 characters", 4 | "repository": "https://github.com/USER/PROJECT.git", 5 | "license": "BSD3", 6 | "source-directories": [ 7 | ".", 8 | "Html/" 9 | ], 10 | "exposed-modules": [], 11 | "dependencies": { 12 | "elm-lang/core": "2.1.0 <= v < 3.0.0", 13 | "evancz/elm-html": "4.0.1 <= v < 5.0.0" 14 | }, 15 | "elm-version": "0.15.1 <= v < 0.16.0" 16 | } -------------------------------------------------------------------------------- /elm-package.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": "1.0.0", 3 | "summary": "", 4 | "repository": "https://github.com/eeue56/elm-http-server.git", 5 | "license": "MIT", 6 | "source-directories": [ 7 | "src", 8 | "example" 9 | ], 10 | "exposed-modules": [ 11 | "Http" 12 | ], 13 | "native-modules": true, 14 | "dependencies": { 15 | "elm-lang/core": "2.1.0 <= v < 3.0.0", 16 | "evancz/elm-html": "4.0.1 <= v < 5.0.0" 17 | }, 18 | "elm-version": "0.15.1 <= v < 0.16.0" 19 | } 20 | -------------------------------------------------------------------------------- /example/client/App.elm: -------------------------------------------------------------------------------- 1 | module App where 2 | 3 | import Html exposing (..) 4 | import Html.Attributes exposing (id, src, href) 5 | import HomepageStylesheet exposing (..) 6 | import Stylesheets 7 | import Json.Encode as Encode 8 | 9 | 10 | main : Html 11 | main = 12 | div 13 | [ id "dave" ] 14 | [ 15 | div [ Html.Attributes.property "innerHTML" (Encode.string ("")) ] [], 16 | 17 | div 18 | [ ] 19 | [ a 20 | [ href "/App.elm" 21 | ] 22 | [ text "This site was entirely written in Elm! Try /App.elm to see the source for this page!" 23 | ] 24 | ] 25 | ] 26 | -------------------------------------------------------------------------------- /src/Http/Request.elm: -------------------------------------------------------------------------------- 1 | module Http.Request 2 | ( Method(..) 3 | , Request, emptyReq 4 | , onCloseReq 5 | ) where 6 | 7 | {-| Stuff for dealing with requests 8 | # Handle Requests 9 | @docs Request, emptyReq 10 | 11 | @docs Method 12 | 13 | # Events 14 | 15 | @docs onCloseReq 16 | -} 17 | 18 | import Http.Listeners exposing (on) 19 | 20 | {-| Standard Http Methods, useful for routing -} 21 | type Method 22 | = GET 23 | | POST 24 | | PUT 25 | | DELETE 26 | | NOOP 27 | 28 | 29 | {-| Node.js native Request object 30 | [Node Docs](https://nodejs.org/api/http.html#http_http_incomingmessage) -} 31 | type alias Request = 32 | { url : String 33 | , method : Method } 34 | 35 | 36 | {-| `emptyReq` is a dummy Native Request object incase you need it, as the initial value of 37 | a `Signal.Mailbox` for example. -} 38 | emptyReq : Request 39 | emptyReq = 40 | { url = "" 41 | , method = NOOP } 42 | 43 | 44 | {-| "Close" events as a Signal for Request objects. 45 | [Node docs](https://nodejs.org/api/http.html#http_event_close_2) -} 46 | onCloseReq : Request -> Signal () 47 | onCloseReq = on "close" 48 | 49 | 50 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Isaac Shapira 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /example/server/Main.elm: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Http.Server exposing (..) 4 | import Http.Request exposing (emptyReq, Request, Method(..)) 5 | import Http.Response exposing (emptyRes, Response, 6 | writeHtml, writeJson, 7 | writeElm, writeFile) 8 | 9 | import Task exposing (..) 10 | import Signal exposing (..) 11 | import Json.Encode as Json 12 | 13 | server : Mailbox (Request, Response) 14 | server = mailbox (emptyReq, emptyRes) 15 | 16 | route : (Request, Response) -> Task x () 17 | route (req, res) = 18 | case req.method of 19 | GET -> case req.url of 20 | "/" -> 21 | writeElm "/client/App" res 22 | "/App.elm" -> 23 | writeFile "/client/App.elm" res 24 | "/foo" -> 25 | writeHtml "

Foozle!

" res 26 | url -> 27 | writeHtml ("You tried to go to " ++ url) res 28 | 29 | POST -> 30 | res |> 31 | writeJson (Json.object [("foo", Json.string "bar")]) 32 | 33 | NOOP -> 34 | succeed () 35 | 36 | _ -> 37 | res |> 38 | writeJson (Json.string "unknown method!") 39 | 40 | port reply : Signal (Task x ()) 41 | port reply = route <~ dropRepeats server.signal 42 | 43 | port serve : Task x Server 44 | port serve = createServer' 45 | server.address 46 | 8080 47 | "Listening on 8080" 48 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DEPRECIATED 2 | 3 | Check out [servelm](https://github.com/eeue56/servelm) instead, which uses this project as a basis for providing a server side framework for Elm. 4 | 5 | # Elm Http Server 6 | 7 | This server, along with rtfeldman's Elm stylesheets, means that we can now have full stack Elm support. At no point in the development of an application will you have to write anything other than Elm! 8 | 9 | A demo can be found [here](http://107.170.81.176/). The styling is done through compile-time correct CSS provided by [elm-stylesheets](https://github.com/rtfeldman/elm-stylesheets). 10 | 11 | # APIs exposed 12 | 13 | The Http.Server module allows you to create servers and run them. 14 | 15 | ## Sending out Elm 16 | 17 | Use the `Http.Response.writeElm` function to compile an Elm file on request. It will compile an Elm file found with `name + ".elm""`. It will write the output to a file in the same folder as `name + ".html"`. This will then be served out to the client. There is no caching involved, meaning that every request that involves a call to `writeElm` will trigger a compile. Use this function as a proof of concept. 18 | 19 | This is enabled by the [node-elm-compiler](https://github.com/rtfeldman/node-elm-compiler) package. 20 | 21 | 22 | 23 | ## Get started 24 | 25 | To start Elm inside of Node simply this to the end of your compiled Elm code. 26 | 27 | ```JavaScript 28 | Elm.worker(Elm.Main); 29 | ``` 30 | 31 | Take a look at `example/run.sh` to see a complete usage 32 | 33 | ```bash 34 | elm make example/server/Main.elm --output=example/main.js 35 | echo "Elm.worker(Elm.Main);" >> example/main.js 36 | node example/main.js 37 | ``` 38 | 39 | ## Run the example 40 | 41 | This project depends on Node.js and the `node` command. 42 | 43 | ```bash 44 | example/run.sh 45 | ``` 46 | 47 | Then load up the browser to see it working! 48 | 49 | 50 | # Credit 51 | 52 | Originally inspired by https://github.com/Fresheyeball/elm-http-server. 53 | 54 | This is now substantially different from the original. 55 | 56 | 57 | -------------------------------------------------------------------------------- /src/Http/Server.elm: -------------------------------------------------------------------------------- 1 | module Http.Server 2 | ( createServer, createServer', listen 3 | , Port, Server 4 | , onRequest, onClose) where 5 | 6 | {-| Simple bindings to Node.js's Http.Server 7 | 8 | # Init the server 9 | 10 | ## Instaniation 11 | @docs createServer, createServer' 12 | 13 | ## Actually listen 14 | @docs listen 15 | 16 | ## Types 17 | @docs Server, Port 18 | 19 | # Listen for events 20 | @docs onRequest, onClose 21 | -} 22 | 23 | import Task exposing (Task, succeed, andThen) 24 | import Signal exposing (Address, Mailbox, mailbox) 25 | import Json.Encode as Json 26 | 27 | import Http.Request exposing (Request) 28 | import Http.Response exposing (Response) 29 | import Http.Listeners exposing (on) 30 | 31 | import Native.Http 32 | 33 | {-| Port number for the server to listen -} 34 | type alias Port = Int 35 | 36 | 37 | {-| Node.js native Server object 38 | [Node Docs](https://nodejs.org/api/http.html#http_class_http_server) -} 39 | type Server = Server 40 | 41 | {-| "Request" events as a Signal. 42 | [Node docs](https://nodejs.org/api/http.html#http_event_request) -} 43 | onRequest : Server -> Signal (Request, Response) 44 | onRequest = on "request" 45 | 46 | {-| "Close" events as a Signal for Servers. 47 | [Node docs](https://nodejs.org/api/http.html#http_event_close) -} 48 | onClose : Server -> Signal () 49 | onClose = on "close" 50 | 51 | 52 | {-| Create a new Http Server, and send (Request, Response) to an Address. For example 53 | 54 | port serve : Task x Server 55 | port serve = createServer server.address 56 | 57 | [Node docs](https://nodejs.org/api/http.html#http_http_createserver_requestlistener) 58 | -} 59 | createServer : Address (Request, Response) -> Task x Server 60 | createServer = Native.Http.createServer 61 | 62 | {-| Create a Http Server and listen in one command! For example 63 | port serve : Task x Server 64 | port serve = createServer' server.address 8080 "Alive on 8080!" 65 | -} 66 | 67 | createServer' : Address (Request, Response) -> Port -> String -> Task x Server 68 | createServer' address port' text = 69 | createServer address `andThen` listen port' text 70 | 71 | {-| Command Server to listen on a specific port, 72 | and echo a message to the console when active. 73 | Task will not resolve until listening is successful. 74 | For example 75 | 76 | port listen : Task x Server 77 | port listen = listen 8080 "Listening on 8080" server 78 | 79 | [Node Docs](https://nodejs.org/api/http.html#http_server_listen_port_hostname_backlog_callback) 80 | -} 81 | listen : Port -> String -> Server -> Task x Server 82 | listen = Native.Http.listen 83 | -------------------------------------------------------------------------------- /src/Http/Response.elm: -------------------------------------------------------------------------------- 1 | module Http.Response 2 | ( Response, StatusCode, Header 3 | , emptyRes 4 | , write, writeHead 5 | , writeHtml, writeJson 6 | , writeFile, writeElm 7 | , textHtml, applicationJson 8 | , onCloseRes, onFinishRes 9 | , end 10 | ) where 11 | 12 | import Native.Http 13 | import Http.Listeners exposing (on) 14 | 15 | import Task exposing (Task, succeed, andThen) 16 | import Json.Encode as Json 17 | 18 | 19 | {-| An http header, such as content type -} 20 | type alias Header = (String, String) 21 | 22 | {-| StatusCode ie 200 or 404 -} 23 | type alias StatusCode = Int 24 | 25 | 26 | {-| Node.js native Response object 27 | [Node Docs](https://nodejs.org/api/http.html#http_class_http_serverresponse) -} 28 | type alias Response = 29 | { statusCode : StatusCode } 30 | 31 | 32 | {-| `emptyRes` is a dummy Native Response object incase you need it, as the initial value of 33 | a `Signal.Mailbox` for example. -} 34 | emptyRes : Response 35 | emptyRes = 36 | { statusCode = 418 } 37 | 38 | 39 | {-| Write Headers to a Response 40 | [Node Docs](https://nodejs.org/api/http.html#http_response_writehead_statuscode_statusmessage_headers) -} 41 | writeHead : StatusCode -> Header -> Response -> Task x Response 42 | writeHead = Native.Http.writeHead 43 | 44 | {-| Write body to a Response 45 | [Node Docs](https://nodejs.org/api/http.html#http_response_write_chunk_encoding_callback) -} 46 | write : String -> Response -> Task x Response 47 | write = Native.Http.write 48 | 49 | {-| End a Response 50 | [Node Docs](https://nodejs.org/api/http.html#http_response_end_data_encoding_callback) -} 51 | end : Response -> Task x () 52 | end = Native.Http.end 53 | 54 | writeAs : Header -> String -> Response -> Task x () 55 | writeAs header html res = 56 | writeHead 200 header res 57 | `andThen` write html `andThen` end 58 | 59 | {-| Write out HTML to a Response. For example 60 | 61 | res `writeHtml` "

Howdy

" 62 | 63 | -} 64 | writeHtml : String -> Response -> Task x () 65 | writeHtml = writeAs textHtml 66 | 67 | {-| Write out JSON to a Response. For example 68 | res `writeJson` Json.object 69 | [ ("foo", Json.string "bar") 70 | , ("baz", Json.int 0) ] 71 | -} 72 | writeJson : Json.Value -> Response -> Task x () 73 | writeJson val res = 74 | writeAs applicationJson (Json.encode 0 val) res 75 | 76 | {-| write a file -} 77 | writeFile : String -> Response -> Task a () 78 | writeFile file res = 79 | writeHead 200 textHtml res 80 | `andThen` Native.Http.writeFile file 81 | `andThen` end 82 | 83 | {-| write elm! -} 84 | writeElm : String -> Response -> Task a () 85 | writeElm file res = 86 | writeHead 200 textHtml res 87 | `andThen` Native.Http.writeElm file 88 | `andThen` end 89 | 90 | {-| Html Header {"Content-Type":"text/html"}-} 91 | textHtml : Header 92 | textHtml = ("Content-Type", "text/html") 93 | 94 | {-| Json Header {"Content-Type":"application/json"}-} 95 | applicationJson : Header 96 | applicationJson = ("Content-Type", "application/json") 97 | 98 | 99 | {-| "Close" events as a Signal for Response objects. 100 | [Node docs](https://nodejs.org/api/http.html#http_event_close_1) -} 101 | onCloseRes : Response -> Signal () 102 | onCloseRes = on "close" 103 | 104 | {-| "Finsh" events as a Signal for Reponse objects. 105 | [Node docs](https://nodejs.org/api/http.html#http_event_finish) -} 106 | onFinishRes : Response -> Signal () 107 | onFinishRes = on "finish" 108 | -------------------------------------------------------------------------------- /src/Native/Http.js: -------------------------------------------------------------------------------- 1 | var COMPILED_DIR = '.comp'; 2 | 3 | var wrap_with_type = function(item){ 4 | return { 5 | ctor: item 6 | }; 7 | }; 8 | 9 | var make_compile_dir = function(fs, dir){ 10 | if (typeof dir === "undefined"){ 11 | dir = COMPILED_DIR; 12 | } 13 | 14 | if (!fs.existsSync(dir)){ 15 | fs.mkdirSync(dir); 16 | } 17 | }; 18 | 19 | var createServer = function createServer(fs, http, Tuple2, Task) { 20 | return function (address) { 21 | make_compile_dir(fs, __dirname + "/" + COMPILED_DIR); 22 | 23 | var send = address._0; 24 | var server = http.createServer(function (request, response) { 25 | request.method = wrap_with_type(request.method); 26 | return Task.perform(send(Tuple2(request, response))); 27 | }); 28 | return Task.asyncFunction(function (callback) { 29 | return callback(Task.succeed(server)); 30 | }); 31 | }; 32 | }; 33 | 34 | var listen = function listen(Task) { 35 | return function (port, echo, server) { 36 | return Task.asyncFunction(function (callback) { 37 | return server.listen(port, function () { 38 | console.log(echo); 39 | return callback(Task.succeed(server)); 40 | }); 41 | }); 42 | }; 43 | }; 44 | var writeHead = function writeHead(Task) { 45 | return function (code, header, res) { 46 | var o = {}; 47 | return Task.asyncFunction(function (callback) { 48 | o[header._0] = header._1; 49 | res.writeHead(code, o); 50 | return callback(Task.succeed(res)); 51 | }); 52 | }; 53 | }; 54 | 55 | var write = function write(Task) { 56 | return function (message, res) { 57 | return Task.asyncFunction(function (callback) { 58 | res.write(message); 59 | return callback(Task.succeed(res)); 60 | }); 61 | }; 62 | }; 63 | 64 | var writeFile = function writeFile(fs, mime, Task){ 65 | return function (fileName, res) { 66 | return Task.asyncFunction(function (callback) { 67 | 68 | var file = __dirname + fileName; 69 | var type = mime.lookup(file); 70 | console.log("file", file); 71 | res.writeHead('Content-Type', type); 72 | 73 | fs.readFile(file, function (e, data) { 74 | res.end(data); 75 | return callback(Task.succeed(res)); 76 | }); 77 | 78 | }); 79 | }; 80 | }; 81 | 82 | var writeElm = function writeElm(fs, mime, crypto, compiler, Task){ 83 | return function (fileName, res) { 84 | var compiled_file = COMPILED_DIR + fileName + '.html'; 85 | 86 | if (fs.existsSync(compiled_file)) { 87 | return writeFile(fs, mime, Task)("/" + compiled_file, res); 88 | } 89 | 90 | return Task.asyncFunction(function (callback) { 91 | var file = __dirname + fileName; 92 | var outfile = __dirname + "/" + compiled_file; 93 | 94 | // switch to the directory that the elm-app is served out of 95 | var dirIndex = file.lastIndexOf('/'); 96 | var dir = file.substr(0, dirIndex); 97 | 98 | process.chdir(dir); 99 | 100 | compiler.compile([file + '.elm'], { 101 | output: outfile, 102 | yes: true 103 | }).on('close', function(exitCode) { 104 | var type = mime.lookup(file + '.html'); 105 | 106 | res.writeHead('Content-Type', type); 107 | 108 | fs.readFile(outfile, function (e, data) { 109 | res.end(data); 110 | return callback(Task.succeed(res)); 111 | }); 112 | }); 113 | }); 114 | }; 115 | }; 116 | 117 | var end = function end(Task, Tuple0) { 118 | return function (res) { 119 | return Task.asyncFunction(function (callback) { 120 | return (function () { 121 | res.end(); 122 | return callback(Task.succeed(Tuple0)); 123 | })(); 124 | }); 125 | }; 126 | }; 127 | var on = function on(Signal) { 128 | return function (eventName, x) { 129 | return x.on(eventName, function (request, response) { 130 | if (typeof(request) == 'undefined') { 131 | return Signal.input(eventName, Tuple0); 132 | } 133 | return Signal.input(eventName, Tuple(request, response)); 134 | }); 135 | }; 136 | }; 137 | var make = function make(localRuntime) { 138 | localRuntime.Native = localRuntime.Native || {}; 139 | localRuntime.Native.Http = localRuntime.Native.Http || {}; 140 | 141 | 142 | if (localRuntime.Native.Http.values) { 143 | return localRuntime.Native.Http.values; 144 | } 145 | 146 | var http = require('http'); 147 | var fs = require('fs'); 148 | var mime = require('mime'); 149 | var compiler = require('node-elm-compiler'); 150 | var crypto = require('crypto'); 151 | 152 | var Task = Elm.Native.Task.make(localRuntime); 153 | var Utils = Elm.Native.Utils.make(localRuntime); 154 | var Signal = Elm.Native.Signal.make(localRuntime); 155 | var Tuple0 = Utils['Tuple0']; 156 | var Tuple2 = Utils['Tuple2']; 157 | 158 | 159 | return { 160 | 'createServer': createServer(fs, http, Tuple2, Task), 161 | 'listen': F3(listen(Task)), 162 | 'writeHead': F3(writeHead(Task)), 163 | 'writeFile': F2(writeFile(fs, mime, Task)), 164 | 'writeElm': F2(writeElm(fs, mime, crypto, compiler, Task)), 165 | 'write': F2(write(Task)), 166 | 'on': F2(on(Signal, Tuple0)), 167 | 'end': end(Task, Tuple0) 168 | }; 169 | }; 170 | Elm.Native.Http = {}; 171 | Elm.Native.Http.make = make; 172 | 173 | if (typeof window === "undefined") { 174 | window = global; 175 | } 176 | -------------------------------------------------------------------------------- /example/client/Stylesheets.elm: -------------------------------------------------------------------------------- 1 | module Stylesheets where 2 | 3 | {- 4 | Implementation notes: 5 | 6 | - strip out []()""'' - so: 7 | - toString ["html", "body"] -> "[\"html\",\"body\"]" -> "html,body" 8 | 9 | How would you write this? 10 | 11 | html, body, .foo, .bar 12 | width: 100% 13 | -} 14 | 15 | import String 16 | 17 | prettyPrint : Int -> Style class id -> String 18 | prettyPrint = 19 | prettyPrintHelp 0 20 | 21 | 22 | prettyPrintHelp : Int -> Int -> Style class id -> String 23 | prettyPrintHelp indentLevel indentSpaces (Style selector attributes children) = 24 | if (indentLevel == 0) && (String.isEmpty selector) then 25 | children 26 | |> List.map (prettyPrintHelp indentLevel indentSpaces) 27 | |> String.join "\n\n" 28 | else 29 | let 30 | indentStr = 31 | String.repeat (indentSpaces * indentLevel) " " 32 | 33 | subIndentStr = 34 | indentStr ++ String.repeat (indentSpaces) " " 35 | 36 | attrsStr = 37 | if List.isEmpty attributes then 38 | "" 39 | else 40 | attributes 41 | |> List.map attributeToString 42 | |> String.join subIndentStr 43 | |> (++) subIndentStr 44 | 45 | prettyPrintChild = 46 | prettyPrintHelp (indentLevel + 1) indentSpaces 47 | 48 | childrenStr = 49 | if List.isEmpty children then 50 | "" 51 | else 52 | children 53 | |> List.map prettyPrintChild 54 | |> String.join subIndentStr 55 | |> (++) subIndentStr 56 | in 57 | indentStr ++ selector ++ " {\n" 58 | ++ attrsStr 59 | ++ childrenStr 60 | ++ "}" 61 | 62 | 63 | attributeToString : Attribute -> String 64 | attributeToString (Attribute str) = 65 | str ++ ";\n" 66 | 67 | 68 | {- Tags -} 69 | 70 | html = Tag "html" 71 | body = Tag "body" 72 | header = Tag "header" 73 | nav = Tag "nav" 74 | div = Tag "div" 75 | span = Tag "span" 76 | img = Tag "img" 77 | nowrap = Tag "nowrap" 78 | button = Tag "button" 79 | h1 = Tag "h1" 80 | h2 = Tag "h2" 81 | h3 = Tag "h3" 82 | h4 = Tag "h4" 83 | p = Tag "p" 84 | ol = Tag "ol" 85 | input = Tag "input" 86 | 87 | tagToString (Tag str) = str 88 | 89 | 90 | -- TODO these are just for @media - maybe improve type guarantees? 91 | screen = "screen" 92 | print = "print" 93 | 94 | -- TODO this is just for ::selection - maybe improve type guarantees? 95 | selection = "selection" 96 | 97 | 98 | {- Units -} 99 | 100 | inheritToString : (a -> String) -> InheritOr a -> String 101 | inheritToString translate value = 102 | case value of 103 | Inherit -> 104 | "inherit" 105 | 106 | NotInherit notInherit -> 107 | translate notInherit 108 | 109 | 110 | autoToString : (a -> String) -> AutoOr a -> String 111 | autoToString translate value = 112 | case value of 113 | Auto -> 114 | "auto" 115 | 116 | NotAuto notAuto -> 117 | translate notAuto 118 | 119 | noneToString : (a -> String) -> NoneOr a -> String 120 | noneToString translate value = 121 | case value of 122 | None -> 123 | "none" 124 | 125 | NotNone notNone -> 126 | translate notNone 127 | 128 | 129 | unitsToString : Units -> String 130 | unitsToString = 131 | (\(ExplicitUnits str) -> str) 132 | |> inheritToString 133 | 134 | 135 | boxSizingToString : BoxSizing -> String 136 | boxSizingToString = 137 | (\(ExplicitBoxSizing str) -> str) 138 | |> inheritToString 139 | 140 | 141 | overflowToString : Overflow -> String 142 | overflowToString = 143 | (\(ExplicitOverflow str) -> str) 144 | |> autoToString 145 | |> inheritToString 146 | 147 | 148 | displayToString : Display -> String 149 | displayToString = 150 | (\(ExplicitDisplay str) -> str) 151 | |> noneToString 152 | |> inheritToString 153 | 154 | 155 | verticalAlignToString : VerticalAlign -> String 156 | verticalAlignToString = 157 | (\(ExplicitVerticalAlign str) -> str) 158 | |> inheritToString 159 | 160 | 161 | whiteSpaceToString : WhiteSpace -> String 162 | whiteSpaceToString = 163 | (\(ExplicitWhiteSpace str) -> str) 164 | |> autoToString 165 | |> inheritToString 166 | 167 | colorToString : Color -> String 168 | colorToString = 169 | (\(ExplicitColor str) -> str) 170 | |> autoToString 171 | |> inheritToString 172 | 173 | 174 | numberToString : number -> String 175 | numberToString num = 176 | toString (num + 0) 177 | 178 | 179 | textShadowToString : TextShadow -> String 180 | textShadowToString = 181 | explicitTextShadowToString 182 | |> noneToString 183 | |> inheritToString 184 | 185 | 186 | explicitTextShadowToString : ExplicitTextShadow -> String 187 | explicitTextShadowToString value = 188 | case value of 189 | NoTextShadow -> 190 | "TODO" 191 | 192 | outlineStyleToString : OutlineStyle -> String 193 | outlineStyleToString (OutlineStyle str) = str 194 | 195 | 196 | opacityStyleToString : OpacityStyle -> String 197 | opacityStyleToString (OpacityStyle str) = str 198 | 199 | 200 | type Tag 201 | = Tag String 202 | 203 | type InheritOr a 204 | = Inherit 205 | | NotInherit a 206 | 207 | type AutoOr a 208 | = Auto 209 | | NotAuto a 210 | 211 | type NoneOr a 212 | = None 213 | | NotNone a 214 | 215 | type alias BoxSizing = InheritOr ExplicitBoxSizing 216 | type alias Overflow = InheritOr (AutoOr ExplicitOverflow) 217 | type alias Display = InheritOr (NoneOr ExplicitDisplay) 218 | type alias WhiteSpace = InheritOr (AutoOr ExplicitWhiteSpace) 219 | type alias Color = InheritOr (AutoOr ExplicitColor) 220 | type alias TextShadow = InheritOr (NoneOr ExplicitTextShadow) 221 | type alias Outline = InheritOr ExplicitOutline 222 | type alias Units = InheritOr ExplicitUnits 223 | type alias VerticalAlign = InheritOr ExplicitVerticalAlign 224 | 225 | type ExplicitUnits = ExplicitUnits String 226 | type ExplicitBoxSizing = ExplicitBoxSizing String 227 | type ExplicitOverflow = ExplicitOverflow String 228 | type ExplicitDisplay = ExplicitDisplay String 229 | type ExplicitWhiteSpace = ExplicitWhiteSpace String 230 | type ExplicitColor = ExplicitColor String 231 | type ExplicitVerticalAlign = ExplicitVerticalAlign String 232 | 233 | type ExplicitOutline 234 | = ExplicitOutline Float ExplicitUnits OutlineStyle OpacityStyle 235 | 236 | type OutlineStyle 237 | = OutlineStyle String 238 | 239 | type OpacityStyle 240 | = OpacityStyle String 241 | 242 | type ExplicitTextShadow 243 | = NoTextShadow 244 | 245 | solid : OutlineStyle 246 | solid = OutlineStyle "solid" 247 | 248 | transparent : OpacityStyle 249 | transparent = OpacityStyle "transparent" 250 | 251 | rgb : number -> number -> number -> Color 252 | rgb r g b = 253 | ExplicitColor ("rgb(" ++ (numberToString r) ++ ", " ++ (numberToString g) ++ ", " ++ (numberToString b) ++ ")") 254 | |> NotAuto |> NotInherit 255 | 256 | 257 | rgba : number -> number -> number -> number -> Color 258 | rgba r g b a = 259 | ExplicitColor ("rgba(" ++ (numberToString r) ++ ", " ++ (numberToString g) ++ ", " ++ (numberToString b) ++ ", " ++ (numberToString a) ++ ")") 260 | |> NotAuto |> NotInherit 261 | 262 | 263 | hex : String -> Color 264 | hex str = 265 | ExplicitColor ("#" ++ str) 266 | |> NotAuto |> NotInherit 267 | 268 | pct : Units 269 | pct = "%" |> ExplicitUnits |> NotInherit 270 | 271 | em : Units 272 | em = "em" |> ExplicitUnits |> NotInherit 273 | 274 | px : Units 275 | px = "px" |> ExplicitUnits |> NotInherit 276 | 277 | borderBox = "border-box" |> ExplicitBoxSizing |> NotInherit 278 | 279 | visible : Display 280 | visible = "visible" |> ExplicitDisplay |> NotNone |> NotInherit 281 | 282 | block : Display 283 | block = "block" |> ExplicitDisplay |> NotNone |> NotInherit 284 | 285 | inlineBlock : Display 286 | inlineBlock = "inline-block" |> ExplicitDisplay |> NotNone |> NotInherit 287 | 288 | inline : Display 289 | inline = "inline" |> ExplicitDisplay |> NotNone |> NotInherit 290 | 291 | none : InheritOr (NoneOr a) 292 | none = None |> NotInherit 293 | 294 | auto : InheritOr (AutoOr a) 295 | auto = Auto |> NotInherit 296 | 297 | inherit : InheritOr a 298 | inherit = Inherit 299 | 300 | noWrap : WhiteSpace 301 | noWrap = "no-wrap" |> ExplicitWhiteSpace |> NotAuto |> NotInherit 302 | 303 | top : VerticalAlign 304 | top = "top" |> ExplicitVerticalAlign |> NotInherit 305 | 306 | middle : VerticalAlign 307 | middle = "middle" |> ExplicitVerticalAlign |> NotInherit 308 | 309 | bottom : VerticalAlign 310 | bottom = "bottom" |> ExplicitVerticalAlign |> NotInherit 311 | 312 | 313 | {- Attributes -} 314 | 315 | attr1 name translate value = 316 | Attribute (name ++ ": " ++ (translate value)) 317 | 318 | 319 | attr2 name translateA translateB valueA valueB = 320 | Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB)) 321 | 322 | 323 | attr3 name translateA translateB translateC valueA valueB valueC = 324 | Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB) ++ (translateC valueC)) 325 | 326 | 327 | attr4 name translateA translateB translateC translateD valueA valueB valueC valueD = 328 | Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB) ++ (translateC valueC) ++ (translateD valueD)) 329 | 330 | 331 | attr5 name translateA translateB translateC translateD translateE valueA valueB valueC valueD valueE = 332 | Attribute (name ++ ": " ++ (translateA valueA) ++ (translateB valueB) ++ (translateC valueC) ++ (translateD valueD) ++ (translateE valueE)) 333 | 334 | 335 | verticalAlign : VerticalAlign -> Attribute 336 | verticalAlign = 337 | attr1 "vertical-align" verticalAlignToString 338 | 339 | 340 | display : Display -> Attribute 341 | display = 342 | attr1 "display" displayToString 343 | 344 | 345 | opacity : OpacityStyle -> Attribute 346 | opacity = 347 | attr1 "opacity" toString 348 | 349 | 350 | width : number -> Units -> Attribute 351 | width = 352 | attr2 "width" numberToString unitsToString 353 | 354 | 355 | minWidth : number -> Units -> Attribute 356 | minWidth = 357 | attr2 "min-width" numberToString unitsToString 358 | 359 | 360 | height : number -> Units -> Attribute 361 | height = 362 | attr2 "height" numberToString unitsToString 363 | 364 | 365 | minHeight : number -> Units -> Attribute 366 | minHeight = 367 | attr2 "min-height" numberToString unitsToString 368 | 369 | 370 | padding : number -> Units -> Attribute 371 | padding = 372 | attr2 "padding" numberToString unitsToString 373 | 374 | paddingTop : number -> Units -> Attribute 375 | paddingTop = 376 | attr2 "padding-top" numberToString unitsToString 377 | 378 | paddingBottom : number -> Units -> Attribute 379 | paddingBottom = 380 | attr2 "padding-bottom" numberToString unitsToString 381 | 382 | paddingRight : number -> Units -> Attribute 383 | paddingRight = 384 | attr2 "padding-right" numberToString unitsToString 385 | 386 | paddingLeft : number -> Units -> Attribute 387 | paddingLeft = 388 | attr2 "padding-left" numberToString unitsToString 389 | 390 | margin : number -> Units -> Attribute 391 | margin = 392 | attr2 "margin" numberToString unitsToString 393 | 394 | marginTop : number -> Units -> Attribute 395 | marginTop = 396 | attr2 "margin-top" numberToString unitsToString 397 | 398 | marginBottom : number -> Units -> Attribute 399 | marginBottom = 400 | attr2 "margin-bottom" numberToString unitsToString 401 | 402 | marginRight : number -> Units -> Attribute 403 | marginRight = 404 | attr2 "margin-right" numberToString unitsToString 405 | 406 | marginLeft : number -> Units -> Attribute 407 | marginLeft = 408 | attr2 "margin-left" numberToString unitsToString 409 | 410 | boxSizing : BoxSizing -> Attribute 411 | boxSizing = 412 | attr1 "box-sizing" boxSizingToString 413 | 414 | 415 | overflowX : Overflow -> Attribute 416 | overflowX = 417 | attr1 "overflow-x" overflowToString 418 | 419 | 420 | overflowY : Overflow -> Attribute 421 | overflowY = 422 | attr1 "overflow-y" overflowToString 423 | 424 | 425 | whiteSpace : WhiteSpace -> Attribute 426 | whiteSpace = 427 | attr1 "white-space" whiteSpaceToString 428 | 429 | 430 | 431 | 432 | 433 | backgroundColor : Color -> Attribute 434 | backgroundColor = 435 | attr1 "background-color" colorToString 436 | 437 | 438 | color : Color -> Attribute 439 | color = 440 | attr1 "color" colorToString 441 | 442 | 443 | media : a -> String 444 | media value = 445 | "media " ++ (toString value) 446 | -- TODO 447 | 448 | textShadow : TextShadow -> Attribute 449 | textShadow = 450 | attr1 "text-shadow" textShadowToString 451 | 452 | 453 | outline : Float -> Units -> OutlineStyle -> OpacityStyle -> Attribute 454 | outline = 455 | attr4 456 | "outline" 457 | toString unitsToString 458 | (\str -> " " ++ outlineStyleToString str ++ " ") 459 | opacityStyleToString 460 | 461 | 462 | {- Types -} 463 | 464 | type Style class id 465 | = Style String (List Attribute) (List (Style class id)) 466 | 467 | 468 | type Attribute 469 | = Attribute String 470 | 471 | 472 | css : Style class id 473 | css = 474 | Style "" [] [] 475 | 476 | 477 | styleWithPrefix : String -> Style class id -> a -> Style class id 478 | styleWithPrefix prefix (Style selector attrs children) childSelector = 479 | children ++ [ Style (prefix ++ (toString childSelector)) [] [] ] 480 | |> Style selector attrs 481 | 482 | 483 | (|%|) : Style class id -> Tag -> Style class id 484 | (|%|) (Style selector attrs children) tag = 485 | children ++ [ Style (tagToString tag) [] [] ] 486 | |> Style selector attrs 487 | 488 | 489 | (|%|=) : Style class id -> List Tag -> Style class id 490 | (|%|=) (Style selector attrs children) tags = 491 | let 492 | childSelector = 493 | tags 494 | |> List.map tagToString 495 | |> String.join ", " 496 | in 497 | children ++ [ Style childSelector [] [] ] 498 | |> Style selector attrs 499 | 500 | 501 | (|@|) : Style class id -> a -> Style class id 502 | (|@|) = styleWithPrefix "@" 503 | 504 | 505 | (|::|) : Style class id -> a -> Style class id 506 | (|::|) = styleWithPrefix "::" 507 | 508 | 509 | (|>%|) : Style class id -> Tag -> Style class id 510 | (|>%|) (Style selector attrs children) tag = 511 | case splitStartLast children of 512 | ( _, Nothing ) -> 513 | children ++ [ Style (selector ++ " > " ++ tagToString tag) [] [] ] 514 | |> Style selector attrs 515 | 516 | ( start, Just (Style activeSelector _ _) ) -> 517 | children ++ [ Style (activeSelector ++ " > " ++ tagToString tag) [] [] ] 518 | |> Style selector attrs 519 | 520 | 521 | (|>%|=) : Style class id -> List Tag -> Style class id 522 | (|>%|=) (Style selector attrs children) tags = 523 | let 524 | selectorFromTag tag = 525 | case splitStartLast children of 526 | ( _, Nothing ) -> 527 | selector ++ " > " ++ tagToString tag 528 | 529 | ( start, Just (Style activeSelector _ _) ) -> 530 | activeSelector ++ " > " ++ tagToString tag 531 | 532 | childSelector = 533 | tags 534 | |> List.map selectorFromTag 535 | |> String.join ", " 536 | in 537 | children ++ [ Style childSelector [] [] ] 538 | |> Style selector attrs 539 | 540 | 541 | (|.|) : Style class id -> class -> Style class id 542 | (|.|) = styleWithPrefix "." 543 | 544 | 545 | (|#|) : Style class id -> id -> Style class id 546 | (|#|) = styleWithPrefix "#" 547 | 548 | 549 | (|>.|) : Style class id -> a -> Style class id 550 | (|>.|) = styleWithPrefix ">." 551 | 552 | 553 | (|!|) : Style class id -> Attribute -> Style class id 554 | (|!|) style (Attribute attrString) = 555 | transformActiveChild (addAttr (Attribute (attrString ++ " !important"))) style 556 | 557 | 558 | (|-|) : Style class id -> Attribute -> Style class id 559 | (|-|) style attr = 560 | transformActiveChild (addAttr attr) style 561 | 562 | 563 | addAttr : Attribute -> Style a b -> Style a b 564 | addAttr attr (Style selector attrs children) = 565 | Style selector (attrs ++ [ attr ]) children 566 | 567 | 568 | transformActiveChild : (Style a b -> Style a b) -> Style a b -> Style a b 569 | transformActiveChild transform (( Style selector attrs children ) as style) = 570 | case splitStartLast children of 571 | ( _, Nothing ) -> 572 | transform style 573 | 574 | ( inactiveChildren, Just activeChild ) -> 575 | Style 576 | selector 577 | attrs 578 | (inactiveChildren ++ [ transform activeChild ]) 579 | 580 | 581 | splitStartLast : List a -> (List a, Maybe a) 582 | splitStartLast list = 583 | case list of 584 | [] -> 585 | ( [], Nothing ) 586 | 587 | elem :: [] -> 588 | ( [], Just elem ) 589 | 590 | elem :: rest -> 591 | let 592 | ( start, last ) = 593 | splitStartLast rest 594 | in 595 | ( elem :: start, last ) 596 | 597 | --------------------------------------------------------------------------------