├── pkg ├── hs │ ├── color │ │ ├── LICENSE │ │ ├── stack.yaml │ │ ├── src │ │ │ └── Data │ │ │ │ ├── Color.hs │ │ │ │ └── Color │ │ │ │ ├── Illuminant.hs │ │ │ │ └── Internal │ │ │ │ ├── Conversion.hs │ │ │ │ └── Types.hs │ │ ├── color.cabal │ │ └── test │ │ │ └── Test.hs │ ├── nauva │ │ ├── LICENSE │ │ ├── Setup.hs │ │ ├── src │ │ │ └── Nauva │ │ │ │ ├── View.hs │ │ │ │ ├── App.hs │ │ │ │ ├── View │ │ │ │ ├── HTML.hs │ │ │ │ ├── Types.hs │ │ │ │ └── Terms.Generator.hs │ │ │ │ ├── Internal │ │ │ │ ├── Fragment.hs │ │ │ │ └── Events.hs │ │ │ │ ├── Service │ │ │ │ ├── Head.hs │ │ │ │ └── Router.hs │ │ │ │ ├── DOM.hs │ │ │ │ ├── NJS.hs │ │ │ │ ├── Static.hs │ │ │ │ └── NJS │ │ │ │ └── TH.hs │ │ └── nauva.cabal │ ├── nauva-native │ │ ├── LICENSE │ │ ├── jsbits │ │ │ └── rollup.config.js │ │ └── nauva-native.cabal │ ├── portfinder │ │ ├── LICENSE │ │ ├── stack.yaml │ │ ├── portfinder.cabal │ │ └── src │ │ │ └── Network │ │ │ └── PortFinder.hs │ ├── nauva-cli │ │ ├── LICENSE │ │ ├── stack.yaml │ │ └── nauva-cli.cabal │ ├── nauva-css │ │ ├── LICENSE │ │ ├── src │ │ │ └── Nauva │ │ │ │ ├── CSS.hs │ │ │ │ └── CSS │ │ │ │ ├── Helpers.hs │ │ │ │ ├── Renderer.hs │ │ │ │ ├── Typeface.hs │ │ │ │ └── Terms.Generator.hs │ │ └── nauva-css.cabal │ ├── nauva-catalog │ │ ├── LICENSE │ │ ├── src │ │ │ └── Nauva │ │ │ │ ├── Catalog │ │ │ │ ├── Types.hs │ │ │ │ ├── Theme │ │ │ │ │ ├── Color.hs │ │ │ │ │ └── Typeface.hs │ │ │ │ └── Specimens │ │ │ │ │ ├── TypefaceSpecimen.hs │ │ │ │ │ ├── CodeSpecimen.hs │ │ │ │ │ ├── ColorGroupSpecimen.hs │ │ │ │ │ └── NauvaSpecimen.hs │ │ │ │ └── Catalog.hs │ │ └── nauva-catalog.cabal │ ├── nauva-dev-server │ │ ├── LICENSE │ │ └── nauva-dev-server.cabal │ └── nauvad │ │ ├── stack.yaml │ │ ├── .gitignore │ │ ├── public │ │ └── rollup.config.js │ │ ├── src │ │ ├── Settings.hs │ │ ├── Language │ │ │ └── Haskell │ │ │ │ └── Ghcid │ │ │ │ ├── Parser.hs │ │ │ │ ├── Types.hs │ │ │ │ └── Util.hs │ │ ├── Wait.hs │ │ └── Session.hs │ │ ├── LICENSE │ │ ├── nauvad.cabal │ │ └── README.md └── js │ ├── .gitignore │ └── src │ ├── jsbits │ └── nauva-native │ │ └── index.ts │ └── Nauva │ ├── React │ ├── Input.ts │ └── Head.ts │ └── CSS.ts ├── .gitignore ├── .codeclimate.yml ├── script └── ci │ ├── hlint │ ├── buildall │ └── weeder ├── product ├── playground │ ├── shared │ │ ├── stack.yaml │ │ └── nauva-product-playground-shared.cabal │ └── app │ │ ├── dev │ │ ├── stack.yaml │ │ ├── Main.hs │ │ └── nauva-product-playground-app-dev.cabal │ │ └── native │ │ ├── src │ │ └── Main.hs │ │ ├── nauva-product-playground-app-native.cabal │ │ └── stack.yaml ├── template │ ├── app │ │ ├── dev │ │ │ ├── Main.hs │ │ │ ├── stack.yaml │ │ │ └── nauva-product-template-app-dev.cabal │ │ └── native │ │ │ ├── Main.hs │ │ │ ├── nauva-product-template-app-native.cabal │ │ │ └── stack.yaml │ ├── catalog │ │ ├── dev │ │ │ ├── Main.hs │ │ │ ├── stack.yaml │ │ │ └── nauva-product-template-catalog-dev.cabal │ │ └── native │ │ │ ├── Main.hs │ │ │ ├── stack.yaml │ │ │ └── nauva-product-template-catalog-native.cabal │ └── shared │ │ ├── stack.yaml │ │ ├── nauva-product-template-shared.cabal │ │ └── src │ │ └── Nauva │ │ └── Product │ │ └── Template │ │ ├── Catalog.hs │ │ └── App.hs ├── nauva │ ├── book │ │ ├── dev │ │ │ ├── Main.hs │ │ │ ├── stack.yaml │ │ │ └── nauva-product-nauva-book-dev.cabal │ │ ├── native │ │ │ ├── Main.hs │ │ │ ├── nauva-product-nauva-book-native.cabal │ │ │ └── stack.yaml │ │ └── static │ │ │ ├── stack.yaml │ │ │ ├── nauva-product-nauva-book-static.cabal │ │ │ └── Main.hs │ ├── shared │ │ ├── stack.yaml │ │ ├── nauva-product-nauva-shared.cabal │ │ └── src │ │ │ └── Nauva │ │ │ └── Product │ │ │ └── Nauva │ │ │ ├── Element │ │ │ ├── Terminal.hs │ │ │ └── Message.hs │ │ │ ├── Book │ │ │ └── App.hs │ │ │ └── Catalog.hs │ └── catalog │ │ └── dev │ │ ├── Main.hs │ │ ├── stack.yaml │ │ └── nauva-product-nauva-catalog-dev.cabal └── varna │ ├── shared │ ├── stack.yaml │ ├── src │ │ └── Nauva │ │ │ └── Product │ │ │ └── Varna │ │ │ ├── Routes.hs │ │ │ ├── Catalog.hs │ │ │ ├── Shared.hs │ │ │ └── Element │ │ │ └── Card.hs │ └── nauva-product-varna-shared.cabal │ ├── catalog │ ├── dev │ │ ├── Main.hs │ │ ├── stack.yaml │ │ └── nauva-product-varna-catalog-dev.cabal │ └── native │ │ ├── src │ │ └── Main.hs │ │ ├── nauva-product-varna-catalog-native.cabal │ │ └── stack.yaml │ └── app │ ├── dev │ ├── src │ │ └── Main.hs │ ├── stack.yaml │ └── nauva-product-varna-app-dev.cabal │ └── native │ ├── src │ └── Main.hs │ ├── nauva-product-varna-app-native.cabal │ └── stack.yaml ├── docs ├── haddock │ ├── stack.yaml │ ├── setup.yaml │ ├── deploy.yaml │ ├── Dockerfile │ └── README.md └── book │ ├── introduction.md │ ├── thunks.md │ ├── getting-started.md │ ├── components.md │ ├── markup.md │ └── styles.md ├── bin └── nauva ├── tsconfig.json ├── package.json ├── .travis.yml ├── LICENSE └── README.md /pkg/hs/color/LICENSE: -------------------------------------------------------------------------------- 1 | MIT -------------------------------------------------------------------------------- /pkg/hs/nauva/LICENSE: -------------------------------------------------------------------------------- 1 | MIT -------------------------------------------------------------------------------- /pkg/hs/nauva-native/LICENSE: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /pkg/hs/portfinder/LICENSE: -------------------------------------------------------------------------------- 1 | MIT -------------------------------------------------------------------------------- /pkg/hs/nauva-cli/LICENSE: -------------------------------------------------------------------------------- 1 | MIT 2 | -------------------------------------------------------------------------------- /pkg/hs/nauva-css/LICENSE: -------------------------------------------------------------------------------- 1 | MIT 2 | -------------------------------------------------------------------------------- /pkg/js/.gitignore: -------------------------------------------------------------------------------- 1 | /build/ 2 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/LICENSE: -------------------------------------------------------------------------------- 1 | MIT 2 | -------------------------------------------------------------------------------- /pkg/hs/nauva-dev-server/LICENSE: -------------------------------------------------------------------------------- 1 | MIT -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work 2 | snapshot.json 3 | .idea 4 | -------------------------------------------------------------------------------- /.codeclimate.yml: -------------------------------------------------------------------------------- 1 | engines: 2 | hlint: 3 | enabled: true 4 | -------------------------------------------------------------------------------- /pkg/hs/color/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | -------------------------------------------------------------------------------- /pkg/hs/nauva/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /pkg/hs/portfinder/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | -------------------------------------------------------------------------------- /pkg/hs/nauva-cli/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - '.' 4 | -------------------------------------------------------------------------------- /script/ci/hlint: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -e 4 | 5 | find . -name stack.yaml | while read path; do 6 | hlint "$(dirname $path)" ||: 7 | done 8 | -------------------------------------------------------------------------------- /product/playground/shared/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../../pkg/hs/nauva 5 | - ../../../pkg/hs/nauva-css 6 | -------------------------------------------------------------------------------- /product/template/app/dev/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Nauva.Server 4 | import Nauva.Product.Template.App 5 | 6 | 7 | main :: IO () 8 | main = devServer app 9 | -------------------------------------------------------------------------------- /product/nauva/book/dev/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Nauva.Server 4 | import Nauva.Product.Nauva.Book.App 5 | 6 | 7 | main :: IO () 8 | main = devServer bookApp 9 | -------------------------------------------------------------------------------- /product/nauva/book/native/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Nauva.Client 4 | import Nauva.Product.Nauva.Book.App 5 | 6 | 7 | main :: IO () 8 | main = runClient bookApp 9 | -------------------------------------------------------------------------------- /product/template/app/native/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Nauva.Client 4 | import Nauva.Product.Template.App 5 | 6 | 7 | main :: IO () 8 | main = runClient app 9 | -------------------------------------------------------------------------------- /product/nauva/shared/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../../pkg/hs/color 5 | - ../../../pkg/hs/nauva 6 | - ../../../pkg/hs/nauva-css 7 | - ../../../pkg/hs/nauva-catalog 8 | -------------------------------------------------------------------------------- /product/template/catalog/dev/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Nauva.Server 4 | import Nauva.Product.Template.Catalog (catalogApp) 5 | 6 | 7 | main :: IO () 8 | main = devServer catalogApp 9 | -------------------------------------------------------------------------------- /product/template/shared/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../../pkg/hs/color 5 | - ../../../pkg/hs/nauva 6 | - ../../../pkg/hs/nauva-css 7 | - ../../../pkg/hs/nauva-catalog 8 | -------------------------------------------------------------------------------- /product/varna/shared/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../../pkg/hs/color 5 | - ../../../pkg/hs/nauva 6 | - ../../../pkg/hs/nauva-css 7 | - ../../../pkg/hs/nauva-catalog 8 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../color 5 | - ../nauva 6 | - ../nauva-css 7 | - ../nauva-catalog 8 | - ../portfinder 9 | - ../../../product/nauva/shared 10 | -------------------------------------------------------------------------------- /product/nauva/catalog/dev/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Nauva.Server 4 | import Nauva.Product.Nauva.Catalog (catalogApp) 5 | 6 | 7 | main :: IO () 8 | main = devServer catalogApp -------------------------------------------------------------------------------- /product/varna/catalog/dev/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Nauva.Server 4 | import Nauva.Product.Varna.Catalog (catalogApp) 5 | 6 | 7 | main :: IO () 8 | main = devServer catalogApp 9 | -------------------------------------------------------------------------------- /pkg/hs/color/src/Data/Color.hs: -------------------------------------------------------------------------------- 1 | module Data.Color 2 | ( module X 3 | ) where 4 | 5 | import Data.Color.Internal.Types as X 6 | import Data.Color.Internal.Conversion as X 7 | 8 | import Data.Color.Illuminant as X 9 | -------------------------------------------------------------------------------- /pkg/hs/nauva-css/src/Nauva/CSS.hs: -------------------------------------------------------------------------------- 1 | module Nauva.CSS 2 | ( module X 3 | ) where 4 | 5 | import Nauva.CSS.Helpers as X 6 | import Nauva.CSS.Terms as X 7 | import Nauva.CSS.Typeface as X 8 | import Nauva.CSS.Types as X 9 | -------------------------------------------------------------------------------- /product/nauva/book/static/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../shared 5 | - ../../../../pkg/hs/color 6 | - ../../../../pkg/hs/nauva 7 | - ../../../../pkg/hs/nauva-css 8 | - ../../../../pkg/hs/nauva-catalog 9 | -------------------------------------------------------------------------------- /docs/haddock/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - ../../pkg/hs/color 4 | - ../../pkg/hs/nauva 5 | - ../../pkg/hs/nauva-css 6 | - ../../pkg/hs/nauva-catalog 7 | - ../../pkg/hs/nauva-dev-server 8 | - ../../product/nauva/shared 9 | -------------------------------------------------------------------------------- /product/varna/app/dev/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Nauva.App 4 | import Nauva.Server 5 | import Nauva.Product.Varna.Shared 6 | 7 | 8 | main :: IO () 9 | main = devServer $ App (root . headH) 10 | -------------------------------------------------------------------------------- /product/template/catalog/native/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Nauva.Client 4 | import Nauva.Product.Template.Catalog (catalogApp) 5 | 6 | 7 | main :: IO () 8 | main = do 9 | putStrLn "Catalog App" 10 | runClient catalogApp 11 | -------------------------------------------------------------------------------- /bin/nauva: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | 4 | TOP="$PWD" # Assumes that user is in the root of the repository! 5 | 6 | stack --stack-yaml "$TOP/pkg/hs/nauva-cli/stack.yaml" build --install-ghc 7 | stack --stack-yaml "$TOP/pkg/hs/nauva-cli/stack.yaml" exec nauva-cli -- $@ 8 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/.gitignore: -------------------------------------------------------------------------------- 1 | /dist 2 | /.dist-buildwrapper 3 | /.project 4 | /cabal.sandbox.config 5 | tags 6 | /.cabal-sandbox 7 | /.stack-work 8 | # Use 'stack init' on a fresh checkout to generate your own stack.yaml file 9 | # for easy building. 10 | /issues 11 | -------------------------------------------------------------------------------- /script/ci/buildall: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | 5 | find . -name stack.yaml | while read path; do 6 | dir=$(dirname $path) 7 | echo $dir 8 | pushd $dir >/dev/null 9 | stack --install-ghc build 10 | popd >/dev/null 11 | done 12 | -------------------------------------------------------------------------------- /tsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "compileOnSave": true, 3 | "compilerOptions": { 4 | "target": "es6", 5 | "module": "es6", 6 | "outDir": "pkg/js/build/js" 7 | }, 8 | "include": [ 9 | "pkg/js/src/**/*.ts" 10 | ] 11 | } 12 | -------------------------------------------------------------------------------- /product/varna/catalog/native/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | 4 | import Nauva.Client 5 | import Nauva.Product.Varna.Catalog 6 | 7 | 8 | 9 | main :: IO () 10 | main = do 11 | putStrLn "Varna Catalog" 12 | runClient catalogApp -------------------------------------------------------------------------------- /product/varna/app/native/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | 4 | import Nauva.App 5 | import Nauva.Client 6 | import Nauva.Product.Varna.Shared 7 | 8 | 9 | 10 | main :: IO () 11 | main = do 12 | putStrLn "Native App" 13 | runClient $ App (root . headH) 14 | -------------------------------------------------------------------------------- /product/nauva/catalog/dev/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../shared 5 | - ../../../../pkg/hs/color 6 | - ../../../../pkg/hs/nauva 7 | - ../../../../pkg/hs/nauva-css 8 | - ../../../../pkg/hs/nauva-catalog 9 | - ../../../../pkg/hs/nauva-dev-server 10 | -------------------------------------------------------------------------------- /product/varna/app/dev/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../shared 5 | - ../../../../pkg/hs/color 6 | - ../../../../pkg/hs/nauva 7 | - ../../../../pkg/hs/nauva-css 8 | - ../../../../pkg/hs/nauva-catalog 9 | - ../../../../pkg/hs/nauva-dev-server 10 | -------------------------------------------------------------------------------- /product/varna/catalog/dev/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../shared 5 | - ../../../../pkg/hs/color 6 | - ../../../../pkg/hs/nauva 7 | - ../../../../pkg/hs/nauva-css 8 | - ../../../../pkg/hs/nauva-catalog 9 | - ../../../../pkg/hs/nauva-dev-server 10 | -------------------------------------------------------------------------------- /product/playground/app/dev/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../shared 5 | - ../../../../pkg/hs/color 6 | - ../../../../pkg/hs/nauva 7 | - ../../../../pkg/hs/nauva-css 8 | - ../../../../pkg/hs/nauva-catalog 9 | - ../../../../pkg/hs/nauva-dev-server 10 | -------------------------------------------------------------------------------- /product/varna/shared/src/Nauva/Product/Varna/Routes.hs: -------------------------------------------------------------------------------- 1 | module Nauva.Product.Varna.Routes 2 | ( Route(..) 3 | ) where 4 | 5 | 6 | import Data.Text (Text) 7 | 8 | 9 | 10 | data Route 11 | = HomeR 12 | | BatteryR !Text 13 | 14 | 15 | -- match :: [(Route, Element)] -> Maybe Element 16 | -------------------------------------------------------------------------------- /pkg/hs/color/src/Data/Color/Illuminant.hs: -------------------------------------------------------------------------------- 1 | module Data.Color.Illuminant 2 | ( d55 3 | , d65 4 | ) where 5 | 6 | 7 | import Data.Color.Internal.Types 8 | 9 | 10 | d55 :: Chromaticity 11 | d55 = Chromaticity 0.33242 0.34743 12 | 13 | d65 :: Chromaticity 14 | d65 = Chromaticity 0.31271 0.32902 15 | -------------------------------------------------------------------------------- /product/playground/app/dev/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main (main) where 4 | 5 | 6 | import Nauva.App (App(App)) 7 | import Nauva.Server 8 | import Nauva.Product.Playground.Shared 9 | 10 | 11 | 12 | main :: IO () 13 | main = devServer playgroundApp 14 | -------------------------------------------------------------------------------- /product/nauva/book/dev/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../shared 5 | - ../../../../pkg/hs/color 6 | - ../../../../pkg/hs/nauva 7 | - ../../../../pkg/hs/nauva-css 8 | - ../../../../pkg/hs/nauva-catalog 9 | - ../../../../pkg/hs/nauva-dev-server 10 | - ../../../../pkg/hs/portfinder 11 | -------------------------------------------------------------------------------- /product/template/app/dev/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../shared 5 | - ../../../../pkg/hs/color 6 | - ../../../../pkg/hs/nauva 7 | - ../../../../pkg/hs/nauva-css 8 | - ../../../../pkg/hs/nauva-catalog 9 | - ../../../../pkg/hs/nauva-dev-server 10 | - ../../../../pkg/hs/portfinder 11 | -------------------------------------------------------------------------------- /product/template/catalog/dev/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: nightly-2017-08-25 2 | packages: 3 | - . 4 | - ../../shared 5 | - ../../../../pkg/hs/color 6 | - ../../../../pkg/hs/nauva 7 | - ../../../../pkg/hs/nauva-css 8 | - ../../../../pkg/hs/nauva-catalog 9 | - ../../../../pkg/hs/nauva-dev-server 10 | - ../../../../pkg/hs/portfinder 11 | -------------------------------------------------------------------------------- /product/playground/app/native/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main (main) where 4 | 5 | 6 | import Nauva.Client 7 | import Nauva.Product.Playground.Shared 8 | 9 | 10 | 11 | main :: IO () 12 | main = do 13 | putStrLn "playground/app/native" 14 | runClient playgroundApp 15 | -------------------------------------------------------------------------------- /script/ci/weeder: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -e 4 | 5 | stack install weeder --resolver=nightly 6 | 7 | PATH=$HOME/.local/bin:$PATH 8 | export PATH 9 | 10 | find . -name stack.yaml | while read path; do 11 | dir=$(dirname $path) 12 | echo $dir 13 | pushd $dir >/dev/null 14 | weeder . --build 15 | popd >/dev/null 16 | done 17 | -------------------------------------------------------------------------------- /docs/haddock/setup.yaml: -------------------------------------------------------------------------------- 1 | # Increase timeout because compiling all the Haskell packages 2 | # takes a *long* time. 3 | timeout: 7200s # 120m 4 | 5 | steps: 6 | - name: 'gcr.io/cloud-builders/docker' 7 | args: ['build', '-t', 'gcr.io/$PROJECT_ID/haskell:nightly-2017-07-25', 'docs/haddock'] 8 | 9 | images: ['gcr.io/$PROJECT_ID/haskell:nightly-2017-07-25'] 10 | -------------------------------------------------------------------------------- /pkg/js/src/jsbits/nauva-native/index.ts: -------------------------------------------------------------------------------- 1 | import {AppH} from '../../Nauva/App' 2 | 3 | export const newBridge = (containerElement, callbacks) => new AppH 4 | ( containerElement 5 | , callbacks.sendLocation 6 | , callbacks.componentEvent 7 | , callbacks.nodeEvent 8 | , callbacks.attachRef 9 | , callbacks.detachRef 10 | , callbacks.componentDidMount 11 | , callbacks.componentWillUnmount 12 | ) 13 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/View.hs: -------------------------------------------------------------------------------- 1 | module Nauva.View 2 | ( module Nauva.CSS 3 | , module Nauva.DOM 4 | , module Nauva.Internal.Events 5 | , module Nauva.Internal.Types 6 | , module Nauva.NJS 7 | , module Nauva.NJS.TH 8 | , module Nauva.View.HTML 9 | ) where 10 | 11 | import Nauva.CSS 12 | import Nauva.DOM 13 | import Nauva.Internal.Events 14 | import Nauva.Internal.Types hiding (State) 15 | import Nauva.NJS 16 | import Nauva.NJS.TH 17 | import Nauva.View.HTML 18 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "dependencies": { 3 | "@types/lodash": "^4.14.74", 4 | "@types/react": "^16.0.5", 5 | "@types/react-dom": "^15.5.4", 6 | "js-yaml": "^3.9.1", 7 | "lodash": "^4.17.4", 8 | "preact": "^8.2.1", 9 | "react": "^15.6.1", 10 | "react-dom": "^15.6.1", 11 | "rollup": "^0.48.2", 12 | "rollup-plugin-commonjs": "^8.2.0", 13 | "rollup-plugin-node-resolve": "^3.0.0", 14 | "rollup-plugin-replace": "^1.1.1", 15 | "typescript": "^2.4.2" 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /product/nauva/book/native/nauva-product-nauva-book-native.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-nauva-book-native 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-nauva-book-native 8 | default-language: Haskell2010 9 | main-is: Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , nauva-native 16 | , nauva-product-nauva-shared 17 | -------------------------------------------------------------------------------- /product/playground/app/native/nauva-product-playground-app-native.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-playground-app-native 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable nauva-product-playground-app-native 7 | default-language: Haskell2010 8 | main-is: src/Main.hs 9 | 10 | build-depends: 11 | base >= 4.7 && < 5 12 | , nauva 13 | , ghcjs-base 14 | , nauva-native 15 | , nauva-product-playground-shared 16 | -------------------------------------------------------------------------------- /product/varna/app/dev/nauva-product-varna-app-dev.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-varna-app-dev 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-varna-app-dev 8 | default-language: Haskell2010 9 | main-is: src/Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , nauva 16 | , nauva-dev-server 17 | , nauva-product-varna-shared 18 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/App.hs: -------------------------------------------------------------------------------- 1 | module Nauva.App 2 | ( AppH(..) 3 | , App(..) 4 | 5 | , module Nauva.Internal.Types 6 | , module Nauva.Service.Head 7 | , module Nauva.Service.Router 8 | ) where 9 | 10 | 11 | import Nauva.Internal.Types (Element(..)) 12 | 13 | import Nauva.Service.Head 14 | import Nauva.Service.Router 15 | 16 | 17 | data AppH = AppH 18 | { headH :: !HeadH 19 | , routerH :: !RouterH 20 | } 21 | 22 | 23 | data App = App 24 | { rootElement :: AppH -> Element 25 | } 26 | -------------------------------------------------------------------------------- /product/template/app/native/nauva-product-template-app-native.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-template-app-native 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-template-app-native 8 | default-language: Haskell2010 9 | main-is: Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , nauva-native 16 | , nauva-product-template-shared 17 | -------------------------------------------------------------------------------- /product/varna/catalog/dev/nauva-product-varna-catalog-dev.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-varna-catalog-dev 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-varna-catalog-dev 8 | default-language: Haskell2010 9 | main-is: Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , nauva 16 | , nauva-dev-server 17 | , nauva-product-varna-shared 18 | -------------------------------------------------------------------------------- /docs/haddock/deploy.yaml: -------------------------------------------------------------------------------- 1 | timeout: 1200s # 20m 2 | 3 | steps: 4 | 5 | - name: 'gcr.io/$PROJECT_ID/haskell:nightly-2017-07-25' 6 | args: [ '--system-ghc', '--stack-yaml=docs/haddock/stack.yaml', 'build', '--haddock' ] 7 | 8 | - name: 'gcr.io/$PROJECT_ID/haskell:nightly-2017-07-25' 9 | entrypoint: 'bash' 10 | args: [ '-c', 'ln -s $(stack --system-ghc --stack-yaml=docs/haddock/stack.yaml path --local-doc-root) doc' ] 11 | 12 | - name: 'gcr.io/cloud-builders/gsutil' 13 | args: ['-m', 'rsync', '-r', 'doc/', 'gs://nvdocs/latest/'] 14 | -------------------------------------------------------------------------------- /product/nauva/book/dev/nauva-product-nauva-book-dev.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-nauva-book-dev 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-nauva-book-dev 8 | default-language: Haskell2010 9 | main-is: Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , nauva 16 | , nauva-dev-server 17 | , nauva-product-nauva-shared 18 | , text 19 | -------------------------------------------------------------------------------- /product/nauva/catalog/dev/nauva-product-nauva-catalog-dev.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-nauva-catalog-dev 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-nauva-catalog-dev 8 | default-language: Haskell2010 9 | main-is: Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , nauva-product-nauva-shared 16 | , nauva-catalog 17 | , nauva-dev-server 18 | -------------------------------------------------------------------------------- /product/playground/app/dev/nauva-product-playground-app-dev.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-playground-app-dev 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-playground-app-dev 8 | default-language: Haskell2010 9 | main-is: Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , nauva 16 | , nauva-dev-server 17 | , nauva-product-playground-shared 18 | -------------------------------------------------------------------------------- /product/template/app/dev/nauva-product-template-app-dev.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-template-app-dev 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-template-app-dev 8 | default-language: Haskell2010 9 | main-is: Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , nauva 16 | , nauva-dev-server 17 | , nauva-product-template-shared 18 | , text 19 | -------------------------------------------------------------------------------- /product/template/catalog/dev/nauva-product-template-catalog-dev.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-template-catalog-dev 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-template-catalog-dev 8 | default-language: Haskell2010 9 | main-is: Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , nauva-catalog 16 | , nauva-dev-server 17 | , nauva-product-template-shared 18 | -------------------------------------------------------------------------------- /product/varna/app/native/nauva-product-varna-app-native.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-varna-app-native 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-varna-app-native 8 | default-language: Haskell2010 9 | main-is: src/Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , ghcjs-base 16 | , nauva 17 | , nauva-native 18 | , nauva-product-varna-shared 19 | -------------------------------------------------------------------------------- /product/template/shared/nauva-product-template-shared.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-template-shared 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | library 7 | hs-source-dirs: src 8 | default-language: Haskell2010 9 | 10 | ghc-options: -Wall -Wno-type-defaults 11 | 12 | exposed-modules: 13 | Nauva.Product.Template.App 14 | Nauva.Product.Template.Catalog 15 | 16 | build-depends: 17 | base >= 4.7 && < 5 18 | , template-haskell 19 | , nauva 20 | , nauva-catalog 21 | -------------------------------------------------------------------------------- /product/nauva/book/native/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.19 2 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007019_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 10 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 11 | 12 | packages: 13 | - . 14 | - ../../shared 15 | - ../../../../pkg/hs/color 16 | - ../../../../pkg/hs/nauva 17 | - ../../../../pkg/hs/nauva-css 18 | - ../../../../pkg/hs/nauva-catalog 19 | - ../../../../pkg/hs/nauva-native 20 | -------------------------------------------------------------------------------- /product/template/app/native/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.19 2 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007019_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 10 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 11 | 12 | packages: 13 | - . 14 | - ../../shared 15 | - ../../../../pkg/hs/color 16 | - ../../../../pkg/hs/nauva 17 | - ../../../../pkg/hs/nauva-css 18 | - ../../../../pkg/hs/nauva-catalog 19 | - ../../../../pkg/hs/nauva-native 20 | -------------------------------------------------------------------------------- /product/varna/app/native/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.19 2 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007019_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 10 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 11 | 12 | packages: 13 | - . 14 | - ../../shared 15 | - ../../../../pkg/hs/color 16 | - ../../../../pkg/hs/nauva 17 | - ../../../../pkg/hs/nauva-css 18 | - ../../../../pkg/hs/nauva-catalog 19 | - ../../../../pkg/hs/nauva-native 20 | -------------------------------------------------------------------------------- /product/varna/catalog/native/nauva-product-varna-catalog-native.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-varna-catalog-native 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-varna-catalog-native 8 | default-language: Haskell2010 9 | main-is: src/Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , ghcjs-base 16 | , nauva 17 | , nauva-native 18 | , nauva-catalog 19 | , nauva-product-varna-shared 20 | -------------------------------------------------------------------------------- /product/varna/catalog/native/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.19 2 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007019_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 10 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 11 | 12 | packages: 13 | - . 14 | - ../../shared 15 | - ../../../../pkg/hs/color 16 | - ../../../../pkg/hs/nauva 17 | - ../../../../pkg/hs/nauva-css 18 | - ../../../../pkg/hs/nauva-catalog 19 | - ../../../../pkg/hs/nauva-native 20 | -------------------------------------------------------------------------------- /product/playground/app/native/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.19 2 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007019_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 10 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 11 | 12 | packages: 13 | - . 14 | - ../../shared 15 | - ../../../../pkg/hs/color 16 | - ../../../../pkg/hs/nauva 17 | - ../../../../pkg/hs/nauva-css 18 | - ../../../../pkg/hs/nauva-catalog 19 | - ../../../../pkg/hs/nauva-native 20 | -------------------------------------------------------------------------------- /product/template/catalog/native/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.19 2 | compiler: ghcjs-0.2.1.9007019_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007019_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2017-02-05-lts-7.19-9007019.tar.gz 10 | sha1: d2cfc25f9cda32a25a87d9af68891b2186ee52f9 11 | 12 | packages: 13 | - . 14 | - ../../shared 15 | - ../../../../pkg/hs/color 16 | - ../../../../pkg/hs/nauva 17 | - ../../../../pkg/hs/nauva-css 18 | - ../../../../pkg/hs/nauva-catalog 19 | - ../../../../pkg/hs/nauva-native 20 | -------------------------------------------------------------------------------- /product/template/catalog/native/nauva-product-template-catalog-native.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-template-catalog-native 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | 7 | executable nauva-product-template-catalog-native 8 | default-language: Haskell2010 9 | main-is: Main.hs 10 | 11 | ghc-options: -Wall -Wno-type-defaults 12 | 13 | build-depends: 14 | base >= 4.7 && < 5 15 | , ghcjs-base 16 | , nauva 17 | , nauva-native 18 | , nauva-catalog 19 | , nauva-product-template-shared 20 | -------------------------------------------------------------------------------- /product/varna/shared/nauva-product-varna-shared.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-varna-shared 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | library 7 | hs-source-dirs: src 8 | default-language: Haskell2010 9 | 10 | ghc-options: -Wall -Wno-type-defaults 11 | 12 | exposed-modules: 13 | Nauva.Product.Varna.Shared 14 | , Nauva.Product.Varna.Catalog 15 | , Nauva.Product.Varna.Element.Card 16 | 17 | build-depends: 18 | base >= 4.7 && < 5 19 | , aeson 20 | , text 21 | , nauva 22 | , nauva-catalog 23 | -------------------------------------------------------------------------------- /product/playground/shared/nauva-product-playground-shared.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-playground-shared 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | library 7 | hs-source-dirs: src 8 | default-language: Haskell2010 9 | 10 | ghc-options: -Wall -Wno-type-defaults 11 | 12 | exposed-modules: 13 | Nauva.Product.Playground.Shared 14 | 15 | build-depends: 16 | base >= 4.7 && < 5 17 | , aeson 18 | , text 19 | , nauva 20 | , aeson 21 | , text 22 | , containers 23 | , nauva 24 | , random 25 | , nauva 26 | -------------------------------------------------------------------------------- /product/nauva/book/static/nauva-product-nauva-book-static.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-nauva-book-static 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable nauva-product-nauva-book-static 7 | default-language: Haskell2010 8 | main-is: Main.hs 9 | 10 | ghc-options: -Wall -Wno-type-defaults 11 | 12 | build-depends: 13 | base >= 4.7 && < 5 14 | , nauva 15 | , nauva-css 16 | , nauva-catalog 17 | , nauva-product-nauva-shared 18 | , stm 19 | , blaze-markup 20 | , aeson 21 | , directory 22 | , filepath 23 | , text 24 | , blaze-html 25 | -------------------------------------------------------------------------------- /product/nauva/shared/nauva-product-nauva-shared.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-product-nauva-shared 2 | version: 0.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | library 7 | hs-source-dirs: src 8 | default-language: Haskell2010 9 | 10 | ghc-options: -Wall -Wno-type-defaults 11 | 12 | exposed-modules: 13 | Nauva.Product.Nauva.Catalog 14 | , Nauva.Product.Nauva.Element.Terminal 15 | , Nauva.Product.Nauva.Element.Message 16 | , Nauva.Product.Nauva.Book.App 17 | 18 | build-depends: 19 | base >= 4.7 && < 5 20 | , aeson 21 | , text 22 | , color 23 | , nauva 24 | , nauva-catalog 25 | -------------------------------------------------------------------------------- /docs/book/introduction.md: -------------------------------------------------------------------------------- 1 | The `Nauva` Haskell framework is an attempt to provide a solid foundation for 2 | building UI applications which use the W3C DOM as the underlying presentation 3 | technology. 4 | 5 | Nauva borrows many concepts from [React][react] - such as the virtual DOM, 6 | stateful components, unidirectional data binding - and implements them in Haskell. 7 | 8 | Applications written in Nauva are portable between server and client. The same 9 | code can be compiled and run on the server, but can also compiled by [GHCJS] 10 | and shipped to a web browser where it runs as a JavaScript application. 11 | 12 | [react]: https://facebook.github.io/react/ 13 | [GHCJS]: https://github.com/ghcjs/ghcjs 14 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | sudo: false 3 | 4 | cache: 5 | directories: 6 | - $HOME/.ghc 7 | - $HOME/.cabal 8 | - $HOME/.stack 9 | 10 | matrix: 11 | include: 12 | - script: stack --stack-yaml=docs/haddock/stack.yaml build 13 | addons: {apt: {packages: [ghc-8.0.2], sources: [hvr-ghc]}} 14 | 15 | # - script: ./script/ci/buildall 16 | # addons: {apt: {packages: [ghc-8.0.2], sources: [hvr-ghc]}} 17 | 18 | # - script: ./script/ci/weeder 19 | # addons: {apt: {packages: [ghc-8.0.2], sources: [hvr-ghc]}} 20 | 21 | before_install: 22 | - mkdir -p ~/.local/bin 23 | - curl -sL https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack'; 24 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/public/rollup.config.js: -------------------------------------------------------------------------------- 1 | import resolve from 'rollup-plugin-node-resolve' 2 | import commonjs from 'rollup-plugin-commonjs' 3 | import replace from 'rollup-plugin-replace' 4 | 5 | export default { 6 | input: __dirname + '/../../../js/build/js/jsbits/nauvad/index.js', 7 | output: { 8 | file: __dirname + '/nauvad.js', 9 | format: 'iife', 10 | name: 'nv$app' 11 | }, 12 | plugins: [ 13 | resolve({ jsnext: true, main: true }), 14 | commonjs({ 15 | namedExports: { 16 | 'react': ['Component', 'createElement'], 17 | 'react-dom': ['render'], 18 | }, 19 | }), 20 | replace({ 21 | 'process.env.NODE_ENV': JSON.stringify('development'), 22 | }), 23 | ], 24 | } 25 | -------------------------------------------------------------------------------- /pkg/hs/nauva-native/jsbits/rollup.config.js: -------------------------------------------------------------------------------- 1 | import resolve from 'rollup-plugin-node-resolve' 2 | import commonjs from 'rollup-plugin-commonjs' 3 | import replace from 'rollup-plugin-replace' 4 | 5 | export default { 6 | input: __dirname + '/../../../js/build/js/jsbits/nauva-native/index.js', 7 | output: { 8 | file: __dirname + '/index.js', 9 | format: 'iife', 10 | name: 'nv$app' 11 | }, 12 | plugins: [ 13 | resolve({ jsnext: true, main: true }), 14 | commonjs({ 15 | namedExports: { 16 | 'react': ['Component', 'createElement'], 17 | 'react-dom': ['render'], 18 | }, 19 | }), 20 | replace({ 21 | 'process.env.NODE_ENV': JSON.stringify('development'), 22 | }), 23 | ], 24 | } 25 | -------------------------------------------------------------------------------- /product/template/shared/src/Nauva/Product/Template/Catalog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module Nauva.Product.Template.Catalog (catalogApp) where 5 | 6 | 7 | import Nauva.Catalog 8 | import Nauva.Catalog.TH 9 | 10 | 11 | 12 | catalogApp :: App 13 | catalogApp = App 14 | { rootElement = catalog . CatalogProps "Nauva Product Template" catalogPages 15 | } 16 | 17 | 18 | catalogPages :: [Page] 19 | catalogPages = 20 | [ PLeaf Leaf 21 | { leafHref = "/" 22 | , leafTitle = "Introduction" 23 | , leafElement = introductionPage 24 | } 25 | ] 26 | 27 | 28 | introductionPage :: Element 29 | introductionPage = [nauvaCatalogPage| 30 | # Welcome to the Template catalog 31 | |] 32 | -------------------------------------------------------------------------------- /pkg/hs/nauva-cli/nauva-cli.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-cli 2 | version: 0.1.0.0 3 | -- synopsis: 4 | -- description: 5 | homepage: https://github.com/githubuser/nauva-cli#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2017 Author name here 11 | category: Web 12 | build-type: Simple 13 | cabal-version: >=1.10 14 | 15 | executable nauva-cli 16 | hs-source-dirs: src 17 | main-is: Main.hs 18 | default-language: Haskell2010 19 | build-depends: base >= 4.7 && < 5, 20 | shelly, 21 | text, 22 | system-filepath, 23 | optparse-applicative 24 | 25 | -------------------------------------------------------------------------------- /pkg/hs/color/color.cabal: -------------------------------------------------------------------------------- 1 | name: color 2 | version: 0.0.0 3 | 4 | license: MIT 5 | license-file: LICENSE 6 | 7 | build-type: Simple 8 | 9 | cabal-version: >=1.10 10 | 11 | library 12 | hs-source-dirs: src 13 | default-language: Haskell2010 14 | 15 | ghc-options: -Wall 16 | 17 | exposed-modules: 18 | Data.Color 19 | , Data.Color.Illuminant 20 | , Data.Color.Internal.Types 21 | , Data.Color.Internal.Conversion 22 | 23 | build-depends: 24 | base >= 4.7 && < 5 25 | , lens 26 | 27 | test-suite spec 28 | hs-source-dirs: test 29 | default-language: Haskell2010 30 | 31 | type: exitcode-stdio-1.0 32 | main-is: Test.hs 33 | 34 | build-depends: 35 | base 36 | , color 37 | , hspec 38 | , lens 39 | -------------------------------------------------------------------------------- /pkg/js/src/Nauva/React/Input.ts: -------------------------------------------------------------------------------- 1 | import * as React from 'react' 2 | 3 | export class Input extends React.Component { 4 | constructor(props) { 5 | super(props) 6 | this.state = { value: props.props.value || '' } 7 | } 8 | 9 | onChange = (ev: any): void => { 10 | this.setState({ value: ev.target.value }) 11 | if (this.props.props.onChange) { 12 | this.props.props.onChange(ev) 13 | } 14 | } 15 | 16 | componentWillReceiveProps(nextProps) { 17 | if (nextProps.props.value !== this.state.value) { 18 | this.setState({ value: nextProps.props.value }) 19 | } 20 | } 21 | 22 | render() { 23 | return React.createElement(this.props.elementType, Object.assign({}, 24 | this.props.props, { value: this.state.value, onChange: this.onChange } 25 | ), ...(this.props.children || [])) 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /pkg/js/src/Nauva/React/Head.ts: -------------------------------------------------------------------------------- 1 | import * as React from 'react' 2 | import isEqual from 'lodash/isEqual' 3 | 4 | export class Head extends React.Component<{el: any}> { 5 | elementClone: null | Node = null 6 | 7 | ref: null | Node = null 8 | refFn = (ref: null | Node) => { 9 | this.ref = ref 10 | this.update() 11 | }; 12 | 13 | update() { 14 | if (this.elementClone !== null) { 15 | document.head.removeChild(this.elementClone) 16 | } 17 | 18 | const ref = this.ref 19 | if (ref) { 20 | this.elementClone = ref.childNodes.item(0).cloneNode(true) 21 | document.head.appendChild(this.elementClone) 22 | } 23 | } 24 | 25 | shouldComponentUpdate(nextProps) { 26 | return !isEqual(this.props.el, nextProps.el) 27 | } 28 | 29 | componentDidUpdate() { 30 | this.update() 31 | } 32 | 33 | render() { 34 | return React.createElement('div', {ref: this.refFn}, this.props.el) 35 | } 36 | } 37 | -------------------------------------------------------------------------------- /docs/haddock/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM haskell:8.0.2 2 | MAINTAINER Tomas Carnecky 3 | 4 | ENV STACK_ROOT /var/lib/stack 5 | RUN mkdir $STACK_ROOT 6 | 7 | # Keep this same as the resolver in the stack config files. Otherwise 8 | # builds will take forever. 9 | ENV RESOLVER nightly-2017-07-25 10 | 11 | RUN stack --no-terminal --color=never --resolver=$RESOLVER --system-ghc install --haddock \ 12 | text aeson snap-core blaze-markup blaze-html mtl tagged haskell-src-meta \ 13 | conduit th-lift-instances yaml siphash snap-blaze file-embed data-default \ 14 | websockets-snap snap-server \ 15 | ansi-terminal terminal-size fsnotify unix cmdargs extra css-text parsec \ 16 | network-uri conduit-extra tagsoup utf8-string xml-types xml-conduit xss-sanitize \ 17 | markdown void parallel StateVar contravariant reflection comonad distributive \ 18 | th-abstraction base-orphans prelude-extras fail lens free semigroupoids profunctors \ 19 | bifunctors adjunctions kan-extensions 20 | 21 | ENTRYPOINT ["stack"] 22 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/src/Nauva/Catalog/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Nauva.Catalog.Types 4 | ( Page(..) 5 | , Leaf(..) 6 | , Directory(..) 7 | 8 | , onlyLeaves 9 | ) where 10 | 11 | 12 | import Data.Text (Text) 13 | import Data.Monoid 14 | 15 | import Nauva.Internal.Types 16 | 17 | 18 | 19 | 20 | data Page 21 | = PLeaf !Leaf 22 | | PDirectory !Directory 23 | 24 | data Leaf = Leaf 25 | { leafHref :: !Text 26 | , leafTitle :: !Text 27 | , leafElement :: !Element 28 | } 29 | 30 | data Directory = Directory 31 | { directoryTitle :: !Text 32 | , directoryChildren :: ![Leaf] 33 | } 34 | 35 | 36 | -- | Return a flat list of 'Leaf' values. Useful when you want to enumerate all 37 | -- (directly referenceable) URLs inside the catalog. 38 | onlyLeaves :: [Page] -> [Leaf] 39 | onlyLeaves [] = [] 40 | onlyLeaves (x:xs) = case x of 41 | PLeaf leaf -> leaf : onlyLeaves xs 42 | PDirectory d -> directoryChildren d <> onlyLeaves xs 43 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/src/Nauva/Catalog/Theme/Color.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Nauva.Catalog.Theme.Color 4 | ( blackColor 5 | , black 6 | 7 | , red 8 | , gray 9 | , lightGray 10 | ) where 11 | 12 | 13 | import Data.Color 14 | import qualified Data.Text as T 15 | import Data.Monoid 16 | 17 | import Control.Lens 18 | 19 | import Nauva.View 20 | 21 | 22 | 23 | colorCSSValue :: Color -> CSSValue 24 | colorCSSValue c = CSSValue $ "rgb(" <> ts r <> "," <> ts g <> "," <> ts b <> ")" 25 | where 26 | (r, g, b) = c ^. toSRGB ^. cvSRGB8 ^. to unColorV 27 | ts = T.pack . show 28 | 29 | 30 | blackColor :: Color 31 | blackColor = mkColor (Chromaticity 0.238 0.281) 0.00424 32 | 33 | black :: CSSValue 34 | black = colorCSSValue blackColor 35 | 36 | red :: CSSValue 37 | red = colorCSSValue $ mkColor (Chromaticity 0.603 0.322) 0.22649 38 | 39 | gray :: CSSValue 40 | gray = colorCSSValue $ mkColor (Chromaticity 0.313 0.329) 0.05781 41 | 42 | lightGray :: CSSValue 43 | lightGray = colorCSSValue $ mkColor (Chromaticity 0.313 0.329) 0.87962 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2017 Tomas Carnecky 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. -------------------------------------------------------------------------------- /pkg/hs/portfinder/portfinder.cabal: -------------------------------------------------------------------------------- 1 | name: portfinder 2 | version: 0.0 3 | 4 | synopsis: Find the next available TCP/IP port 5 | description: … 6 | 7 | homepage: https://github.com/wereHamster/nauva 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | 12 | author: Tomas Carnecky 13 | maintainer: tomas.carnecky@gmail.com 14 | copyright: 2017 Tomas Carnecky 15 | 16 | category: Network 17 | build-type: Simple 18 | 19 | cabal-version: >=1.10 20 | 21 | 22 | flag release 23 | description: Enable additional checks and compiler options for release builds 24 | default: False 25 | 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/wereHamster/nauva 30 | 31 | 32 | library 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | 36 | ghc-options: -Wall 37 | if flag(release) 38 | ghc-options: -Wall -Werror 39 | 40 | exposed-modules: 41 | Network.PortFinder 42 | 43 | build-depends: 44 | base >= 4.7 && < 5 45 | , network 46 | -------------------------------------------------------------------------------- /docs/haddock/README.md: -------------------------------------------------------------------------------- 1 | Files in this folder are used to generate [Haddock] documentation for the core 2 | nauva packages. 3 | 4 | > https://storage.googleapis.com/nvdocs/latest/index.html 5 | 6 | - `stack.yaml`: defines the packages which are included in the documentation 7 | - `deploy.yaml`: Google Cloud Container Builder configuration file which 8 | builds the documentation and uploads it into the `nvdocs` bucket. 9 | - `Dockerfile`: Docker image which contains GHC, stack and all dependencies 10 | required by the nauva packages. It is used to speed up the builds. 11 | - `setup.yaml`: Google Cloud Container Builder configuration file which 12 | builds the docker image. 13 | 14 | To manually submit the job, use the `gcloud` command from the [Google Cloud SDK]. 15 | Though that shouldn't be needed, there is a build trigger which does that 16 | automatically after each push to the repository. 17 | 18 | gcloud container builds submit --config deploy.yaml ../.. 19 | 20 | One-time setup to create the GHC/stack docker image: 21 | 22 | gcloud container builds submit --config setup.yaml ../.. 23 | 24 | [Haddock]: https://www.haskell.org/haddock/ 25 | [Google Cloud SDK]: https://cloud.google.com/sdk/ 26 | -------------------------------------------------------------------------------- /product/varna/shared/src/Nauva/Product/Varna/Catalog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | module Nauva.Product.Varna.Catalog (catalogApp) where 6 | 7 | import Nauva.App 8 | import Nauva.Catalog 9 | import Nauva.Catalog.TH 10 | 11 | import Nauva.Product.Varna.Element.Card as Card 12 | 13 | 14 | 15 | catalogApp :: App 16 | catalogApp = App 17 | { rootElement = catalog . CatalogProps "Varna" catalogPages 18 | } 19 | 20 | catalogPages :: [Page] 21 | catalogPages = 22 | [ PLeaf Leaf 23 | { leafHref = "/" 24 | , leafTitle = "Introduction" 25 | , leafElement = introductionPage 26 | } 27 | , PDirectory Directory 28 | { directoryTitle = "Elements" 29 | , directoryChildren = 30 | [ Leaf 31 | { leafHref = "/elements/card" 32 | , leafTitle = "Card" 33 | , leafElement = Card.catalogPage 34 | } 35 | ] 36 | } 37 | ] 38 | 39 | 40 | introductionPage :: Element 41 | introductionPage = [nauvaCatalogPage| 42 | # Welcome to the Varna catalog 43 | |] 44 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/View/HTML.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Nauva.View.HTML 7 | ( module Nauva.View.Types 8 | , module Nauva.View.Terms 9 | 10 | , onMouseMove_ 11 | , onClick_ 12 | , onChange_ 13 | 14 | , null_ 15 | , str_ 16 | , thunk_ 17 | , component_ 18 | ) where 19 | 20 | 21 | import Data.Text (Text) 22 | 23 | import Nauva.Internal.Types 24 | import Nauva.Internal.Events 25 | import Nauva.NJS 26 | 27 | import Nauva.View.Types 28 | import Nauva.View.Terms 29 | 30 | 31 | 32 | onMouseMove_ :: FE MouseEvent r -> Attribute 33 | onMouseMove_ = AEVL . EventListener "mouseMove" 34 | 35 | onClick_ :: FE MouseEvent r -> Attribute 36 | onClick_ = AEVL . EventListener "click" 37 | 38 | onChange_ :: FE MouseEvent r -> Attribute 39 | onChange_ = AEVL . EventListener "change" 40 | 41 | 42 | null_ :: Element 43 | null_ = ENull 44 | 45 | str_ :: Text -> Element 46 | str_ = EText 47 | 48 | thunk_ :: Term arg res => arg -> res 49 | thunk_ = term "thunk" 50 | 51 | component_ :: Term arg res => arg -> res 52 | component_ = term "component" 53 | -------------------------------------------------------------------------------- /pkg/hs/nauva-css/nauva-css.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-css 2 | version: 0.0.0 3 | 4 | synopsis: It will. It will be good. 5 | description: React in Haskell. 6 | 7 | homepage: https://github.com/wereHamster/nauva 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | 12 | author: Tomas Carnecky 13 | maintainer: tomas.carnecky@gmail.com 14 | copyright: 2016 Tomas Carnecky 15 | 16 | category: Web 17 | build-type: Simple 18 | 19 | cabal-version: >=1.10 20 | 21 | 22 | flag release 23 | description: Enable additional checks and compiler options for release builds 24 | default: False 25 | 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/wereHamster/nauva 30 | 31 | 32 | library 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | 36 | ghc-options: -Wall -Wno-type-defaults 37 | if flag(release) 38 | ghc-options: -Wall -Wno-type-defaults -Werror 39 | 40 | exposed-modules: 41 | Nauva.CSS 42 | , Nauva.CSS.Helpers 43 | , Nauva.CSS.Renderer 44 | , Nauva.CSS.Terms 45 | , Nauva.CSS.Typeface 46 | , Nauva.CSS.Types 47 | 48 | build-depends: 49 | base >= 4.7 && < 5 50 | , aeson 51 | , bytestring 52 | , containers 53 | , mtl 54 | , siphash 55 | , text 56 | -------------------------------------------------------------------------------- /pkg/hs/nauva-dev-server/nauva-dev-server.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-dev-server 2 | version: 0.1.0 3 | 4 | synopsis: Nauva Development Server 5 | description: ... 6 | 7 | homepage: https://github.com/wereHamster/nauva 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | 12 | author: Tomas Carnecky 13 | maintainer: tomas.carnecky@gmail.com 14 | copyright: 2016 Tomas Carnecky 15 | 16 | category: Web 17 | build-type: Simple 18 | 19 | cabal-version: >=1.10 20 | 21 | 22 | flag release 23 | default: False 24 | description: 25 | Enable additional checks and compiler options for release builds. 26 | 27 | 28 | source-repository head 29 | type: git 30 | location: https://github.com/wereHamster/nauva 31 | 32 | 33 | library 34 | hs-source-dirs: src 35 | default-language: Haskell2010 36 | 37 | ghc-options: -Wall -Wno-type-defaults 38 | if flag(release) 39 | ghc-options: -Wall -Wno-type-defaults -Werror 40 | 41 | exposed-modules: 42 | Nauva.Server 43 | 44 | build-depends: 45 | base >= 4.7 && < 5 46 | , aeson 47 | , blaze-html 48 | , bytestring 49 | , directory 50 | , nauva 51 | , snap-blaze 52 | , snap-core 53 | , snap-server 54 | , stm 55 | , text 56 | , mtl 57 | , websockets 58 | , websockets-snap 59 | -------------------------------------------------------------------------------- /pkg/hs/nauva-native/nauva-native.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-native 2 | version: 0.1.0 3 | 4 | synopsis: It will. It will be good. 5 | description: React in Haskell. 6 | 7 | homepage: https://github.com/wereHamster/nauva 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | 12 | author: Tomas Carnecky 13 | maintainer: tomas.carnecky@gmail.com 14 | copyright: 2016 Tomas Carnecky 15 | 16 | category: Web 17 | build-type: Simple 18 | 19 | cabal-version: >=1.10 20 | 21 | 22 | flag release 23 | description: Enable additional checks and compiler options for release builds 24 | default: False 25 | 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/wereHamster/nauva 30 | 31 | 32 | library 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | 36 | ghc-options: -Wall -Wno-type-defaults 37 | if flag(release) 38 | ghc-options: -Wall -Wno-type-defaults -Werror 39 | 40 | exposed-modules: 41 | Nauva.Client 42 | , Nauva.Native.Bridge 43 | 44 | build-depends: 45 | base >= 4.7 && < 5 46 | , aeson 47 | , bytestring 48 | , text 49 | , mtl 50 | , stm 51 | , containers 52 | , scientific 53 | , data-default 54 | , ghcjs-base 55 | , nauva 56 | , nauva-css 57 | 58 | js-sources: jsbits/index.js 59 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/Internal/Fragment.hs: -------------------------------------------------------------------------------- 1 | module Nauva.Internal.Fragment where 2 | 3 | 4 | import Control.Monad.Writer.Lazy 5 | 6 | import Nauva.DOM 7 | import Nauva.Internal.Types 8 | 9 | 10 | 11 | 12 | -- | A 'Fragment' is a list of 'Element's. Often when rendering we want to 13 | -- incrementally build the children list of a 'ENode'. Doing this with the 14 | -- normal list notation is cumbersome. 15 | -- 16 | -- Furthermore, a 'Fragment' allows us to pass multiple 'Element's as if they 17 | -- were a unit, without having to wrap them in a node (eg. @"span"@ 18 | -- or @"div"@). 19 | -- 20 | -- There are downsides though to using 'Fragment's. TK: explain. 21 | 22 | newtype Fragment = Fragment { unFragment :: [Element] } 23 | 24 | instance Monoid Fragment where 25 | mempty = Fragment [] 26 | (Fragment a) `mappend` (Fragment b) = Fragment (a <> b) 27 | 28 | 29 | singleton :: Element -> Fragment 30 | singleton x = Fragment [x] 31 | 32 | 33 | type FragmentM = Writer Fragment () 34 | 35 | -- | Execute a 'FragmentM' and simplify the result by merging adjacent 36 | -- 'EString' elements. 37 | execFragmentM :: FragmentM -> [Element] 38 | execFragmentM = simplify . unFragment . execWriter 39 | where 40 | simplify [] = [] 41 | simplify (EText a : EText b : xs) = simplify (EText (a <> b) : xs) 42 | simplify (x:xs) = x : simplify xs 43 | 44 | 45 | nodeFromFragment :: Tag -> [Attribute] -> FragmentM -> Element 46 | nodeFromFragment tag attrs fm = ENode tag attrs $ execFragmentM fm 47 | -------------------------------------------------------------------------------- /docs/book/thunks.md: -------------------------------------------------------------------------------- 1 | Sometimes you have parts of an application which rarely or never change, but 2 | are expensive to render. For example the footer, or any part of the website 3 | which the user is *not* currently interacting with. For these cases Nauva 4 | offers `Thunks` as means to optimise these parts. 5 | 6 | You can think of a `Thunk` as a pure function `p -> Element` and a predicate 7 | `p -> p -> Bool`. If you try to render the same thunk, Nauva will use the 8 | predicate to determine if the rendering should be skipped. 9 | 10 | Once you have a `Thunk` defined, you can instantiate it with `thunk_`. 11 | 12 | 13 | # simpleThunk 14 | 15 | Use `simpleThunk` to create a `Thunk` if your `p` has an `Eq` instance. 16 | 17 | ``` 18 | expensiveFunction :: MyData -> Element 19 | expensiveFunction mydata = … 20 | 21 | expensiveFunctionThunk :: Thunk MyData 22 | expensiveFunctionThunk = simpleThunk 23 | "expensiveFunctionThunk" 24 | expensiveFunction 25 | 26 | optimisedFunction :: MyData -> Element 27 | optimisedFunction = thunk_ expensiveFunctionThunk 28 | ``` 29 | 30 | 31 | # constElement 32 | 33 | If you have an element which doesn't ever change, you can wrap your 34 | element in `constElment` and it will optimise any subtree updates 35 | away. 36 | 37 | This is useful for static assets (SVG icons / logos) and larger non-interactive 38 | things such as a footer. 39 | 40 | 41 | ``` 42 | footer :: Element 43 | footer = constElement "footer" $ div_ 44 | [ 45 | … 46 | ] 47 | ``` 48 | 49 | 50 | # Next 51 | 52 | [Components](/components). 53 | -------------------------------------------------------------------------------- /docs/book/getting-started.md: -------------------------------------------------------------------------------- 1 | # Prerequisites 2 | 3 | The only tool you need to install yourself is [stack](https://www.haskellstack.org). 4 | 5 | 6 | # The template application 7 | 8 | We've tried to make it as easy as possible to get from zero to a running 9 | application. For that purpose, the source repository comes with multiple 10 | example applications. The one we're going to use here is the **template** 11 | application. 12 | 13 | git clone https://github.com/wereHamster/nauva.git 14 | cd nauva 15 | ./bin/nauva start template/app 16 | 17 | Eventually, a browser should open pointing to a local web server where the 18 | application is running. I say eventually because it may take a while. If this 19 | is your first time you run the `bin/nauva` script, it will download the GHC 20 | compiler and all other dependencies that are required. This may easily take 21 | more than 30 minutes. 22 | 23 | If for some reason the browser doesn't open automatically, go to [http://localhost:8000](http://localhost:8000). Note that the server may be running one a different port 24 | if port 8000 is already occupied. See in the terminal output which port the server 25 | has picked. 26 | 27 | # Your first changes 28 | 29 | The page you see tells you which file you can change. Open the file, and make 30 | some changes. Immediately after you save your changes, you'll see that the page 31 | updates. 32 | 33 | Or if you make a mistake such that the code doesn't cleanly compile, you'll see 34 | the errors inside your browser. 35 | 36 | 37 | # Next 38 | 39 | [The markup language](/markup) 40 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/src/Settings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Settings 5 | ( mkStaticSettings 6 | ) where 7 | 8 | 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString.Char8 as BS8 11 | import Data.Monoid 12 | import Data.FileEmbed (embedDir) 13 | 14 | import System.Environment 15 | import System.FilePath 16 | 17 | import Language.Haskell.TH (Loc(loc_filename), location) 18 | 19 | import Prelude 20 | 21 | import Snap.Core (Snap, MonadSnap (..), route, writeBS) 22 | import Snap.Util.FileServe (serveDirectory) 23 | 24 | 25 | 26 | embeddedPublicDir :: [(FilePath, ByteString)] 27 | embeddedPublicDir = $(do 28 | loc <- location 29 | embedDir (takeDirectory (loc_filename loc) <> "/../public")) 30 | 31 | 32 | mkStaticSettings :: IO (Snap ()) 33 | mkStaticSettings = do 34 | mbPublicPath <- lookupEnv "NAUVAD_PUBLIC_PATH" 35 | case mbPublicPath of 36 | Nothing -> do 37 | putStrLn "NauvaD: serving embedded files" 38 | pure $ route $ map toRoute embeddedPublicDir 39 | Just publicPath -> do 40 | putStrLn $ "NauvaD: serving files from " <> publicPath 41 | pure $ serveDirectory publicPath 42 | 43 | toRoute :: MonadSnap m => (FilePath, ByteString) -> (ByteString, m ()) 44 | toRoute (path, content) = 45 | ( BS8.pack path, do 46 | -- modifyResponse $ addHeader "Content-Type" "text/html; charset=UTF-8" 47 | writeBS content 48 | ) 49 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Neil Mitchell 2014-2017. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Neil Mitchell nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /pkg/hs/nauva-css/src/Nauva/CSS/Helpers.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Nauva.CSS.Helpers where 4 | 5 | 6 | import Data.Text (Text) 7 | import qualified Data.Text as T 8 | 9 | import Control.Monad.Writer.Lazy 10 | 11 | import Nauva.CSS.Types 12 | 13 | 14 | 15 | vh :: Int -> CSSValue 16 | vh n = CSSValue $ T.pack $ show n ++ "vh" 17 | 18 | px :: (Show a) => a -> CSSValue 19 | px n = CSSValue $ T.pack $ show n ++ "px" 20 | 21 | rem :: (Show a) => a -> CSSValue 22 | rem n = CSSValue $ T.pack $ show n ++ "rem" 23 | 24 | pct :: (Show a) => a -> CSSValue 25 | pct n = CSSValue $ T.pack $ show n ++ "%" 26 | 27 | 28 | 29 | fontFamily_ :: Writer [CSSDeclaration] () -> Writer [Statement] () 30 | fontFamily_ v = tell [SEmit $ DFontFamily $ execWriter v] 31 | 32 | 33 | before :: Writer [Statement] () -> Writer [Statement] () 34 | before style = tell [SSuffix "::before" style] 35 | 36 | after :: Writer [Statement] () -> Writer [Statement] () 37 | after style = tell [SSuffix "::after" style] 38 | 39 | 40 | onHover :: Writer [Statement] () -> Writer [Statement] () 41 | onHover style = tell [SSuffix ":hover" style] 42 | 43 | onActive :: Writer [Statement] () -> Writer [Statement] () 44 | onActive style = tell [SSuffix ":active" style] 45 | 46 | firstChild :: Writer [Statement] () -> Writer [Statement] () 47 | firstChild style = tell [SSuffix ":first-child" style] 48 | 49 | lastChild :: Writer [Statement] () -> Writer [Statement] () 50 | lastChild style = tell [SSuffix ":last-child" style] 51 | 52 | media :: Text -> Writer [Statement] () -> Writer [Statement] () 53 | media m style = tell [SCondition (CMedia m) style] 54 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/Service/Head.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Nauva.Service.Head 4 | ( HeadH(..) 5 | , constHead 6 | ) where 7 | 8 | 9 | import Data.Aeson as A 10 | 11 | import Control.Concurrent.STM 12 | 13 | import Nauva.View 14 | 15 | 16 | 17 | data HeadH = HeadH 18 | { hElements :: TVar [Element] 19 | -- ^ The list of elements which are to be shown in the . 20 | 21 | , hReplace :: [Element] -> IO () 22 | -- ^ Replace the current set of 'Elements' with new ones. 23 | } 24 | 25 | 26 | 27 | constHeadComponent :: Component (HeadH, [Element], Element) () () () 28 | constHeadComponent = createComponent $ \cId -> Component 29 | { componentId = cId 30 | , componentDisplayName = "constHeadComponent" 31 | , initialComponentState = \(headH, headElements, _) -> pure ((), [], [updateHead headH headElements]) 32 | , componentEventListeners = \_ -> [] 33 | , componentHooks = emptyHooks 34 | , processLifecycleEvent = \() _ s -> (s, []) 35 | , receiveProps = \_ s -> pure (s, [], []) 36 | , update = \() (headH, headElements, _) s -> (s, [updateHead headH headElements]) 37 | , renderComponent = \(_, _, el) _ -> el 38 | , componentSnapshot = \_ -> A.object [] 39 | , restoreComponent = \_ s -> Right (s, []) 40 | } 41 | where 42 | updateHead :: HeadH -> [Element] -> IO (Maybe ()) 43 | updateHead headH headElements = do 44 | hReplace headH headElements 45 | pure Nothing 46 | 47 | constHead :: HeadH -> [Element] -> Element -> Element 48 | constHead headH headElements el = 49 | component_ constHeadComponent (headH, headElements, el) 50 | -------------------------------------------------------------------------------- /product/template/shared/src/Nauva/Product/Template/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Nauva.Product.Template.App (app) where 5 | 6 | 7 | import Nauva.App 8 | import Nauva.View 9 | 10 | import Language.Haskell.TH 11 | import Language.Haskell.TH.Syntax 12 | 13 | 14 | 15 | app :: App 16 | app = App 17 | { rootElement = \appH -> constHead (headH appH) headElements $ div_ [style_ style] 18 | [ header 19 | , intro 20 | ] 21 | } 22 | 23 | where 24 | headElements = 25 | [ style_ [str_ "*,*::before,*::after{box-sizing:inherit}body{margin:0;box-sizing:border-box;font-family:-apple-system, BlinkMacSystemFont, \"Segoe UI\", Roboto, Helvetica, Arial, sans-serif, \"Apple Color Emoji\", \"Segoe UI Emoji\", \"Segoe UI Symbol\"}"] 26 | ] 27 | 28 | style = mkStyle $ do 29 | textAlign center 30 | 31 | 32 | header :: Element 33 | header = div_ [style_ style] 34 | [ h1_ [str_ "Welcome to Nauva"] 35 | ] 36 | where 37 | style = mkStyle $ do 38 | backgroundColor "#222" 39 | height "150px" 40 | padding "20px" 41 | color "white" 42 | 43 | intro :: Element 44 | intro = p_ [style_ style] 45 | [ str_ "To get started, edit " 46 | , code_ [str_ thisFilePath] 47 | , str_ " and save to reload." 48 | ] 49 | where 50 | style = mkStyle $ do 51 | fontSize "large" 52 | 53 | -- The path to this file. Here we use a bit of TemplateHaskell magic 54 | -- so that we can show the exact path the user has to edit to get 55 | -- started 56 | thisFilePath = $(lift =<< loc_filename <$> location) 57 | -------------------------------------------------------------------------------- /pkg/hs/nauva/nauva.cabal: -------------------------------------------------------------------------------- 1 | name: nauva 2 | version: 0.1.0 3 | 4 | synopsis: It will. It will be good. 5 | description: React in Haskell. 6 | 7 | homepage: https://github.com/wereHamster/nauva 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | 12 | author: Tomas Carnecky 13 | maintainer: tomas.carnecky@gmail.com 14 | copyright: 2016 Tomas Carnecky 15 | 16 | category: Web 17 | build-type: Simple 18 | 19 | cabal-version: >=1.10 20 | 21 | 22 | flag release 23 | description: Enable additional checks and compiler options for release builds 24 | default: False 25 | 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/wereHamster/nauva 30 | 31 | 32 | library 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | 36 | ghc-options: -Wall -Wno-type-defaults 37 | if flag(release) 38 | ghc-options: -Wall -Wno-type-defaults -Werror 39 | 40 | exposed-modules: 41 | Nauva.Handle 42 | , Nauva.Static 43 | , Nauva.NJS 44 | , Nauva.NJS.TH 45 | , Nauva.Internal.Types 46 | , Nauva.DOM 47 | , Nauva.Internal.Events 48 | , Nauva.Internal.Fragment 49 | , Nauva.View 50 | , Nauva.View.HTML 51 | , Nauva.View.Types 52 | , Nauva.View.Terms 53 | , Nauva.Service.Head 54 | , Nauva.Service.Router 55 | , Nauva.App 56 | 57 | build-depends: 58 | base >= 4.7 && < 5 59 | , aeson 60 | , attoparsec 61 | , blaze-html 62 | , blaze-markup 63 | , bytestring 64 | , containers 65 | , mtl 66 | , nauva-css 67 | , siphash 68 | , stm 69 | , template-haskell 70 | , text 71 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/Internal/Events.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module Nauva.Internal.Events where 8 | 9 | 10 | import qualified Data.Aeson as A 11 | import Data.Text (Text) 12 | 13 | import Nauva.NJS 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- 18 | -- Type tags for all the different events we want to be able to transform using 19 | -- 'EventListener'. 20 | 21 | data WheelEvent = WheelEvent 22 | data MouseEvent = MouseEvent 23 | data KeyboardEvent = KeyboardEvent 24 | data Event = Event 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- 30 | -- | The thing which is attached to nodes. A tuple of @DOM event name@ and the 31 | -- function which shall be used to process the event. 32 | 33 | data EventListener = EventListener Text F 34 | deriving (Eq) 35 | 36 | instance A.ToJSON EventListener where 37 | toJSON (EventListener ev f) = A.toJSON 38 | [ A.String ev 39 | , A.toJSON f 40 | ] 41 | 42 | 43 | onClick :: FE MouseEvent r -> EventListener 44 | onClick = EventListener "click" 45 | 46 | onChange :: FE MouseEvent r -> EventListener 47 | onChange = EventListener "change" 48 | 49 | onWheel :: FE WheelEvent r -> EventListener 50 | onWheel = EventListener "wheel" 51 | 52 | onMouseMove :: FE MouseEvent r -> EventListener 53 | onMouseMove = EventListener "mouseMove" 54 | 55 | onResize :: FE MouseEvent r -> EventListener 56 | onResize = EventListener "resize" 57 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/src/Nauva/Catalog/Specimens/TypefaceSpecimen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | 8 | module Nauva.Catalog.Specimens.TypefaceSpecimen 9 | ( typefaceSpecimen 10 | , typefaceSpecimen' 11 | ) where 12 | 13 | 14 | import Data.Text (Text) 15 | import Data.Monoid 16 | import Data.List 17 | 18 | import Nauva.View 19 | import Nauva.Catalog.Theme.Typeface 20 | import Nauva.Catalog.Elements 21 | 22 | 23 | 24 | typefaceSpecimen :: Text -> Typeface -> Element 25 | typefaceSpecimen t tf = pageElement 26 | PageElementProps{pepTitle = Nothing, pepSpan = 6} 27 | [ div_ [style_ rootStyle] 28 | [ div_ [style_ metaStyle] [str_ $ tfName tf <> " – " <> metaString] 29 | , div_ [style_ previewStyle] [str_ t] 30 | ] 31 | ] 32 | where 33 | rootStyle = mkStyle $ do 34 | display flex 35 | flexDirection column 36 | 37 | metaStyle = mkStyle $ do 38 | typeface meta14Typeface 39 | color "black" 40 | marginBottom "4px" 41 | color "#333" 42 | 43 | metaString = mconcat $ intersperse ", " 44 | [ unCSSValue (tfFontFamily tf) 45 | , unCSSValue (tfFontWeight tf) 46 | , unCSSValue (tfFontSize tf) <> "/" <> unCSSValue (tfLineHeight tf) 47 | ] 48 | 49 | previewStyle = mkStyle $ do 50 | typeface tf 51 | padding "20px" 52 | backgroundColor "white" 53 | border "1px solid #eee" 54 | 55 | typefaceSpecimen' :: Typeface -> Element 56 | typefaceSpecimen' = typefaceSpecimen "A very bad quack might jinx zippy fowls" 57 | -------------------------------------------------------------------------------- /pkg/hs/nauva-css/src/Nauva/CSS/Renderer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | 8 | module Nauva.CSS.Renderer 9 | ( renderCSSRule 10 | , cssRuleClass 11 | ) where 12 | 13 | 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | import Data.Monoid 17 | import Data.List 18 | 19 | import Nauva.CSS.Types 20 | 21 | 22 | 23 | renderCSSDeclarations :: CSSStyleDeclaration -> Text 24 | renderCSSDeclarations = mconcat . intersperse ";" . map renderDeclaration 25 | where 26 | renderDeclaration (k, CSSValue v) = "\n " <> k <> ": " <> v 27 | 28 | cssRuleClass :: Text -> Hash -> Text 29 | cssRuleClass name hash = (if T.null name then "s-" else (name <> "-")) <> unHash hash 30 | 31 | cssRuleSelector :: Text -> Hash -> [Suffix] -> Text 32 | cssRuleSelector name hash suffixes = "." <> cssRuleClass name hash <> mconcat (map unSuffix suffixes) 33 | 34 | wrapInConditions :: [Condition] -> Text -> Text 35 | wrapInConditions [] t = t 36 | wrapInConditions (CMedia x:xs) t = "@media " <> x <> " {" <> wrapInConditions xs t <> "\n}" 37 | wrapInConditions (CSupports x:xs) t = "@supports " <> x <> " {" <> wrapInConditions xs t <> "\n}" 38 | 39 | renderCSSRule :: CSSRule -> Text 40 | renderCSSRule (CSSStyleRule name hash conditions suffixes styleDeclaration) = wrapInConditions conditions $ mconcat 41 | [ cssRuleSelector name hash suffixes <> " {" 42 | , renderCSSDeclarations styleDeclaration 43 | , "\n}" 44 | ] 45 | renderCSSRule (CSSFontFaceRule _hash styleDeclaration) = mconcat 46 | [ "@font-face {" 47 | , renderCSSDeclarations styleDeclaration 48 | , "\n}" 49 | ] 50 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/nauva-catalog.cabal: -------------------------------------------------------------------------------- 1 | name: nauva-catalog 2 | version: 0.0.0 3 | 4 | synopsis: It will. It will be good. 5 | description: React in Haskell. 6 | 7 | homepage: https://github.com/wereHamster/nauva 8 | 9 | license: MIT 10 | license-file: LICENSE 11 | 12 | author: Tomas Carnecky 13 | maintainer: tomas.carnecky@gmail.com 14 | copyright: 2016 Tomas Carnecky 15 | 16 | category: Web 17 | build-type: Simple 18 | 19 | cabal-version: >=1.10 20 | 21 | 22 | flag release 23 | description: Enable additional checks and compiler options for release builds 24 | default: False 25 | 26 | 27 | source-repository head 28 | type: git 29 | location: https://github.com/wereHamster/nauva 30 | 31 | 32 | library 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | 36 | ghc-options: -Wall -Wno-type-defaults 37 | if flag(release) 38 | ghc-options: -Wall -Wno-type-defaults -Werror 39 | 40 | exposed-modules: 41 | Nauva.Catalog 42 | , Nauva.Catalog.Elements 43 | , Nauva.Catalog.Shell 44 | , Nauva.Catalog.Specimens.CodeSpecimen 45 | , Nauva.Catalog.Specimens.NauvaSpecimen 46 | , Nauva.Catalog.Specimens.TypefaceSpecimen 47 | , Nauva.Catalog.Specimens.ColorGroupSpecimen 48 | , Nauva.Catalog.TH 49 | , Nauva.Catalog.Theme.Color 50 | , Nauva.Catalog.Theme.Typeface 51 | , Nauva.Catalog.Types 52 | 53 | build-depends: 54 | base >= 4.7 && < 5 55 | , aeson 56 | , blaze-html 57 | , blaze-markup 58 | , bytestring 59 | , color 60 | , conduit 61 | , filepath 62 | , haskell-src-meta 63 | , lens 64 | , markdown 65 | , nauva 66 | , nauva-css 67 | , stm 68 | , template-haskell 69 | , text 70 | , th-lift-instances 71 | , yaml 72 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/View/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Nauva.View.Types where 7 | 8 | 9 | import Data.Text (Text) 10 | import Data.Monoid 11 | import Data.Typeable 12 | 13 | import Nauva.DOM 14 | import Nauva.Internal.Types 15 | import Nauva.Internal.Events 16 | import Nauva.NJS 17 | import Nauva.CSS 18 | 19 | 20 | 21 | class Term arg res | arg -> res where 22 | term :: Text -> arg -> res 23 | 24 | 25 | instance Term Text Attribute where 26 | term = stringAttribute 27 | 28 | instance Term Int Attribute where 29 | term = intAttribute 30 | 31 | instance Term Style Attribute where 32 | term _ = styleAttribute 33 | 34 | instance Term EventListener Attribute where 35 | term _ = eventListenerAttribute 36 | 37 | instance Term Ref Attribute where 38 | term _ = refAttribute 39 | 40 | 41 | instance Term [Attribute] ([Element] -> Element) where 42 | term tag = ENode (Tag tag) 43 | 44 | instance Term [Element] Element where 45 | term tag = ENode (Tag tag) [] 46 | 47 | instance (Typeable p) => Term (Thunk p) (p -> Element) where 48 | term _ = EThunk 49 | 50 | instance (Typeable p, Value h, Value a) => Term (Component p h s a) (p -> Element) where 51 | term _ = EComponent 52 | 53 | 54 | 55 | class With a where 56 | with :: a -> [Attribute] -> a 57 | 58 | 59 | instance With Element where 60 | with (ENode tag attrs children) extraAttrs = ENode tag (attrs <> extraAttrs) children 61 | with el _ = el 62 | 63 | instance With ([Element] -> Element) where 64 | with f extraAttrs = \arg -> case f arg of 65 | (ENode tag attrs children) -> ENode tag (attrs <> extraAttrs) children 66 | el -> el 67 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/src/Nauva/Catalog/Specimens/CodeSpecimen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | 8 | module Nauva.Catalog.Specimens.CodeSpecimen 9 | ( CodeSpecimenProps(..) 10 | , codeSpecimen 11 | ) where 12 | 13 | 14 | import Data.Text (Text) 15 | import Data.Typeable 16 | import Data.Data 17 | import qualified Data.Aeson as A 18 | 19 | import Language.Haskell.TH.Syntax 20 | 21 | import Nauva.View 22 | import Nauva.Catalog.Theme.Typeface 23 | import Nauva.Catalog.Elements 24 | 25 | 26 | 27 | data CodeSpecimen = CodeSpecimen 28 | { csProps :: CodeSpecimenProps 29 | , csElement :: Element 30 | , csLanguage :: Text 31 | , csSource :: Text 32 | } 33 | 34 | data CodeSpecimenProps = CodeSpecimenProps 35 | { cspPEP :: PageElementProps 36 | , cspNoSource :: Bool 37 | } deriving (Typeable, Data, Lift) 38 | 39 | instance A.FromJSON CodeSpecimenProps where 40 | parseJSON v@(A.Object o) = CodeSpecimenProps 41 | <$> A.parseJSON v 42 | <*> o A..:? "noSource" A..!= False 43 | 44 | parseJSON _ = fail "CodeSpecimenProps" 45 | 46 | 47 | codeSpecimen :: CodeSpecimen -> Element 48 | codeSpecimen CodeSpecimen{..} = if cspNoSource 49 | then div_ [style_ rootStyle] [pageElementContainer [csElement]] 50 | else div_ [style_ rootStyle] [pageElementContainer [csElement], codeBlock csLanguage csSource] 51 | where 52 | CodeSpecimenProps{..} = csProps 53 | rootStyle = mkStyle $ do 54 | typeface mono12Typeface 55 | fontStyle "normal" 56 | fontWeight "400" 57 | color "rgb(51, 51, 51)" 58 | display "block" 59 | width "100%" 60 | background "rgb(255, 255, 255)" 61 | border "1px solid rgb(238, 238, 238)" 62 | -------------------------------------------------------------------------------- /pkg/hs/nauva-css/src/Nauva/CSS/Typeface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Nauva.CSS.Typeface 4 | ( Typeface(..) 5 | , typeface 6 | , typeFace 7 | ) where 8 | 9 | 10 | import Data.Text (Text) 11 | import Nauva.CSS.Terms 12 | import Nauva.CSS.Types 13 | import Control.Monad.Writer.Lazy 14 | 15 | 16 | 17 | -- | A 'Typeface' is a combination of font family, font weight, font size, 18 | -- line height and font variation. The four properties together identify 19 | -- a particular type face which is used in one or more places inside your 20 | -- application. 21 | -- 22 | -- You should not define new type faces ad-hoc inside individual components. 23 | -- Instead, define them once in a single place and then reuse. This allows 24 | -- you to manage an index of all typefaces which are used throughout your 25 | -- application, show them all in the catalog, and prevents the number 26 | -- of distinct typefaces from exploding. 27 | -- 28 | -- A 'Typeface' also has a name, which should be unique and is only used 29 | -- in the catalog, for documentation purposes. 30 | -- 31 | -- Note: the font family is specified using a 'CSSValue'. This means custom 32 | -- @font-face is not supported at the moment (see 'fontFamily_' or 'DFontFamily'). 33 | 34 | data Typeface = Typeface 35 | { tfName :: Text 36 | , tfFontFamily :: CSSValue 37 | , tfFontWeight :: CSSValue 38 | , tfFontSize :: CSSValue 39 | , tfLineHeight :: CSSValue 40 | } 41 | 42 | 43 | -- | Apply the given 'Typeface' in a CSS block. 44 | -- 45 | -- > someTypeface = Typeface "brandBodyCopy" "Helvetica, sans-serif" "normal" "16px" "1.4" 46 | -- 47 | -- > rootStyle = mkStyle $ do 48 | -- > typeface someTypeface 49 | -- > color "black" 50 | 51 | typeface :: Typeface -> Writer [Statement] () 52 | typeface Typeface{..} = do 53 | fontFamily tfFontFamily 54 | fontWeight tfFontWeight 55 | fontSize tfFontSize 56 | lineHeight tfLineHeight 57 | 58 | {-# DEPRECATED typeFace "Use typeface instead of typeFace (with capital F)" #-} 59 | typeFace :: Typeface -> Writer [Statement] () 60 | typeFace = typeface 61 | -------------------------------------------------------------------------------- /product/nauva/shared/src/Nauva/Product/Nauva/Element/Terminal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Nauva.Product.Nauva.Element.Terminal 7 | ( terminalEl 8 | , TerminalProps(..) 9 | 10 | , catalogPage 11 | ) where 12 | 13 | 14 | import Data.Text (Text) 15 | 16 | import Nauva.Internal.Types 17 | import Nauva.View 18 | 19 | import Nauva.Catalog.TH (nauvaCatalogPage) 20 | import Nauva.Catalog.Theme.Color 21 | import Nauva.Catalog.Theme.Typeface 22 | 23 | import Prelude hiding (rem) 24 | 25 | 26 | data TerminalProps = TerminalProps 27 | { terminalLines :: ![Text] 28 | } 29 | 30 | terminalEl :: TerminalProps -> Element 31 | terminalEl props = div_ [style_ rootStyle] els 32 | where 33 | rootStyle = mkStyle' "terminal" $ do 34 | typeface mono12Typeface 35 | backgroundColor black 36 | color "rgba(255,255,255,0.95)" 37 | overflow "auto" 38 | padding "2rem" 39 | 40 | lineStyle = mkStyle' "line" $ do 41 | whiteSpace "nowrap" 42 | overflow "hidden" 43 | cssTerm "text-overflow" "ellipsis" 44 | 45 | els = (flip map) (terminalLines props) $ \str -> div_ [style_ lineStyle] [str_ str] 46 | 47 | 48 | 49 | catalogPage :: Element 50 | catalogPage = [nauvaCatalogPage| 51 | ```nauva 52 | terminalEl $ TerminalProps 53 | { terminalLines = 54 | [ "Building nauvad... this may take a while" 55 | , "nauva-product-nauva-shared-0.0.0: unregistering (local file changes: src/Nauva/Product/Nauva/Element/Message.hs)" 56 | , "nauvad-0.6.6: unregistering (missing dependencies: nauva-product-nauva-shared)" 57 | , "nauva-product-nauva-shared-0.0.0: build (lib)" 58 | , "nauva-product-nauva-shared-0.0.0: copy/register" 59 | , "nauvad-0.6.6: build (lib + exe)" 60 | , "nauvad-0.6.6: copy/register" 61 | , "Completed 2 action(s)." 62 | ] 63 | } 64 | ``` 65 | |] 66 | -------------------------------------------------------------------------------- /pkg/hs/portfinder/src/Network/PortFinder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Network.PortFinder 4 | ( findPort 5 | ) where 6 | 7 | 8 | import Control.Exception (IOException, catch) 9 | import Network.Socket 10 | 11 | 12 | 13 | -- | Return a free port to which the application can bind a socket. 14 | -- 15 | -- Throws an error if it can't find a free port. 16 | 17 | findPort :: PortNumber -> IO PortNumber 18 | findPort basePort = do 19 | let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } 20 | addr:_ <- getAddrInfo (Just hints) (Just "0.0.0.0") (Just $ show basePort) 21 | sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 22 | 23 | case addrAddress addr of 24 | (SockAddrInet port hostAddress) -> go 99 sock port hostAddress 25 | _ -> error "findPort: not an inet addr" 26 | 27 | 28 | where 29 | go :: Int -> Socket -> PortNumber -> HostAddress -> IO PortNumber 30 | go 0 _ _ _ = error "findPort: exhausted" 31 | go i sock port hostAddress = try sock port hostAddress `catch` \(_ :: IOException) -> 32 | -- Bummer. Try the next port. 33 | go (i - 1) sock (port + 1) hostAddress 34 | 35 | try :: Socket -> PortNumber -> HostAddress -> IO PortNumber 36 | try sock port hostAddress = do 37 | -- Try to bind the socket the the address. This will throw 38 | -- an 'IOException' in the following common cases: 39 | -- 40 | -- - EADDRINUSE: The port is occupied (bound to an exinstig socket). 41 | -- - EACCESS: Port is priviledged (<1024) and user is not root. 42 | bind sock (SockAddrInet port hostAddress) 43 | 44 | -- Verify that we can listen on the port. May not be necessary but 45 | -- it's a good, additional check to have. 46 | -- 47 | -- Another useful check would be to try to connect to the socket, 48 | -- to verify that it's actually reachable. 49 | listen sock 5 50 | 51 | -- Alright, if we've reached this point without running into 52 | -- an exception, it means the port is available. Clean up so 53 | -- that the caller can actually bind to the socket himself. 54 | close sock 55 | 56 | pure port 57 | -------------------------------------------------------------------------------- /docs/book/components.md: -------------------------------------------------------------------------------- 1 | Components are reusable, self-contained chunks of your application. Components 2 | have a local state, can react to events, can issue IO actions and more. 3 | 4 | A component is defined at the very least by the type of local state it manages, 5 | the type of actions it can process, an initial state, and an update function. 6 | 7 | 8 | # Counter 9 | 10 | We'll start with a simple component: a counter which counts how many times 11 | a button was clicked. 12 | 13 | It is useful to define this logic separated from any Nauva-specific dependencies. 14 | This makes it easy to reason just about the logic, and also makes testing easier. 15 | 16 | ### Types 17 | 18 | First we defined our two types. 19 | 20 | ``` 21 | data State = State 22 | { numberOfClicks :: Int 23 | } 24 | 25 | data Action 26 | = Clicked 27 | ``` 28 | 29 | ### Initial state 30 | 31 | Then we need an initial state. 32 | 33 | ``` 34 | initialState :: State 35 | initialState = State 36 | { numberOfClicks: 0 37 | } 38 | ``` 39 | 40 | ### Update function 41 | 42 | ``` 43 | updateState :: Action -> State -> State 44 | updateState Clicked State{..} = State { numberOfClicks = numberOfClicks + 1 } 45 | ``` 46 | 47 | ## View function 48 | 49 | The second big piece is a function which renders the UI for this counter. 50 | 51 | ``` 52 | renderCounter :: State -> Element 53 | renderCounter State{..} = div_ [] 54 | [ button_ 55 | [ value_ "Click Me!" 56 | ] [] 57 | , div_ [] [str_ $ "Clicked " <> show numberOfClicks <> " times"] 58 | ] 59 | ``` 60 | 61 | 62 | ## Creating our counter component 63 | 64 | ``` 65 | counterComponent :: Component () () State () 66 | counterComponent = createComponent $ \componentId -> Component 67 | { componentId = componentId 68 | , componentDisplayName = "Counter" 69 | , initialComponentState = \_ -> pure (initialState, [], []) 70 | , componentEventListeners = const [] 71 | , componentHooks = emptyHooks 72 | , processLifecycleEvent = \() _ s -> (s, []) 73 | , receiveProps = \_ s -> pure (s, [], []) 74 | , update = \a _ s _ -> (updateState a s, []) 75 | , renderComponent = … 76 | , componentSnapshot = \_ -> A.object [] 77 | , restoreComponent = \_ s -> Right (s, []) 78 | } 79 | ``` 80 | 81 | # Working example 82 | 83 | ```nauva 84 | component_ counterComponent () 85 | ``` 86 | -------------------------------------------------------------------------------- /product/nauva/book/static/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Main (main) where 5 | 6 | 7 | import qualified Data.Text as T 8 | import Data.List 9 | import Data.Monoid 10 | import Data.Foldable 11 | 12 | import Control.Monad 13 | import Control.Concurrent.STM 14 | 15 | import System.Directory 16 | import System.FilePath 17 | 18 | import Nauva.App 19 | import Nauva.Catalog 20 | import Nauva.Static (elementToMarkup) 21 | import Nauva.CSS.Renderer 22 | 23 | import Nauva.Product.Nauva.Book.App (bookApp, catalogPages) 24 | 25 | import qualified Text.Blaze.Html5 as H 26 | import qualified Text.Blaze.Html5.Attributes as A 27 | import Text.Blaze.Html.Renderer.String 28 | 29 | 30 | 31 | main :: IO () 32 | main = do 33 | putStrLn "Nauva Book" 34 | 35 | forM_ (onlyLeaves catalogPages) $ \leaf -> do 36 | putStrLn $ T.unpack $ leafHref leaf 37 | 38 | headH <- do 39 | var <- newTVarIO [] 40 | pure HeadH 41 | { hElements = var 42 | , hReplace = atomically . writeTVar var 43 | } 44 | 45 | routerH <- do 46 | locVar <- newTVarIO $ Location (leafHref leaf) 47 | locChan <- newTChanIO 48 | 49 | pure $ RouterH (locVar, locChan) (\_ -> pure ()) 50 | 51 | (bodyHtml, styles, actions) <- atomically $ elementToMarkup $ 52 | rootElement bookApp (AppH headH routerH) 53 | 54 | sequence_ actions 55 | 56 | headElements <- atomically $ readTVar (hElements headH) 57 | headElementsHtml <- forM headElements $ \el -> do 58 | (html, _, _) <- atomically $ elementToMarkup el 59 | pure html 60 | 61 | let html = H.docTypeHtml $ do 62 | H.head $ do 63 | H.meta H.! A.charset "utf-8" 64 | mconcat headElementsHtml 65 | 66 | H.style $ H.text $ mconcat $ intersperse "\n" $ 67 | nub $ map renderCSSRule (mconcat $ map unStyle styles) 68 | 69 | H.body 70 | bodyHtml 71 | 72 | createDirectoryIfMissing True ("output" `joinDrive` T.unpack (leafHref leaf)) 73 | writeFile ("output" `joinDrive` T.unpack (leafHref leaf) `joinDrive` "index.html") (renderHtml html) 74 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/Service/Router.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module Nauva.Service.Router 6 | ( RouterH(..) 7 | , Location(..) 8 | 9 | , LinkProps(..) 10 | , link 11 | ) where 12 | 13 | 14 | import Data.Text (Text) 15 | import qualified Data.Aeson as A 16 | 17 | import Control.Concurrent.STM 18 | 19 | import Nauva.View 20 | 21 | 22 | 23 | data RouterH = RouterH 24 | { hLocation :: (TVar Location, TChan Location) 25 | -- ^ The current 'Location' and a (broadcast) 'TChan' which can 26 | -- be subscribed to in order to receive notifications when the location 27 | -- changes. 28 | 29 | , hPush :: Text -> IO () 30 | -- ^ Push a new URL to the router stack. 31 | } 32 | 33 | 34 | data Location = Location 35 | { locPathname :: !Text 36 | } 37 | 38 | 39 | 40 | ------------------------------------------------------------------------------- 41 | -- link 42 | 43 | data LinkProps = LinkProps 44 | { p_routerH :: !RouterH 45 | -- ^ The router handle provides the callbacks. 46 | , p_href :: !Text 47 | -- ^ The path which shall be pushed to the router history when the element 48 | -- is clicked. 49 | , p_element :: !Element 50 | -- ^ The element to which a 'onClick' handler is attached. 51 | } 52 | 53 | link :: LinkProps -> Element 54 | link = component_ linkComponent 55 | 56 | 57 | 58 | linkComponent :: Component LinkProps () () () 59 | linkComponent = createComponent $ \componentId -> Component 60 | { componentId = componentId 61 | , componentDisplayName = "Link" 62 | , initialComponentState = \_ -> pure ((), [], []) 63 | , componentEventListeners = \_ -> [] 64 | , componentHooks = emptyHooks 65 | , processLifecycleEvent = \() _ s -> (s, []) 66 | , receiveProps = \_ _ -> pure ((), [], []) 67 | , update = \() p s -> (s, [clickEffect p]) 68 | , renderComponent = \(LinkProps {..}) _ -> with p_element [onClick_ onClickHandler] 69 | , componentSnapshot = \_ -> A.object [] 70 | , restoreComponent = \_ s -> Right (s, []) 71 | } 72 | where 73 | onClickHandler :: FE MouseEvent () 74 | onClickHandler = [njs| ev => { ev.preventDefault(); return [] } |] 75 | 76 | clickEffect :: LinkProps -> IO (Maybe ()) 77 | clickEffect (LinkProps {..}) = do 78 | hPush p_routerH p_href 79 | pure Nothing 80 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/DOM.hs: -------------------------------------------------------------------------------- 1 | {-| 2 | Types which are needed to represent DOM-related objects which Nauva uses. Many 3 | of these already exist in the 'blaze-markup' or 'blaze-html' packages. However, 4 | those types are not suited for use within 'Nauva', so we define our own. 5 | 6 | - 'Tag' -- The tag of a DOM node. Used in 'ENode', 'INode', and 'SNode'. 7 | - 'Attribute' and 'AttributeValue' -- Attributes which are attached to DOM nodes. 8 | 9 | -} 10 | 11 | module Nauva.DOM 12 | ( -- * Tag 13 | Tag(..) 14 | 15 | -- * AttributeValue 16 | , AttributeValue(..) 17 | ) where 18 | 19 | 20 | import Data.Aeson 21 | import Data.String (IsString(..)) 22 | import Data.Function 23 | import Data.Text (Text) 24 | import qualified Data.Text as T 25 | 26 | import Control.Applicative 27 | 28 | import Prelude 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- 33 | -- | DOM tag. We provide a 'IsString' instance for convenience, use it 34 | -- judiciously. 35 | -- 36 | -- In any application, by far the most common 'Tag' will be @Tag "div"@, or 37 | -- simpler, if using the OverloadedStrings extension, just @"div"@. Thus the 38 | -- two following forms are equivalent: 39 | -- 40 | -- > ENode "div" Nothing [] [] ... 41 | -- > ENode (Tag "div") Nothing [] [] ... 42 | 43 | newtype Tag = Tag { unTag :: Text } 44 | deriving (Eq, Ord) 45 | 46 | instance Show Tag where 47 | show = T.unpack . unTag 48 | 49 | instance IsString Tag where 50 | fromString = Tag . T.pack 51 | 52 | instance ToJSON Tag where 53 | toJSON = toJSON . unTag 54 | 55 | instance FromJSON Tag where 56 | parseJSON x = Tag <$> parseJSON x 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- 61 | data AttributeValue 62 | = AVBool !Bool 63 | | AVString !Text 64 | | AVInt !Int 65 | | AVDouble !Double 66 | deriving (Eq, Ord) 67 | 68 | 69 | instance IsString AttributeValue where 70 | fromString = AVString . T.pack 71 | 72 | instance ToJSON AttributeValue where 73 | toJSON (AVBool b) = toJSON b 74 | toJSON (AVString s) = toJSON s 75 | toJSON (AVInt i) = toJSON i 76 | toJSON (AVDouble d) = toJSON d 77 | 78 | instance FromJSON AttributeValue where 79 | parseJSON (Bool b) = pure $ AVBool b 80 | parseJSON (String s) = pure $ AVString s 81 | parseJSON v@(Number _) = (AVInt <$> parseJSON v) <|> (AVDouble <$> parseJSON v) 82 | parseJSON _ = fail "AttributeValue" 83 | -------------------------------------------------------------------------------- /pkg/hs/color/src/Data/Color/Internal/Conversion.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Data.Color.Internal.Conversion where 5 | 6 | 7 | import Control.Lens 8 | 9 | import Data.Color.Internal.Types 10 | 11 | 12 | 13 | ------------------------------------------------------------------------------ 14 | -- CIExyY 15 | 16 | toCIExyY :: Iso' Color CIExyY 17 | toCIExyY = iso sa bt 18 | where 19 | sa Color{..} = CIExyY x y (1 - x - y) 20 | where 21 | x = cX / (cX + cY + cZ) 22 | y = cY / (cX + cY + cZ) 23 | 24 | bt (CIExyY x y cY) = Color{..} 25 | where 26 | cX = (cY / y) * x 27 | cZ = (cY / y) * (1 - x - y) 28 | 29 | 30 | 31 | ------------------------------------------------------------------------------ 32 | -- CIELAB 33 | 34 | toCIELAB :: Chromaticity -> Iso' Color CIELAB 35 | toCIELAB white = iso sa bt 36 | where 37 | Color {cX = xn, cY = yn, cZ = zn} = mkColor white 1 38 | rho = 6 / 29 39 | 40 | sa :: Color -> CIELAB 41 | sa Color{..} = CIELAB (116 * fy - 16) (500 * (fx - fy)) (200 * (fy - fz)) 42 | where 43 | (fx, fy, fz) = (f (cX/xn), f (cY/yn), f (cZ/zn)) 44 | 45 | f t = if t > (rho ** 3) then t ** (1/3) else (t / (3 * (rho ** 2))) + 4 / 29 46 | 47 | 48 | bt (CIELAB l a b) = Color x y z 49 | where 50 | l' = (l + 16) / 116 51 | 52 | x = xn * f (l' + (a / 500)) 53 | y = yn * f l' 54 | z = zn * f (l' - (b / 200)) 55 | 56 | f t = if t > rho then t ** 3 else 3 * (rho ** 2) * (t - 4 / 29) 57 | 58 | 59 | 60 | ------------------------------------------------------------------------------ 61 | -- SRGB 62 | 63 | toSRGB :: Iso' Color SRGB 64 | toSRGB = iso sa bt 65 | where 66 | a = 0.055 67 | 68 | sa Color{..} = SRGB r g b 69 | where 70 | r' = 3.2404542 * cX - 1.5371385 * cY - 0.4985314 * cZ 71 | g' = -0.9692660 * cX + 1.8760108 * cY + 0.0415560 * cZ 72 | b' = 0.0556434 * cX - 0.2040259 * cY + 1.0572252 * cZ 73 | 74 | r = f r' 75 | g = f g' 76 | b = f b' 77 | 78 | f t = if t < 0.0031308 then 12.92 * t else (a + 1) * (t ** (1 / 2.4)) - a; 79 | 80 | bt (SRGB r g b) = Color{..} 81 | where 82 | r' = f r 83 | g' = f g 84 | b' = f b 85 | 86 | cX = 0.4124564 * r' + 0.3575761 * g' + 0.1804375 * b' 87 | cY = 0.2126729 * r' + 0.7151522 * g' + 0.0721750 * b' 88 | cZ = 0.0193339 * r' + 0.1191920 * g' + 0.9503041 * b' 89 | 90 | f t = if t <= 0.04045 then t / 12.92 else ((t + a) / (a + 1)) ** 2.4 91 | -------------------------------------------------------------------------------- /pkg/js/src/Nauva/CSS.ts: -------------------------------------------------------------------------------- 1 | type CSSDeclarations = { 2 | [key: string]: number | string | string[]; 3 | } 4 | 5 | const cssRules = new Set() 6 | 7 | const styleSheet = (() => { 8 | let ss; 9 | function mk() { 10 | const style = document.createElement("style"); 11 | style.type = "text/css"; 12 | 13 | document.head.appendChild(style); 14 | 15 | ss = document.styleSheets[document.styleSheets.length - 1]; 16 | } 17 | 18 | return () => { 19 | if (ss === undefined) { 20 | mk() 21 | }; 22 | 23 | return ss; 24 | }; 25 | })(); 26 | 27 | export const emitRule = (rule: any): string => { 28 | const {hash} = rule; 29 | 30 | if (!cssRules.has(hash)) { 31 | cssRules.add(hash); 32 | const text = cssRuleExText(rule); 33 | styleSheet().insertRule(text, styleSheet().cssRules.length); 34 | } 35 | 36 | return rule.name === '' ? `s-${rule.hash}` : `${rule.name}-${rule.hash}`; 37 | }; 38 | 39 | const renderCSSDeclarations = (() => { 40 | const hyphenate = (x: string): string => x 41 | .replace(/([A-Z])/g, "-$1") 42 | .replace(/^ms-/, "-ms-") // Internet Explorer vendor prefix. 43 | .toLowerCase(); 44 | 45 | const append = (str: string, k: string, v: string | number): string => 46 | str + (str.length === 0 ? "" : ";") + hyphenate(k) + ":" + v; 47 | 48 | return (x: CSSDeclarations): string => Object.keys(x).reduce((str, k) => { 49 | const v = x[k]; 50 | return Array.isArray(v) 51 | ? v.reduce((a, v) => append(a, k, v), str) 52 | : append(str, k, v); 53 | }, ""); 54 | })(); 55 | 56 | const cssRuleExText = (() => { 57 | const renderCondition = c => 58 | (c[0] == 1 ? `@media ` : `@supports `) + c[1] + ' '; 59 | 60 | const wrapWithCondition = (c: string[], text: string): string => 61 | c.length === 0 ? text : wrapWithCondition(c.slice(1), renderCondition(c[0]) + "{" + text + "}"); 62 | 63 | const cssStyleRuleExText = (rule: any): string => 64 | wrapWithCondition(rule.conditions, 65 | [ "." 66 | , rule.name === '' ? `s-${rule.hash}` : `${rule.name}-${rule.hash}` 67 | , rule.suffixes.join("") 68 | , "{" 69 | , renderCSSDeclarations(rule.cssDeclarations) 70 | , "}" 71 | ].join("")); 72 | 73 | return (rule: any): string => { 74 | switch (rule.type) { 75 | case 1: return cssStyleRuleExText(rule); 76 | case 5: return `@font-face{${renderCSSDeclarations(rule.cssDeclarations)}}`; 77 | } 78 | }; 79 | })(); 80 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/nauvad.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.18 2 | build-type: Simple 3 | name: nauvad 4 | version: 0.6.6 5 | license: BSD3 6 | license-file: LICENSE 7 | category: Development 8 | author: Neil Mitchell , jpmoresmau 9 | maintainer: Neil Mitchell 10 | copyright: Neil Mitchell 2014-2017 11 | synopsis: GHCi based bare bones IDE 12 | description: 13 | Either \"GHCi as a daemon\" or \"GHC + a bit of an IDE\". A very simple Haskell development tool which shows you the errors in your project and updates them whenever you save. Run @ghcid --topmost --command=ghci@, where @--topmost@ makes the window on top of all others (Windows only) and @--command@ is the command to start GHCi on your project (defaults to @ghci@ if you have a @.ghci@ file, or else to @cabal repl@). 14 | homepage: https://github.com/wereHamster/nauva#readme 15 | bug-reports: https://github.com/wereHamster/nauva/issues 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/wereHamster/nauva.git 20 | 21 | library 22 | hs-source-dirs: src 23 | default-language: Haskell2010 24 | build-depends: 25 | base >= 4, 26 | filepath, 27 | time, 28 | text, 29 | aeson, 30 | directory, 31 | nauva, 32 | nauva-product-nauva-shared, 33 | extra >= 1.2, 34 | process >= 1.1, 35 | cmdargs >= 0.10 36 | 37 | exposed-modules: 38 | Language.Haskell.Ghcid 39 | other-modules: 40 | Language.Haskell.Ghcid.Types, 41 | Language.Haskell.Ghcid.Parser, 42 | Language.Haskell.Ghcid.Util 43 | 44 | executable nauvad 45 | hs-source-dirs: src 46 | default-language: Haskell2010 47 | ghc-options: -main-is Nauvad.main -threaded -rtsopts "-with-rtsopts=-N" 48 | main-is: Nauvad.hs 49 | build-depends: 50 | base == 4.*, 51 | filepath, 52 | time, 53 | directory, 54 | containers, 55 | fsnotify, 56 | extra >= 1.2, 57 | process >= 1.1, 58 | cmdargs >= 0.10, 59 | ansi-terminal, 60 | terminal-size >= 0.3, 61 | snap-core, 62 | snap-server, 63 | snap-blaze, 64 | bytestring, 65 | websockets, 66 | websockets-snap, 67 | blaze-html, 68 | aeson, 69 | text, 70 | stm, 71 | nauva, 72 | nauva-catalog, 73 | nauva-product-nauva-shared, 74 | process, 75 | portfinder, 76 | file-embed, 77 | template-haskell, 78 | mtl, 79 | async 80 | other-modules: 81 | Language.Haskell.Ghcid.Types 82 | Language.Haskell.Ghcid.Parser 83 | Language.Haskell.Ghcid.Util 84 | Language.Haskell.Ghcid 85 | Session 86 | Settings 87 | Wait 88 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/src/Language/Haskell/Ghcid/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | 3 | -- | Parses the output from GHCi 4 | module Language.Haskell.Ghcid.Parser( 5 | parseShowModules, parseLoad 6 | ) where 7 | 8 | import System.FilePath 9 | import Data.Char 10 | import Data.List.Extra 11 | import Data.Tuple.Extra 12 | import Control.Applicative 13 | import Prelude 14 | 15 | import Language.Haskell.Ghcid.Types 16 | 17 | 18 | -- | Parse messages from show modules command. Given the parsed lines 19 | -- return a list of (module name, file). 20 | parseShowModules :: [String] -> [(String, FilePath)] 21 | parseShowModules xs = 22 | [ (takeWhile (not . isSpace) $ trimStart a, takeWhile (/= ',') b) 23 | | x <- xs, (a,'(':' ':b) <- [break (== '(') x]] 24 | 25 | 26 | -- | Parse messages given on reload. 27 | parseLoad :: [String] -> [Load] 28 | -- nub, because cabal repl sometimes does two reloads at the start 29 | parseLoad = nubOrd . f 30 | where 31 | f :: [String] -> [Load] 32 | f (('[':xs):rest) = 33 | map (uncurry Loading) (parseShowModules [drop 11 $ dropWhile (/= ']') xs]) ++ 34 | f rest 35 | f (x:xs) 36 | | not $ " " `isPrefixOf` x 37 | , Just (file,rest) <- breakFileColon x 38 | , takeExtension file `elem` [".hs",".lhs",".hs-boot",".lhs-boot"] 39 | -- take position, including span if present 40 | , (pos,rest) <- span (\c -> c == ':' || c == '-' || isSpan c || isDigit c) rest 41 | -- separate line and column, ignoring span (we want the start point only) 42 | , [p1,p2] <- map read $ wordsBy (\c -> c == ':' || isSpan c) $ takeWhile (\c->c /= '-') pos 43 | , (msg,las) <- span (isPrefixOf " ") xs 44 | , rest <- trimStart $ unwords $ rest : xs 45 | , sev <- if "warning:" `isPrefixOf` lower rest then Warning else Error 46 | = Message sev file (p1,p2) (x:msg) : f las 47 | f (x:xs) 48 | | Just file <- stripPrefix ": can't find file: " x 49 | = Message Error file (0,0) [file ++ ": Can't find file"] : f xs 50 | f (x:xs) 51 | | x == "Module imports form a cycle:" 52 | , (xs,rest) <- span (isPrefixOf " ") xs 53 | , let ms = [takeWhile (/= ')') x | x <- xs, '(':x <- [dropWhile (/= '(') x]] 54 | = Message Error "" (0,0) (x:xs) : 55 | -- need to label the modules in the import cycle so I can find them 56 | [Message Error m (0,0) [] | m <- nubOrd ms] ++ f rest 57 | f (_:xs) = f xs 58 | f [] = [] 59 | isSpan c = c== ',' || c == '(' || c == ')' 60 | 61 | -- A filename, followed by a colon - be careful to handle Windows drive letters, see #61 62 | breakFileColon :: String -> Maybe (FilePath, String) 63 | breakFileColon (x:':':xs) | isLetter x = first ([x,':']++) <$> stripInfix ":" xs 64 | breakFileColon xs = stripInfix ":" xs 65 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/src/Language/Haskell/Ghcid/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | 3 | -- | The types types that we use in Ghcid 4 | module Language.Haskell.Ghcid.Types( 5 | GhciError(..), 6 | Stream(..), 7 | Load(..), Severity(..), isMessage, 8 | NVDMessage(..), GHCMessage(..) 9 | ) where 10 | 11 | import Data.Data 12 | import Data.Text (Text) 13 | import qualified Data.Aeson as A 14 | import Control.Exception.Base (Exception) 15 | import Nauva.Internal.Types 16 | 17 | -- | GHCi shut down 18 | data GhciError = UnexpectedExit String String 19 | deriving (Show,Eq,Ord,Typeable,Data) 20 | 21 | -- | Make GhciError an exception 22 | instance Exception GhciError 23 | 24 | -- | The stream Ghci is talking over. 25 | data Stream = Stdout | Stderr 26 | deriving (Show,Eq,Ord,Bounded,Enum,Read,Typeable,Data) 27 | 28 | -- | Severity of messages 29 | data Severity = Warning | Error 30 | deriving (Show,Eq,Ord,Bounded,Enum,Read,Typeable,Data) 31 | 32 | -- | Load messages 33 | data Load 34 | = Loading 35 | {loadModule :: String 36 | ,loadFile :: FilePath 37 | } 38 | | Message 39 | {loadSeverity :: Severity 40 | ,loadFile :: FilePath 41 | ,loadFilePos :: (Int,Int) 42 | ,loadMessage :: [String] 43 | } 44 | deriving (Show, Eq, Ord) 45 | 46 | -- | Is a Load a message with severity? 47 | isMessage :: Load -> Bool 48 | isMessage Message{} = True 49 | isMessage _ = False 50 | 51 | 52 | 53 | -- | Here we have two groups of messages: control and data. Control is 54 | -- all about the connection between NVD and the browser. Data is all 55 | -- about the state and contents of the application. 56 | data NVDMessage 57 | = NVDMLoading 58 | -- ^ The application was killed and the server is recompiling it. 59 | -- During this time the client SHOULD NOT send any messages to the 60 | -- server (as they will be ignored). The client SHOULD wait for 61 | -- 'NVDMGood' or 'NVDMFailed'. 62 | 63 | | NVDMGood 64 | | NVDMFailed [GHCMessage] 65 | 66 | | NVDMLocation Text 67 | | NVDMLocationRaw A.Value 68 | | NVDMSpine Spine 69 | | NVDMSpineRaw A.Value A.Value 70 | 71 | instance A.ToJSON NVDMessage where 72 | toJSON NVDMLoading = A.toJSON [A.toJSON (1 :: Int)] 73 | toJSON NVDMGood = A.toJSON [A.toJSON (2 :: Int)] 74 | toJSON (NVDMFailed msgs) = A.toJSON [A.toJSON (3 :: Int), A.toJSON (map A.toJSON msgs)] 75 | toJSON (NVDMLocation loc) = A.toJSON [A.toJSON (4 :: Int), A.toJSON loc] 76 | toJSON (NVDMLocationRaw v) = A.toJSON [A.toJSON (4 :: Int), v] 77 | toJSON (NVDMSpine spine) = A.toJSON [A.toJSON (5 :: Int), A.toJSON spine] 78 | toJSON (NVDMSpineRaw v h) = A.toJSON [A.toJSON (5 :: Int), v, h] 79 | 80 | 81 | data GHCMessage = GHCMessage Severity FilePath (Int, Int) [Text] 82 | 83 | instance A.ToJSON GHCMessage where 84 | toJSON (GHCMessage severity filePath filePos msg) = A.toJSON 85 | [ A.toJSON severity 86 | , A.toJSON filePath 87 | , A.toJSON filePos 88 | , A.toJSON msg 89 | ] 90 | 91 | instance A.ToJSON Severity where 92 | toJSON Warning = A.toJSON [A.toJSON (1 :: Int)] 93 | toJSON Error = A.toJSON [A.toJSON (2 :: Int)] 94 | -------------------------------------------------------------------------------- /docs/book/markup.md: -------------------------------------------------------------------------------- 1 | The Nauva markup language is what you use to describe how the UI should look. 2 | It is declarative, very similar to HTML and partly inspired by [React](https://facebook.github.io/react/) and [blaze-html](https://hackage.haskell.org/package/blaze-html). 3 | 4 | 5 | # Imports 6 | 7 | First we need to establishe some imports. Internally the code is split into 8 | many separate modules. But to make it easier for users, all the functions are 9 | re-exported through `Nauva.View`. It is recommended that you import the module 10 | unqualified and without explicit import list. 11 | 12 | import Nauva.View 13 | 14 | 15 | # HTML elements 16 | 17 | Most HTML elements have an equivalent function in Nauva. The function name 18 | is the same as the HTML tag but with an underscore suffix. The reason for 19 | the suffix is so that there is no conflict between `div` from the `Prelude` 20 | and the `
` HTML element (which is used very often). 21 | 22 | We refer to these functions as *terms*. They are used to build the document 23 | object model (DOM) tree. We use *term* because certain functions can appear 24 | both as a tag (``) and as an attribute (`<a title="…">`) at the same 25 | time. But more on that later. 26 | 27 | There are a few special functions which don't correspond to a HTML tag. Two 28 | important ones are `str_ :: Text -> Element` and `null_ :: Element`. 29 | 30 | 31 | ## Example 32 | 33 | ```nauva 34 | div_ [str_ "This is a <div> element with a text within"] 35 | ``` 36 | 37 | The functions are overloaded and can take either one or two arguments (this 38 | is possible through the use of multiple Haskell language extensions). 39 | 40 | - `div_ :: [Element] -> Element` – takes a list of children. 41 | - `div_ :: [Attribute] -> [Element] -> Element` – takes a list of attributes and then a list of childern. 42 | - `br_ :: [Attribute] -> Element` – takes a list of attributes. 43 | 44 | ```hint 45 | To create an element with no children, you have to explicitly supply the type 46 | signature. Without it the compiler gets confused. 47 | 48 | Example: `let emptyDiv = (div_ [] :: Element)` 49 | ``` 50 | 51 | 52 | # HTML attributes 53 | 54 | The same *terms* that are used to create HTML elements can also be used 55 | to create attributes. Nauva can attach `Bool`, `Text`, `Int`, and `Double` 56 | attributes directly to an element. Other attributes you have to manually 57 | convert to one of those types first. 58 | 59 | 60 | ## Example 61 | 62 | ```nauva 63 | a_ [href_ ("https://google.com" :: Text)] [str_ "This is a link"] 64 | ``` 65 | 66 | # Dual use of terms as tags and attributes 67 | 68 | Remember when I said that there are terms which are use both as a tag 69 | and attribute? `title_` is one such example. It can be used as a child 70 | of `<head>` to set the page title, and also as an attribute on elements. 71 | 72 | 73 | -- As a child of <head> 74 | head_ 75 | [ title_ [str_ "The Nauva Book"] 76 | ] 77 | 78 | -- As an attribute on <abbr> 79 | abbr_ 80 | [title_ ("Glasgow Haskell Compiler" :: Text)] 81 | [str_ "GHC"] 82 | 83 | 84 | # Next 85 | 86 | There are two other important types of attributes that are attached to elments: styles and event handlers. More to that in the [next](/styles) chapter. 87 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/src/Language/Haskell/Ghcid/Util.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Utility functions 3 | module Language.Haskell.Ghcid.Util( 4 | dropPrefixRepeatedly, 5 | chunksOfWord, 6 | outWith, outStrLn, outStr, 7 | allGoodMessage, 8 | getModTime, getModTimeResolution 9 | ) where 10 | 11 | import Control.Concurrent.Extra 12 | import System.Time.Extra 13 | import System.IO.Unsafe 14 | import System.IO.Extra 15 | import System.FilePath 16 | import Data.List.Extra 17 | import Data.Char 18 | import Data.Time.Clock 19 | import System.IO.Error 20 | import System.Directory 21 | import Control.Exception 22 | import Control.Monad.Extra 23 | import Control.Applicative 24 | import Prelude 25 | 26 | 27 | -- | Drop a prefix from a list, no matter how many times that prefix is present 28 | dropPrefixRepeatedly :: Eq a => [a] -> [a] -> [a] 29 | dropPrefixRepeatedly [] s = s 30 | dropPrefixRepeatedly pre s = maybe s (dropPrefixRepeatedly pre) $ stripPrefix pre s 31 | 32 | 33 | {-# NOINLINE lock #-} 34 | lock :: Lock 35 | lock = unsafePerformIO newLock 36 | 37 | outWith :: IO a -> IO a 38 | outWith = withLock lock 39 | 40 | outStr :: String -> IO () 41 | outStr = outWith . putStr 42 | 43 | outStrLn :: String -> IO () 44 | outStrLn s = outStr $ s ++ "\n" 45 | 46 | 47 | -- | The message to show when no errors have been reported 48 | allGoodMessage :: String 49 | allGoodMessage = "All good" 50 | 51 | -- | Like chunksOf, but deal with words up to some gap. 52 | -- Flows onto a subsequent line if less than N characters end up being empty. 53 | chunksOfWord :: Int -> Int -> String -> [String] 54 | chunksOfWord mx gap = repeatedly $ \x -> 55 | let (a,b) = splitAt mx x in 56 | if null b then (a, []) else 57 | let (a1,a2) = breakEnd isSpace a in 58 | if length a2 <= gap then (a1, a2 ++ b) else (a, dropWhile isSpace b) 59 | 60 | -- | Given a 'FilePath' return either 'Nothing' (file does not exist) or 'Just' (the modification time) 61 | getModTime :: FilePath -> IO (Maybe UTCTime) 62 | getModTime file = handleJust 63 | (\e -> if isDoesNotExistError e then Just () else Nothing) 64 | (\_ -> return Nothing) 65 | (Just <$> getModificationTime file) 66 | 67 | 68 | 69 | -- | Get the smallest difference that can be reported by two modification times 70 | getModTimeResolution :: IO Seconds 71 | getModTimeResolution = return getModTimeResolutionCache 72 | 73 | {-# NOINLINE getModTimeResolutionCache #-} 74 | -- Cache the result so only computed once per run 75 | getModTimeResolutionCache :: Seconds 76 | getModTimeResolutionCache = unsafePerformIO $ withTempDir $ \dir -> do 77 | let file = dir </> "calibrate.txt" 78 | 79 | -- with 10 measurements can get a bit slow, see Shake issue tracker #451 80 | -- if it rounds to a second then 1st will be a fraction, but 2nd will be full second 81 | mtime <- fmap maximum $ forM [1..3] $ \i -> fmap fst $ duration $ do 82 | writeFile file $ show i 83 | t1 <- getModificationTime file 84 | flip loopM 0 $ \j -> do 85 | writeFile file $ show (i,j) 86 | t2 <- getModificationTime file 87 | return $ if t1 == t2 then Left $ j+1 else Right () 88 | putStrLn $ "Longest file modification time lag was " ++ show (ceiling (mtime * 1000)) ++ "ms" 89 | -- add a little bit of safety, but if it's really quick, don't make it that much slower 90 | return $ mtime + min 0.1 mtime 91 | -------------------------------------------------------------------------------- /product/nauva/shared/src/Nauva/Product/Nauva/Element/Message.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Nauva.Product.Nauva.Element.Message 7 | ( messageEl 8 | , MessageProps(..) 9 | , MessageSeverity(..) 10 | 11 | , catalogPage 12 | ) where 13 | 14 | 15 | import Data.Text (Text) 16 | import qualified Data.Text as T 17 | 18 | import Nauva.View 19 | 20 | import Nauva.Catalog.TH (nauvaCatalogPage) 21 | import Nauva.Catalog.Theme.Color 22 | import Nauva.Catalog.Theme.Typeface 23 | 24 | import Prelude hiding (rem) 25 | 26 | 27 | data MessageSeverity 28 | = MSError 29 | | MSWarning 30 | deriving (Eq) 31 | 32 | data MessageProps = MessageProps 33 | { filePath :: Text 34 | , messages :: [Text] 35 | , severity :: MessageSeverity 36 | } 37 | 38 | messageEl :: MessageProps -> Element 39 | messageEl props = div_ [style_ rootStyle] 40 | [ div_ [style_ filePathStyle] [str_ $ filePath props] 41 | , div_ [style_ messageStyle] $ map (\x -> div_ [str_ x]) strippedMessages 42 | ] 43 | where 44 | rootStyle :: Style 45 | rootStyle = mkStyle' "message" $ do 46 | display flex 47 | flexDirection column 48 | marginBottom "20px" 49 | 50 | filePathStyle :: Style 51 | filePathStyle = mkStyle' "filePath" $ do 52 | typeface system14Typeface 53 | padding (px 8) (px 12) 54 | backgroundColor $ case severity props of 55 | MSError -> red 56 | MSWarning -> gray 57 | color "rgba(255,255,255,0.95)" 58 | overflow "hidden" 59 | 60 | messageStyle :: Style 61 | messageStyle = mkStyle' "messageText" $ do 62 | typeface mono12Typeface 63 | padding (px 12) (px 12) 64 | whiteSpace "pre" 65 | backgroundColor lightGray 66 | overflowX "auto" 67 | 68 | strippedMessages = stripLeadingSpaces (messages props) 69 | stripLeadingSpaces xs = if allHaveALeadingSpace then stripLeadingSpaces (map (T.tail) xs) else xs 70 | where 71 | hasLeadingSpace :: Text -> Bool 72 | hasLeadingSpace x = case T.uncons x of 73 | Just (' ', _) -> True 74 | _ -> False 75 | 76 | allHaveALeadingSpace :: Bool 77 | allHaveALeadingSpace = and $ map hasLeadingSpace xs 78 | 79 | 80 | catalogPage :: Element 81 | catalogPage = [nauvaCatalogPage| 82 | 83 | Messages are warnings or errors which are generated during compilation. 84 | They are shown in the browser window. 85 | 86 | ```nauva 87 | messageEl $ MessageProps 88 | { filePath = "/Users/tomc/src/nauva/product/nauva/shared/src/Nauva/Product/Nauva/Element/Message.hs" 89 | , messages = 90 | [ " • No instance for (Term [Text -> Element] Element)" 91 | , " arising from a use of ‘div_’" 92 | ] 93 | , severity = MSWarning 94 | } 95 | ``` 96 | 97 | # Another example of `messageEl` 98 | 99 | ```nauva 100 | noSource: true 101 | --- 102 | messageEl $ MessageProps 103 | { filePath = "…/Product/Nauva/Element/Message.hs" 104 | , messages = 105 | [ " • No instance for (Term [Text -> Element] Element)" 106 | , " arising from a use of ‘div_’" 107 | ] 108 | , severity = MSError 109 | } 110 | ``` 111 | |] 112 | -------------------------------------------------------------------------------- /pkg/hs/color/test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | 6 | import Test.Hspec 7 | 8 | import Control.Lens 9 | 10 | import Data.Color.Illuminant 11 | import Data.Color.Internal.Types 12 | import Data.Color.Internal.Conversion 13 | 14 | 15 | 16 | -- D65 at 0% and 100% luminance. 17 | whiteD65_0, whiteD65_1 :: Color 18 | whiteD65_0 = mkColor d65 0 19 | whiteD65_1 = mkColor d65 1 20 | 21 | -- sRGB primaries 22 | sRGB_r, sRGB_g, sRGB_b :: Color 23 | (sRGB_r, sRGB_g, sRGB_b) = 24 | ( mkColor (Chromaticity 0.6400 0.3300) 0.2126 25 | , mkColor (Chromaticity 0.3000 0.6000) 0.7152 26 | , mkColor (Chromaticity 0.1500 0.0600) 0.0722 27 | ) 28 | 29 | _unColorV :: Getter (ColorV a) (a, a, a) 30 | _unColorV = to unColorV 31 | 32 | within :: (Num a, Ord a) => a -> a -> a -> Bool 33 | within eps a b = abs (a - b) < eps 34 | 35 | 36 | main :: IO () 37 | main = hspec $ parallel $ do 38 | describe "colorLuminance" $ do 39 | it "luminance of sRGB (124,124,124) should be 20% (18% gray card)" $ 40 | mkSRGB8 (124,124,124) ^.re toSRGB ^. colorLuminance `shouldSatisfy` within 0.005 0.2 41 | it "luminance of sRGB (128,128,128) should be 21.40% (50% sRGB brightness)" $ 42 | mkSRGB8 (128,128,128) ^.re toSRGB ^. colorLuminance `shouldSatisfy` within 0.005 0.214 43 | it "luminance of sRGB (188,188,188) should be 50% (middle gray as defined by absolute whiteness)" $ 44 | mkSRGB8 (188,188,188) ^.re toSRGB ^. colorLuminance `shouldSatisfy` within 0.005 0.5 45 | 46 | describe "CIE LAB" $ do 47 | describe "toCIELAB" $ do 48 | it "should convert D65 at 0% luminance to L=0" $ 49 | whiteD65_0 ^. toCIELAB d65 ^. cvCIELAB ^. _unColorV ^. _1 `shouldBe` 0 50 | it "should convert D65 at 100% luminance to L=100" $ 51 | whiteD65_1 ^. toCIELAB d65 ^. cvCIELAB ^. _unColorV ^. _1 `shouldBe` 100 52 | 53 | describe "L=50" $ 54 | it "should convert to sRGB (119,119,119)" $ 55 | CIELAB 50 0 0 ^.re (toCIELAB d65) ^. toSRGB ^. cvSRGB8 `shouldBe` ColorV (119,119,119) 56 | 57 | describe "sRGB" $ 58 | describe "toSRGB" $ do 59 | it "should convert D65 at 0% luminance to (0,0,0)" $ 60 | whiteD65_0 ^. toSRGB ^. cvSRGB8 `shouldBe` ColorV (0,0,0) 61 | it "should convert D65 at 100% luminance to (255,255,255)" $ 62 | whiteD65_1 ^. toSRGB ^. cvSRGB8 `shouldBe` ColorV (255,255,255) 63 | 64 | describe "primaries" $ do 65 | it "should convert the red primary to (255,0,0)" $ 66 | sRGB_r ^. toSRGB ^. cvSRGB8 `shouldBe` ColorV (255,0,0) 67 | it "should convert the green primary to (0,255,0)" $ 68 | sRGB_g ^. toSRGB ^. cvSRGB8 `shouldBe` ColorV (0,255,0) 69 | it "should convert the blue primary to (0,0,255)" $ 70 | sRGB_b ^. toSRGB ^. cvSRGB8 `shouldBe` ColorV (0,0,255) 71 | 72 | 73 | describe "regressions" $ do 74 | it "roundtrip from sRGB to CIE LAB and back" $ 75 | let rgb = (44,9,103) 76 | ColorV (l, a, b) = mkSRGB8 rgb ^.re toSRGB ^. toCIELAB d65 ^. cvCIELAB 77 | in CIELAB l a b ^.re (toCIELAB d65) ^. toSRGB ^. cvSRGB8 ^. _unColorV `shouldBe` rgb 78 | 79 | it "xyY 0.238 0.281 0.00424 == rgb 5 15 20" $ 80 | let color = mkColor (Chromaticity 0.238 0.281) 0.00424 81 | in color ^. toSRGB ^. cvSRGB8 `shouldBe` ColorV (5, 15, 20) 82 | -------------------------------------------------------------------------------- /pkg/hs/nauva-css/src/Nauva/CSS/Terms.Generator.hs: -------------------------------------------------------------------------------- 1 | module Nauva.CSS.Terms.Generator (main) where 2 | 3 | import Data.List (sort, nub) 4 | import Data.Char (toUpper) 5 | 6 | 7 | sanitize :: String -> String 8 | sanitize = removeDash 9 | where 10 | removeDash ('-' : x : xs) = toUpper x : removeDash xs 11 | removeDash (x : xs) = x : removeDash xs 12 | removeDash [] = [] 13 | 14 | 15 | exportList :: [String] -> String 16 | exportList [] = error "exportList without functions." 17 | exportList (f:functions) = unlines $ 18 | [ "module Nauva.CSS.Terms" 19 | , " ( " ++ f 20 | ] ++ 21 | map (" , " ++) functions ++ 22 | [ " ) where"] 23 | 24 | 25 | makeTerm :: String -> String 26 | makeTerm tag = unlines 27 | [ function ++ " :: CSSTerm a => a" 28 | , function ++ " = cssTerm \"" ++ tag ++ "\"" 29 | , "{-# INLINE " ++ function ++ " #-}" 30 | ] 31 | where 32 | function = sanitize tag 33 | 34 | -- Terms which can appear both as properties and values. 35 | properties :: [String] 36 | properties = 37 | [ "align-items" 38 | , "background" 39 | , "background-color" 40 | , "border" 41 | , "border-bottom" 42 | , "border-left" 43 | , "border-radius" 44 | , "border-right" 45 | , "border-top" 46 | , "bottom" 47 | , "box-sizing" 48 | , "color" 49 | , "content" 50 | , "cursor" 51 | , "display" 52 | , "flex-basis" 53 | , "flex-direction" 54 | , "flex-end" 55 | , "flex-flow" 56 | , "flex-shrink" 57 | , "flex-wrap" 58 | , "flex" 59 | , "font-family" 60 | , "font-size" 61 | , "font-style" 62 | , "font-variant" 63 | , "font-weight" 64 | , "height" 65 | , "hyphens" 66 | , "justify-content" 67 | , "left" 68 | , "line-height" 69 | , "list-style" 70 | , "margin-bottom" 71 | , "margin-left" 72 | , "margin-right" 73 | , "margin-top" 74 | , "margin" 75 | , "max-height" 76 | , "max-width" 77 | , "min-height" 78 | , "opacity" 79 | , "outline" 80 | , "overflow" 81 | , "overflow-x" 82 | , "overflow-y" 83 | , "padding" 84 | , "padding-bottom" 85 | , "padding-left" 86 | , "padding-right" 87 | , "padding-top" 88 | , "position" 89 | , "quotes" 90 | , "src" 91 | , "text-align" 92 | , "text-decoration" 93 | , "text-indent" 94 | , "text-rendering" 95 | , "text-transform" 96 | , "top" 97 | , "transform" 98 | , "transition" 99 | , "user-select" 100 | , "white-space" 101 | , "width" 102 | ] 103 | 104 | -- Terms which only appear as values. 105 | values :: [String] 106 | values = 107 | [ "absolute" 108 | , "auto" 109 | , "block" 110 | , "center" 111 | , "column" 112 | , "fixed" 113 | , "inline-block" 114 | , "none" 115 | , "normal" 116 | , "pointer" 117 | , "relative" 118 | , "right" 119 | , "row" 120 | , "uppercase" 121 | , "wrap" 122 | ] 123 | 124 | terms :: [String] 125 | terms = nub $ sort $ properties ++ values 126 | 127 | main :: IO () 128 | main = putStr $ removeTrailingNewlines $ unlines 129 | [ "{-# LANGUAGE OverloadedStrings #-}" 130 | , "" 131 | , exportList (map sanitize terms) 132 | , "" 133 | , "import Nauva.CSS.Types" 134 | , "" 135 | , "" 136 | , unlines $ map makeTerm terms 137 | ] 138 | 139 | where 140 | removeTrailingNewlines = reverse . drop 2 . reverse 141 | -------------------------------------------------------------------------------- /docs/book/styles.md: -------------------------------------------------------------------------------- 1 | In traditional UI frameworks you author and manage styling information 2 | separately from markup (eg. in external CSS files). This approach 3 | requires significant effort on the side of developers to keep the two 4 | in sync. People have tried to solve this by using convention (BEM, 5 | OOCSS, SCMACSS, SUITCSS, Atomic etc) or tooling (CSS modules + 6 | webpack). 7 | 8 | In Nauva you attach styling information directly to elements because 9 | the two are often tightly coupled. And *if* you ever need to make 10 | an element customisable or themeable, simply make the theme an 11 | additional function argument, just like you would in any programming 12 | language! 13 | 14 | 15 | # Define styles 16 | 17 | First you need to define a style. This is done with the `mkStyle` 18 | function and a do block where you declare the style in a CSS-like DSL. 19 | 20 | The CSS DSL uses the same terms as CSS IDL attributes, eg. `background-color` 21 | becomes `backgroundColor`. Unlike the HTML terms there is no underscore 22 | suffix. This makes the syntax very approachable to people who already know 23 | CSS. 24 | 25 | Like the HTML terms, the CSS DSL terms are overloaded. They can appear 26 | both in place of the property or value. For example `flex` can be either 27 | a property (`flex "1"`) or a value (`display flex`). 28 | 29 | If for some reason a property or value is not defined, you have a very 30 | easy way to define your own ones. Thanks to the `IsString` instance 31 | you can simply use a string! 32 | 33 | ## Example 34 | 35 | ``` 36 | bigRedTextStyle :: Style 37 | bigRedTextStyle = mkStyle $ do 38 | fontSize (px 28) 39 | 40 | -- Custom value for the 'color' property. 41 | color "red" 42 | 43 | -- Custom property and value. 44 | "-webkit-font-smoothing" "subpixel-antialiased" 45 | ``` 46 | 47 | 48 | # Attaching style to an element 49 | 50 | Use `style_` to convert a `Style` to an `Attribute`. 51 | 52 | ```nauva 53 | let bigRedTextStyle = mkStyle $ do 54 | color "red" 55 | fontSize (px 28) 56 | 57 | in div_ [style_ bigRedTextStyle] [str_ "BIG RED TEXT"] 58 | ``` 59 | 60 | # Pseudo selectors, pseudo elements, and media queries 61 | 62 | The CSS DSL supports pseudo selectors, pseudo elements, and media queries. 63 | A limited number of combinators exist (`onHover`, `onActive`, `firstChild` 64 | etc). You can also nest them. 65 | 66 | ```nauva 67 | let bigRedTextWithHoverStyle = mkStyle $ do 68 | color "red" 69 | fontSize (px 28) 70 | cursor pointer 71 | 72 | onHover $ do 73 | color "green" 74 | 75 | media "(min-width: 1000px)" $ do 76 | color "blue" 77 | 78 | onHover $ do 79 | color "yellow" 80 | 81 | in div_ [style_ bigRedTextWithHoverStyle] [str_ "BIG RED TEXT TURNING GREEN ON HOVER"] 82 | ``` 83 | 84 | ```hint 85 | The semantics of multiple uses of these combinators is not formally defined. Use 86 | with caution! 87 | ``` 88 | 89 | 90 | # Next 91 | 92 | The [next](/thunks) chapter explains how to use thunks to optimize performance. 93 | 94 | 95 | ## Event handlers 96 | 97 | Event handlers are `NJS` expressions that are attached to `Elements` and executed 98 | when an event is dispatched to the `Element`. 99 | 100 | ``` 101 | let onClickHandler :: F1 MouseEvent Int 102 | onClickHandler = [njs| ev => { 103 | ev.stopPropagation() 104 | return 1 105 | }|] 106 | 107 | in button_ [onClick_ onClickHandler] [str_ "Click Me!"] 108 | ``` 109 | -------------------------------------------------------------------------------- /pkg/hs/color/src/Data/Color/Internal/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Data.Color.Internal.Types where 4 | 5 | 6 | import Data.Word 7 | import Control.Lens 8 | 9 | 10 | 11 | ------------------------------------------------------------------------------- 12 | -- | A generic representation of a color as three values, usually numbers, 13 | -- without giving them any particular meaning. It could be the RGB channels 14 | -- of a SRGB or AdobeRGB color, XYZ tristimulus values, CIE xyY values 15 | -- or something else. 16 | 17 | newtype ColorV a = ColorV { unColorV :: (a, a, a) } 18 | deriving (Eq, Show) 19 | 20 | instance Functor ColorV where 21 | fmap f (ColorV (a, b, c)) = ColorV (f a, f b, f c) 22 | 23 | 24 | 25 | ------------------------------------------------------------------------------- 26 | -- | The x and y coordinates of CIE xyY. 27 | -- 28 | -- The 'chromaX' and 'chromaY' components are usually referred to with @x@ and 29 | -- @y@ symbols in mathematical formulas. 30 | -- 31 | -- See https://en.wikipedia.org/wiki/Chromaticity 32 | 33 | data Chromaticity = Chromaticity { chromaX :: !Double, chromaY :: !Double } 34 | deriving (Eq, Show) 35 | 36 | 37 | 38 | ------------------------------------------------------------------------------- 39 | -- | Color is stored as CIE XYZ tristimulus values, normalized to @cY = 1@ 40 | -- being the brightest color. 41 | 42 | data Color = Color { cX :: !Double, cY :: !Double, cZ :: !Double } 43 | deriving (Eq, Show) 44 | 45 | 46 | -- | Construct a 'Color' from a 'Chromaticity' and the @Y@ tristimulus value. 47 | mkColor :: Chromaticity -> Double -> Color 48 | mkColor Chromaticity{..} cY = Color{..} 49 | where 50 | cX = (cY / chromaY) * chromaX 51 | cZ = (cY / chromaY) * (1 - chromaX - chromaY) 52 | 53 | 54 | colorChromaticity :: Getter Color Chromaticity 55 | colorChromaticity = to $ \Color{..} -> 56 | Chromaticity (cX / (cX + cY + cZ)) (cY / (cX + cY + cZ)) 57 | 58 | colorLuminance :: Getter Color Double 59 | colorLuminance = to cY 60 | 61 | 62 | 63 | ------------------------------------------------------------------------------ 64 | -- | CIE xyY 65 | 66 | data CIExyY = CIExyY !Double !Double !Double 67 | deriving (Eq, Show) 68 | 69 | cvCIExyY :: Getter CIExyY (ColorV Double) 70 | cvCIExyY = to $ \(CIExyY a b c) -> ColorV (a, b, c) 71 | 72 | 73 | 74 | ------------------------------------------------------------------------------ 75 | -- | CIE LAB 76 | -- 77 | -- The L is normalized to [0..100]. 78 | 79 | data CIELAB = CIELAB !Double !Double !Double 80 | deriving (Eq, Show) 81 | 82 | cvCIELAB :: Getter CIELAB (ColorV Double) 83 | cvCIELAB = to $ \(CIELAB a b c) -> ColorV (a, b, c) 84 | 85 | 86 | 87 | ------------------------------------------------------------------------------ 88 | -- | sRGB 89 | -- 90 | -- The RGB channels are normalized to [0..1]. 91 | 92 | data SRGB = SRGB !Double !Double !Double 93 | deriving (Eq, Show) 94 | 95 | mkSRGB8 :: (Word8, Word8, Word8) -> SRGB 96 | mkSRGB8 (r, g, b) = SRGB (f r) (f g) (f b) 97 | where f x = fromIntegral x / 255 98 | 99 | 100 | cvSRGB :: Getter SRGB (ColorV Double) 101 | cvSRGB = to $ \(SRGB a b c) -> ColorV (a, b, c) 102 | 103 | -- | Convert a 'SRGB' color to a 'ColorV' of 'Word8's. Channel values which 104 | -- are out of bounds (<0 or >1) are clamped. 105 | cvSRGB8 :: Getter SRGB (ColorV Word8) 106 | cvSRGB8 = to $ \(SRGB a b c) -> ColorV (f a, f b, f c) 107 | where 108 | f x = round $ fromIntegral (maxBound :: Word8) * clamp x 109 | clamp x 110 | | x < 0 = 0 111 | | x > 1 = 1 112 | | otherwise = x 113 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/src/Nauva/Catalog/Theme/Typeface.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Nauva.Catalog.Theme.Typeface 4 | ( h2Typeface 5 | , h3Typeface 6 | , h4Typeface 7 | 8 | , paragraphTypeface 9 | , blockquoteTypeface 10 | , meta14Typeface 11 | 12 | , system14Typeface 13 | 14 | , mono12Typeface 15 | , mono14Typeface 16 | ) where 17 | 18 | 19 | import Nauva.View 20 | 21 | 22 | 23 | themeFontFamily :: CSSValue 24 | themeFontFamily = "'Roboto', sans-serif" 25 | 26 | 27 | 28 | ------------------------------------------------------------------------------- 29 | -- Headings 30 | 31 | h2Typeface :: Typeface 32 | h2Typeface = Typeface 33 | { tfName = "h2" 34 | , tfFontFamily = themeFontFamily 35 | , tfFontWeight = "400" 36 | , tfFontSize = "27.648px" 37 | , tfLineHeight = "1.2" 38 | } 39 | 40 | h3Typeface :: Typeface 41 | h3Typeface = Typeface 42 | { tfName = "h3" 43 | , tfFontFamily = themeFontFamily 44 | , tfFontWeight = "400" 45 | , tfFontSize = "23.04px" 46 | , tfLineHeight = "1.2" 47 | } 48 | 49 | h4Typeface :: Typeface 50 | h4Typeface = Typeface 51 | { tfName = "h4" 52 | , tfFontFamily = themeFontFamily 53 | , tfFontWeight = "400" 54 | , tfFontSize = "19.2px" 55 | , tfLineHeight = "1.2" 56 | } 57 | 58 | 59 | 60 | ------------------------------------------------------------------------------- 61 | -- Copy 62 | 63 | paragraphTypeface :: Typeface 64 | paragraphTypeface = Typeface 65 | { tfName = "paragraph" 66 | , tfFontFamily = themeFontFamily 67 | , tfFontWeight = "400" 68 | , tfFontSize = "16px" 69 | , tfLineHeight = "1.44" 70 | } 71 | 72 | blockquoteTypeface :: Typeface 73 | blockquoteTypeface = Typeface 74 | { tfName = "blockquote" 75 | , tfFontFamily = themeFontFamily 76 | , tfFontWeight = "400" 77 | , tfFontSize = "19.2px" 78 | , tfLineHeight = "1.44" 79 | } 80 | 81 | meta14Typeface :: Typeface 82 | meta14Typeface = Typeface 83 | { tfName = "paragraph" 84 | , tfFontFamily = themeFontFamily 85 | , tfFontWeight = "400" 86 | , tfFontSize = "14px" 87 | , tfLineHeight = "1.2" 88 | } 89 | 90 | 91 | 92 | ------------------------------------------------------------------------------- 93 | -- System 94 | 95 | systemFontFamily :: CSSValue 96 | systemFontFamily = "-apple-system, BlinkMacSystemFont, \"Segoe UI\", Roboto, Helvetica, Arial, sans-serif, \"Apple Color Emoji\", \"Segoe UI Emoji\", \"Segoe UI Symbol\"" 97 | 98 | 99 | system14Typeface :: Typeface 100 | system14Typeface = Typeface 101 | { tfName = "system14" 102 | , tfFontFamily = systemFontFamily 103 | , tfFontWeight = "400" 104 | , tfFontSize = "14px" 105 | , tfLineHeight = "1.44" 106 | } 107 | 108 | 109 | 110 | ------------------------------------------------------------------------------- 111 | -- Monospace 112 | 113 | monoFontFamily :: CSSValue 114 | monoFontFamily = "'SFMono-Regular', Consolas, 'Liberation Mono', Menlo, Courier, monospace" 115 | 116 | 117 | mono12Typeface :: Typeface 118 | mono12Typeface = Typeface 119 | { tfName = "mono12" 120 | , tfFontFamily = monoFontFamily 121 | , tfFontWeight = "400" 122 | , tfFontSize = "12px" 123 | , tfLineHeight = "1.44" 124 | } 125 | 126 | mono14Typeface :: Typeface 127 | mono14Typeface = Typeface 128 | { tfName = "mono14" 129 | , tfFontFamily = monoFontFamily 130 | , tfFontWeight = "400" 131 | , tfFontSize = "14px" 132 | , tfLineHeight = "1.44" 133 | } 134 | -------------------------------------------------------------------------------- /product/varna/shared/src/Nauva/Product/Varna/Shared.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Nauva.Product.Varna.Shared 6 | ( root 7 | 8 | , batteryCard 9 | ) where 10 | 11 | 12 | import qualified Data.Aeson as A 13 | 14 | import Nauva.View 15 | 16 | import Nauva.Service.Head 17 | 18 | import Nauva.Product.Varna.Element.Card 19 | 20 | import Prelude hiding (rem) 21 | 22 | 23 | 24 | root :: HeadH -> Element 25 | root = component_ rootComponent 26 | 27 | rootComponent :: Component HeadH () () () 28 | rootComponent = createComponent $ \cId -> Component 29 | { componentId = cId 30 | , componentDisplayName = "Root" 31 | , initialComponentState = \p -> pure ((), [], [updateHead p]) 32 | , componentEventListeners = \_ -> [] 33 | , componentHooks = emptyHooks 34 | , processLifecycleEvent = \_ _ s -> (s, []) 35 | , receiveProps = \_ s -> pure (s, [], []) 36 | , update = \_ p _ -> ((), [updateHead p]) 37 | , renderComponent = render 38 | , componentSnapshot = \_ -> A.Null 39 | , restoreComponent = \_ s -> Right (s, []) 40 | } 41 | where 42 | updateHead :: HeadH -> IO (Maybe ()) 43 | updateHead headH = do 44 | hReplace headH 45 | [ style_ [str_ "*,*::before,*::after{box-sizing:inherit}body{margin:0;box-sizing:border-box}"] 46 | , title_ [str_ "Varna"] 47 | ] 48 | pure Nothing 49 | 50 | render _ _ = div_ [style_ rootStyle] $ 51 | [ navbar 52 | , batteries 53 | [ batteryCard 54 | [ batteryCardBodyParagraph True [str_ "This looks like a fresh battery. Congratulations on your purchase."] 55 | , batteryCardBodyPrimaryButton "charge battery" 56 | , batteryCardBodySecondaryButton "discharge battery" 57 | ] 58 | , batteryCard [] 59 | , batteryCard [] 60 | , batteryCard [] 61 | , batteryCard [] 62 | , batteryCard [] 63 | , batteryCard [] 64 | , batteryCard [] 65 | , batteryCard [] 66 | , batteryCard [] 67 | , batteryCard [] 68 | ] 69 | ] 70 | where 71 | rootStyle :: Style 72 | rootStyle = mkStyle $ do 73 | height (vh 100) 74 | display flex 75 | flexDirection column 76 | fontFamily "museo-slab, serif" 77 | 78 | 79 | 80 | 81 | navbar :: Element 82 | navbar = div_ [style_ rootStyle] 83 | [ div_ [style_ navbarItemStyle] [ str_ "Home" ] 84 | , div_ [style_ navbarItemStyle] [ str_ "Create Battery" ] 85 | , null_ 86 | , div_ [style_ navbarItemStyle] [ str_ "Account" ] 87 | ] 88 | where 89 | rootStyle :: Style 90 | rootStyle = mkStyle $ do 91 | display flex 92 | flexDirection row 93 | height (rem 3) 94 | backgroundColor "rgb(126, 120, 3)" 95 | color "rgb(228, 228, 238)" 96 | fontSize (rem 1.8) 97 | lineHeight (rem 3) 98 | flexShrink "0" 99 | 100 | navbarItemStyle :: Style 101 | navbarItemStyle = mkStyle $ do 102 | padding (rem 0) (rem 0.5) 103 | cursor pointer 104 | 105 | onHover $ do 106 | backgroundColor "#999" 107 | 108 | 109 | batteries :: [Element] -> Element 110 | batteries = div_ [style_ rootStyle] 111 | where 112 | rootStyle = mkStyle $ do 113 | marginTop (rem 1) 114 | display flex 115 | flexDirection row 116 | flexWrap wrap 117 | -------------------------------------------------------------------------------- /product/nauva/shared/src/Nauva/Product/Nauva/Book/App.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE DeriveGeneric #-} 7 | 8 | module Nauva.Product.Nauva.Book.App 9 | ( bookApp 10 | , catalogPages 11 | ) where 12 | 13 | 14 | import Data.Text 15 | import Data.Monoid 16 | import qualified Data.Aeson as A 17 | 18 | import Nauva.App 19 | import Nauva.Catalog 20 | import Nauva.Catalog.TH 21 | 22 | 23 | 24 | data State = State 25 | { numberOfClicks :: Int 26 | } 27 | 28 | data Action 29 | = Clicked 30 | 31 | $( return [] ) 32 | 33 | instance Value Action where 34 | parseValue _ = pure Clicked 35 | 36 | 37 | initialState :: State 38 | initialState = State 39 | { numberOfClicks = 0 40 | } 41 | 42 | updateState :: Action -> State -> State 43 | updateState Clicked State{..} = State { numberOfClicks = numberOfClicks + 1 } 44 | 45 | 46 | renderCounter :: State -> Element 47 | renderCounter State{..} = div_ 48 | [ button_ [onClick_ onClickHandler] [str_ "Click Me!"] 49 | , span_ [str_ ("Clicked " <> pack (show numberOfClicks) <> " times" :: Text)] 50 | ] 51 | where 52 | onClickHandler :: FE MouseEvent Action 53 | onClickHandler = [njs| ev => { 54 | ev.stopPropagation() 55 | return $Clicked() 56 | }|] 57 | 58 | 59 | counterComponent :: Component () () State Action 60 | counterComponent = createComponent $ \componentId -> Component 61 | { componentId = componentId 62 | , componentDisplayName = "Counter" 63 | , initialComponentState = \_ -> pure (initialState, [], []) 64 | , componentEventListeners = const [] 65 | , componentHooks = emptyHooks 66 | , processLifecycleEvent = \() _ s -> (s, []) 67 | , receiveProps = \_ s -> pure (s, [], []) 68 | , update = \a _ s -> (updateState a s, []) 69 | , renderComponent = \_ -> renderCounter 70 | , componentSnapshot = \_ -> A.object [] 71 | , restoreComponent = \_ s -> Right (s, []) 72 | } 73 | 74 | 75 | bookApp :: App 76 | bookApp = App 77 | { rootElement = catalog . CatalogProps "Nauva" catalogPages 78 | } 79 | 80 | 81 | catalogPages :: [Page] 82 | catalogPages = 83 | [ PLeaf Leaf 84 | { leafHref = "/" 85 | , leafTitle = "Introduction" 86 | , leafElement = $(catalogPageFromFile 87 | "../../../../../../../../docs/book/introduction.md") 88 | } 89 | , PLeaf Leaf 90 | { leafHref = "/getting-started" 91 | , leafTitle = "Getting started" 92 | , leafElement = $(catalogPageFromFile 93 | "../../../../../../../../docs/book/getting-started.md") 94 | } 95 | , PLeaf Leaf 96 | { leafHref = "/markup" 97 | , leafTitle = "Markup" 98 | , leafElement = $(catalogPageFromFile 99 | "../../../../../../../../docs/book/markup.md") 100 | } 101 | , PLeaf Leaf 102 | { leafHref = "/styles" 103 | , leafTitle = "Styles" 104 | , leafElement = $(catalogPageFromFile 105 | "../../../../../../../../docs/book/styles.md") 106 | } 107 | , PLeaf Leaf 108 | { leafHref = "/thunks" 109 | , leafTitle = "Thunks" 110 | , leafElement = $(catalogPageFromFile 111 | "../../../../../../../../docs/book/thunks.md") 112 | } 113 | , PLeaf Leaf 114 | { leafHref = "/components" 115 | , leafTitle = "Components" 116 | , leafElement = $(catalogPageFromFile 117 | "../../../../../../../../docs/book/components.md") 118 | } 119 | ] 120 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/View/Terms.Generator.hs: -------------------------------------------------------------------------------- 1 | module Nauva.View.Terms.Generator (main) where 2 | 3 | import Data.List (sort, nub) 4 | import Data.Char (toUpper) 5 | 6 | 7 | sanitize :: String -> String 8 | sanitize str = removeDash str ++ "_" 9 | where 10 | removeDash ('-' : x : xs) = toUpper x : removeDash xs 11 | removeDash (x : xs) = x : removeDash xs 12 | removeDash [] = [] 13 | 14 | 15 | exportList :: [String] -> String 16 | exportList [] = error "exportList without functions." 17 | exportList (f:functions) = unlines $ 18 | [ "module Nauva.View.Terms" 19 | , " ( " ++ f 20 | ] ++ 21 | map (" , " ++) functions ++ 22 | [ " ) where"] 23 | 24 | 25 | makeVoidTerm :: String -> String 26 | makeVoidTerm tag = unlines 27 | [ function ++ " :: [Attribute] -> Element" 28 | , function ++ " = with (ENode \"" ++ tag ++ "\" [] [])" 29 | , "{-# INLINE " ++ function ++ " #-}" 30 | ] 31 | where 32 | function = sanitize tag 33 | 34 | makeTerm :: String -> String 35 | makeTerm tag = unlines 36 | [ function ++ " :: Term arg res => arg -> res" 37 | , function ++ " = term \"" ++ tag ++ "\"" 38 | , "{-# INLINE " ++ function ++ " #-}" 39 | ] 40 | where 41 | function = sanitize tag 42 | 43 | makeAttributeTerm :: String -> String 44 | makeAttributeTerm tag = unlines 45 | [ function ++ " :: Term arg res => arg -> res" 46 | , function ++ " = term \"" ++ tag ++ "\"" 47 | , "{-# INLINE " ++ function ++ " #-}" 48 | ] 49 | where 50 | function = sanitize tag 51 | 52 | 53 | -- For distinction between void and normal elements, please refer to 54 | -- https://www.w3.org/TR/html5/syntax.html#elements-0 55 | 56 | voidElements :: [String] 57 | voidElements = 58 | [ "area" 59 | , "base" 60 | , "br" 61 | , "col" 62 | , "embed" 63 | , "hr" 64 | , "img" 65 | , "input" 66 | , "keygen" 67 | , "link" 68 | , "meta" 69 | , "param" 70 | , "source" 71 | , "track" 72 | , "wbr" 73 | ] 74 | 75 | normalElements :: [String] 76 | normalElements = 77 | [ "a" 78 | , "blockquote" 79 | , "button" 80 | , "circle" 81 | , "code" 82 | , "div" 83 | , "em" 84 | , "h1" 85 | , "h2" 86 | , "h3" 87 | , "h4" 88 | , "h5" 89 | , "h6" 90 | , "i" 91 | , "li" 92 | , "p" 93 | , "path" 94 | , "pre" 95 | , "rect" 96 | , "section" 97 | , "span" 98 | , "strong" 99 | , "style" 100 | , "svg" 101 | , "title" 102 | , "ul" 103 | , "ol" 104 | , "value" 105 | ] 106 | 107 | attributes :: [String] 108 | attributes = 109 | [ "className" 110 | , "cx" 111 | , "cy" 112 | , "d" 113 | , "fill" 114 | , "height" 115 | , "href" 116 | , "r" 117 | , "ref" 118 | , "rel" 119 | , "src" 120 | , "stroke" 121 | , "strokeWidth" 122 | , "type" 123 | , "viewBox" 124 | , "width" 125 | , "x" 126 | , "y" 127 | ] 128 | 129 | terms :: [String] 130 | terms = nub $ sort $ voidElements ++ normalElements ++ attributes 131 | 132 | main :: IO () 133 | main = do 134 | putStr $ removeTrailingNewlines $ unlines 135 | [ "{-# LANGUAGE OverloadedStrings #-}" 136 | , "{-# LANGUAGE TypeFamilies #-}" 137 | , "" 138 | , exportList (map sanitize terms) 139 | , "" 140 | , "import Nauva.Internal.Types" 141 | , "import Nauva.View.Types" 142 | , "" 143 | , "" 144 | , unlines $ map makeVoidTerm (nub $ sort $ voidElements) 145 | , "" 146 | , unlines $ map makeTerm (nub $ sort $ normalElements) 147 | , "" 148 | , unlines $ map makeAttributeTerm (nub $ sort $ attributes) 149 | ] 150 | 151 | where 152 | removeTrailingNewlines = reverse . drop 2 . reverse 153 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/src/Wait.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | -- | Use 'withWaiterPoll' or 'withWaiterNotify' to create a 'Waiter' object, 4 | -- then access it (single-threaded) by using 'waitFiles'. 5 | module Wait(Waiter, withWaiterPoll, withWaiterNotify, waitFiles) where 6 | 7 | import Control.Concurrent.Extra 8 | import qualified Data.Map as Map 9 | import qualified Data.Set as Set 10 | import Control.Monad.Extra 11 | import Data.List.Extra 12 | import System.FilePath 13 | import Control.Exception.Extra 14 | import System.Directory.Extra 15 | import Data.Time.Clock 16 | import Data.String 17 | import Data.Maybe 18 | import System.Console.CmdArgs 19 | import System.Time.Extra 20 | import System.FSNotify 21 | import Language.Haskell.Ghcid.Util 22 | 23 | 24 | data Waiter = WaiterPoll 25 | | WaiterNotify WatchManager (MVar ()) (Var (Map.Map FilePath StopListening)) 26 | 27 | withWaiterPoll :: (Waiter -> IO a) -> IO a 28 | withWaiterPoll f = f WaiterPoll 29 | 30 | withWaiterNotify :: (Waiter -> IO a) -> IO a 31 | withWaiterNotify f = withManagerConf defaultConfig{confDebounce=NoDebounce} $ \manager -> do 32 | mvar <- newEmptyMVar 33 | var <- newVar Map.empty 34 | f $ WaiterNotify manager mvar var 35 | 36 | 37 | -- | Given the pattern: 38 | -- 39 | -- > wait <- waitFiles waiter 40 | -- > ... 41 | -- > wait ["File1.hs","File2.hs"] 42 | -- 43 | -- This continues as soon as either @File1.hs@ or @File2.hs@ changes, 44 | -- starting from when 'waitFiles' was initially called. 45 | -- 46 | -- Returns a message about why you are continuing (usually a file name). 47 | waitFiles :: Waiter -> IO ([FilePath] -> IO [String]) 48 | waitFiles waiter = do 49 | base <- getCurrentTime 50 | return $ \files -> handle (\(e :: IOError) -> do sleep 0.1; return [show e]) $ do 51 | whenLoud $ outStrLn $ "%WAITING: " ++ unwords files 52 | files <- fmap concat $ forM files $ \file -> 53 | ifM (doesDirectoryExist file) (listFilesInside (return . not . isPrefixOf "." . takeFileName) file) (return [file]) 54 | case waiter of 55 | WaiterPoll -> return () 56 | WaiterNotify manager kick mp -> do 57 | dirs <- fmap Set.fromList $ mapM canonicalizePathSafe $ nubOrd $ map takeDirectory files 58 | modifyVar_ mp $ \mp -> do 59 | let (keep,del) = Map.partitionWithKey (\k v -> k `Set.member` dirs) mp 60 | sequence_ $ Map.elems del 61 | new <- forM (Set.toList $ dirs `Set.difference` Map.keysSet keep) $ \dir -> do 62 | can <- watchDir manager (fromString dir) (const True) $ \event -> do 63 | whenLoud $ outStrLn $ "%NOTIFY: " ++ show event 64 | void $ tryPutMVar kick () 65 | return (dir, can) 66 | let mp2 = keep `Map.union` Map.fromList new 67 | whenLoud $ outStrLn $ "%WAITING: " ++ unwords (Map.keys mp2) 68 | return mp2 69 | void $ tryTakeMVar kick 70 | new <- mapM getModTime files 71 | case [x | (x,Just t) <- zip files new, t > base] of 72 | [] -> recheck files new 73 | xs -> return xs 74 | where 75 | recheck files old = do 76 | sleep 0.1 77 | case waiter of 78 | WaiterPoll -> return () 79 | WaiterNotify _ kick _ -> do 80 | takeMVar kick 81 | whenLoud $ outStrLn "%WAITING: Notify signaled" 82 | new <- mapM getModTime files 83 | case [x | (x,t1,t2) <- zip3 files old new, t1 /= t2] of 84 | [] -> recheck files new 85 | xs -> do 86 | when (or $ zipWith (\o n -> isJust o && isNothing n) old new) $ do 87 | -- if someone is deleting a needed file, give them some space to put the file back 88 | -- typically caused by VIM 89 | whenLoud $ outStrLn "%WAITING: Extra wait due to file removal" 90 | sleep 1 91 | return xs 92 | 93 | 94 | canonicalizePathSafe :: FilePath -> IO FilePath 95 | canonicalizePathSafe x = canonicalizePath x `catch_` const (return x) 96 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/NJS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE CPP #-} 3 | 4 | module Nauva.NJS 5 | ( FID(..), unFID 6 | 7 | , createF 8 | , F(..) 9 | 10 | , FE 11 | , FRA, FRD 12 | 13 | , Value(..) 14 | ) where 15 | 16 | 17 | import Data.Function 18 | import qualified Data.Aeson as A 19 | import qualified Data.Aeson.Types as A 20 | import Data.Text (Text) 21 | import qualified Data.Text as T 22 | import Data.ByteString.Lazy (toStrict) 23 | 24 | import Crypto.MAC.SipHash (SipHash(..), SipKey(..)) 25 | import qualified Crypto.MAC.SipHash as SH 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- 30 | -- | 'NJS' is a JavaScript function which is run in the browser. The function 31 | -- can take a number of arguments (depending on in which context it runs), and 32 | -- may construct values which are piped back into the Haskell code. 33 | -- 34 | -- 'NJS' functions are untyped, meaning that Haskell allows you to construct 35 | -- arbitrary functions which won't typecheck. For that reason you shouldn't 36 | -- deal with 'NJS' directly and instaed use the supplied smart consturctors for 37 | -- the newtype wrappers which are defined further below. 38 | 39 | data F = F 40 | { fId :: !FID 41 | , fConstructors :: ![Text] 42 | -- ^ Action constructors which are used by the function body. 43 | , fArguments :: ![Text] 44 | -- ^ Arguments which the function body requires. 45 | , fBody :: !Text 46 | -- ^ JavaScript code of the function body. This string is passed to 47 | -- @new Function(…)@. 48 | } 49 | 50 | instance Eq F where 51 | (==) = (==) `on` fId 52 | 53 | instance A.ToJSON F where 54 | toJSON f = A.object 55 | [ "id" A..= fId f 56 | , "constructors" A..= fConstructors f 57 | , "arguments" A..= fArguments f 58 | , "body" A..= fBody f 59 | ] 60 | 61 | createF :: [Text] -> [Text] -> Text -> F 62 | createF constructors arguments body = F 63 | { fId = hash $ A.toJSON [A.toJSON constructors, A.toJSON arguments, A.toJSON body] 64 | , fConstructors = constructors 65 | , fArguments = arguments 66 | , fBody = body 67 | } 68 | where 69 | hash = FID . T.pack . show . unSipHash . SH.hash sipKey . toStrict . A.encode 70 | sipKey = SipKey 0 1 71 | unSipHash (SipHash x) = x 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- 76 | -- | FID - Function ID 77 | -- 78 | -- The 'FID' is used to uniquely identify NJS function expressions. The 79 | -- constructor is private, only a smart constructor ('mkFID') is exported. 80 | -- 'mkFID' ensures that the 'FID' is globally unique. 81 | 82 | newtype FID = FID Text 83 | deriving (Eq) 84 | 85 | instance A.ToJSON FID where 86 | toJSON = A.toJSON . unFID 87 | 88 | -- Q: Why is this exported? A: So we can implement the ToJSVal instance. 89 | unFID :: FID -> Text 90 | unFID (FID x) = x 91 | 92 | 93 | 94 | 95 | -- | Type synonym for a function which implements an event handler. 96 | type FE ev a = F 97 | 98 | 99 | -- | A function which is called whenever a ref is attached to a component. 100 | type FRA el a = F 101 | 102 | -- | Function (when) Ref (is) Detach(ed). You don't get the element which was 103 | -- detached. This means you can't really add the same ref handler to multiple 104 | -- components. 105 | type FRD a = F 106 | 107 | 108 | 109 | -------------------------------------------------------------------------------- 110 | 111 | class Value a where 112 | parseValue :: A.Value -> A.Parser a 113 | 114 | instance Value () where 115 | parseValue _ = pure () -- A.parseJSON 116 | 117 | instance Value Int where 118 | parseValue = A.parseJSON 119 | 120 | instance Value Float where 121 | parseValue = A.parseJSON 122 | 123 | instance Value Text where 124 | parseValue = A.parseJSON 125 | 126 | instance (Value a, Value b) => Value (a,b) where 127 | parseValue v = do 128 | list <- A.parseJSON v 129 | case list of 130 | [a,b] -> (,) <$> parseValue a <*> parseValue b 131 | _ -> fail "(,)" 132 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/Static.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | {-| 5 | This module contains function to convert 'Element's or 'Instance's into static 6 | markup (blaze-markup / blaze-html). Useful when you want to render your 7 | application on the server to generate static web pages. 8 | 9 | The functions generate 'Text.Blaze.Html' markup. You can convert that further 10 | into 'String', 'Text', 'ByteString' etc by using functions from the 11 | blaze-html 'Text.Blaze.Html.Renderer' modules. 12 | -} 13 | 14 | module Nauva.Static 15 | ( elementToMarkup 16 | , instanceToMarkup 17 | ) where 18 | 19 | 20 | import Data.Monoid 21 | import Data.Maybe 22 | import qualified Data.Text as T 23 | import Data.String 24 | import Data.List (intersperse) 25 | 26 | import Control.Monad 27 | 28 | import qualified Text.Blaze.Html as B 29 | import qualified Text.Blaze.Internal as B 30 | 31 | import Control.Concurrent.STM 32 | 33 | import Nauva.Internal.Types 34 | import Nauva.CSS 35 | import Nauva.CSS.Renderer 36 | import Nauva.DOM 37 | 38 | import Prelude 39 | 40 | 41 | -- | Convert an 'Element' into blaze-html markup ('B.Html') and a list of all 42 | -- 'Style' objects which are used by the tree. If the 'Element' tree contains 43 | -- 'Component's, they will be rendered in their initial state. 44 | -- 45 | -- Note that the function was cobbled together without a thorough understanding 46 | -- of the 'blaze-markup' and 'blaze-html' types. Furthermore, I know for a fact 47 | -- that the way how Nauva 'Attribute's are converted into blaze-markup 48 | -- Attributes is not accurate: 'Nauva' models them after IDL attributes, while 49 | -- 'blaze-html' uses content attributes. 50 | 51 | elementToMarkup :: Element -> STM (B.Html, [Style], [IO ()]) 52 | elementToMarkup el = case el of 53 | ENull -> 54 | pure (mempty, mempty, []) 55 | 56 | (EText text) -> 57 | pure (B.toMarkup text, mempty, []) 58 | 59 | (ENode tag attributes children) -> do 60 | let tagString = T.unpack $ unTag tag 61 | parent = B.Parent (fromString tagString) (fromString $ "<" <> tagString) (fromString $ "</" <> tagString <> ">") 62 | styles = mapMaybe toStyle attributes 63 | where 64 | toStyle (ASTY x) = Just x 65 | toStyle _ = Nothing 66 | 67 | cssRuleClass' :: CSSRule -> Maybe T.Text 68 | cssRuleClass' (CSSStyleRule name hash _ _ _) = Just $ cssRuleClass name hash 69 | cssRuleClass' (CSSFontFaceRule _ _) = Nothing 70 | 71 | classes = catMaybes $ map cssRuleClass' $ mconcat $ map unStyle styles 72 | attrs = mapMaybe toAttribute attributes 73 | toAttribute (AEVL _) = Nothing 74 | toAttribute (ASTY _) = Nothing 75 | toAttribute (AREF _) = Nothing 76 | toAttribute (AVAL n v) = Just $ B.attribute (B.textTag n) (B.textTag $ " " <> n <> "=\"") $ case v of 77 | AVBool b -> B.textValue $ if b then "true" else "false" 78 | AVString t -> B.textValue t 79 | AVInt i -> B.stringValue $ show i 80 | AVDouble d -> B.stringValue $ show d 81 | parentWithAttributes = foldl (B.!) parent attrs 82 | 83 | (children', childrenStyles, childrenActions) :: (B.Html, [Style], [IO ()]) <- mconcat <$> mapM elementToMarkup children 84 | let html = if null classes 85 | then parentWithAttributes children' 86 | else parentWithAttributes children' B.! B.attribute (B.textTag "class") (B.textTag " class=\"") (B.textValue (mconcat (intersperse " " classes))) 87 | pure (html, styles <> childrenStyles, childrenActions) 88 | 89 | (EThunk thunk p) -> 90 | elementToMarkup $ forceThunk thunk p 91 | 92 | (EComponent component p) -> do 93 | (s, _, actions) <- initialComponentState component p 94 | (html, styles, innerActions) <- elementToMarkup $ renderComponent component p s 95 | pure (html, styles, map void actions <> innerActions) 96 | 97 | 98 | 99 | -- | Not implemented yet! 100 | instanceToMarkup :: Instance -> STM B.Html 101 | instanceToMarkup _inst = error "instanceToMarkup: Not implemented yet!" 102 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/README.md: -------------------------------------------------------------------------------- 1 | # ghcid [![Hackage version](https://img.shields.io/hackage/v/ghcid.svg?label=Hackage)](https://hackage.haskell.org/package/ghcid) [![Stackage version](https://www.stackage.org/package/ghcid/badge/lts?label=Stackage)](https://www.stackage.org/package/ghcid) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/ghcid.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/ghcid) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/ghcid.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/ghcid) 2 | 3 | Either "GHCi as a daemon" or "GHC + a bit of an IDE". To a first approximation, it opens `ghci` and runs `:reload` whenever your source code changes, formatting the output to fit a fixed height console. Unlike other Haskell development tools, `ghcid` is intended to be _incredibly simple_. In particular, it doesn't integrate with any editors, doesn't depend on GHC the library and doesn't start web servers. 4 | 5 | _Acknowledgements:_ This project incorporates significant work from [JPMoresmau](https://github.com/JPMoresmau), who is listed as a co-author. 6 | 7 | ### Using it 8 | 9 | Run `cabal update && cabal install ghcid` to install it as normal. Then run `ghcid --height=8 --topmost "--command=ghci Main.hs"`. The `height` is the number of lines you are going to resize your console window to (defaults to height of the console). The `topmost` is to make the window sit above all others, which only works on Windows. The `command` is how you start your project in `ghci`. If you omit `--command` then it will default to `stack ghci` if you have the `stack.yaml` file and `.stack-work` directory, default to `ghci` if you have a `.ghci` file in the current directory, and otherwise default to `cabal repl`. 10 | 11 | Personally, I always create a `.ghci` file at the root of all my projects, which usually [reads something like](https://github.com/ndmitchell/ghcid/blob/master/.ghci): 12 | 13 | :set -fwarn-unused-binds -fwarn-unused-imports 14 | :set -isrc 15 | :load Main 16 | 17 | After that, resize your console and make it so you can see it while working in your editor. On Windows the console will automatically sit on top of all other windows. On Linux, you probably want to use your window manager to make it topmost or use a [tiling window manager](http://xmonad.org/). 18 | 19 | ### What you get 20 | 21 | On every save you'll see a list of the errors and warnings in your project. It uses `ghci` under the hood, so even relatively large projects should update their status pretty quickly. As an example: 22 | 23 | Main.hs:23:10: 24 | Not in scope: `verbosit' 25 | Perhaps you meant `verbosity' (imported from System.Console.CmdArgs) 26 | Util.hs:18:1: Warning: Defined but not used: `foo' 27 | 28 | Or, if everything is good, you see: 29 | 30 | All good 31 | 32 | Please [report any bugs](https://github.com/ndmitchell/ghcid/issues) you find. 33 | 34 | ### Ghcid Integration 35 | 36 | There are a few tools that integrate Ghcid into editors, see the [plugins](plugins/) folder for currently supported integrations. 37 | 38 | ### FAQ 39 | 40 | * _This isn't as good as full IDE._ I've gone for simplicity over features. It's a point in the design space, but not necessarily the best point in the design space for you. For "real" IDEs see [the Haskell wiki](http://www.haskell.org/haskellwiki/IDEs). 41 | * _If I delete a file and put it back it gets stuck._ Yes, that's a [bug in GHCi](https://ghc.haskell.org/trac/ghc/ticket/9648). If you see GHCi getting confused just kill `ghcid` and start it again. 42 | * _I want to run my tests when files change._ You can pass any `ghci` expression with the `--test` flag, e.g. `--test=:main`, which will be run whenever the code is warning free (or pass `--warnings` for when the code is merely error free). 43 | * _I want to run arbitrary commands when arbitrary files change._ This project reloads `ghci` when files loaded by `ghci` change. If you want a more general mechanism something like [Steel Overseer](https://github.com/schell/steeloverseer) will probably work better. 44 | * _I want syntax highlighting in the error messages._ One option is to use Neovim or Emacs and run the terminal in a buffer whose file type is set to Haskell. 45 | * _I'm not seeing pattern matching warnings._ Ghcid automatically appends `-fno-code` to the command line, which makes the reload cycle about twice as fast. Unfortunately GHC 8.0 suffers from [bug 10600](https://ghc.haskell.org/trac/ghc/ticket/10600) which means `-fno-code` also disables pattern matching warnings. Until that GHC bug is fixed either accept no pattern match warnings or use `-c` to specify a command line to start `ghci` that doesn't include `-fno-code`. 46 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/src/Nauva/Catalog/Specimens/ColorGroupSpecimen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | 8 | module Nauva.Catalog.Specimens.ColorGroupSpecimen 9 | ( ColorGroup(..) 10 | , colorGroup 11 | 12 | , ColorCell(..) 13 | , ColorCellValue(..) 14 | ) where 15 | 16 | 17 | import Data.Text (Text) 18 | import qualified Data.Text as T 19 | import Data.Monoid 20 | import Data.Color 21 | import Data.Word 22 | 23 | import Control.Lens hiding (none) 24 | 25 | import Nauva.View 26 | import Nauva.Catalog.Elements 27 | 28 | 29 | 30 | data ColorCellValue = ColorCellValue 31 | { csvName :: !Text 32 | , csvColor :: !Color 33 | } 34 | 35 | data ColorCell = ColorCell 36 | { ccLabel :: !Text 37 | -- ^ The label of the cell. Shown inside the reference color box. 38 | -- Can be empty. 39 | , ccLuminance :: !Double -- 0..100 40 | -- ^ The luminance of the reference box on the left side of the color cell. 41 | , ccValue :: !(Maybe ColorCellValue) 42 | } 43 | 44 | -- instance A.FromJSON ColorCell where 45 | -- parseJSON v@(A.Object o) = do 46 | -- luminance <- o A..: "luminance" 47 | -- label <- o A..: "label" <|> (pure $ T.pack $ show luminance) 48 | -- value <- o A..: "value" 49 | 50 | -- pure $ ColorCell label luminance value 51 | 52 | data ColorGroup = ColorGroup 53 | { cgLabel :: !Text 54 | , cgCells :: ![ColorCell] 55 | } 56 | 57 | -- instance A.FromJSON ColorGroup where 58 | -- parseJSON v@(A.Object o) = ColorGroup 59 | -- <$> o A..: "label" 60 | -- <*> o A..: "cells" 61 | 62 | 63 | luminanceToRGB :: Double -> (Word8, Word8, Word8) 64 | luminanceToRGB l = CIELAB l 0 0 ^.re (toCIELAB d65) ^. toSRGB ^. cvSRGB8 ^. to unColorV 65 | 66 | colorCSSValue :: Getter Color CSSValue 67 | colorCSSValue = to (\c -> CSSValue $ T.pack $ "rgb" <> show (c ^. toSRGB ^. cvSRGB8 ^. to unColorV)) 68 | 69 | 70 | colorGroup :: ColorGroup -> Element 71 | colorGroup ColorGroup{..} = pageElement 72 | PageElementProps{ pepTitle = Just (T.unpack cgLabel), pepSpan = 1 } 73 | [div_ [style_ rootStyle] (map colorCell cgCells)] 74 | where 75 | rootStyle = mkStyle $ do 76 | display flex 77 | flexDirection column 78 | fontFamily "Roboto" 79 | 80 | 81 | colorCell :: ColorCell -> Element 82 | colorCell cc@ColorCell{..} = div_ [style_ rootStyle] 83 | [ div_ [style_ refStyle] [str_ ccLabel] 84 | , maybe null_ (colorCellValue cc) ccValue 85 | ] 86 | where 87 | rootStyle = mkStyle $ do 88 | position relative 89 | display flex 90 | height (px 56) 91 | marginBottom "2px" 92 | alignItems center 93 | color $ if ccLuminance > 50 then "rgba(0,0,0,.9)" else "rgba(255,255,255,.9)" 94 | 95 | refStyle = mkStyle $ do 96 | width (px 48) 97 | flexShrink "0" 98 | height "56px" 99 | display flex 100 | alignItems center 101 | justifyContent center 102 | position relative 103 | 104 | let mapTuple f (a, b, c) = (f a, f b, f c) 105 | -- let v = T.pack (show (floor $ ((100 - ccLuminance) / 100) * 255.0)) 106 | let (r,g,b) = mapTuple (T.pack . show) (luminanceToRGB ccLuminance) 107 | 108 | color $ if ccLuminance > 50 then "rgba(0,0,0,.9)" else "rgba(255,255,255,.9)" 109 | backgroundColor $ CSSValue $ "rgb(" <> r <> "," <> g <> "," <> b <> ")" 110 | 111 | 112 | colorCellValue :: ColorCell -> ColorCellValue -> Element 113 | colorCellValue ColorCell{..} ColorCellValue{..} = div_ [style_ colorCellValueStyle] 114 | [ div_ [style_ colorNameStyle] [str_ csvName] 115 | , div_ [style_ colorValueStyle] [str_ (unCSSValue (csvColor ^. colorCSSValue))] 116 | , luminanceDistance ccLuminance l 117 | ] 118 | where 119 | colorCellValueStyle = mkStyle $ do 120 | flex "1" 121 | display flex 122 | justifyContent center 123 | flexDirection column 124 | height "56px" 125 | padding "0" (px 8) 126 | backgroundColor (csvColor ^. colorCSSValue) 127 | color $ if l > 50 then "rgba(0,0,0,.9)" else "rgba(255,255,255,.9)" 128 | 129 | colorNameStyle = mkStyle $ do 130 | marginBottom "4px" 131 | 132 | colorValueStyle = mkStyle $ do 133 | fontSize "0.8125em" 134 | color $ if l > 50 then "rgba(0,0,0,.6)" else "rgba(255,255,255,.6)" 135 | 136 | luminanceDistance b a = case round (a - b) of 137 | 0 -> ENull 138 | d -> div_ [style_ luminanceDistanceStyle] [str_ $ "L" <> (if d > 0 then "+" else "") <> T.pack (show d)] 139 | 140 | luminanceDistanceStyle = mkStyle $ do 141 | position absolute 142 | bottom "2px" 143 | right "3px" 144 | fontSize "11px" 145 | lineHeight "11px" 146 | 147 | l = csvColor ^. toCIELAB d65 ^. cvCIELAB ^. to unColorV ^. _1 148 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![license](https://img.shields.io/github/license/wereHamster/nauva.svg?style=flat-square)]() [![GitHub issues](https://img.shields.io/github/issues/wereHamster/nauva.svg?style=flat-square&label=GitHub+–+Issues)]() [![Code Climate](https://img.shields.io/codeclimate/issues/github/wereHamster/nauva.svg?style=flat-square&label=Code+Climate+–+Issues)]() 2 | 3 | # Nauva 4 | 5 | > **Etymology:** nauva, from Quenya, "it will". 6 | 7 | The `Nauva` Haskell library is an attempt to provide a solid foundation for 8 | building UI applications which use the W3C DOM as the underlying presentation 9 | technology. 10 | 11 | Nauva borrows many concepts from [React][react] - such as the virtual DOM, 12 | stateful components, unidirectional data binding - and implements them in Haskell. 13 | 14 | Applications written in Nauva are portable between server and client. The same 15 | code can be compiled and run on the server, but can also compiled by [GHCJS] 16 | and shipped to a web browser where it runs as a JavaScript application. 17 | 18 | 19 | ## TLDR 20 | 21 | For best experience use macOS. Better support for other platforms (Linux, Windows) 22 | will follow later. 23 | 24 | First install [stack], then: 25 | 26 | git clone https://github.com/wereHamster/nauva.git 27 | cd nauva 28 | ./bin/nauva start template/app 29 | 30 | A browser should automatically open. If not then open [http://localhost:8000](http://localhost:8000) 31 | manually. Note: if port 8000 is already occupied the server will pick the next 32 | free port. See in the output which port the server has picked. 33 | 34 | Now edit the template app source file (product/template/app/dev/src/Main.hs), 35 | save and observe how the UI instantly reloads to reflect your changes. 36 | 37 | 38 | ## Documentation 39 | 40 | Haddock documentation of the core packages is available [here][nvdocs]. 41 | It is automatically built from the current source (`master` branch). 42 | 43 | A book for end-users is available at https://book.nauva.xyz. Its source 44 | is inside this repository (under product/nauva/book). 45 | 46 | 47 | ## Focus and Goals 48 | 49 | - Implement as much as possible in Haskell, only use JavaScript where 50 | necessary for performance or convenience. 51 | - Provide a good developer experience. That includes server-side 52 | rendering and near-instant reload times during development (to 53 | match expectations of people coming from the webpack ecosystem). 54 | - Good performance. At the very least should be fast enough to render 55 | interactive SVG visualizations. 56 | 57 | 58 | ## Structure of the repository 59 | 60 | This repository contains multiple packages and projects (ie. a monorepo) which 61 | are all related to Nauva. 62 | 63 | - **bin/** 64 | - **pkg/** 65 | - **hs/** - Main packages which are written in Haskell 66 | - **nauva/** - The core Nauva package 67 | - **nauva-css/** - CSS DSL 68 | - **nauva-catalog/** - Catalog (interactive development and documentation environment) 69 | - **nauva-dev-server/** - A shell to run an application in develompent mode 70 | (server-side rendering, instant reload etc.). 71 | - **navua-native/** - JavaScript bindings to run an application in the browser. 72 | - **nauvad/** - Heavily modified [ghcid] with integrated HTTP / WebSocket server. 73 | - **product/** 74 | - **template/** - A mostly empty application template you can use as a starting point for your own application. 75 | - **playground/** - Really ugly application which I use to test new features, performance etc. 76 | - **varna/** - Port of one of my personal applications, a somewhat more realistic example of a real-world application. 77 | - **nauva/** - For now just the catalog for some of the UI components used by nauva itself. 78 | 79 | 80 | ### Products 81 | 82 | A product is a collection of one or more applications which share some common code 83 | (business logic, theme, colors, typefaces, UI components etc). Each application is 84 | in its own subfolder and is split into yet more folders. Each of these folders has 85 | one specific purpose, contains one Cabal file which defines a single executable. 86 | 87 | In the following example we have a product which consists of an application (**app**) 88 | and a website (**website**) which share common code. Furthermore, both **app** and 89 | **website** have a **dev** variant which is what you can run with **bin/nauva start** 90 | (to work on the code locally). The **app** can be compiled into **native** 91 | (JavaScript) code, while the **website** can produce a **static** version which 92 | you can upload to your HTTP server. 93 | 94 | - **shared/** - Any code which is independent of the platform where the application will run. 95 | Must be free of GHCJS-specific code, and not use libraries which can not be compiled with 96 | GHCJS. Nor must it use libraries which can not run in a JavaScript environment. 97 | - **app/** 98 | - **dev/** - Project which runs the app using **nauvad** / **nauva-dev-server**. 99 | - **native/** - Project which compiles the app into a native JavaScript file. 100 | - **website/** 101 | - **dev/** - Project which runs the website using **nauvad** / **nauva-dev-server**. 102 | - **static/** - Project which compiles the website into static output (HTML + CSS files). 103 | 104 | 105 | [react]: https://facebook.github.io/react 106 | [GHCJS]: https://github.com/ghcjs/ghcjs 107 | [stack]: https://github.com/commercialhaskell/stack 108 | [ghcid]: https://github.com/ndmitchell/ghcid 109 | [nvdocs]: https://storage.googleapis.com/nvdocs/latest/index.html 110 | -------------------------------------------------------------------------------- /pkg/hs/nauva/src/Nauva/NJS/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Nauva.NJS.TH 5 | ( njs 6 | ) where 7 | 8 | 9 | import Data.Text (Text) 10 | import qualified Data.Text as T 11 | import Data.Monoid 12 | import qualified Data.Attoparsec.Text as AP 13 | import Data.Char 14 | 15 | import Control.Applicative 16 | import Control.Monad.Writer.Lazy 17 | 18 | import Language.Haskell.TH 19 | import Language.Haskell.TH.Quote 20 | 21 | import Nauva.Internal.Types 22 | import Nauva.NJS 23 | 24 | 25 | 26 | njs :: QuasiQuoter 27 | njs = QuasiQuoter 28 | { quoteExp = njsQ . T.pack 29 | , quotePat = error "njs: quotePat" 30 | , quoteType = error "njs: quoteType" 31 | , quoteDec = error "njs: quoteDec" 32 | } 33 | 34 | 35 | njsQ :: Text -> Q Exp 36 | njsQ t = do 37 | let templ = template t 38 | (body, w) <- runWriterT $ render templ 39 | 40 | pure $ foldl1 AppE 41 | [ VarE 'createF 42 | , ListE $ map (LitE . StringL . T.unpack) w 43 | , ListE $ map (\(x, _) -> LitE $ StringL $ T.unpack x) $ templateArguments templ 44 | , body 45 | ] 46 | 47 | 48 | 49 | data Fragment 50 | = StringF !Text 51 | | RefF !Text 52 | | ConsF !Text 53 | deriving (Show, Eq) 54 | 55 | data Template = Template 56 | { templateArguments :: [(Text, Maybe Text)] 57 | , templateBody :: [Fragment] 58 | } 59 | 60 | 61 | template :: Text -> Template 62 | template input = case AP.parseOnly expParser input of 63 | Left x -> error $ x ++ " on input '" ++ T.unpack input ++ "'" 64 | Right x -> x 65 | 66 | mergeStrings :: [Fragment] -> [Fragment] 67 | mergeStrings = reverse . foldl f [] 68 | where 69 | f acc (StringF "") = acc 70 | f ((StringF a):xs) (StringF b) = (StringF $ a <> b) : xs 71 | f acc frag = frag:acc 72 | 73 | expParser :: AP.Parser Template 74 | expParser = do 75 | AP.skipSpace 76 | arguments <- argumentsParser 77 | AP.skipSpace 78 | fragments <- fragmentParser 79 | 80 | pure $ Template 81 | { templateArguments = arguments 82 | , templateBody = fragments 83 | } 84 | 85 | argumentsParser :: AP.Parser [(Text, Maybe Text)] 86 | argumentsParser = (multipleArguments <|> singleArgument) <* AP.skipSpace <* AP.string "=>" <* AP.skipSpace 87 | where 88 | arg = do 89 | AP.skipSpace 90 | n <- AP.takeWhile1 isAlpha 91 | AP.skipSpace 92 | ch <- AP.peekChar' 93 | case ch of 94 | ':' -> do 95 | t <- AP.char ':' *> AP.skipSpace *> AP.takeWhile1 isAlpha <* AP.skipSpace 96 | pure (n, Just t) 97 | 98 | _ -> do 99 | pure (n, Nothing) 100 | 101 | multipleArguments = 102 | AP.string "(" *> (arg `AP.sepBy` (AP.char ',')) <* AP.string ")" 103 | 104 | singleArgument = do 105 | text <- AP.takeWhile1 isAlpha 106 | pure [(text, Nothing)] 107 | 108 | fragmentParser :: AP.Parser [Fragment] 109 | fragmentParser = normalBody <|> arrowBody 110 | where 111 | normalBody = do 112 | fragments <- AP.string "{" *> (mergeStrings <$> go) 113 | 114 | -- Delete the closing '}' from the last fragment (if it's a string) 115 | let len = length fragments 116 | if len == 0 117 | then pure fragments 118 | else case drop (len - 1) fragments of 119 | [StringF x] -> pure $ take (len - 1) fragments <> [StringF (T.dropEnd 1 $ T.strip x)] 120 | _ -> pure fragments 121 | 122 | 123 | -- Prepend "return " so that we get a valid JS function body. 124 | arrowBody = do 125 | fragments <- go 126 | pure $ mergeStrings $ [StringF "return "] <> fragments 127 | 128 | go = ref <|> cons <|> string <|> (pure [] <* AP.endOfInput) 129 | 130 | ref = do 131 | text <- AP.string "@" *> AP.takeWhile1 isAlpha 132 | (RefF text :) <$> go 133 | 134 | cons = do 135 | text <- AP.string "$" *> AP.takeWhile1 isAlpha 136 | (ConsF text :) <$> go 137 | 138 | string = do 139 | text <- T.singleton <$> AP.anyChar 140 | (StringF text :) <$> go 141 | 142 | render :: Template -> WriterT [Text] Q Exp 143 | render (Template _ frags) = do 144 | exprs <- traverse renderFragment frags 145 | pure $ AppE (VarE 'T.pack) $ foldl1 (\a b -> UInfixE a (VarE '(<>)) b) exprs 146 | where 147 | renderFragment :: Fragment -> WriterT [Text] Q Exp 148 | renderFragment (StringF s) = 149 | pure $ LitE $ StringL $ T.unpack s 150 | 151 | renderFragment (RefF s) = do 152 | name <- lift $ do 153 | n <- lookupValueName (T.unpack s) 154 | case n of 155 | Nothing -> fail $ "renderFragment: ref not found: " <> T.unpack s 156 | Just x -> pure x 157 | 158 | pure $ foldl1 (\a b -> UInfixE a (VarE '(<>)) b) 159 | [ LitE $ StringL "nv$ref(" 160 | , AppE (VarE 'show) $ AppE (VarE 'unRefKey) (VarE name) 161 | , LitE $ StringL ")" 162 | ] 163 | 164 | renderFragment (ConsF s) = do 165 | name <- lift $ do 166 | n <-lookupValueName (T.unpack s) 167 | case n of 168 | Nothing -> fail $ "renderFragment: constructor not found: " <> T.unpack s 169 | Just x -> pure x 170 | 171 | info <- lift $ reify name 172 | case info of 173 | DataConI _ _ _ -> pure () 174 | _ -> fail "renderFragment: not a data constructor" 175 | 176 | tell [s] 177 | 178 | pure $ LitE $ StringL $ T.unpack $ "nv$" <> s 179 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/src/Nauva/Catalog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DuplicateRecordFields #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE NamedFieldPuns #-} 5 | 6 | module Nauva.Catalog 7 | ( CatalogProps(..) 8 | , catalog 9 | 10 | , module Nauva.App 11 | , module Nauva.View 12 | , module Nauva.Catalog.Types 13 | ) where 14 | 15 | 16 | import Data.Text (Text) 17 | import qualified Data.Aeson as A 18 | import Data.Maybe 19 | 20 | import Control.Concurrent.STM 21 | 22 | import Nauva.App 23 | import Nauva.Internal.Types (Signal(..), Element, Component(..), createComponent, emptyHooks) 24 | import Nauva.View 25 | 26 | import Nauva.Catalog.Shell 27 | import Nauva.Catalog.Types 28 | 29 | 30 | 31 | ------------------------------------------------------------------------------- 32 | -- The 'catalog' element is meant to be used as the root element of the 33 | -- application. It renders the sidebar (navigation) and page content depending 34 | -- on the current location. 35 | 36 | data CatalogProps = CatalogProps 37 | { p_title :: !Text 38 | , p_pages :: ![Page] 39 | , p_appH :: !AppH 40 | } 41 | 42 | catalog :: CatalogProps -> Element 43 | catalog = component_ catalogComponent 44 | 45 | 46 | 47 | ------------------------------------------------------------------------------- 48 | 49 | data State = State 50 | { path :: !Text 51 | } 52 | 53 | catalogComponent :: Component CatalogProps () State () 54 | catalogComponent = createComponent $ \componentId -> Component 55 | { componentId = componentId 56 | , componentDisplayName = "Catalog" 57 | 58 | , initialComponentState = \props@CatalogProps{..} -> do 59 | loc <- readTVar $ fst $ hLocation $ routerH $ p_appH 60 | pure 61 | ( State (locPathname loc) 62 | , [ Signal (snd $ hLocation $ routerH $ p_appH) (\(Location p) props' s -> (s { path = p }, [updateHead props' p])) ] 63 | , [ updateHead props (locPathname loc) ] 64 | ) 65 | 66 | , componentEventListeners = const [] 67 | , componentHooks = emptyHooks 68 | , processLifecycleEvent = \() _ s -> (s, []) 69 | , receiveProps = \CatalogProps{..} s -> pure (s, [Signal (snd $ hLocation $ routerH $ p_appH) (\(Location p) props' s' -> (s' { path = p }, [updateHead props' p]))], []) 70 | , update = update 71 | , renderComponent = render 72 | , componentSnapshot = \_ -> A.object [] 73 | , restoreComponent = \_ s -> Right (s, []) 74 | } 75 | where 76 | updateHead :: CatalogProps -> Text -> IO (Maybe ()) 77 | updateHead CatalogProps{..} path = do 78 | hReplace (headH p_appH) 79 | [ style_ [str_ "*,*::before,*::after{box-sizing:inherit}body{margin:0;box-sizing:border-box}"] 80 | , title_ [str_ $ title p_pages path] 81 | 82 | , link_ [rel_ ("stylesheet" :: Text), type_ ("text/css" :: Text), href_ ("https://fonts.googleapis.com/css?family=Roboto:400,700,400italic" :: Text)] 83 | , link_ [rel_ ("stylesheet" :: Text), type_ ("text/css" :: Text), href_ ("https://fonts.googleapis.com/css?family=Source+Code+Pro:400,700" :: Text)] 84 | , link_ [rel_ ("stylesheet" :: Text), type_ ("text/css" :: Text), href_ ("https://fonts.googleapis.com/css?family=Open+Sans:300,300i,400,400i,600,600i,700" :: Text)] 85 | ] 86 | pure Nothing 87 | 88 | update () props s = 89 | ( s 90 | , [ updateHead props (path s) ] 91 | ) 92 | 93 | title :: [Page] -> Text -> Text 94 | title pages p = case lookup p (flattenedPages pages) of 95 | Nothing -> "Unknown Page" 96 | Just leaf -> leafTitle leaf 97 | 98 | flattenPage :: Page -> [(Text, Leaf)] 99 | flattenPage (PLeaf leaf@(Leaf {..})) = [(leafHref, leaf)] 100 | flattenPage (PDirectory (Directory {..})) = map (\x -> (leafHref x, x)) directoryChildren 101 | 102 | flattenedPages pages = concat $ map flattenPage pages 103 | 104 | render CatalogProps{..} State{..} = div_ [style_ rootStyle] 105 | [ div_ [style_ mainStyle] 106 | [ header (HeaderProps { section, title = title p_pages path }) 107 | , div_ [style_ pageStyle] [page] 108 | ] 109 | 110 | , sidebar $ SidebarProps 111 | { p_routerH = routerH p_appH 112 | , p_logoUrl 113 | , p_pages = p_pages 114 | } 115 | ] 116 | where 117 | p_logoUrl = "/" 118 | 119 | page = case lookup path (flattenedPages $ p_pages) of 120 | Nothing -> div_ [style_ pageInnerStyle] [str_ "page not found"] 121 | Just leaf -> leafElement leaf 122 | 123 | section :: Text 124 | section = findSection Nothing $ p_pages 125 | where 126 | findSection mbTitle [] = fromMaybe p_title mbTitle 127 | findSection _ (PDirectory (Directory {..}):xs) = findSection (Just directoryTitle) xs 128 | findSection mbTitle (PLeaf (Leaf {..}):xs) = if leafHref == path 129 | then fromMaybe p_title mbTitle 130 | else findSection mbTitle xs 131 | 132 | rootStyle = mkStyle $ do 133 | position relative 134 | background "rgb(249, 249, 249)" 135 | margin "0px" 136 | padding "0px" 137 | width "100%" 138 | height "100%" 139 | 140 | mainStyle = mkStyle $ do 141 | display flex 142 | flexDirection column 143 | minHeight (vh 100) 144 | position relative 145 | 146 | -- media "(min-width: 1000px)" $ do 147 | marginLeft (px 251) 148 | 149 | pageStyle = mkStyle $ do 150 | flex "1 1 0%" 151 | 152 | pageInnerStyle = mkStyle $ do 153 | margin "0 30px 0 40px" 154 | maxWidth "64em" 155 | display flex 156 | flexFlow row wrap 157 | padding "48px 0px" 158 | -------------------------------------------------------------------------------- /pkg/hs/nauva-catalog/src/Nauva/Catalog/Specimens/NauvaSpecimen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveLift #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | 8 | module Nauva.Catalog.Specimens.NauvaSpecimen 9 | ( NauvaSpecimen(..) 10 | , nauvaSpecimen 11 | ) where 12 | 13 | 14 | import Data.Text (Text) 15 | import qualified Data.Text as T 16 | import Data.List 17 | import qualified Data.Aeson as A 18 | 19 | import qualified Text.Blaze.Html as B 20 | import qualified Text.Blaze.Html.Renderer.Pretty as B 21 | 22 | import Nauva.View 23 | import Nauva.Catalog.Theme.Typeface 24 | import Nauva.Static 25 | import Nauva.Catalog.Specimens.CodeSpecimen 26 | import Nauva.Catalog.Elements 27 | import Nauva.CSS.Renderer 28 | 29 | 30 | 31 | data NauvaSpecimen = NauvaSpecimen 32 | { csProps :: CodeSpecimenProps 33 | , csElement :: Element 34 | , csLang :: Text 35 | , csSource :: Text 36 | } 37 | 38 | data State = State 39 | { nssLang :: Text 40 | , nssStyles :: [Style] 41 | , nssHtml :: B.Html 42 | } 43 | 44 | data Action 45 | = NSASelectLanguage Text 46 | 47 | instance Value Action where 48 | parseValue v = do 49 | list <- A.parseJSON v 50 | case list of 51 | (t:xs) -> do 52 | ctag <- A.parseJSON t 53 | case ctag :: Text of 54 | "NSASelectLanguage" -> do 55 | case xs of 56 | [a] -> NSASelectLanguage <$> A.parseJSON a 57 | _ -> fail "Action:NSASelectLanguage" 58 | _ -> fail "Action" 59 | _ -> fail "Action" 60 | 61 | 62 | $( return [] ) 63 | 64 | 65 | 66 | nauvaSpecimen :: NauvaSpecimen -> Element 67 | nauvaSpecimen = component_ nauvaSpecimenComponent 68 | 69 | nauvaSpecimenComponent :: Component NauvaSpecimen () State Action 70 | nauvaSpecimenComponent = createComponent $ \componentId -> Component 71 | { componentId = componentId 72 | , componentDisplayName = "CodeSpecimen" 73 | , initialComponentState = \props -> do 74 | (html, styles, _) <- elementToMarkup $ csElement props 75 | pure (State "Haskell" styles html, [], []) 76 | , componentEventListeners = const [] 77 | , componentHooks = emptyHooks 78 | , processLifecycleEvent = \() _ s -> (s, []) 79 | , receiveProps = \_ s -> pure (s, [], []) 80 | , update = update 81 | , renderComponent = render 82 | , componentSnapshot = \_ -> A.object [] 83 | , restoreComponent = \_ s -> Right (s, []) 84 | } 85 | where 86 | update (NSASelectLanguage t) _ s = (s { nssLang = t}, []) 87 | 88 | onClickHandler :: FE MouseEvent Action 89 | onClickHandler = [njs| ev => { 90 | return $NSASelectLanguage(ev.target.innerText) 91 | }|] 92 | 93 | render NauvaSpecimen{..} State{..} = if cspNoSource 94 | then div_ [style_ rootStyle] [pageElementContainer [c]] 95 | else div_ [style_ rootStyle] 96 | [ pageElementContainer [c] 97 | , div_ [style_ tabsStyle] 98 | [ tab "Haskell" 99 | , tab "HTML" 100 | , tab "CSS" 101 | ] 102 | , case nssLang of 103 | "Haskell" -> codeBlock "" s 104 | "HTML" -> codeBlock "" $ T.pack $ B.renderHtml nssHtml 105 | "CSS" -> codeBlock "" $ mconcat $ intersperse "\n" $ 106 | nub $ map renderCSSRule (mconcat $ map unStyle nssStyles) 107 | _ -> codeBlock "" "other" 108 | ] 109 | where 110 | CodeSpecimenProps{..} = csProps 111 | c = csElement 112 | s = csSource 113 | 114 | tab t = div_ 115 | [ onClick_ onClickHandler 116 | , style_ (if nssLang == t then activeTabStyle else tabStyle) 117 | ] 118 | [str_ t] 119 | 120 | rootStyle = mkStyle $ do 121 | typeface mono12Typeface 122 | fontStyle "normal" 123 | fontWeight "400" 124 | color "rgb(51, 51, 51)" 125 | display "block" 126 | width "100%" 127 | background "rgb(255, 255, 255)" 128 | border "1px solid rgb(238, 238, 238)" 129 | 130 | tabsStyle = mkStyle $ do 131 | typeface meta14Typeface 132 | fontSize "16px" 133 | display flex 134 | backgroundColor "rgba(180,180,180,.1)" 135 | borderTop "1px solid rgb(238, 238, 238)" 136 | 137 | tabStyle = mkStyle $ do 138 | padding "12px" "20px" 139 | cursor pointer 140 | color "rgba(0,0,0,.7)" 141 | position relative 142 | userSelect none 143 | 144 | transition "color .2s" 145 | 146 | after $ do 147 | display block 148 | content "''" 149 | position absolute 150 | bottom "5px" 151 | left "20px" 152 | right "20px" 153 | height "2px" 154 | backgroundColor "transparent" 155 | 156 | transition "background-color .2s, bottom .2s" 157 | 158 | onHover $ do 159 | color "rgba(0,0,0,1)" 160 | 161 | after $ do 162 | backgroundColor "rgba(0,0,0,.7)" 163 | bottom "7px" 164 | 165 | activeTabStyle = mkStyle $ do 166 | padding "12px" "20px" 167 | cursor pointer 168 | color "rgba(0,0,0,1)" 169 | position relative 170 | userSelect none 171 | 172 | transition "color .2s" 173 | 174 | after $ do 175 | display block 176 | content "''" 177 | position absolute 178 | bottom "7px" 179 | left "20px" 180 | right "20px" 181 | height "2px" 182 | backgroundColor "rgba(0,0,0,.7)" 183 | 184 | transition "background-color .2s, bottom .2s" 185 | 186 | -------------------------------------------------------------------------------- /product/nauva/shared/src/Nauva/Product/Nauva/Catalog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DuplicateRecordFields #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | module Nauva.Product.Nauva.Catalog (catalogApp) where 6 | 7 | 8 | import Data.Color 9 | 10 | import Nauva.App 11 | 12 | import Nauva.Catalog 13 | import Nauva.Catalog.TH 14 | import Nauva.Catalog.Theme.Color 15 | import Nauva.Catalog.Theme.Typeface 16 | import Nauva.Catalog.Specimens.TypefaceSpecimen 17 | import Nauva.Catalog.Specimens.ColorGroupSpecimen 18 | 19 | import Nauva.Product.Nauva.Element.Terminal as Terminal 20 | import Nauva.Product.Nauva.Element.Message as Message 21 | 22 | 23 | 24 | catalogApp :: App 25 | catalogApp = App 26 | { rootElement = catalog . CatalogProps "Nauva" catalogPages 27 | } 28 | 29 | 30 | catalogPages :: [Page] 31 | catalogPages = 32 | [ PLeaf $ Leaf 33 | { leafHref = "/" 34 | , leafTitle = "Introduction" 35 | , leafElement = introductionPage 36 | } 37 | , PDirectory $ Directory 38 | { directoryTitle = "Theme" 39 | , directoryChildren = 40 | [ Leaf 41 | { leafHref = "/theme/colors" 42 | , leafTitle = "Colors" 43 | , leafElement = colorsPage 44 | } 45 | , Leaf 46 | { leafHref = "/theme/typefaces" 47 | , leafTitle = "Typefaces" 48 | , leafElement = typefacesPage 49 | } 50 | ] 51 | } 52 | , PDirectory $ Directory 53 | { directoryTitle = "Elements" 54 | , directoryChildren = 55 | [ Leaf 56 | { leafHref = "/elements/terminal" 57 | , leafTitle = "Terminal" 58 | , leafElement = Terminal.catalogPage 59 | } 60 | , Leaf 61 | { leafHref = "/elements/message" 62 | , leafTitle = "Message" 63 | , leafElement = Message.catalogPage 64 | } 65 | ] 66 | } 67 | ] 68 | 69 | 70 | introductionPage :: Element 71 | introductionPage = [nauvaCatalogPage| 72 | # Welcome to the Nauva catalog 73 | |] 74 | 75 | 76 | colorsPage :: Element 77 | colorsPage = [nauvaCatalogPage| 78 | ```element 79 | colorGroup $ ColorGroup 80 | { cgLabel = "Black" 81 | , cgCells = 82 | [ ColorCell 83 | { ccLabel = "100" 84 | , ccLuminance = 90 85 | , ccValue = Just $ ColorCellValue 86 | { csvName = "black100" 87 | , csvColor = mkColor (Chromaticity 0.305 0.329) 0.76 88 | } 89 | } 90 | , ColorCell 91 | { ccLabel = "200" 92 | , ccLuminance = 80 93 | , ccValue = Just $ ColorCellValue 94 | { csvName = "black200" 95 | , csvColor = mkColor (Chromaticity 0.305 0.329) 0.56 96 | } 97 | } 98 | , ColorCell 99 | { ccLabel = "500" 100 | , ccLuminance = 50 101 | , ccValue = Just $ ColorCellValue 102 | { csvName = "black500" 103 | , csvColor = mkColor (Chromaticity 0.288 0.291) 0.185 104 | } 105 | } 106 | , ColorCell 107 | { ccLabel = "900" 108 | , ccLuminance = 10 109 | , ccValue = Just $ ColorCellValue 110 | { csvName = "black900" 111 | , csvColor = blackColor 112 | } 113 | } 114 | ] 115 | } 116 | ``` 117 | |] 118 | 119 | 120 | typefacesPage :: Element 121 | typefacesPage = [nauvaCatalogPage| 122 | # Headings 123 | 124 | The heading typefaces are used in the catalog for for the main page header (h1) 125 | and headings inside the page content (h2 – h4). 126 | 127 | 128 | ```typeface 129 | h2Typeface 130 | ``` 131 | 132 | ```typeface 133 | h3Typeface 134 | ``` 135 | 136 | ```typeface 137 | h4Typeface 138 | ``` 139 | 140 | # Copy 141 | 142 | ```element 143 | typefaceSpecimen "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." paragraphTypeface 144 | ``` 145 | 146 | ```element 147 | typefaceSpecimen "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." blockquoteTypeface 148 | ``` 149 | 150 | # System 151 | 152 | The system typefaces are used in some elements rendered by nauvad. 153 | 154 | ```element 155 | typefaceSpecimen "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." system14Typeface 156 | ``` 157 | 158 | # Monospace 159 | 160 | Monospace fonts are used to show terminal output and code blocks. 161 | 162 | ```element 163 | typefaceSpecimen "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." mono12Typeface 164 | ``` 165 | 166 | ```element 167 | typefaceSpecimen "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum." mono14Typeface 168 | ``` 169 | 170 | |] 171 | -------------------------------------------------------------------------------- /pkg/hs/nauvad/src/Session.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | -- | A persistent version of the Ghci session, encoding lots of semantics on top. 4 | -- Not suitable for calling multithreaded. 5 | module Session( 6 | Session, withSession, 7 | sessionStart, sessionRestart, sessionReload, 8 | sessionExecAsync, 9 | ) where 10 | 11 | import Language.Haskell.Ghcid 12 | import Language.Haskell.Ghcid.Util 13 | import Data.IORef 14 | import System.Time.Extra 15 | import System.Process 16 | import Control.Exception.Extra 17 | import Control.Concurrent.Extra 18 | import Control.Monad.Extra 19 | import Data.Maybe 20 | import Data.List.Extra 21 | import Control.Applicative 22 | import Prelude 23 | 24 | 25 | data Session = Session 26 | {ghci :: IORef (Maybe Ghci) -- ^ The Ghci session, or Nothing if there is none 27 | ,command :: IORef (Maybe String) -- ^ The last command passed to sessionStart 28 | ,warnings :: IORef [Load] -- ^ The warnings from the last load 29 | ,running :: Var Bool -- ^ Am I actively running an async command 30 | ,withThread :: ThreadId -- ^ Thread that called withSession 31 | } 32 | 33 | 34 | debugShutdown x = when False $ print ("DEBUG SHUTDOWN", x) 35 | 36 | -- | The function 'withSession' expects to be run on the main thread, 37 | -- but the inner function will not. This ensures Ctrl-C is handled 38 | -- properly and any spawned Ghci processes will be aborted. 39 | withSession :: (Session -> IO a) -> IO a 40 | withSession f = do 41 | ghci <- newIORef Nothing 42 | command <- newIORef Nothing 43 | warnings <- newIORef [] 44 | running <- newVar False 45 | debugShutdown "Starting session" 46 | withThread <- myThreadId 47 | f Session{..} `finally` do 48 | debugShutdown "Start finally" 49 | modifyVar_ running $ const $ return False 50 | whenJustM (readIORef ghci) $ \v -> do 51 | writeIORef ghci Nothing 52 | debugShutdown "Calling kill" 53 | kill v 54 | debugShutdown "Finish finally" 55 | 56 | 57 | -- | Kill. Wait just long enough to ensure you've done the job, but not to see the results. 58 | kill :: Ghci -> IO () 59 | kill ghci = ignore $ do 60 | timeout 5 $ do 61 | debugShutdown "Before quit" 62 | ignore $ quit ghci 63 | debugShutdown "After quit" 64 | debugShutdown "Before terminateProcess" 65 | terminateProcess $ process ghci 66 | debugShutdown "After terminateProcess" 67 | 68 | 69 | -- | Spawn a new Ghci process at a given command line. Returns the load messages, plus 70 | -- the list of files that were observed (both those loaded and those that failed to load). 71 | sessionStart :: Session -> (Stream -> String -> IO ()) -> String -> IO ([Load], [FilePath]) 72 | sessionStart Session{..} echo cmd = do 73 | modifyVar_ running $ const $ return False 74 | writeIORef command $ Just cmd 75 | 76 | -- cleanup any old instances 77 | whenJustM (readIORef ghci) $ \v -> do 78 | writeIORef ghci Nothing 79 | void $ forkIO $ kill v 80 | 81 | -- start the new 82 | echo Stdout $ "Loading " ++ cmd ++ " ..." 83 | (v, messages) <- startGhci cmd Nothing $ echo 84 | writeIORef ghci $ Just v 85 | 86 | -- install a handler 87 | forkIO $ do 88 | waitForProcess $ process v 89 | whenJustM (readIORef ghci) $ \ghci -> 90 | when (ghci == v) $ do 91 | sleep 0.3 -- give anyone reading from the stream a chance to throw first 92 | throwTo withThread $ ErrorCall $ "Command \"" ++ cmd ++ "\" exited unexpectedly" 93 | 94 | -- handle what the process returned 95 | messages <- return $ mapMaybe tidyMessage messages 96 | writeIORef warnings [m | m@Message{..} <- messages, loadSeverity == Warning] 97 | return (messages, nubOrd $ map loadFile messages) 98 | 99 | 100 | -- | Call 'sessionStart' at the previous command. 101 | sessionRestart :: Session -> (Stream -> String -> IO ()) -> IO ([Load], [FilePath]) 102 | sessionRestart session@Session{..} echo = do 103 | Just cmd <- readIORef command 104 | sessionStart session echo cmd 105 | 106 | 107 | -- | Reload, returning the same information as 'sessionStart'. In particular, any 108 | -- information that GHCi doesn't repeat (warnings from loaded modules) will be 109 | -- added back in. 110 | sessionReload :: Session -> (Stream -> String -> IO ()) -> IO ([Load], [FilePath]) 111 | sessionReload session@Session{..} echo = do 112 | -- kill anything async, set stuck if you didn't succeed 113 | old <- modifyVar running $ \b -> return (False, b) 114 | stuck <- if not old then return False else do 115 | Just ghci <- readIORef ghci 116 | fmap isNothing $ timeout 5 $ interrupt ghci 117 | 118 | if stuck then sessionRestart session echo else do 119 | -- actually reload 120 | Just ghci <- readIORef ghci 121 | messages <- mapMaybe tidyMessage <$> reload ghci 122 | loaded <- map snd <$> showModules ghci 123 | let reloaded = nubOrd $ filter (/= "") $ map loadFile messages 124 | warn <- readIORef warnings 125 | 126 | -- only keep old warnings from files that are still loaded, but did not reload 127 | let validWarn w = loadFile w `elem` loaded && loadFile w `notElem` reloaded 128 | -- newest warnings always go first, so the file you hit save on most recently has warnings first 129 | messages <- return $ messages ++ filter validWarn warn 130 | 131 | writeIORef warnings [m | m@Message{..} <- messages, loadSeverity == Warning] 132 | return (messages, nubOrd $ loaded ++ reloaded) 133 | 134 | 135 | -- | Run an exec operation asynchronously. Should not be a @:reload@ or similar. 136 | -- Will be automatically aborted if it takes too long. Only fires done if not aborted. 137 | -- Argument to done is the final stderr line. 138 | sessionExecAsync :: Session -> String -> (String -> IO ()) -> IO () 139 | sessionExecAsync Session{..} cmd done = do 140 | Just ghci <- readIORef ghci 141 | stderr <- newIORef "" 142 | modifyVar_ running $ const $ return True 143 | caller <- myThreadId 144 | void $ flip forkFinally (either (throwTo caller) (const $ return ())) $ do 145 | execStream ghci cmd $ \strm msg -> 146 | when (msg /= "*** Exception: ExitSuccess") $ do 147 | when (strm == Stderr) $ writeIORef stderr msg 148 | outStrLn msg 149 | old <- modifyVar running $ \b -> return (False, b) 150 | -- don't fire Done if someone interrupted us 151 | stderr <- readIORef stderr 152 | when old $ done stderr 153 | 154 | 155 | -- | Ignore entirely pointless messages and remove unnecessary lines. 156 | tidyMessage :: Load -> Maybe Load 157 | tidyMessage Message{loadSeverity=Warning, loadMessage=[_,x]} 158 | | x == " -O conflicts with --interactive; -O ignored." = Nothing 159 | tidyMessage m@Message{..} 160 | = Just m{loadMessage = filter (\x -> not $ any (`isPrefixOf` x) bad) loadMessage} 161 | where bad = [" except perhaps to import instances from" 162 | ," To import instances alone, use: import "] 163 | tidyMessage x = Just x 164 | -------------------------------------------------------------------------------- /product/varna/shared/src/Nauva/Product/Varna/Element/Card.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Nauva.Product.Varna.Element.Card 7 | ( batteryCard 8 | 9 | , batteryCardBodyParagraph 10 | , batteryCardBodyPrimaryButton 11 | , batteryCardBodySecondaryButton 12 | 13 | , catalogPage 14 | ) where 15 | 16 | 17 | import Data.Text (Text) 18 | 19 | import Control.Monad 20 | 21 | import Nauva.Internal.Types 22 | import Nauva.View 23 | 24 | import Nauva.Catalog.TH (nauvaCatalogPage) 25 | 26 | import Prelude hiding (rem) 27 | 28 | 29 | 30 | batteryCard :: [Element] -> Element 31 | batteryCard body = div_ [style_ rootStyle] $ [batteryCardBody body] 32 | where 33 | rootStyle :: Style 34 | rootStyle = mkStyle $ do 35 | margin (rem 0.5) 36 | width "calc(100vw - 16px)" 37 | height (rem 12) 38 | 39 | display flex 40 | 41 | -- min: 254px -> 260px 42 | media "(min-width: 552px) and (max-width: 827px)" $ do 43 | width "calc((100vw - 32px) / 2)" 44 | 45 | media "(min-width: 828px) and (max-width: 1167px)" $ do 46 | width "calc((100vw - 48px) / 3)" 47 | 48 | media "(min-width: 1168px)" $ do 49 | width "calc((100vw - 64px) / 4)" 50 | 51 | 52 | batteryCardBody :: [Element] -> Element 53 | batteryCardBody body = div_ [style_ style] $ [batteryTileHeader] ++ body 54 | where 55 | style = mkStyle $ do 56 | flex "1" 57 | display flex 58 | flexDirection column 59 | backgroundColor "rgb(240, 239, 244)" 60 | 61 | 62 | batteryTileHeader :: Element 63 | batteryTileHeader = div_ [style_ rootStyle] 64 | [ indicator 65 | , batId 66 | , meta 67 | ] 68 | where 69 | rootStyle :: Style 70 | rootStyle = mkStyle $ do 71 | display flex 72 | flexDirection row 73 | 74 | backgroundColor "rgb(45, 48, 57)" 75 | color "rgb(236, 225, 233)" 76 | 77 | backgroundColor "#1f633c" 78 | 79 | indicatorStyle :: Style 80 | indicatorStyle = mkStyle $ do 81 | width (rem 1.5) 82 | height (rem 3) 83 | 84 | backgroundColor "rgb(158, 156, 156)" 85 | color "rgb(236, 225, 233)" 86 | 87 | lineHeight (rem 3) 88 | fontSize (rem 2.2) 89 | textAlign center 90 | 91 | backgroundColor "#28b262" 92 | 93 | indicator = div_ [style_ indicatorStyle] [] 94 | 95 | batIdStyle :: Style 96 | batIdStyle = mkStyle $ do 97 | flex "1" 98 | fontSize (rem 2.2) 99 | lineHeight (rem 3) 100 | marginLeft (rem 0.6) 101 | 102 | batId = div_ [style_ batIdStyle] [str_ "XXX"] 103 | 104 | metaStyle :: Style 105 | metaStyle = mkStyle $ do 106 | display flex 107 | flexDirection column 108 | textAlign right 109 | marginRight (rem 0.3) 110 | 111 | meta = div_ [style_ metaStyle] 112 | [ metaRow "3S / 1500mAh" 113 | , metaRow "4.198V" 114 | ] 115 | 116 | 117 | metaRow s = div_ [style_ metaRowStyle] [str_ s] 118 | 119 | metaRowStyle :: Style 120 | metaRowStyle = mkStyle $ do 121 | height (rem 1.5) 122 | lineHeight (rem 1.5) 123 | 124 | 125 | -- batteryCardBody :: [Element] -> Element 126 | -- batteryCardBody = div_ [style_ rootStyle] 127 | -- where 128 | -- rootStyle = mkStyle $ do 129 | -- flex "1" 130 | -- display flex 131 | -- justifyContent center 132 | -- flexDirection column 133 | -- alignItems center 134 | 135 | batteryCardBodyParagraph :: Bool -> [Element] -> Element 136 | batteryCardBodyParagraph centered = div_ [style_ rootStyle] 137 | where 138 | rootStyle = mkStyle $ do 139 | margin (rem 0.0) (rem 0) 140 | padding (rem 0) (rem 1) 141 | flex "1" 142 | when centered $ do 143 | display flex 144 | flexDirection column 145 | justifyContent center 146 | textAlign center 147 | 148 | batteryCardBodyPrimaryButton :: Text -> Element 149 | batteryCardBodyPrimaryButton label = div_ [style_ rootStyle] [str_ label] 150 | where 151 | rootStyle = mkStyle $ do 152 | -- button 153 | display inlineBlock 154 | padding (rem 0.2) (rem 0.5) (rem 0.1) 155 | backgroundColor "#ddd" 156 | textAlign center 157 | cursor pointer 158 | 159 | 160 | -- battery-card-body-button 161 | backgroundColor "rgb(226, 206, 226)" 162 | color "rgb(37, 37, 32)" 163 | 164 | fontSize (rem 1.5) 165 | textTransform uppercase 166 | 167 | padding (rem 0.5) (rem 1) (rem 0.4) 168 | 169 | onHover $ do 170 | backgroundColor "rgb(202, 174, 202)" 171 | 172 | batteryCardBodySecondaryButton :: Text -> Element 173 | batteryCardBodySecondaryButton label = div_ [style_ rootStyle] [str_ label] 174 | where 175 | rootStyle = mkStyle $ do 176 | -- button 177 | display inlineBlock 178 | padding (rem 0.2) (rem 0.5) (rem 0.1) 179 | backgroundColor "#ddd" 180 | textAlign center 181 | cursor pointer 182 | 183 | 184 | -- battery-card-body-button 185 | backgroundColor "rgb(226, 206, 226)" 186 | color "rgb(37, 37, 32)" 187 | 188 | fontSize (rem 1.5) 189 | textTransform uppercase 190 | 191 | padding (rem 0.5) (rem 1) (rem 0.4) 192 | 193 | 194 | -- battery-card-body-button-secondary 195 | backgroundColor "rgb(136, 113, 136)" 196 | color "white" 197 | fontSize (rem 0.75) 198 | 199 | onHover $ do 200 | backgroundColor "rgb(112, 86, 112)" 201 | 202 | 203 | catalogPage :: Element 204 | catalogPage = [nauvaCatalogPage| 205 | # Overview 206 | 207 | A `batteryCardBody` is the container for the body elements. It is epected to be placed 208 | in a flex container and expands to the size to its container (`flex:1`). 209 | 210 | The minimum dimensions are `254px` wide and `12rem` tall, but ideally `20rem` by `14rem`. 211 | 212 | ```nauva 213 | div_ [style_ $ mkStyle (display flex >> flexDirection row >> justifyContent "space-between")] 214 | [ div_ [style_ $ mkStyle (display flex >> width "254px" >> height "12rem")] [batteryCardBody []] 215 | , div_ [style_ $ mkStyle (display flex >> width "20rem" >> height "14em")] [batteryCardBody []] 216 | ] 217 | ``` 218 | 219 | # Body Elements 220 | 221 | You can place any of these elements into the card body: 222 | 223 | - `batteryCardBodyParagraph` 224 | - `batteryCardBodyPrimaryButton` 225 | - `batteryCardBodySecondaryButton` 226 | 227 | ```nauva 228 | div_ [style_ $ mkStyle (display flex >> width "20rem" >> height "14rem")] 229 | [ batteryCardBody 230 | [ batteryCardBodyParagraph True [str_ "This looks like a fresh battery. Congratulations on your purchase."] 231 | , batteryCardBodyPrimaryButton "charge battery" 232 | , batteryCardBodySecondaryButton "discharge battery" 233 | ] 234 | ] 235 | ``` 236 | |] 237 | --------------------------------------------------------------------------------