├── .gitignore ├── LICENSE ├── README.org ├── Test.hs ├── XHRIO.hs ├── default.nix ├── francium.cabal ├── material ├── CSS.hs ├── Cubic ├── Cubic.hs ├── Main.hs ├── Memo1.hs ├── cubic.html ├── default.nix ├── default.nix.1 ├── material.cabal ├── nixpkgs ├── rb ├── rb.hs ├── shell.nix ├── try-reflex.nix └── weak.hs ├── shell.nix ├── src └── Francium.hs └── todo-mvc ├── ClearCompleted.hs ├── IdiomExp.hs ├── Main.hs ├── NewItemAdder.hs ├── OpenItemCount.hs ├── StateFilter.hs ├── Storage.hs ├── TODO.org ├── TextInput.hs ├── ToDoItem.hs ├── ToDoList.hs ├── ToggleAll.hs ├── shell.nix └── todo-mvc.cabal /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *hi 3 | *o 4 | \#*# 5 | *.jsexe 6 | dist/ 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Oliver Charles 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 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 Oliver Charles 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 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | #+TITLE: Francium 2 | 3 | Francium is a [[http://haskell.org][Haskell]] library to help build interactive applications 4 | that run in the web browser. Francium applications use [[https://github.com/ghcjs/ghcjs][GHCJS]] to 5 | compile Haskell to Javascript, allowing one to use all the Haskell 6 | libraries and extensions they are already familiar with. 7 | 8 | In terms of paradigms, Francium uses [[https://wiki.haskell.org/reactive-banana][reactive-banana]] as its underlying 9 | FRP framework, and follows in the style of [[https://facebook.github.io/react][React]] for rendering. Users 10 | build their application by describing a network of discrete events and 11 | continuously varying behaviours - influenced by those events - in 12 | order to finally produce interactive HTML. 13 | 14 | As a small example of a Francium application, below demonstrates a 15 | basic counter application, allowing the user to increment and 16 | decrement a counter. 17 | 18 | #+BEGIN_SRC haskell 19 | import Francium 20 | import Francium.Hooks 21 | import VirtualDom 22 | 23 | main :: IO () 24 | main = react counterApp 25 | 26 | counterApp :: Frameworks t => Moment t (Behavior t HTML) 27 | counterApp = 28 | do 29 | -- We register two hooks to observe the users interaction with our 30 | -- application. 'newClickHook' provides us with an event that occurs whenever 31 | -- the target element is clicked, and a hook that we can bind to clickable 32 | -- elements. 33 | (increment,incrHook) <- newClickHook 34 | (decrement,decrHook) <- newClickHook 35 | -- We fold over the stream of all increment and decrement events to produce 36 | -- a single time varying integer. Whenever @increment@ happens, we add 1 37 | -- and whenever @decrement@ happens we subtract 1. 38 | let counter = 39 | accumB (0 :: Int) 40 | (unions [fmap (const (+ 1)) increment 41 | ,fmap (const (subtract 1)) decrement]) 42 | -- Finally, we produce a time varying HTML fragment. To do so, we transform 43 | -- the counter value - an 'Int' - into a 'HTML' fragment. We do this by 44 | -- using 'fmap'. 'fmap' takes a function that views the counter value, and 45 | -- we use "Francium.HTML" to produce a HTML tree. 46 | return (fmap (\n -> 47 | into body_ 48 | [into h1_ ["Counter"] 49 | -- Here we render the counter, by 'show'ing the value 50 | -- of @n@. 51 | ,into p_ 52 | ["The counter currently reads: ",text (show n)] 53 | -- Here we build the increment and decrement buttons 54 | -- and apply the necessary hooks. 55 | ,applyHooks decrHook 56 | (into button "-1") 57 | ,"/" 58 | ,applyHooks incrHook 59 | (into button "+1")]) 60 | counter) 61 | #+END_SRC 62 | 63 | For a more detailed example, see the =todo-mvc= example in this repository. 64 | -------------------------------------------------------------------------------- /Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | 4 | module Main where 5 | 6 | import Francium.Component 7 | import Francium.Components.Form.Input 8 | import Francium 9 | import Francium.Hooks 10 | import VirtualDom 11 | import Data.Char 12 | import GHCJS.Foreign 13 | 14 | main :: IO () 15 | main = 16 | react (mdo input <- construct (Input v (pure False)) 17 | (clickHook,onClick) <- newClickHook 18 | let v = 19 | fmap (toJSString . show) 20 | (accumB 0 (fmap (const (+ 1)) onClick)) 21 | let value = 22 | stepper "" 23 | (fmap (toJSString . map toUpper . fromJSString) 24 | (inputChanged (outputs input))) 25 | return (div_ (mconcat [render input 26 | ,button_ (applyHooks clickHook) "Inc"]))) 27 | -------------------------------------------------------------------------------- /XHRIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ForeignFunctionInterface #-} 2 | {-# LANGUAGE InterruptibleFFI #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | module XHR where 6 | 7 | import Control.Applicative 8 | import Control.Arrow 9 | import Data.Foldable (for_) 10 | import Data.List.Split 11 | import Data.Maybe 12 | import GHCJS.Foreign 13 | import GHCJS.Types 14 | 15 | data Request = 16 | Request {rqWithCredentials :: Bool 17 | ,rqURL :: String 18 | ,rqMethod :: Method 19 | ,rqHeaders :: [(String,String)] 20 | ,rqPayload :: Maybe JSString} 21 | 22 | data Method 23 | = GET 24 | | POST 25 | | DELETE 26 | | PUT 27 | deriving (Eq,Show) 28 | 29 | instance ToJSString Method where 30 | toJSString = toJSString . show 31 | 32 | data Response = 33 | Response {resStatus :: Int 34 | ,resHeaders :: [(String,String)]} 35 | 36 | request :: Request -> IO Response 37 | request Request{..} = 38 | do xhr <- jsNewXHR 39 | jsXHROpen xhr 40 | (toJSString rqMethod) 41 | (toJSString rqURL) 42 | jsXHRSetWithCredentials xhr 43 | (toJSBool rqWithCredentials) 44 | for_ rqHeaders $ 45 | \(k,v) -> 46 | jsXHRSetRequestHeader xhr 47 | (toJSString k) 48 | (toJSString v) 49 | jsXHRSend xhr (fromMaybe jsNull rqPayload) 50 | Response <$> jsXHRGetStatus xhr <*> 51 | (map (second (drop 2) . 52 | break (== ':')) . 53 | splitOn "\r\n" . 54 | fromJSString <$> 55 | jsXHRGetAllResponseHeaders xhr) 56 | 57 | -------------------------------------------------------------------------------- 58 | data XHR 59 | 60 | foreign import javascript unsafe 61 | "$r = new XMLHttpRequest();\ 62 | \$r.latestProgressMessage = null;\ 63 | \$r.awaitingProgress = null;\ 64 | \$r.incrementalPos = 0;\ 65 | \$r.err = null" 66 | jsNewXHR :: IO (JSRef XHR) 67 | 68 | foreign import javascript unsafe 69 | "$1.withCredentials = $2;" 70 | jsXHRSetWithCredentials :: JSRef XHR -> JSBool -> IO () 71 | 72 | foreign import javascript unsafe 73 | "$1.open($2, $3, true);" 74 | jsXHROpen :: JSRef XHR -> JSString -> JSString -> IO () 75 | 76 | foreign import javascript unsafe 77 | "$1.setRequestHeader($2, $3);" 78 | jsXHRSetRequestHeader :: JSRef XHR -> JSString -> JSString -> IO () 79 | 80 | foreign import javascript interruptible 81 | "$1.onload = function(e) { $c(); };\ 82 | \$1.onerror = function(e) { $1['h$err'] = true; $c(); };\ 83 | \$1.send($2);" 84 | jsXHRSend :: JSRef XHR -> JSRef a -> IO () 85 | 86 | foreign import javascript unsafe 87 | "$1.status" 88 | jsXHRGetStatus :: JSRef XHR -> IO Int 89 | 90 | foreign import javascript unsafe 91 | "$1.getAllResponseHeaders()" 92 | jsXHRGetAllResponseHeaders :: JSRef XHR -> IO JSString 93 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, mtl, transformers, reactive-banana, stdenv, ghcjs-dom 2 | , ghcjs-base 3 | }: 4 | mkDerivation { 5 | pname = "francium"; 6 | version = "0.1"; 7 | src = ./.; 8 | buildDepends = [ 9 | base mtl transformers reactive-banana ghcjs-dom ghcjs-base 10 | ]; 11 | license = stdenv.lib.licenses.unfree; 12 | } 13 | -------------------------------------------------------------------------------- /francium.cabal: -------------------------------------------------------------------------------- 1 | -- Initial francium.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: francium 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Oliver Charles 11 | maintainer: ollie@ocharles.org.uk 12 | -- copyright: 13 | category: Web 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Francium 20 | -- other-extensions: 21 | build-depends: base >=4.8 && <4.9, ghcjs-dom, transformers, mtl, ghcjs-base, reactive-banana 22 | hs-source-dirs: src 23 | default-language: Haskell2010 24 | ghc-options: -Wall -O2 -------------------------------------------------------------------------------- /material/CSS.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE DataKinds #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE OverloadedStrings #-} 9 | 10 | module CSS 11 | (absolute, static, fixed, Position, position, top, (@@), px, left, 12 | width, pct, height, backgroundColor, display, inlineBlock, 13 | relative, textAlign, right, center, justify, lineHeight, fontSize, 14 | white, zIndex, margin, padding, auto, textTransform, uppercase, 15 | capitalize, lowercase, overflow, hidden) 16 | where 17 | 18 | import Reactive.Banana 19 | import Data.JSString (JSString) 20 | import Data.String (fromString) 21 | import Control.Applicative 22 | import Data.Monoid 23 | import Data.Coerce 24 | import Francium 25 | 26 | -------------------------------------------------------------------------------- 27 | coerceStr :: Coercible JSString a => JSString -> a 28 | coerceStr = coerce 29 | 30 | class Coercible JSString a => Absolute a where 31 | absolute :: Behavior t a 32 | absolute = pure (coerceStr "absolute") 33 | {-# INLINE absolute #-} 34 | 35 | class Coercible JSString a => Fixed a where 36 | fixed :: Behavior t a 37 | fixed = pure (coerceStr "fixed") 38 | {-# INLINE fixed #-} 39 | 40 | class Coercible JSString a => Static a where 41 | static :: Behavior t a 42 | static = pure (coerceStr "static") 43 | {-# INLINE static #-} 44 | 45 | class Coercible JSString a => Relative a where 46 | relative :: Behavior t a 47 | relative = pure (coerceStr "relative") 48 | {-# INLINE relative #-} 49 | 50 | class Coercible JSString a => Auto a where 51 | auto :: Behavior t a 52 | auto = pure (coerceStr "auto") 53 | {-# INLINE auto #-} 54 | 55 | -------------------------------------------------------------------------------- 56 | newtype Position = Position JSString 57 | 58 | instance Absolute Position 59 | instance Fixed Position 60 | instance Static Position 61 | instance Relative Position 62 | 63 | position :: Behavior t Position -> CSS t () 64 | position v = "position" -: fmap coerce v 65 | {-# INLINE position #-} 66 | 67 | -------------------------------------------------------------------------------- 68 | infixl 1 @@ 69 | (@@) :: a -> (a -> b) -> b 70 | x @@ f = f x 71 | {-# INLINE (@@) #-} 72 | 73 | instance Num a => Num (Behavior t a) where 74 | (*) = liftA2 (*) 75 | {-# INLINE (*) #-} 76 | (+) = liftA2 (+) 77 | {-# INLINE (+) #-} 78 | abs = fmap abs 79 | {-# INLINE abs #-} 80 | signum = fmap signum 81 | {-# INLINE signum #-} 82 | fromInteger = pure . fromInteger 83 | {-# INLINE fromInteger #-} 84 | negate = fmap negate 85 | {-# INLINE negate #-} 86 | 87 | instance Fractional a => Fractional (Behavior t a) where 88 | fromRational = pure . fromRational 89 | {-# INLINE fromRational #-} 90 | recip = fmap recip 91 | {-# INLINE recip #-} 92 | 93 | -------------------------------------------------------------------------------- 94 | class Coercible JSString a => Length a where 95 | mkLength :: Behavior t JSString -> Behavior t a 96 | mkLength = fmap coerce 97 | {-# INLINE mkLength #-} 98 | 99 | px :: (Num a, Show a, Length css) => Behavior t a -> Behavior t css 100 | px = mkLength . fmap (coerceStr . (<> "px") . fromString . show) -- TODO Data.JSString probably exports something better 101 | {-# INLINE px #-} 102 | 103 | -------------------------------------------------------------------------------- 104 | class Coercible JSString a => Percentage a where 105 | mkPercentage :: Behavior t JSString -> Behavior t a 106 | mkPercentage = fmap coerce 107 | {-# INLINE mkPercentage #-} 108 | 109 | pct :: (Num a, Show a, Percentage css) => Behavior t a -> Behavior t css 110 | pct = mkPercentage . fmap (coerceStr . (<> "%") . fromString . show) 111 | {-# INLINE pct #-} 112 | 113 | -------------------------------------------------------------------------------- 114 | newtype Top = Top JSString 115 | 116 | instance Length Top 117 | instance Percentage Top 118 | 119 | top :: Behavior t Top -> CSS t () 120 | top v = "top" -: fmap coerce v 121 | {-# INLINE top #-} 122 | 123 | -------------------------------------------------------------------------------- 124 | newtype Left = Left JSString 125 | 126 | instance Length Left 127 | instance Percentage Left 128 | 129 | class ValueOrKeyword a where 130 | valueOrKeyword :: JSString -> a 131 | 132 | instance ValueOrKeyword (Behavior t JSString) where 133 | valueOrKeyword kw = pure (coerceStr kw) 134 | {-# INLINE valueOrKeyword #-} 135 | 136 | instance (b ~ (), x ~ Left, t ~ t') => ValueOrKeyword (Behavior t x -> CSS t' b) where 137 | valueOrKeyword kw v = kw -: fmap coerce v 138 | {-# INLINE valueOrKeyword #-} 139 | 140 | left :: ValueOrKeyword a => a 141 | left = valueOrKeyword "left" 142 | {-# INLINE left #-} 143 | 144 | -------------------------------------------------------------------------------- 145 | newtype Width = Width JSString 146 | 147 | instance Length Width 148 | instance Percentage Width 149 | 150 | width :: Behavior t Width -> CSS t () 151 | width v = "width" -: fmap coerce v 152 | {-# INLINE width #-} 153 | 154 | -------------------------------------------------------------------------------- 155 | newtype Height = Height JSString 156 | 157 | instance Length Height 158 | instance Percentage Height 159 | 160 | height :: Behavior t Height -> CSS t () 161 | height v = "height" -: fmap coerce v 162 | {-# INLINE height #-} 163 | 164 | -------------------------------------------------------------------------------- 165 | newtype BackgroundColor = BackgroundColor JSString 166 | 167 | backgroundColor :: Behavior t JSString -> CSS t () 168 | backgroundColor v = "background-color" -: fmap coerceStr v 169 | {-# INLINE backgroundColor #-} 170 | 171 | -------------------------------------------------------------------------------- 172 | -- TODO Values 173 | newtype Display = Display JSString 174 | 175 | inlineBlock :: Behavior t Display 176 | inlineBlock = pure (Display "inline-block") 177 | {-# INLINE inlineBlock #-} 178 | 179 | display :: Behavior t Display -> CSS t () 180 | display v = "display" -: fmap coerce v 181 | {-# INLINE display #-} 182 | 183 | -------------------------------------------------------------------------------- 184 | newtype TextAlign = TextAlign JSString 185 | 186 | right, center, justify :: Behavior t TextAlign 187 | right = pure (coerceStr "right") 188 | center = pure (coerceStr "center") 189 | justify = pure (coerceStr "justify") 190 | {-# INLINE right #-} 191 | {-# INLINE center #-} 192 | {-# INLINE justify #-} 193 | 194 | textAlign :: Behavior t TextAlign -> CSS t () 195 | textAlign v = "display" -: fmap coerce v 196 | {-# INLINE textAlign #-} 197 | 198 | instance ValueOrKeyword (Behavior t TextAlign) where 199 | valueOrKeyword = pure . coerce 200 | {-# INLINE valueOrKeyword #-} 201 | 202 | -------------------------------------------------------------------------------- 203 | newtype LineHeight = LineHeight JSString 204 | 205 | instance Length LineHeight 206 | instance Percentage LineHeight 207 | 208 | lineHeight :: Behavior t LineHeight -> CSS t () 209 | lineHeight v = "line-height" -: fmap coerce v 210 | {-# INLINE lineHeight #-} 211 | 212 | -------------------------------------------------------------------------------- 213 | newtype FontSize = FontSize JSString 214 | 215 | instance Length FontSize 216 | instance Percentage FontSize 217 | 218 | fontSize :: Behavior t FontSize -> CSS t () 219 | fontSize v = "fontSize" -: fmap coerce v 220 | {-# INLINE fontSize #-} 221 | 222 | -------------------------------------------------------------------------------- 223 | white :: Behavior t JSString 224 | white = pure "white" 225 | {-# INLINE white #-} 226 | 227 | -------------------------------------------------------------------------------- 228 | zIndex :: (Integral a, Show a) => Behavior t a -> CSS t () 229 | zIndex v = "z-index" -: fmap (fromString . show) v 230 | {-# INLINE zIndex #-} 231 | 232 | -------------------------------------------------------------------------------- 233 | newtype Margin = Margin JSString 234 | 235 | instance Length Margin 236 | instance Percentage Margin 237 | 238 | class MarginOverload a where 239 | margin :: a 240 | 241 | instance (a ~ Margin,b ~ (), t ~ t') => MarginOverload (Behavior t a -> CSS t' b) where 242 | margin v = "margin" -: fmap coerce v 243 | {-# INLINE margin #-} 244 | 245 | instance (a ~ Margin,b ~ a,c ~ (), t ~ t', t' ~ t'') => MarginOverload (Behavior t a -> Behavior t' b -> CSS t'' c) where 246 | margin a b = 247 | "margin" -: 248 | (liftA2 (\a' b' -> coerce a' <> " " <> coerce b') a b) 249 | {-# INLINE margin #-} 250 | 251 | instance (a ~ Margin,b ~ a,c ~ b,d ~ (),t ~ t',t' ~ t'',t'' ~ t''') => MarginOverload (Behavior t a -> Behavior t' b -> Behavior t'' c -> CSS t''' d) where 252 | margin a b c = 253 | "margin" -: 254 | (liftA3 (\a' b' c' -> coerce a' <> " " <> coerce b' <> " " <> coerce c') a b c) 255 | {-# INLINE margin #-} 256 | 257 | instance (a ~ Margin,b ~ a,c ~ b,d ~ c,e ~ (),t ~ t',t' ~ t'',t'' ~ t''', t''' ~ t'''') => MarginOverload (Behavior t a -> Behavior t' b -> Behavior t'' c -> Behavior t''' d -> CSS t'''' e) where 258 | margin a b c d = 259 | "margin" -: 260 | ((\a' b' c' d' -> coerce a' <> " " <> coerce b' <> " " <> coerce c' <> " " <> 261 | coerce d') <$> a <*> b <*> c <*> d) 262 | {-# INLINE margin #-} 263 | 264 | -------------------------------------------------------------------------------- 265 | newtype Padding = Padding JSString 266 | 267 | instance Length Padding 268 | instance Percentage Padding 269 | 270 | class PaddingOverload a where 271 | padding :: a 272 | 273 | instance (a ~ Padding,b ~ (), t ~ t') => PaddingOverload (Behavior t a -> CSS t' b) where 274 | padding v = "padding" -: fmap coerce v 275 | {-# INLINE padding #-} 276 | 277 | instance (a ~ Padding,b ~ a,c ~ (), t ~ t', t' ~ t'') => PaddingOverload (Behavior t a -> Behavior t' b -> CSS t'' c) where 278 | padding a b = 279 | "padding" -: 280 | (liftA2 (\a' b' -> coerce a' <> " " <> coerce b') a b) 281 | {-# INLINE padding #-} 282 | 283 | instance (a ~ Padding,b ~ a,c ~ b,d ~ (),t ~ t',t' ~ t'',t'' ~ t''') => PaddingOverload (Behavior t a -> Behavior t' b -> Behavior t'' c -> CSS t''' d) where 284 | padding a b c = 285 | "padding" -: 286 | (liftA3 (\a' b' c' -> coerce a' <> " " <> coerce b' <> " " <> coerce c') a b c) 287 | {-# INLINE padding #-} 288 | 289 | instance (a ~ Padding,b ~ a,c ~ b,d ~ c,e ~ (),t ~ t',t' ~ t'',t'' ~ t''', t''' ~ t'''') => PaddingOverload (Behavior t a -> Behavior t' b -> Behavior t'' c -> Behavior t''' d -> CSS t'''' e) where 290 | padding a b c d = 291 | "padding" -: 292 | ((\a' b' c' d' -> coerce a' <> " " <> coerce b' <> " " <> coerce c' <> " " <> 293 | coerce d') <$> a <*> b <*> c <*> d) 294 | {-# INLINE padding #-} 295 | 296 | ------------------------------------text--------------------------------------------- 297 | newtype TextTransform = TextTransform JSString 298 | 299 | capitalize, uppercase, lowercase :: Behavior t TextTransform 300 | capitalize = pure (coerceStr "capitalize") 301 | uppercase = pure (coerceStr "uppercase") 302 | lowercase = pure (coerceStr "lowercase") 303 | {-# INLINE capitalize #-} 304 | {-# INLINE uppercase #-} 305 | {-# INLINE lowercase #-} 306 | 307 | textTransform :: Behavior t TextTransform -> CSS t () 308 | textTransform v = "text-transform" -: fmap coerce v 309 | {-# INLINE textTransform #-} 310 | 311 | -------------------------------------------------------------------------------- 312 | newtype Overflow = Overflow JSString 313 | 314 | hidden :: Behavior t Overflow 315 | hidden = pure (coerceStr "hidden") 316 | {-# INLINE hidden #-} 317 | 318 | overflow :: Behavior t Overflow -> CSS t () 319 | overflow v = "overflow" -: fmap coerce v 320 | {-# INLINE overflow #-} 321 | -------------------------------------------------------------------------------- /material/Cubic: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocharles/Francium/82584a12ff184ad63bd2311f3672967709e57ab2/material/Cubic -------------------------------------------------------------------------------- /material/Cubic.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | import Criterion 5 | import Criterion.Main 6 | import Control.Applicative 7 | import Data.Maybe 8 | import Control.Monad 9 | import Numeric.AD hiding (diff') 10 | import Numeric.AD.Rank1.Forward 11 | import qualified Numeric.AD.Rank1.Forward.Double as FD2 12 | import qualified Numeric.AD.Rank1.Newton as Newton 13 | 14 | cubicBezier 15 | :: (Double,Double) -> (Double,Double) -> Double -> Double -> Double 16 | cubicBezier !(!p1x,!p1y) !(!p2x,!p2y) = 17 | let cx = 3 * p1x 18 | bx = 3 * (p2x - p1x) - cx 19 | ax = 1 - cx - bx 20 | cy = 3 * p1y 21 | by = 3 * (p2y - p1y) - cy 22 | ay = 1 - cy - by 23 | sampleCurveX !t = 24 | ((ax * t + bx) * t + cx) * t 25 | sampleCurveY !t = 26 | ((ay * t + by) * t + cy) * t 27 | sampleCurveDerivativeX !t = 28 | (3 * ax * t + 2 * bx) * t + cx 29 | solveCurveX !x !epsilon = 30 | let solveByNewton 31 | :: Int -> Double -> Maybe Double 32 | solveByNewton !n !t2 = 33 | do guard (n < 8) 34 | let x2 = sampleCurveX t2 - x 35 | if abs x2 < epsilon 36 | then return t2 37 | else do let d2 = sampleCurveDerivativeX t2 38 | guard (abs d2 < 1.0e-6) 39 | solveByNewton (n + 1) 40 | (t2 - x2 / d2) 41 | solveByBisection !t0 !t1 !t2 = 42 | do guard (t0 < t1) 43 | let x2 = sampleCurveX t2 44 | if abs (x2 - x) < epsilon 45 | then return t2 46 | else (let (t0',t1') = 47 | if x > x2 48 | then (t2,t1) 49 | else (t0,t2) 50 | t2' = 51 | (t1' - t0') * 0.5 + t0' 52 | in solveByBisection t0' t1' t2' <|> return t2') 53 | in fromMaybe x (solveByNewton 0 x <|> solveByBisection 0 1 x) 54 | solveEpsilon !d = 1.0 / (200.0 * d) 55 | in \duration x -> 56 | sampleCurveY 57 | (solveCurveX x 58 | (solveEpsilon duration)) 59 | 60 | solveCubicBezierTForX :: (Double,Double) 61 | -> (Double,Double) 62 | -> Double 63 | -> [Double] 64 | solveCubicBezierTForX p2 p3 x = 65 | findZero 66 | (\t -> cubicBezierXAD p2 p3 t - auto x) 67 | x 68 | where findZero f = go 69 | where go x = x : if x == xn then [] else go xn 70 | where (y,y') = FD2.diff' f x 71 | xn = x - y / y' 72 | 73 | cubicBezierX :: (Double,Double) -> (Double,Double) -> Double -> Double 74 | cubicBezierX (p1x,_) (p2x,_) t = ((ax * t + bx) * t + cx) * t 75 | cx = 3 * p1x 76 | bx = 3 * (p2x - p1x) - cx 77 | ax = 1 - cx - bx 78 | 79 | cubicBezierXAD 80 | :: Mode a 81 | => (Scalar a,Scalar a) -> (Scalar a,Scalar a) -> a -> a 82 | cubicBezierXAD (p2x,_) (p3x,_) t = 83 | ((ax * t + bx) * t + cx) * t 84 | where cx = 3 * auto p2x 85 | bx = 3 * (auto p3x - auto p2x) - cx 86 | ax = 1 - cx - bx 87 | 88 | cubicBezierY 89 | :: Mode a 90 | => (Scalar a,Scalar a) -> (Scalar a,Scalar a) -> a -> a 91 | cubicBezierY (_,p2y) (_,p3y) t = 92 | ((ay * t + by) * t + cy) * t 93 | where cy = 3 * auto p2y 94 | by = 3 * (auto p3y - auto p2y) - cy 95 | ay = 1 - cy - by 96 | 97 | 98 | 99 | main :: IO () 100 | main = 101 | defaultMain 102 | [bgroup "cubicBezierX" 103 | (map (\t -> 104 | bench (show t) 105 | (whnf (cubicBezierX (0.23,1) 106 | (0.32,1)) 107 | t)) 108 | [0 :: Double]) 109 | ,bgroup "cubicBezierXAD" 110 | (map (\t -> 111 | bench (show t) 112 | (whnf (\t -> 113 | fst (diff' (cubicBezierXAD (0.23,1) 114 | (0.32,1)) 115 | t)) 116 | t)) 117 | [0 :: Double]) 118 | ,bgroup "cubicBezierXAD2" 119 | (map (\t -> 120 | bench (show t) 121 | (whnf (\t -> 122 | fst (FD2.diff' (cubicBezierXAD (0.23,1) 123 | (0.32,1)) 124 | t)) 125 | t)) 126 | [0 :: Double]) 127 | ,bgroup "cubicBezier" 128 | (map (\t -> 129 | bench (show t) 130 | (whnf (cubicBezier (0.23,1) 131 | (0.32,1) 132 | 10000) 133 | t)) 134 | [0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0]) 135 | ,bgroup "cubicBezierAD Newton" 136 | (map (\t -> 137 | bench (show t) 138 | (whnf (cubicBezierAD (0.23,1) 139 | (0.32,1) 140 | 10000) 141 | t)) 142 | [0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0])] 143 | -------------------------------------------------------------------------------- /material/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecursiveDo #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | 10 | module Main where 11 | 12 | import System.Mem 13 | import Numeric.AD (Mode, Scalar, auto) 14 | import Numeric.AD.Rank1.Forward.Double (diff') 15 | import Control.Monad.Trans.Class 16 | import Reactive.Banana 17 | import Reactive.Banana.Frameworks 18 | import GHCJS.DOM.ClientRect (getTop, getLeft) 19 | import Control.Monad.IO.Class 20 | import Control.Applicative 21 | import Control.Lens 22 | import Control.Monad 23 | import Control.Monad.Trans.Reader 24 | import Control.Monad.Trans.State.Strict 25 | import Data.Bool 26 | import Data.Maybe (fromMaybe) 27 | import Data.Monoid 28 | import Data.String (fromString) 29 | import Francium hiding (main) 30 | import GHCJS.DOM 31 | import GHCJS.DOM.Document (getBody) 32 | import GHCJS.DOM.Element 33 | (setAttribute, castToElement, getScrollLeft, getScrollTop, 34 | getOffsetHeight, getOffsetWidth, getBoundingClientRect) 35 | import GHCJS.DOM.HTMLButtonElement (castToHTMLButtonElement) 36 | import GHCJS.DOM.Event hiding (Event) 37 | import GHCJS.DOM.EventTarget (addEventListener) 38 | import GHCJS.DOM.EventTargetClosures 39 | (eventListenerNew, eventListenerRelease) 40 | import GHCJS.DOM.UIEvent (UIEvent, getPageX, getPageY) 41 | import GHCJS.DOM.Types (IsGObject) 42 | import GHCJS.Types 43 | import Debug.Trace 44 | 45 | import qualified CSS 46 | 47 | -------------------------------------------------------------------------------- 48 | 49 | data AvatarContents = 50 | AvatarImg String 51 | 52 | data AvatarConfig t = 53 | AvatarConfig {_avatarSize :: Behavior t Integer 54 | ,_avatarBackgroundColor :: Behavior t JSString 55 | ,_avatarBorderRadius :: Behavior t Double} 56 | 57 | makeLenses ''AvatarConfig 58 | 59 | defaultAvatarConfig :: AvatarConfig t 60 | defaultAvatarConfig = 61 | AvatarConfig {_avatarSize = 40 62 | ,_avatarBackgroundColor = CSS.white 63 | ,_avatarBorderRadius = 50} 64 | 65 | avatar 66 | :: Frameworks t 67 | => State (AvatarConfig t) x -> AvatarContents -> Francium t () 68 | avatar configurator contents = 69 | div_ (style_ containerStyle) 70 | (case contents of 71 | AvatarImg imageUrl -> 72 | img_ (do src_ (pure imageUrl) 73 | style_ imageStyle) 74 | _ -> 75 | div_ (style_ (do CSS.position CSS.absolute 76 | CSS.top (0 CSS.@@ CSS.px) 77 | CSS.left (0 CSS.@@ CSS.px) 78 | CSS.width (0 CSS.@@ CSS.pct) 79 | CSS.height (0 CSS.@@ CSS.pct))) 80 | mempty) 81 | where config = 82 | execState configurator defaultAvatarConfig 83 | containerStyle = 84 | do "userSelect" -: "none" 85 | imageStyle 86 | CSS.backgroundColor (config ^. avatarBackgroundColor) 87 | CSS.display CSS.inlineBlock 88 | CSS.position CSS.relative 89 | CSS.textAlign CSS.center 90 | CSS.lineHeight (config ^. avatarSize CSS.@@ CSS.px) 91 | CSS.fontSize 92 | (fmap (\sz -> sz `div` 2 + 4) 93 | (config ^. avatarSize) CSS.@@ 94 | CSS.px) 95 | imageStyle = 96 | do CSS.height (config ^. avatarSize CSS.@@ CSS.px) 97 | CSS.width (config ^. avatarSize CSS.@@ CSS.px) 98 | "border-radius" -: 99 | fmap ((<> "px") . fromString . show) 100 | (config ^. avatarBorderRadius) 101 | 102 | img_ :: Frameworks t => Attribute t () -> Francium t () 103 | img_ attrs = basicElement "img" attrs mempty 104 | 105 | src_ :: Frameworks t => Behavior t String -> Attribute t () 106 | src_ = 107 | mkAttribute (flip setAttribute ("src" :: JSString)) 108 | castToElement 109 | 110 | -------------------------------------------------------------------------------- 111 | 112 | data FullscreenOverlayConfig t = 113 | FullscreenOverlayConfig {_fullscreenOverlayLockScrolling :: Bool 114 | ,_fullscreenOverlayActive :: Behavior t Bool} 115 | 116 | makeLenses ''FullscreenOverlayConfig 117 | 118 | -- fullscreenOverlay 119 | -- :: Frameworks t => State (FullscreenOverlayConfig t) x -> Francium t () 120 | -- fullscreenOverlay mkFsoConfig = 121 | -- do let visibilityChanged = 122 | -- toChanges (fsoConfig ^. fullscreenOverlayActive) 123 | -- clock <- getClock 124 | -- overlayOpacity <- 125 | -- sample (linearInterpolator' clock 126 | -- 0 127 | -- 0.4 128 | -- (fmap (bool 0 1) visibilityChanged)) 129 | -- observe (fsoConfig ^. fullscreenOverlayActive) 130 | -- (\case 131 | -- False -> return () 132 | -- True -> 133 | -- div_ (style_ (do CSS.position CSS.fixed 134 | -- CSS.height (100 CSS.@@ CSS.pct) 135 | -- CSS.width (100 CSS.@@ CSS.pct) 136 | -- CSS.zIndex 9 137 | -- CSS.top (0 CSS.@@ CSS.px) 138 | -- CSS.left (0 CSS.@@ CSS.px) 139 | -- "opacity" -: fmap (fromString . show) overlayOpacity 140 | -- "background-color" -: "rgba(0,0,0,0.541)" 141 | -- "transform" -: "translateZ(0px)")) 142 | -- mempty) 143 | -- where fsoConfig = 144 | -- execState mkFsoConfig 145 | -- FullscreenOverlayConfig {_fullscreenOverlayLockScrolling = True 146 | -- ,_fullscreenOverlayActive = 147 | -- pure False} 148 | 149 | def :: State config () 150 | def = return () 151 | 152 | -------------------------------------------------------------------------------- 153 | 154 | integrate 155 | :: Event t Double -> Behavior t Double -> Behavior t Double 156 | integrate t b = sumB ((*) <$> b <@> diffE t) 157 | where diffE = withPrevEWith (-) 158 | withPrevEWith f e = 159 | filterJust . fst . mapAccum Nothing $ g <$> e 160 | where g y Nothing = (Nothing,Just y) 161 | g y (Just x) = 162 | (Just (f y x),Just y) 163 | sumB = accumB 0 . fmap (+) 164 | 165 | cubicBezier 166 | :: (Double,Double) -> (Double,Double) -> Double -> Double -> Double 167 | cubicBezier (p2x,p2y) (p3x,p3y) dur x = 168 | let epsilon = 1 / (200 * dur) 169 | cubicBezierX :: (Mode a, Scalar a ~ Double) => a -> a 170 | cubicBezierX t = 171 | ((ax * t + bx) * t + cx) * t 172 | ax,bx,cx :: (Mode a, Scalar a ~ Double) => a 173 | cx = 3 * auto p2x 174 | bx = 3 * (auto p3x - auto p2x) - cx 175 | ax = 1 - cx - bx 176 | cubicBezierY t = 177 | ((ay * t + by) * t + cy) * t 178 | cy = 3 * auto p2y 179 | by = 3 * (auto p3y - auto p2y) - cy 180 | ay = 1 - cy - by 181 | findZero f = 182 | let go x = 183 | let (y,y') = diff' f x 184 | xn = x - y / y' 185 | in x : 186 | if x == xn 187 | then [] 188 | else go xn 189 | in go 190 | in cubicBezierY 191 | (head (dropWhile ((> epsilon) . abs . subtract x . cubicBezierX) 192 | (findZero (\t -> cubicBezierX t - auto x) x))) 193 | 194 | interpolator 195 | :: Event t Double -> Double -> Behavior t Double 196 | interpolator clock duration = 197 | fmap (cubicBezier (0.23,1) 198 | (0.32,1) 199 | (duration * 1000) . 200 | min 1 . max 0) 201 | (integrate clock (pure (1 / duration))) 202 | 203 | lerp :: Double -> Double -> Double -> Double 204 | lerp a b x = a + (b - a) * x 205 | 206 | linearInterpolator' 207 | :: Event t Double 208 | -> Double 209 | -> Double 210 | -> Event t Double 211 | -> Moment t (Behavior t Double) 212 | linearInterpolator' clock v0 duration transitions = 213 | do trimmedClock <- trimE clock 214 | let animation start target = 215 | anyMoment (do clock' <- now trimmedClock 216 | return (fmap (lerp start target) 217 | (interpolator clock' duration))) 218 | val = 219 | switchB (pure v0) 220 | (animation <$> val <@> transitions) 221 | pure val 222 | 223 | -------------------------------------------------------------------------------- 224 | 225 | data PaperShape 226 | = PaperRounded 227 | | PaperCircle 228 | | PaperRectangle 229 | 230 | data PaperConfig = 231 | PaperConfig {_paperShape :: PaperShape 232 | ,_paperDepth :: Int} 233 | 234 | makeLenses ''PaperConfig 235 | 236 | paper 237 | :: Frameworks t 238 | => State PaperConfig x -> Francium t () -> Francium t () 239 | paper mkPaperConfig = 240 | div_ (style_ (do CSS.backgroundColor CSS.white 241 | "box-sizing" -: "border-box" 242 | "box-shadow" -: 243 | pure (head (drop (paperConfig ^. paperDepth) boxShadows)) 244 | "border-radius" -: 245 | pure (case paperConfig ^. paperShape of 246 | PaperRounded -> "2px" 247 | PaperCircle -> "50%" 248 | _ -> "0"))) 249 | where paperConfig = 250 | execState mkPaperConfig 251 | PaperConfig {_paperShape = PaperRounded 252 | ,_paperDepth = 1} 253 | boxShadows = 254 | ["0 1px 6px rgba(0, 0, 0, 0.12), 0 1px 4px rgba(0, 0, 0, 0.24)" 255 | ,"0 3px 10px rgba(0, 0, 0, 0.16), 0 3px 10px rgba(0, 0, 0, 0.23)" 256 | ,"0 10px 30px rgba(0, 0, 0, 0.19), 0 6px 10px rgba(0, 0, 0, 0.23)" 257 | ,"0 14px 45px rgba(0, 0, 0, 0.25), 0 10px 18px rgba(0, 0, 0, 0.22)" 258 | ,"0 19px 60px rgba(0, 0, 0, 0.30), 0 15px 20px rgba(0, 0, 0, 0.22)"] 259 | 260 | -- -------------------------------------------------------------------------------- 261 | 262 | -- data DialogConfig = 263 | -- DialogConfig {_dialogOpen :: Behavior Bool} 264 | 265 | -- makeLenses ''DialogConfig 266 | 267 | -- dialog :: State DialogConfig a -> Francium () 268 | -- dialog mkDialogConfig = 269 | -- do fullscreenOverlay (fullscreenOverlayActive .= (dialogConfig ^. dialogOpen)) 270 | -- switchMany 271 | -- (tag (edges (dialogConfig ^. dialogOpen)) 272 | -- (div_ (style_ (do CSS.position CSS.fixed 273 | -- CSS.zIndex 10 274 | -- CSS.top (0 CSS.@@ CSS.px) 275 | -- CSS.left (0 CSS.@@ CSS.px) 276 | -- CSS.width (100 CSS.@@ CSS.pct) 277 | -- CSS.height (100 CSS.@@ CSS.pct) 278 | -- "box-sizing" -: "border-box")) 279 | -- newDialog)) 280 | -- where dialogHeader = 281 | -- h3_ (style_ (do CSS.margin (0 CSS.@@ CSS.px) 282 | -- CSS.padding (24 CSS.@@ CSS.px) 283 | -- (24 CSS.@@ CSS.px) 284 | -- (0 CSS.@@ CSS.px) 285 | -- (24 CSS.@@ CSS.px) 286 | -- CSS.fontSize (24 CSS.@@ CSS.px) 287 | -- CSS.lineHeight (32 CSS.@@ CSS.px))) 288 | -- (text_ "static") 289 | -- dialogBody = 290 | -- div_ (style_ (CSS.padding (24 CSS.@@ CSS.px))) "Dialog" 291 | -- renderDialog = 292 | -- paper (paperDepth .= 4) 293 | -- (do dialogHeader 294 | -- dialogBody) 295 | -- newDialog :: Francium (Event ()) 296 | -- newDialog = 297 | -- do clock <- getClock 298 | -- entranceAnimation <- 299 | -- sample (interpolator clock 0.45) 300 | -- dropIn entranceAnimation renderDialog 301 | -- return never 302 | -- dropIn 303 | -- :: Behavior Double -> Francium () -> Francium () 304 | -- dropIn animationAmount content = 305 | -- div_ (style_ (do "box-sizing" -: "border-box" 306 | -- "opacity" -: fmap (fromString . show) animationAmount 307 | -- CSS.position CSS.relative 308 | -- CSS.width (75 CSS.@@ CSS.pct) 309 | -- CSS.margin (0 CSS.@@ CSS.px) 310 | -- CSS.auto 311 | -- CSS.zIndex 10 312 | -- "transform" -: 313 | -- (fmap (("translate3d(0px," <>) . 314 | -- (<> "px,0px)") . fromString . show . lerp 0 64) 315 | -- animationAmount))) 316 | -- content 317 | -- dialogConfig = 318 | -- execState mkDialogConfig 319 | -- DialogConfig {_dialogOpen = 320 | -- pure False} 321 | 322 | -- h3_ :: Term () attrsOrChildren html 323 | -- => attrsOrChildren -> html 324 | -- h3_ = basicElement "h3" 325 | 326 | -------------------------------------------------------------------------------- 327 | 328 | data ButtonConfig = 329 | ButtonConfig {} 330 | 331 | makeLenses ''ButtonConfig 332 | 333 | data Button t = 334 | Button {buttonClicks :: Event t ()} 335 | 336 | button 337 | :: Frameworks t 338 | => State ButtonConfig () -> Francium t () -> Francium t (Button t) 339 | button mkButtonConfig content = 340 | mdo let hovering = 341 | union (True <$ onMouseEnter buttonElement) 342 | (False <$ onMouseLeave buttonElement) 343 | clock <- getClock 344 | backgroundColor <- 345 | fmap (fmap (\t -> 346 | (round (lerp 0 255 t) :: Int,lerp 0.14902 1 t))) 347 | (rb (linearInterpolator' clock 348 | 1 349 | 0.4 350 | (fmap (bool 1 0) hovering))) 351 | rb (reactimate (fmap print hovering)) 352 | buttonElement <- 353 | button_ (style_ (do "border" -: "10px" 354 | "background" -: "none" 355 | "box-sizing" -: "border-box" 356 | "appearance" -: "button" 357 | "cursor" -: "pointer" 358 | "text-decoration" -: "none" 359 | "outline" -: "none" 360 | "letter-spacing" -: "0" 361 | "font-family" -: "Roboto" 362 | "font-weight" -: "500" 363 | "border-radius" -: "2px" 364 | "user-select" -: "none" 365 | "position" -: "relative" 366 | "overflow" -: "hidden" 367 | "background-color" -: 368 | fmap (\(diffuse,alpha) -> 369 | rgba diffuse diffuse diffuse alpha) 370 | backgroundColor 371 | CSS.display CSS.inlineBlock 372 | CSS.fontSize (14 CSS.@@ CSS.px) 373 | CSS.textTransform CSS.uppercase 374 | CSS.position CSS.relative 375 | CSS.overflow CSS.hidden 376 | CSS.lineHeight (36 CSS.@@ CSS.px) 377 | CSS.padding (0 CSS.@@ CSS.px) 378 | CSS.margin (0 CSS.@@ CSS.px) 379 | "transform" -: "translate3d(0, 0, 0)")) 380 | (do div_ (style_ (do CSS.height (100 CSS.@@ CSS.pct) 381 | CSS.width (100 CSS.@@ CSS.pct) 382 | CSS.position CSS.absolute 383 | CSS.top (0 CSS.@@ CSS.px) 384 | CSS.left (0 CSS.@@ CSS.px) 385 | CSS.overflow CSS.hidden)) 386 | (switchMany 387 | (onClick buttonElement) 388 | (\uiEvent -> 389 | liftIO (rippleCSS uiEvent) >>= ripple)) 390 | span_ (style_ (CSS.padding (0 CSS.@@ CSS.px) 391 | (16 CSS.@@ CSS.px))) 392 | content) 393 | return Button {buttonClicks = 394 | void (onClick buttonElement)} 395 | where buttonConfig = 396 | execState mkButtonConfig ButtonConfig {} 397 | rippleCSS :: UIEvent -> IO (CSS t ()) 398 | rippleCSS uiEvent = 399 | do Just el <- 400 | fmap (fmap castToElement) 401 | (getTarget uiEvent) 402 | elHeight <- getOffsetHeight el 403 | elWidth <- getOffsetWidth el 404 | Just document <- currentDocument 405 | Just body <- getBody document 406 | Just boundingClientRect <- getBoundingClientRect el 407 | offset <- 408 | liftA2 (,) 409 | (liftA2 (+) 410 | (getTop boundingClientRect) 411 | (fmap fromIntegral (getScrollTop body))) 412 | (liftA2 (+) 413 | (getLeft boundingClientRect) 414 | (fmap fromIntegral (getScrollLeft body))) 415 | pageX <- 416 | fmap fromIntegral (getPageX uiEvent) 417 | pageY <- 418 | fmap fromIntegral (getPageY uiEvent) 419 | let pointerX = 420 | realToFrac (pageX - (snd offset)) 421 | pointerY = 422 | realToFrac (pageY - (fst offset)) 423 | calcDiag a b = 424 | sqrt ((a * a) + (b * b)) 425 | topLeftDiag = 426 | calcDiag pointerX pointerY 427 | topRightDiag = 428 | calcDiag (elWidth - pointerX) pointerY 429 | botRightDiag = 430 | calcDiag (elWidth - pointerX) 431 | (elHeight - pointerY) 432 | botLeftDiag = 433 | calcDiag pointerX (elHeight - pointerY) 434 | rippleRadius = 435 | maximum [topLeftDiag,topRightDiag,botRightDiag,botLeftDiag] 436 | rippleSize = rippleRadius * 2 437 | return (do CSS.height (pure rippleSize CSS.@@ CSS.px) 438 | CSS.width (pure rippleSize CSS.@@ CSS.px) 439 | CSS.top (pure (pointerY - rippleRadius) CSS.@@ CSS.px) 440 | CSS.left (pure (pointerX - rippleRadius) CSS.@@ CSS.px)) 441 | 442 | rgba :: (Show a,Integral a,Num a,Num b,Show b) 443 | => a -> a -> a -> b -> JSString 444 | rgba r g b a = 445 | fromString 446 | ("rgba(" ++ 447 | show r ++ "," ++ show g ++ "," ++ show b ++ "," ++ show a ++ ")") 448 | 449 | span_ :: Term arg result 450 | => arg -> result 451 | span_ = basicElement "span" 452 | 453 | data ButtonElement t = 454 | ButtonElement {onClick :: Event t UIEvent 455 | ,onMouseEnter :: Event t UIEvent 456 | ,onMouseLeave :: Event t UIEvent} 457 | 458 | button_ 459 | :: Frameworks t 460 | => Attribute t () -> Francium t a -> Francium t (ButtonElement t) 461 | button_ attrs contents = do 462 | basicElement 463 | "button" 464 | attrs 465 | (do _ <- contents 466 | node <- domNode 467 | ButtonElement <$> 468 | domEvStream (castToHTMLButtonElement node) 469 | "click" <*> 470 | domEvStream (castToHTMLButtonElement node) 471 | "mouseenter" <*> 472 | domEvStream (castToHTMLButtonElement node) 473 | "mouseleave") 474 | 475 | domEvStream 476 | :: (Frameworks t, IsGObject a) 477 | => a -> String -> Francium t (Event t UIEvent) 478 | domEvStream node event = 479 | do (evstream,fire) <- rb newEvent 480 | rb (liftIOLater 481 | (do eventListener <- eventListenerNew fire 482 | addEventListener (castToHTMLButtonElement node) 483 | event 484 | (Just eventListener) 485 | False)) 486 | -- _ <- 487 | -- plan (tag destroyed (liftIO (eventListenerRelease eventListener))) 488 | return evstream 489 | 490 | -------------------------------------------------------------------------------- 491 | ripple :: Frameworks t => CSS t () -> Francium t (Event t ()) 492 | ripple extraStyle = 493 | do clock <- getClock 494 | let opacityAnimation = interpolator clock 2 495 | let scaleAnimation = interpolator clock 1 496 | div_ (style_ (do CSS.position CSS.absolute 497 | CSS.top (-30 CSS.@@ CSS.px) 498 | CSS.left (-3 CSS.@@ CSS.px) 499 | CSS.height (100 CSS.@@ CSS.px) 500 | CSS.width (100 CSS.@@ CSS.px) 501 | "opacity" -: 502 | fmap (fromString . show . lerp 0.16 0) opacityAnimation 503 | "border-radius" -: "50%" 504 | "background-color" -: "rgba(0,0,0,222)" 505 | "transform" -: 506 | fmap (("scale(" <>) . 507 | (<> ")") . fromString . show . lerp 0 1) 508 | scaleAnimation 509 | extraStyle)) 510 | mempty 511 | return (void (filterE (> 2) (integrate clock 1 <@ clock))) 512 | 513 | -------------------------------------------------------------------------------- 514 | 515 | main :: IO () 516 | main = francium materialUIDemo 517 | 518 | materialUIDemo :: Frameworks t => Francium t () 519 | materialUIDemo = 520 | getClock >>= text_ . fmap (fromString . show) . stepper 0 521 | -- do render <- Francium (asks onRender) 522 | -- let contents = accumB 0 . fmap (const (+1)) $ render 523 | -- --text_ contents 524 | -- rb $ reactimate $ fmap print (contents <@ render) 525 | 526 | -- mdo paper def 527 | -- (mdo traceM "link_" 528 | -- link_ (do href_ "http://fonts.googleapis.com/css?family=Roboto:400,300,500" 529 | -- rel_ "stylesheet" 530 | -- type_ "text/css") 531 | -- b <- 532 | -- button_ mempty 533 | -- (text_ (fmap (fromString . show) 534 | -- (stepper False (tag (onClick b) True)))) 535 | -- traceM "avatar" 536 | -- avatar (avatarBackgroundColor .= "salmon") 537 | -- (AvatarImg "http://www.unixstickers.com/image/cache/data/stickers/haskell/Haskell.sh-600x600.png") 538 | -- traceM "showDialog" 539 | -- -- ripple (return ()) 540 | -- showDialogButton <- 541 | -- button def "Show Dialog" 542 | -- -- dialogIsOpen <- 543 | -- -- sample (fromChanges False 544 | -- -- (True <$ buttonClicks showDialogButton)) 545 | -- traceM "switchMany" 546 | -- switchMany 547 | -- (buttonClicks showDialogButton) 548 | -- (const (do div_ "Ouch!" 549 | -- return never)) 550 | -- -- dialog (dialogOpen .= dialogIsOpen)) 551 | -- traceM "getClock" 552 | -- clock <- getClock 553 | -- traceM "clock" 554 | -- text_ (fmap (fromString . show) 555 | -- (accumB 0 (fmap (+) clock))) 556 | -- return ()) 557 | 558 | link_ :: Frameworks t => Attribute t () -> Francium t () 559 | link_ attrs = basicElement "link" attrs mempty 560 | 561 | rel_, href_ :: Frameworks t => Behavior t JSString -> Attribute t () 562 | href_ = basicAttribute "href" 563 | rel_ = basicAttribute "rel" 564 | -------------------------------------------------------------------------------- /material/Memo1.hs: -------------------------------------------------------------------------------- 1 | module Memo1 2 | ( memo -- :: (a -> b) -> a -> b 3 | , memoSized -- :: Int -> (a -> b) -> a -> b 4 | ) 5 | where 6 | 7 | import System.Mem.StableName ( StableName, makeStableName, hashStableName ) 8 | import System.Mem.Weak ( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize ) 9 | import Data.Array.IO ( IOArray, newArray, readArray, writeArray ) 10 | import System.IO.Unsafe ( unsafePerformIO ) 11 | import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar ) 12 | 13 | type MemoTable key val 14 | = MVar ( 15 | Int, -- current table size 16 | IOArray Int [MemoEntry key val] -- hash table 17 | ) 18 | 19 | -- a memo table entry: compile with -funbox-strict-fields to eliminate 20 | -- the boxes around the StableName and Weak fields. 21 | data MemoEntry key val = MemoEntry !(StableName key) !(Weak val) 22 | 23 | memo :: (a -> b) -> a -> b 24 | memo f = memoSized default_table_size f 25 | 26 | default_table_size = 1001 27 | 28 | -- Our memo functions are *strict*. Lazy memo functions tend to be 29 | -- less useful because it is less likely you'll get a memo table hit 30 | -- for a thunk. This change was made to match Hugs's Memo 31 | -- implementation, and as the result of feedback from Conal Elliot 32 | -- . 33 | 34 | memoSized :: Int -> (a -> b) -> a -> b 35 | memoSized size f = strict (lazyMemoSized size f) 36 | 37 | strict = ($!) 38 | 39 | lazyMemoSized :: Int -> (a -> b) -> a -> b 40 | lazyMemoSized size f = 41 | let (table,weak) = unsafePerformIO ( 42 | do { tbl <- newArray (0,size) [] 43 | ; mvar <- newMVar (size,tbl) 44 | ; weak <- mkWeakPtr mvar (Just (table_finalizer tbl size)) 45 | ; return (mvar,weak) 46 | }) 47 | in memo' f table weak 48 | 49 | table_finalizer :: IOArray Int [MemoEntry key val] -> Int -> IO () 50 | table_finalizer table size = 51 | sequence_ [ finalizeBucket i | i <- [0..size] ] 52 | where 53 | finalizeBucket i = do 54 | bucket <- readArray table i 55 | sequence_ [ finalize w | MemoEntry _ w <- bucket ] 56 | 57 | memo' :: (a -> b) -> MemoTable a b -> Weak (MemoTable a b) -> a -> b 58 | memo' f ref weak_ref = \k -> unsafePerformIO $ do 59 | stable_key <- makeStableName k 60 | (size, table) <- takeMVar ref 61 | let hash_key = hashStableName stable_key `mod` size 62 | bucket <- readArray table hash_key 63 | lkp <- lookupSN stable_key bucket 64 | 65 | case lkp of 66 | Just result -> do 67 | putMVar ref (size,table) 68 | return result 69 | Nothing -> do 70 | let result = f k 71 | weak <- mkWeak k result (Just (finalizer hash_key stable_key weak_ref)) 72 | writeArray table hash_key (MemoEntry stable_key weak : bucket) 73 | putMVar ref (size,table) 74 | return result 75 | 76 | finalizer :: Int -> StableName a -> Weak (MemoTable a b) -> IO () 77 | finalizer hash_key stable_key weak_ref = 78 | do r <- deRefWeak weak_ref 79 | case r of 80 | Nothing -> return () 81 | Just mvar -> do 82 | (size,table) <- takeMVar mvar 83 | bucket <- readArray table hash_key 84 | let new_bucket = [ e | e@(MemoEntry sn weak) <- bucket, 85 | sn /= stable_key ] 86 | writeArray table hash_key new_bucket 87 | putMVar mvar (size,table) 88 | 89 | lookupSN :: StableName key -> [MemoEntry key val] -> IO (Maybe val) 90 | lookupSN sn [] = sn `seq` return Nothing -- make it strict in sn 91 | lookupSN sn (MemoEntry sn' weak : xs) 92 | | sn == sn' = do maybe_item <- deRefWeak weak 93 | case maybe_item of 94 | Nothing -> error ("dead weak pair: " ++ 95 | show (hashStableName sn)) 96 | Just v -> return (Just v) 97 | | otherwise = lookupSN sn xs 98 | -------------------------------------------------------------------------------- /material/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, base, francium, ghcjs-base, mtl, reactive-banana, stdenv, transformers, lens, ad 2 | }: 3 | mkDerivation { 4 | pname = "material-ui"; 5 | version = "0.1"; 6 | src = ./.; 7 | isLibrary = false; 8 | isExecutable = true; 9 | buildDepends = [ 10 | base francium ghcjs-base mtl reactive-banana transformers lens ad 11 | ]; 12 | license = stdenv.lib.licenses.unfree; 13 | } 14 | -------------------------------------------------------------------------------- /material/default.nix.1: -------------------------------------------------------------------------------- 1 | { system ? null, config ? null }: 2 | let overrideCabal = drv: f: if drv == null then null else (drv.override (args: args // { 3 | mkDerivation = drv: args.mkDerivation (drv // f drv); 4 | })) // { 5 | overrideScope = scope: overrideCabal (drv.overrideScope scope) f; 6 | }; 7 | nixpkgs = import ./nixpkgs ({ 8 | config.allowUnfree = true; 9 | } // ( 10 | if system == null then {} else { inherit system; } 11 | ) // ( 12 | if config == null then {} else { inherit config; } 13 | )); 14 | hspecGit = nixpkgs.fetchgit { 15 | url = git://github.com/ryantrinkle/hspec; 16 | rev = "937c0ae61d70dcd71c35a170b800c30f14a5bc9c"; 17 | sha256 = "1819d5b3f973b432339256ba783b33ada691a785d059e83009e5e2edc6178f6d"; 18 | }; 19 | combineOverrides = old: new: (old // new) // { 20 | overrides = self: super: 21 | let oldOverrides = old.overrides self super; 22 | in oldOverrides // new.overrides self (super // oldOverrides); 23 | }; 24 | makeRecursivelyOverridable = x: old: x.override old // { 25 | override = new: makeRecursivelyOverridable x (combineOverrides old new); 26 | }; 27 | extendHaskellPackages = haskellPackages: makeRecursivelyOverridable haskellPackages { 28 | overrides = self: super: { 29 | ######################################################################## 30 | # Reflex packages 31 | ######################################################################## 32 | reflex = self.callPackage ./reflex {}; 33 | reflex-dom = self.callPackage ./reflex-dom {}; 34 | reflex-todomvc = self.callPackage ./reflex-todomvc {}; 35 | 36 | ######################################################################## 37 | # ghcjs-boot packages 38 | ######################################################################## 39 | aeson = overrideCabal super.aeson (drv: { 40 | version = "0.9.0.1"; 41 | sha256 = "1g7qdq7zpyvqwmh4sfhizqpb51cg24lrcj9vq5msz8k896y7vfcj"; 42 | }); 43 | async = overrideCabal super.async (drv: { 44 | version = "2.0.1.6"; 45 | sha256 = "06fzkqjliccxqiygms7v1xff3wlkg54n9xwzv7m1yxylkzlikjkz"; 46 | jailbreak = true; 47 | }); 48 | attoparsec = overrideCabal super.attoparsec (drv: { 49 | version = "0.13.0.0"; 50 | sha256 = "12b4xi6nlnhpwz8apn4mk880mkhcv1sfvf4j3z1h5dgkadi2zgbi"; 51 | }); 52 | case-insensitive = overrideCabal super.case-insensitive (drv: { 53 | version = "1.2.0.4"; 54 | sha256 = "07nm40r9yw2p9qsfp3pjbsmyn4dabrxw34p48171zmccdd5hv0v3"; 55 | }); 56 | dlist = overrideCabal super.dlist (drv: { 57 | version = "0.7.1.1"; 58 | sha256 = "1zayvxvkan2s2ixajdr3f5rn1gzhprzv6cww4cbpwjhzw0l7zc08"; 59 | }); 60 | extensible-exceptions = overrideCabal super.extensible-exceptions (drv: { 61 | version = "0.1.1.3"; 62 | sha256 = "1i8rjfczsx1wjfaq423a7cp7qrnxh053865z7bg6hwhk2pxsrxkm"; 63 | }); 64 | hashable = overrideCabal super.hashable (drv: { 65 | version = "1.2.3.2"; 66 | sha256 = "0h9295pv2sgbaqlwpwbx2bap6nngm0jcdhkqham1wpjwyxqgqrlc"; 67 | }); 68 | mtl = overrideCabal super.mtl (drv: { 69 | version = "2.2.1"; 70 | sha256 = "1icdbj2rshzn0m1zz5wa7v3xvkf6qw811p4s7jgqwvx1ydwrvrfa"; 71 | }); 72 | old-locale = overrideCabal super.old-locale (drv: { 73 | version = "1.0.0.7"; 74 | sha256 = "0l3viphiszvz5wqzg7a45zp40grwlab941q5ay29iyw8p3v8pbyv"; 75 | }); 76 | old-time = overrideCabal super.old-time (drv: { 77 | version = "1.1.0.3"; 78 | sha256 = "1h9b26s3kfh2k0ih4383w90ibji6n0iwamxp6rfp2lbq1y5ibjqw"; 79 | }); 80 | parallel = overrideCabal super.parallel (drv: { 81 | version = "3.2.0.6"; 82 | sha256 = "0hp6vf4zxsw6vz6lj505xihmnfhgjp39c9q7nyzlgcmps3xx6a5r"; 83 | }); 84 | primitive = overrideCabal super.primitive (drv: { 85 | version = "0.5.4.0"; 86 | sha256 = "05gdgj383xdrdkhxh26imlvs8ji0z28ny38ms9snpvv5i8l2lg10"; 87 | }); 88 | scientific = overrideCabal super.scientific (drv: { 89 | version = "0.3.3.3"; 90 | sha256 = "1hngkmd1kggc84sz4mddc0yj2vyzc87dz5dkkywjgxczys51mhqn"; 91 | jailbreak = true; 92 | }); 93 | stm = overrideCabal super.stm (drv: { 94 | version = "2.4.4"; 95 | sha256 = "0gc8zvdijp3rwmidkpxv76b4i0dc8dw6nbd92rxl4vxl0655iysx"; 96 | }); 97 | syb = overrideCabal super.syb (drv: { 98 | version = "0.5.1"; 99 | sha256 = "0iiqz5mamk1nsij99rypms7dhx5flm2n02k1x6miqgnhg075zc41"; 100 | }); 101 | unordered-containers = overrideCabal super.unordered-containers (drv: { 102 | version = "0.2.5.1"; 103 | sha256 = "06l1xv7vhpxly75saxdrbc6p2zlgz1az278arfkz4rgawfnphn3f"; 104 | }); 105 | vector = overrideCabal super.vector (drv: { 106 | version = "0.10.12.2"; 107 | sha256 = "01hc71k1z9m0g0dv4zsvq5d2dvbgyc5p01hryw5c53792yi2fm25"; 108 | }); 109 | 110 | ######################################################################## 111 | # Other packages 112 | ######################################################################## 113 | hspec = overrideCabal super.hspec (drv: { 114 | version = "2.1.8"; 115 | src = hspecGit; 116 | }); 117 | hspec-core = overrideCabal super.hspec-core (drv: { 118 | version = "2.1.9"; 119 | src = hspecGit + "/hspec-core"; 120 | preConfigure = '' 121 | rm LICENSE 122 | touch LICENSE 123 | ''; 124 | }); 125 | hspec-discover = overrideCabal super.hspec-discover (drv: { 126 | version = "2.1.9"; 127 | src = hspecGit + "/hspec-discover"; 128 | preConfigure = '' 129 | rm LICENSE 130 | touch LICENSE 131 | ''; 132 | }); 133 | hspec-expectations = overrideCabal super.hspec-expectations (drv: { 134 | version = "0.7.0"; 135 | sha256 = "1gzjnmhi6ia2p5i5jlnj4586rkml5af8f7ijgipzs6fczpx7ds4l"; 136 | }); 137 | ghcjs-jquery = self.callPackage ({ mkDerivation, data-default, ghcjs-base, ghcjs-dom, text }: 138 | mkDerivation { 139 | pname = "ghcjs-jquery"; 140 | version = "0.1.0.0"; 141 | src = nixpkgs.fetchgit { 142 | url = git://github.com/ghcjs/ghcjs-jquery; 143 | rev = "c5eeeafcf81c0d3237b8b9fcb98c4b3633a1297f"; 144 | sha256 = "3b2de54224963ee17857a9737b65d49edc423e06ad7e9c9b85d9f69ca923676a"; 145 | }; 146 | buildDepends = [ 147 | data-default ghcjs-base ghcjs-dom text 148 | ]; 149 | jailbreak = true; 150 | license = null; 151 | } 152 | ) {}; 153 | thyme = overrideCabal super.thyme (drv: { 154 | doCheck = false; 155 | }); 156 | orgmode-parse = overrideCabal super.orgmode-parse (with self; drv: { 157 | version = "0.1.0.4"; 158 | sha256 = "098zl8nyph459zyla0y2mkqiy78zp74yzadrnwa6xv07i5zs125h"; 159 | buildDepends = [ 160 | aeson attoparsec free hashable text thyme unordered-containers 161 | ]; 162 | testDepends = [ 163 | aeson attoparsec hashable HUnit tasty tasty-hunit text thyme 164 | unordered-containers 165 | ]; 166 | doCheck = false; 167 | }); 168 | twitter-types = overrideCabal super.twitter-types (drv: { 169 | doCheck = false; 170 | }); 171 | twitter-types-lens = overrideCabal super.twitter-types-lens (drv: { 172 | doCheck = false; 173 | }); 174 | HaskellForMaths = overrideCabal super.HaskellForMaths (drv: { 175 | version = "0.4.8"; 176 | sha256 = "0yn2nj6irmj24j1djvnnq26i2lbf9g9x1wdhmcrk519glcn5k64j"; 177 | buildDepends = [ self.semigroups ] ++ drv.buildDepends; # For some reason, without the spurious import of self.semigroups, HaskellForMaths will fail to build the environment for HaskellForMaths on ghcjs (it works on ghc) 178 | }); 179 | dependent-sum-template = overrideCabal super.dependent-sum-template (drv: { 180 | version = "0.0.0.4"; 181 | sha256 = "103jxzzw3drg7pkgmh39s7258zcwr8ixg8mijm6p33b87a8wdpwr"; 182 | }); 183 | ChasingBottoms = overrideCabal super.ChasingBottoms (drv: { 184 | version = "1.3.0.13"; 185 | sha256 = "1fb86jd6cdz4rx3fj3r9n8d60kx824ywwy7dw4qnrdran46ja3pl"; 186 | }); 187 | doctest = overrideCabal super.doctest (drv: { 188 | version = "0.9.13"; 189 | revision = "1"; 190 | sha256 = "0xl570ay5bw1rpd1aw59c092rnwjbp9qykh2rhpxyvl333p8mg00"; 191 | editedCabalFile = "592ab6d62eca8a0b43930f15c8fb653c54d60983bd232ecc505bd5a5aebe6f7f"; 192 | }); 193 | haskell-src-meta = overrideCabal super.haskell-src-meta (drv: { 194 | version = "0.6.0.10"; 195 | sha256 = "0flcyimibz4flq66isshn2zsmzlly6sja6gfb0a0xn4ns4xpwpy1"; 196 | }); 197 | haddock = overrideCabal super.haddock (drv: { 198 | version = "2.16.1"; 199 | sha256 = "1mnnvc5jqp6n6rj7xw8wdm0z2xp9fndkz11c8p3vbljsrcqd3v26"; 200 | doCheck = false; 201 | }); 202 | haddock-api = overrideCabal super.haddock-api (drv: { 203 | version = "2.16.1"; 204 | sha256 = "1spd5axg1pdjv4dkdb5gcwjsc8gg37qi4mr2k2db6ayywdkis1p2"; 205 | doCheck = false; 206 | }); 207 | haddock-library = overrideCabal super.haddock-library (drv: { 208 | version = "1.2.1"; 209 | sha256 = "0mhh2ppfhrvvi9485ipwbkv2fbgj35jvz3la02y3jlvg5ffs1c8g"; 210 | doCheck = false; 211 | }); 212 | }; 213 | }; 214 | in rec { 215 | inherit nixpkgs overrideCabal; 216 | ghc = extendHaskellPackages nixpkgs.pkgs.haskell-ng.packages.ghc7102; 217 | ghcjsCompiler = ghc.callPackage "${nixpkgs.path}/pkgs/development/compilers/ghcjs" { 218 | ghc = nixpkgs.pkgs.haskell-ng.compiler.ghc7102; 219 | }; 220 | ghcjsPackages = nixpkgs.callPackage "${nixpkgs.path}/pkgs/development/haskell-modules" { 221 | ghc = ghcjsCompiler; 222 | packageSetConfig = nixpkgs.callPackage "${nixpkgs.path}/pkgs/development/haskell-modules/configuration-ghcjs.nix" { }; 223 | }; 224 | 225 | ghcjs = extendHaskellPackages ghcjsPackages; 226 | platforms = [ "ghcjs" ] ++ (if !nixpkgs.stdenv.isDarwin then [ "ghc" ] else []); 227 | 228 | attrsToList = s: map (name: { inherit name; value = builtins.getAttr name s; }) (builtins.attrNames s); 229 | mapSet = f: s: builtins.listToAttrs (map ({name, value}: { 230 | inherit name; 231 | value = f value; 232 | }) (attrsToList s)); 233 | mkSdist = pkg: pkg.override { 234 | mkDerivation = drv: ghc.mkDerivation (drv // { 235 | postConfigure = '' 236 | ./Setup sdist 237 | mkdir "$out" 238 | mv dist/*.tar.gz "$out/${drv.pname}-${drv.version}.tar.gz" 239 | exit 0 240 | ''; 241 | }); 242 | }; 243 | sdists = mapSet mkSdist ghc; 244 | mkHackageDocs = pkg: pkg.override { 245 | mkDerivation = drv: ghc.mkDerivation (drv // { 246 | postConfigure = '' 247 | ./Setup haddock --hoogle --hyperlink-source --html --html-location='/package/${drv.pname}-${drv.version}/docs' --contents-location='/package/${drv.pname}-${drv.version}' --haddock-option=--built-in-themes 248 | cd dist/doc/html 249 | mv "${drv.pname}" "${drv.pname}-${drv.version}-docs" 250 | mkdir "$out" 251 | tar cz --format=ustar -f "$out/${drv.pname}-${drv.version}-docs.tar.gz" "${drv.pname}-${drv.version}-docs" 252 | exit 0 253 | ''; 254 | }); 255 | }; 256 | hackageDocs = mapSet mkHackageDocs ghc; 257 | mkReleaseCandidate = pkg: nixpkgs.stdenv.mkDerivation (rec { 258 | name = pkg.name + "-rc"; 259 | sdist = mkSdist pkg + "/${pkg.pname}-${pkg.version}.tar.gz"; 260 | docs = mkHackageDocs pkg + "/${pkg.pname}-${pkg.version}-docs.tar.gz"; 261 | 262 | builder = builtins.toFile "builder.sh" '' 263 | source $stdenv/setup 264 | 265 | mkdir "$out" 266 | echo -n "${pkg.pname}-${pkg.version}" >"$out/pkgname" 267 | ln -s "$sdist" "$docs" "$out" 268 | ''; 269 | 270 | # 'checked' isn't used, but it is here so that the build will fail if tests fail 271 | checked = overrideCabal pkg (drv: { 272 | doCheck = true; 273 | src = sdist; 274 | }); 275 | }); 276 | releaseCandidates = mapSet mkReleaseCandidate ghc; 277 | 278 | # The systems that we want to build for on the current system 279 | cacheTargetSystems = 280 | if nixpkgs.stdenv.system == "x86_64-linux" 281 | then [ "x86_64-linux" "i686-linux" ] # On linux, we want to build both 32-bit and 64-bit versions 282 | else [ nixpkgs.stdenv.system ]; 283 | } 284 | -------------------------------------------------------------------------------- /material/material.cabal: -------------------------------------------------------------------------------- 1 | name: material-ui 2 | version: 0.1 3 | build-type: Simple 4 | cabal-version: >= 1.20 5 | 6 | executable material-ui 7 | build-depends: 8 | base >= 4 && < 5, 9 | francium, ghcjs-base, transformers, mtl, ghcjs-dom, reactive-banana, lens, ad 10 | default-language: Haskell2010 11 | main-is: Main.hs 12 | ghc-options: -Wall -O2 -------------------------------------------------------------------------------- /material/nixpkgs: -------------------------------------------------------------------------------- 1 | /home/ollie/nixpkgs -------------------------------------------------------------------------------- /material/rb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocharles/Francium/82584a12ff184ad63bd2311f3672967709e57ab2/material/rb -------------------------------------------------------------------------------- /material/rb.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | {-# LANGUAGE BangPatterns #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecursiveDo #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | 10 | module Main where 11 | 12 | import Control.Concurrent 13 | import Control.Event.Handler 14 | import Control.Monad 15 | import Reactive.Banana.Internal.Combinators 16 | import System.Mem 17 | 18 | main :: IO () 19 | main = 20 | do (ah,tick) <- newAddHandler 21 | network <- 22 | compile (do render <- fromAddHandler ah 23 | addReactimate 24 | (applyE (mapB (\x _ -> 25 | return (print x)) 26 | (stepperB 0 render)) 27 | render)) 28 | actuate network 29 | performGC 30 | tick 1 31 | putStrLn "GC" 32 | putStrLn "Done" 33 | tick 2 34 | mapM_ tick [3 .. 10] 35 | -------------------------------------------------------------------------------- /material/shell.nix: -------------------------------------------------------------------------------- 1 | with (import {}).pkgs; 2 | let 3 | try-reflex = import ./try-reflex.nix {}; 4 | modifiedHaskellPackages = try-reflex.ghcjs.override { 5 | overrides = self: super: { 6 | francium = self.callPackage ../rb-2 {}; 7 | todo-mvc = self.callPackage ./. {}; 8 | virtual-dom = self.callPackage ../../virtual-dom {}; 9 | frpnow = self.callPackage ../../frpnow {}; 10 | reactive-banana = self.callPackage ../../reactive-banana/reactive-banana {}; 11 | }; 12 | }; 13 | in modifiedHaskellPackages.todo-mvc.env 14 | -------------------------------------------------------------------------------- /material/try-reflex.nix: -------------------------------------------------------------------------------- 1 | { system ? null, config ? null }: 2 | let overrideCabal = drv: f: if drv == null then null else (drv.override (args: args // { 3 | mkDerivation = drv: args.mkDerivation (drv // f drv); 4 | })) // { 5 | overrideScope = scope: overrideCabal (drv.overrideScope scope) f; 6 | }; 7 | nixpkgs = import ./nixpkgs ({ 8 | config.allowUnfree = true; 9 | } // ( 10 | if system == null then {} else { inherit system; } 11 | ) // ( 12 | if config == null then {} else { inherit config; } 13 | )); 14 | hspecGit = nixpkgs.fetchgit { 15 | url = git://github.com/ryantrinkle/hspec; 16 | rev = "937c0ae61d70dcd71c35a170b800c30f14a5bc9c"; 17 | sha256 = "1819d5b3f973b432339256ba783b33ada691a785d059e83009e5e2edc6178f6d"; 18 | }; 19 | combineOverrides = old: new: (old // new) // { 20 | overrides = self: super: 21 | let oldOverrides = old.overrides self super; 22 | in oldOverrides // new.overrides self (super // oldOverrides); 23 | }; 24 | makeRecursivelyOverridable = x: old: x.override old // { 25 | override = new: makeRecursivelyOverridable x (combineOverrides old new); 26 | }; 27 | extendHaskellPackages = haskellPackages: makeRecursivelyOverridable haskellPackages { 28 | overrides = self: super: { 29 | reflex = self.callPackage ./reflex {}; 30 | reflex-dom = self.callPackage ./reflex-dom {}; 31 | reflex-todomvc = self.callPackage ./reflex-todomvc {}; 32 | these = overrideCabal super.these (drv: { 33 | version = "0.5.0.0"; 34 | src = nixpkgs.fetchgit { 35 | url = git://github.com/ryantrinkle/these; 36 | rev = "36e7dc3e55c85b2d501c7ddc5e77a9a6bb522db2"; 37 | sha256 = "8841dd7426ad5e0edd05599a0896a6033043f8fa7faf6f7f4c6f88ef1d0209c7"; 38 | }; 39 | revision = null; 40 | editedCabalFile = null; 41 | }); 42 | lens = overrideCabal super.lens (drv: { 43 | version = "4.12.3"; 44 | sha256 = "0898z1ws9sy77yfhvx5did0pibpp81yxz0jg418gdx3znd39vyj8"; 45 | }); 46 | profunctors = overrideCabal super.profunctors (drv: { 47 | version = "5.1.1"; 48 | sha256 = "0lw2ipacpnp9yqmi8zsp01pzpn5hwj8af3y0f3079mddrmw48gw7"; 49 | revision = null; 50 | editedCabalFile = null; 51 | }); 52 | bifunctors = overrideCabal super.bifunctors (drv: { 53 | version = "5"; 54 | sha256 = "13990xdgx0n23qgi18ghhmsywj5zkr0a5bim0g8a4nzi0cx95ps1"; 55 | buildDepends = with self; [ 56 | semigroups 57 | tagged 58 | ]; 59 | }); 60 | reflection = overrideCabal super.reflection (drv: { 61 | version = "2"; 62 | sha256 = "1hlrji6wyqr892a78px7wilhywyiqdfdmnr7zp4c641qks4rw6gf"; 63 | }); 64 | adjunctions = overrideCabal super.adjunctions (drv: { 65 | version = "4.2.1"; 66 | sha256 = "0vzlz2q6863ywnhvax3m5xq99x6bz1h47z7z8hmnqdfg5pa4r9k5"; 67 | }); 68 | kan-extensions = overrideCabal super.kan-extensions (drv: { 69 | version = "4.2.2"; 70 | sha256 = "0dqqlrzrhz8di5hp4kby3205inpj2r30bl75zyy24nq4hgans7g5"; 71 | revision = null; 72 | editedCabalFile = null; 73 | }); 74 | free = overrideCabal super.free (drv: { 75 | version = "4.12.1"; 76 | sha256 = "0sr8phvrb4ny8j1wzq55rdn8q4br23q4pw2j276npr844825jr9p"; 77 | buildDepends = drv.buildDepends ++ (with self; [ 78 | exceptions 79 | ]); 80 | }); 81 | semigroupoids = overrideCabal super.semigroupoids (drv: { 82 | version = "5.0.0.2"; 83 | sha256 = "14q7284gq44h86j6jxi7pz1hxwfal0jgv6i2j1v2hdzqfnd8z5sw"; 84 | revision = null; 85 | editedCabalFile = null; 86 | buildDepends = drv.buildDepends ++ (with self; [ 87 | base-orphans 88 | bifunctors 89 | ]); 90 | }); 91 | comonad = overrideCabal super.comonad (drv: { 92 | version = "4.2.7.2"; 93 | sha256 = "0arvbaxgkawzdp38hh53akkahjg2aa3kj2b4ns0ni8a5ylg2cqmp"; 94 | }); 95 | either = overrideCabal super.either (drv: { 96 | version = "4.4.1"; 97 | sha256 = "1jq9b7mwljyqxmcs09bnqzza6710sfk2x444p3aagjlvq3mpvrci"; 98 | buildDepends = drv.buildDepends ++ (with self; [ 99 | mmorph 100 | ]); 101 | }); 102 | monoid-extras = overrideCabal super.monoid-extras (drv: { 103 | version = "0.4.0.1"; 104 | sha256 = "0jcyjqmk4s64j05qisvibmy87m5xi5n837wsivq7lml8lfyrj7yf"; 105 | }); 106 | linear = overrideCabal super.linear (drv: { 107 | version = "1.19.1.3"; 108 | sha256 = "1hprmhs1nm6l81kpnnznz92l66j10z4asn3g3l9c47165q881592"; 109 | }); 110 | vector-algorithms = overrideCabal super.vector-algorithms (drv: { 111 | jailbreak = true; 112 | }); 113 | vector = overrideCabal super.vector (drv: { 114 | version = "0.11.0.0"; 115 | sha256 = "1r1jlksy7b0kb0fy00g64isk6nyd9wzzdq31gx5v1wn38knj0lqa"; 116 | }); 117 | ghcjs-dom = overrideCabal super.ghcjs-dom (drv: { 118 | version = "0.2.1.0"; 119 | src = nixpkgs.fetchgit { 120 | url = git://github.com/ghcjs/ghcjs-dom; 121 | rev = "d6eb927ae279071495f5edd7413bef517508bc7d"; 122 | sha256 = "c5cc066fd16a7838b6cb51d151d8d01264ac682228fd1730a9f08cf3437c6f3c"; 123 | }; 124 | }); 125 | webkitgtk3 = overrideCabal super.webkitgtk3 (drv: { 126 | version = "0.14.1.0"; 127 | src = nixpkgs.fetchgit { 128 | url = git://github.com/gtk2hs/webkit; 129 | rev = "482e30764bcfd8207347fd71027d4c8e1f423ee4"; 130 | sha256 = "280eae67462787cc737ddf56178c54a9f6f2c7d308366e2dbe638c331d6e3a1b"; 131 | }; 132 | }); 133 | webkitgtk3-javascriptcore = overrideCabal super.webkitgtk3-javascriptcore (drv: { 134 | version = "0.13.1.0"; 135 | src = nixpkgs.fetchgit { 136 | url = git://github.com/gtk2hs/webkit-javascriptcore; 137 | rev = "555064049fadd0a83a72d315232040efce1fd0bd"; 138 | sha256 = "04f12913d7d4a9818f3fe0c27dd57489a41adf59d8fffdf9eaced084feb34d05"; 139 | }; 140 | }); 141 | hspec = overrideCabal super.hspec (drv: { 142 | version = "2.1.8"; 143 | src = hspecGit; 144 | }); 145 | hspec-core = overrideCabal super.hspec-core (drv: { 146 | version = "2.1.9"; 147 | src = hspecGit + "/hspec-core"; 148 | preConfigure = '' 149 | rm LICENSE 150 | touch LICENSE 151 | ''; 152 | }); 153 | hspec-discover = overrideCabal super.hspec-discover (drv: { 154 | version = "2.1.9"; 155 | src = hspecGit + "/hspec-discover"; 156 | preConfigure = '' 157 | rm LICENSE 158 | touch LICENSE 159 | ''; 160 | }); 161 | hspec-expectations = overrideCabal super.hspec-expectations (drv: { 162 | version = "0.7.0"; 163 | sha256 = "1gzjnmhi6ia2p5i5jlnj4586rkml5af8f7ijgipzs6fczpx7ds4l"; 164 | }); 165 | ghcjs-jquery = self.callPackage ({ mkDerivation, data-default, ghcjs-base, ghcjs-dom, text }: 166 | mkDerivation { 167 | pname = "ghcjs-jquery"; 168 | version = "0.1.0.0"; 169 | src = nixpkgs.fetchgit { 170 | url = git://github.com/ghcjs/ghcjs-jquery; 171 | rev = "c5eeeafcf81c0d3237b8b9fcb98c4b3633a1297f"; 172 | sha256 = "3b2de54224963ee17857a9737b65d49edc423e06ad7e9c9b85d9f69ca923676a"; 173 | }; 174 | buildDepends = [ 175 | data-default ghcjs-base ghcjs-dom text 176 | ]; 177 | jailbreak = true; 178 | license = null; 179 | } 180 | ) {}; 181 | thyme = overrideCabal super.thyme (drv: { 182 | doCheck = false; 183 | }); 184 | orgmode-parse = overrideCabal super.orgmode-parse (with self; drv: { 185 | version = "0.1.0.4"; 186 | sha256 = "098zl8nyph459zyla0y2mkqiy78zp74yzadrnwa6xv07i5zs125h"; 187 | buildDepends = [ 188 | aeson attoparsec free hashable text thyme unordered-containers 189 | ]; 190 | testDepends = [ 191 | aeson attoparsec hashable HUnit tasty tasty-hunit text thyme 192 | unordered-containers 193 | ]; 194 | doCheck = false; 195 | }); 196 | twitter-types = overrideCabal super.twitter-types (drv: { 197 | doCheck = false; 198 | }); 199 | twitter-types-lens = overrideCabal super.twitter-types-lens (drv: { 200 | doCheck = false; 201 | }); 202 | HaskellForMaths = overrideCabal super.HaskellForMaths (drv: { 203 | version = "0.4.8"; 204 | sha256 = "0yn2nj6irmj24j1djvnnq26i2lbf9g9x1wdhmcrk519glcn5k64j"; 205 | buildDepends = [ self.semigroups ] ++ drv.buildDepends; # For some reason, without the spurious import of self.semigroups, HaskellForMaths will fail to build the environment for HaskellForMaths on ghcjs (it works on ghc) 206 | }); 207 | dependent-sum-template = overrideCabal super.dependent-sum-template (drv: { 208 | version = "0.0.0.4"; 209 | src = nixpkgs.fetchgit { 210 | url = git://github.com/ryantrinkle/dependent-sum-template; 211 | rev = "abcd0f01a3e264e5bc1f3b00f3d03082f091ec49"; 212 | sha256 = "16f95348c559394a39848394a9e1aa8318c79bfc62bc6946edad9aabd20a8e2d"; 213 | }; 214 | }); 215 | diagrams-core = overrideCabal super.diagrams-core (drv: { 216 | jailbreak = true; 217 | }); 218 | diagrams-lib = overrideCabal super.diagrams-lib (drv: { 219 | jailbreak = true; 220 | }); 221 | diagrams-contrib = overrideCabal super.diagrams-contrib (drv: { 222 | jailbreak = true; 223 | }); 224 | force-layout = overrideCabal super.force-layout (drv: { 225 | jailbreak = true; 226 | }); 227 | active = overrideCabal super.active (drv: { 228 | version = "0.2.0.4"; 229 | sha256 = "1xm2y8knqhd883c41194h323vchv4hx57wl32l9f64kf7gdglag0"; 230 | }); 231 | snap = overrideCabal super.snap (drv: { 232 | version = "0.14.0.6"; 233 | sha256 = "05xnil6kfxwrnbvg7sigzh7hl8jsfr8cvbjd41z9ywn6ymxzr7zs"; 234 | revision = null; 235 | editedCabalFile = null; 236 | }); 237 | ad = overrideCabal super.ad (drv: { 238 | version = "4.2.3"; 239 | sha256 = "0w9nd8llzcjb91x1d3mh5482pavbx1jpn8w2ahm6ydjwvijjd9r5"; 240 | }); 241 | }; 242 | }; 243 | in rec { 244 | inherit nixpkgs overrideCabal; 245 | ghc = extendHaskellPackages nixpkgs.pkgs.haskell-ng.packages.ghc7101; 246 | ghcjs = extendHaskellPackages nixpkgs.pkgs.haskell-ng.packages.ghcjs; 247 | platforms = [ "ghcjs" ] ++ (if !nixpkgs.stdenv.isDarwin then [ "ghc" ] else []); 248 | 249 | attrsToList = s: map (name: { inherit name; value = builtins.getAttr name s; }) (builtins.attrNames s); 250 | mapSet = f: s: builtins.listToAttrs (map ({name, value}: { 251 | inherit name; 252 | value = f value; 253 | }) (attrsToList s)); 254 | mkSdist = pkg: pkg.override { 255 | mkDerivation = drv: ghc.mkDerivation (drv // { 256 | postConfigure = '' 257 | ./Setup sdist 258 | mkdir "$out" 259 | mv dist/*.tar.gz "$out/${drv.pname}-${drv.version}.tar.gz" 260 | exit 0 261 | ''; 262 | }); 263 | }; 264 | sdists = mapSet mkSdist ghc; 265 | mkHackageDocs = pkg: pkg.override { 266 | mkDerivation = drv: ghc.mkDerivation (drv // { 267 | postConfigure = '' 268 | ./Setup haddock --hoogle --hyperlink-source --html --html-location='/package/${drv.pname}-${drv.version}/docs' --contents-location='/package/${drv.pname}-${drv.version}' --haddock-option=--built-in-themes 269 | cd dist/doc/html 270 | mv "${drv.pname}" "${drv.pname}-${drv.version}-docs" 271 | mkdir "$out" 272 | tar cz --format=ustar -f "$out/${drv.pname}-${drv.version}-docs.tar.gz" "${drv.pname}-${drv.version}-docs" 273 | exit 0 274 | ''; 275 | }); 276 | }; 277 | hackageDocs = mapSet mkHackageDocs ghc; 278 | mkReleaseCandidate = pkg: nixpkgs.stdenv.mkDerivation (rec { 279 | name = pkg.name + "-rc"; 280 | sdist = mkSdist pkg + "/${pkg.pname}-${pkg.version}.tar.gz"; 281 | docs = mkHackageDocs pkg + "/${pkg.pname}-${pkg.version}-docs.tar.gz"; 282 | 283 | builder = builtins.toFile "builder.sh" '' 284 | source $stdenv/setup 285 | 286 | mkdir "$out" 287 | echo -n "${pkg.pname}-${pkg.version}" >"$out/pkgname" 288 | ln -s "$sdist" "$docs" "$out" 289 | ''; 290 | 291 | # 'checked' isn't used, but it is here so that the build will fail if tests fail 292 | checked = overrideCabal pkg (drv: { 293 | doCheck = true; 294 | src = sdist; 295 | }); 296 | }); 297 | releaseCandidates = mapSet mkReleaseCandidate ghc; 298 | 299 | # The systems that we want to build for on the current system 300 | cacheTargetSystems = 301 | if nixpkgs.stdenv.system == "x86_64-linux" 302 | then [ "x86_64-linux" "i686-linux" ] # On linux, we want to build both 32-bit and 64-bit versions 303 | else [ nixpkgs.stdenv.system ]; 304 | } 305 | -------------------------------------------------------------------------------- /material/weak.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MagicHash, UnboxedTuples #-} 2 | import Control.Monad 3 | import Control.Concurrent 4 | import Data.IORef 5 | import System.Mem.Weak 6 | import qualified GHC.Base as GHC 7 | import qualified GHC.IORef as GHC 8 | import qualified GHC.STRef as GHC 9 | import qualified GHC.Weak as GHC 10 | 11 | main :: IO () 12 | main = do 13 | ref <- newIORef "Hello" 14 | weak <- mkWeakIORefValueFinalizer ref True (putStrLn "You shouldn't see me") 15 | forever (threadDelay maxBound) 16 | readIORef ref >>= print 17 | 18 | mkWeakIORefValueFinalizer :: IORef a -> value -> IO () -> IO (Weak value) 19 | mkWeakIORefValueFinalizer r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s -> 20 | case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) 21 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | with (import {}).pkgs; 2 | let overrideCabal = drv: f: if drv == null then null else (drv.override (args: 3 | args // { 4 | mkDerivation = drv: args.mkDerivation (drv // f drv); 5 | })) // { 6 | overrideScope = scope: overrideCabal (drv.overrideScope 7 | scope) f; 8 | }; 9 | modifiedHaskellPackages = haskell-ng.packages.ghcjs.override { 10 | overrides = self: super: { 11 | francium = self.callPackage ./. {}; 12 | frpnow = self.callPackage ../../frpnow {}; 13 | reactive-banana = self.callPackage ../../reactive-banana/reactive-banana {}; 14 | ghcjs-base = overrideCabal super.ghcjs-base (drv: { 15 | src = /home/ollie/work/ghcjs/ghcjs-base; 16 | }); 17 | ghcjs-dom = overrideCabal super.ghcjs-dom (drv: { 18 | version = "0.2.1.0"; 19 | src = fetchgit { 20 | url = git://github.com/ghcjs/ghcjs-dom; 21 | rev = "d6eb927ae279071495f5edd7413bef517508bc7d"; 22 | sha256 = "c5cc066fd16a7838b6cb51d151d8d01264ac682228fd1730a9f08cf3437c6f3c"; 23 | }; 24 | }); 25 | }; 26 | }; 27 | in 28 | modifiedHaskellPackages.francium.env 29 | -------------------------------------------------------------------------------- /src/Francium.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE RecursiveDo #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Francium where 13 | 14 | import Control.Concurrent 15 | import Debug.Trace 16 | import Control.Monad.IO.Class 17 | import Control.Monad.Reader 18 | import Control.Monad.Trans.Reader (ReaderT(..)) 19 | import Control.Monad.Trans.Writer.Strict 20 | (WriterT(..), execWriterT, Writer, execWriter) 21 | import Control.Monad.Writer (MonadWriter(..)) 22 | import Data.Char 23 | import Data.Coerce 24 | import Data.Foldable 25 | import Data.JSString (pack, unpack) 26 | import Data.Maybe (fromMaybe) 27 | import Data.Monoid 28 | import Data.String 29 | import Data.Unique 30 | import GHCJS.DOM (currentDocument) 31 | import GHCJS.DOM.CSSStyleDeclaration 32 | import GHCJS.DOM.CharacterData (setData) 33 | import GHCJS.DOM.Document (createElement, createTextNode, getBody) 34 | import GHCJS.DOM.Element (getStyle, setAttribute) 35 | import GHCJS.DOM.EventTarget (addEventListener) 36 | import GHCJS.DOM.EventTargetClosures 37 | import GHCJS.DOM.HTMLButtonElement (castToHTMLButtonElement) 38 | import GHCJS.DOM.HTMLInputElement 39 | import GHCJS.DOM.Node 40 | import GHCJS.DOM.Text (Text) 41 | import GHCJS.DOM.Types (IsGObject) 42 | import GHCJS.DOM.Types (Node, castToNode) 43 | import GHCJS.DOM.Types (UIEvent, castToElement) 44 | import GHCJS.Types 45 | import JavaScript.Web.AnimationFrame 46 | import Reactive.Banana 47 | import Reactive.Banana.Frameworks 48 | import System.IO.Unsafe 49 | import System.Mem 50 | 51 | data FranciumEnv t = 52 | FranciumEnv {onRender :: Event t () 53 | ,parentNode :: Node 54 | ,appClock :: Event t Double} 55 | 56 | newtype Francium t a = 57 | Francium {runFrancium :: ReaderT (FranciumEnv t) (WriterT (Behavior t [MarkedNode]) (Moment t)) a} 58 | 59 | instance Monad (Francium t) where 60 | return a = Francium (return a) 61 | Francium a >>= f = 62 | Francium (a >>= runFrancium . f) 63 | 64 | instance Frameworks t => MonadIO (Francium t) where 65 | liftIO m = Francium (liftIO m) 66 | 67 | instance Applicative (Francium t) where 68 | pure = return 69 | (<*>) = ap 70 | 71 | instance Functor (Francium t) where 72 | fmap f (Francium m) = Francium (fmap f m) 73 | 74 | instance MonadFix (Francium t) where 75 | mfix f = Francium (mfix (runFrancium . f)) 76 | 77 | rb :: Frameworks t 78 | => Moment t a -> Francium t a 79 | rb m = Francium (lift (lift m)) 80 | 81 | instance Monoid a => Monoid (Behavior t a) where 82 | mempty = pure mempty 83 | mappend = liftA2 mappend 84 | 85 | text_ :: Frameworks t 86 | => Behavior t JSString -> Francium t () 87 | text_ contents = 88 | do tNode <- 89 | do initialContent <- rb (initial contents) 90 | liftIO (unsafeInterleaveIO (newTextElement initialContent)) -- TODO Still necessary? Arose when trying to read if a button had or hadn't been clicked as the text of a button itself 91 | env <- Francium ask 92 | contentsChanged <- rb (changes contents) 93 | let contentsChangedSinceRender = 94 | stepper False 95 | (fmap or 96 | (collect (union (True <$ contentsChanged) 97 | (False <$ requiresRender)))) 98 | requiresRender = 99 | whenE contentsChangedSinceRender (onRender env) 100 | traceM "Installing render loop" 101 | rb (reactimate 102 | (fmap (setData tNode . Just) 103 | (contents <@ onRender env))) 104 | traceM "Marking" 105 | markedElem <- mark (castToNode tNode) 106 | traceM "All done" 107 | Francium (tell (pure [markedElem])) 108 | 109 | tag :: Functor f 110 | => f b -> a -> f a 111 | tag a b = b <$ a 112 | {-# INLINE tag #-} 113 | 114 | data MarkedNode = 115 | MarkedNode {nodeId :: Unique 116 | ,markedNode :: Node} 117 | 118 | instance Eq MarkedNode where 119 | MarkedNode a _ == MarkedNode b _ = a == b 120 | 121 | mark :: MonadIO m 122 | => Node -> m MarkedNode 123 | mark node = 124 | do id_ <- liftIO newUnique 125 | return (MarkedNode id_ 126 | (castToNode node)) 127 | 128 | newTextElement :: MonadIO m 129 | => JSString -> m Text 130 | newTextElement content = 131 | liftIO (do Just document <- currentDocument 132 | Just tnode <- 133 | createTextNode document content 134 | return tnode) 135 | 136 | class Term arg result | result -> arg where 137 | term :: JSString -> arg -> result 138 | 139 | instance (Frameworks t,x ~ Attribute t (),arg ~ Francium t a) => Term x (arg -> Francium t a) where 140 | term = mkElement 141 | 142 | instance (Frameworks t,arg ~ Francium t a) => Term arg (Francium t a) where 143 | term name inner = mkElement name mempty inner 144 | 145 | newtype Attribute t a = 146 | Attribute {runAttribute :: ReaderT (Node,Event t ()) (Moment t) a} 147 | 148 | instance Functor (Attribute t) where 149 | fmap f (Attribute x) = Attribute (fmap f x) 150 | 151 | instance Applicative (Attribute t) where 152 | pure = Attribute . pure 153 | Attribute f <*> Attribute x = 154 | Attribute (f <*> x) 155 | 156 | instance Monad (Attribute t) where 157 | return = Attribute . return 158 | Attribute f >>= m = 159 | Attribute (f >>= runAttribute . m) 160 | 161 | instance (a ~ ()) => Monoid (Attribute t a) where 162 | mempty = Attribute (return mempty) 163 | Attribute l `mappend` Attribute r = 164 | Attribute (liftA2 mappend l r) 165 | 166 | domNode :: Francium t Node 167 | domNode = Francium (asks parentNode) 168 | 169 | newElement :: MonadIO m 170 | => JSString -> m Node 171 | newElement element = 172 | liftIO (do Just document <- currentDocument 173 | Just domNode <- 174 | createElement document 175 | (Just element) 176 | return (castToNode domNode)) 177 | 178 | mkElement 179 | :: Frameworks t 180 | => JSString -> Attribute t () -> Francium t a -> Francium t a 181 | mkElement el (Attribute attributes) inner = 182 | mdo env <- Francium ask 183 | traceM "newElement" 184 | divElement <- newElement el 185 | traceM "runChildren" 186 | (a,children) <- 187 | rb (runWriterT 188 | (runReaderT (runFrancium inner) 189 | env {parentNode = divElement})) 190 | traceM "runAttributes" 191 | _ <- 192 | rb (runReaderT attributes 193 | (divElement,onRender env)) 194 | traceM "initialChildren" 195 | initialChildren <- rb (initial children) 196 | traceM "append children" 197 | rb (liftIOLater 198 | (for_ initialChildren (appendChild divElement . Just . markedNode))) 199 | -- XXX TODO 200 | let lastRenderedChildren = 201 | pure initialChildren 202 | traceM "new children render loop" 203 | rb (reactimate 204 | (fmap (\(newChildren,oldChildren) -> 205 | do traverse_ (appendChild divElement . Just . markedNode) 206 | (filter (not . 207 | (`elem` map nodeId oldChildren) . 208 | nodeId) 209 | newChildren) 210 | traverse_ (removeChild divElement . Just . markedNode) 211 | (filter (not . 212 | (`elem` map nodeId newChildren) . 213 | nodeId) 214 | oldChildren)) 215 | (whenE (liftA2 (/=) children lastRenderedChildren) 216 | (liftA2 (,) children lastRenderedChildren <@ 217 | (onRender env))))) 218 | traceM "mark container" 219 | markedElem <- liftIO (mark divElement) 220 | traceM "tell" 221 | Francium (tell (pure [markedElem])) 222 | traceM "ok" 223 | return a 224 | 225 | mkAttribute :: (Eq v,Show v,Frameworks t) 226 | => (a -> v -> IO ()) 227 | -> (Node -> a) 228 | -> Behavior t v 229 | -> Attribute t () 230 | mkAttribute f cast b = 231 | Attribute (ReaderT (\(node,renders) -> 232 | do initialValue <- initial b 233 | liftIOLater (f (cast node) initialValue) 234 | contentsChanged <- changes b 235 | let contentsChangedSinceRender = 236 | stepper False 237 | (fmap or 238 | (collect (union (True <$ 239 | contentsChanged) 240 | (False <$ 241 | requiresRender)))) 242 | requiresRender = 243 | whenE contentsChangedSinceRender renders 244 | reactimate 245 | (fmap (f (cast node)) 246 | (b <@ requiresRender)))) 247 | 248 | basicAttribute 249 | :: Frameworks t 250 | => JSString -> Behavior t JSString -> Attribute t () 251 | basicAttribute k = 252 | mkAttribute (\e -> setAttribute e k) 253 | castToElement 254 | 255 | type_ :: Frameworks t 256 | => Behavior t JSString -> Attribute t () 257 | type_ = basicAttribute "type" 258 | 259 | basicElement :: Term arg result 260 | => JSString -> arg -> result 261 | basicElement el = term el 262 | 263 | div_, li_, ul_ :: Term attrsOrChildren html 264 | => attrsOrChildren -> html 265 | div_ = basicElement "div" 266 | li_ = basicElement "li" 267 | ul_ = basicElement "ul" 268 | 269 | value_ :: Frameworks t 270 | => Behavior t JSString -> Attribute t () 271 | value_ b = 272 | let Attribute f = 273 | mkAttribute setValue 274 | castToHTMLInputElement 275 | (fmap Just b) 276 | in Attribute (do (node,renders) <- ask 277 | lift (do runReaderT f 278 | (node,renders) 279 | (input,fixInput) <- newEvent 280 | eventListener <- 281 | liftIO (eventListenerNew (const (fixInput ()) :: UIEvent -> IO ())) 282 | liftIOLater 283 | (addEventListener (castToHTMLInputElement node) 284 | ("input" :: JSString) 285 | (Just eventListener) 286 | False) 287 | valueChanged <- changes b 288 | reactimate 289 | (fmap (setValue (castToHTMLInputElement node) . 290 | Just) 291 | (b <@ input)))) 292 | 293 | data InputElement t = 294 | InputElement {onInput :: Event t JSString 295 | ,onChange :: Event t JSString} 296 | 297 | input_ 298 | :: Frameworks t 299 | => Attribute t () -> Francium t (InputElement t) 300 | input_ attrs = 301 | mkElement "input" 302 | attrs 303 | (do node <- domNode 304 | rb (do onInput_ <- 305 | do (input,fireInput) <- newEvent 306 | liftIOLater 307 | (do eventListener <- 308 | eventListenerNew 309 | (const (getValue (castToHTMLInputElement node) >>= 310 | fireInput) :: UIEvent -> IO ()) 311 | addEventListener (castToHTMLInputElement node) 312 | ("input" :: JSString) 313 | (Just eventListener) 314 | False) 315 | return input 316 | onChange_ <- 317 | do (changes,fireChange) <- newEvent 318 | liftIOLater 319 | (do eventListener <- 320 | (eventListenerNew 321 | (const (getValue (castToHTMLInputElement node) >>= 322 | fireChange) :: UIEvent -> IO ())) 323 | addEventListener (castToHTMLInputElement node) 324 | ("change" :: JSString) 325 | (Just eventListener) 326 | False) 327 | return changes 328 | return InputElement {onInput = 329 | fmap (fromMaybe "") onInput_ 330 | ,onChange = 331 | fmap (fromMaybe "") onChange_})) 332 | 333 | francium 334 | :: (forall t. Frameworks t => Francium t a) -> IO () 335 | francium app = 336 | do (ah,tick) <- newAddHandler 337 | let app' :: Frameworks t 338 | => Moment t () 339 | app' = 340 | do body <- 341 | liftIO (do Just document <- currentDocument 342 | Just body <- getBody document 343 | return body) 344 | render <- fromAddHandler ah 345 | let clock = fmap (/ 1000) render 346 | traceM "Building app" 347 | nodes <- 348 | execWriterT 349 | (runReaderT 350 | (runFrancium app) 351 | (FranciumEnv (void render) 352 | (castToNode body) 353 | clock)) 354 | startingNodes <- initial nodes 355 | liftIOLater 356 | (for_ (map markedNode startingNodes) 357 | (appendChild (castToNode body) . Just)) 358 | network <- compile app' 359 | actuate network 360 | forever (do waitForAnimationFrame 361 | tick =<< performanceNow) 362 | 363 | foreign import javascript unsafe 364 | "console.timeStamp($1)" timeStamp :: JSString -> IO () 365 | 366 | foreign import javascript unsafe 367 | "performance.now()" 368 | performanceNow :: IO Double 369 | 370 | newtype CSS t a = 371 | CSS (Writer (Endo [(JSString,Behavior t JSString)]) a) 372 | deriving (Applicative,Functor,Monad,MonadFix) 373 | 374 | instance (a ~ ()) => Monoid (CSS t a) where 375 | mempty = CSS (pure mempty) 376 | {-# INLINE mempty #-} 377 | CSS l `mappend` CSS r = 378 | CSS (liftA2 mappend l r) 379 | {-# INLINE mappend #-} 380 | 381 | infixr 4 -: 382 | (-:) 383 | :: JSString -> Behavior t JSString -> CSS t () 384 | k -: v = CSS (tell (Endo ((k,v) :))) 385 | {-# INLINE (-:) #-} 386 | 387 | style_ :: Frameworks t 388 | => CSS t x -> Attribute t () 389 | style_ (CSS styles) = 390 | Attribute (ReaderT (\(node,renders) -> 391 | do Just cssDecl <- 392 | getStyle (castToElement node) 393 | for_ (appEndo (execWriter styles) []) 394 | (\(k,v) -> 395 | do initialValue <- initial v 396 | liftIOLater 397 | (setProperty cssDecl 398 | k 399 | (Just initialValue) 400 | ("" :: JSString)) 401 | contentsChanged <- changes v 402 | let contentsChangedSinceRender = 403 | stepper False 404 | (fmap or 405 | (collect (union (True <$ 406 | contentsChanged) 407 | (False <$ 408 | requiresRender)))) 409 | requiresRender = 410 | whenE contentsChangedSinceRender renders 411 | reactimate 412 | (fmap (\v' -> 413 | setProperty cssDecl 414 | k 415 | (Just v') 416 | ("" :: JSString)) 417 | (v <@ requiresRender))))) 418 | 419 | instance a ~ () => Monoid (Francium t a) where 420 | mempty = Francium (return ()) 421 | Francium l `mappend` Francium r = 422 | Francium (l >> r) 423 | 424 | instance IsString a => IsString (Behavior t a) where 425 | fromString = pure . fromString 426 | 427 | instance (Frameworks t,a ~ ()) => IsString (Francium t a) where 428 | fromString = text_ . fromString 429 | 430 | getClock :: Francium t (Event t Double) 431 | getClock = Francium (asks appClock) 432 | 433 | switchMany :: Frameworks t 434 | => Event t a 435 | -> (forall tLater. Frameworks tLater => a -> Francium tLater (Event tLater ())) 436 | -> Francium t () 437 | switchMany creations f = 438 | do env <- Francium ask 439 | trimmedRender <- rb (trimE (onRender env)) 440 | trimmedAppClock <- rb (trimE (appClock env)) 441 | moreChildren <- 442 | rb (execute (fmap (\a -> 443 | FrameworksMoment 444 | (do onRender' <- now trimmedRender 445 | appClock' <- now trimmedAppClock 446 | (done,children) <- 447 | runWriterT 448 | (runReaderT 449 | (runFrancium (f a)) 450 | FranciumEnv {onRender = onRender' 451 | ,appClock = appClock' 452 | ,parentNode = parentNode env}) 453 | trimB (switchB children (tag done (pure []))))) 454 | creations)) 455 | Francium (tell (switchB (pure []) moreChildren)) 456 | -------------------------------------------------------------------------------- /todo-mvc/ClearCompleted.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module ClearCompleted where 5 | 6 | import Control.Lens ((.=)) 7 | import Francium 8 | import Francium.CSS 9 | import Francium.Component 10 | import Francium.HTML 11 | import Francium.Hooks 12 | 13 | data ClearCompleted t = 14 | ClearCompleted 15 | 16 | instance Component ClearCompleted where 17 | data Output behavior event 18 | ClearCompleted = ClearCompletedOutput{clearCompleted :: event ()} 19 | construct _ = 20 | do (hoverHook,isHovering) <- newHoverHook 21 | (clickHook,click) <- newClickHook 22 | return Instantiation {outputs = 23 | ClearCompletedOutput {clearCompleted = click} 24 | ,render = 25 | fmap (\h -> 26 | with (applyHooks clickHook button_) 27 | (do style .= 28 | (do float floatRight 29 | position relative 30 | lineHeight (px 20) 31 | textDecoration none 32 | cursor pointer)) 33 | ["Clear Completed"]) 34 | isHovering} 35 | -------------------------------------------------------------------------------- /todo-mvc/IdiomExp.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module IdiomExp where 4 | 5 | import Control.Monad 6 | import Language.Haskell.TH 7 | import Prelude hiding (exp) 8 | 9 | i :: Q Exp -> Q Exp 10 | i = runQ >=> go 11 | where go (AppE f x) = 12 | [|$(go f) <*> 13 | $(return x)|] 14 | go (InfixE (Just l) op (Just r)) = 15 | [|$(go op) <*> 16 | $(return l) <*> 17 | $(return r)|] 18 | go (TupE elems) = 19 | do names <- 20 | mapM (\_ -> newName "t") elems 21 | let lam = 22 | LamE (map VarP names) 23 | (TupE (map VarE names)) 24 | return (foldl (\l r -> 25 | InfixE (Just l) 26 | (VarE '(<*>)) 27 | (Just r)) 28 | (AppE (VarE 'pure) lam) 29 | elems) 30 | go (RecConE n exprs) = 31 | do names <- 32 | mapM (\_ -> newName "t") exprs 33 | let lam = 34 | LamE (map VarP names) 35 | (RecConE n 36 | (zipWith (\(f,_) n' -> 37 | (f,VarE n')) 38 | exprs 39 | names)) 40 | return (foldl (\l r -> 41 | InfixE (Just l) 42 | (VarE '(<*>)) 43 | (Just r)) 44 | (AppE (VarE 'pure) lam) 45 | (map (\(_,expr) -> expr) exprs)) 46 | go (RecUpdE x exprs) = 47 | do names <- 48 | mapM (\_ -> newName "t") exprs 49 | let lam = 50 | LamE (map VarP names) 51 | (RecUpdE x 52 | (zipWith (\(f,_) n -> 53 | (f,VarE n)) 54 | exprs 55 | names)) 56 | return (foldl (\l r -> 57 | InfixE (Just l) 58 | (VarE '(<*>)) 59 | (Just r)) 60 | (AppE (VarE 'pure) lam) 61 | (map (\(_,expr) -> expr) exprs)) 62 | go (CaseE exp stmts) = 63 | do lam <- 64 | [|\t -> 65 | $(return (CaseE (VarE 't) stmts))|] 66 | return (InfixE (Just (AppE (VarE 'pure) lam)) 67 | (VarE '(<*>)) 68 | (Just exp)) 69 | go e = [|pure $(return e)|] 70 | -------------------------------------------------------------------------------- /todo-mvc/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE RecursiveDo #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | import ClearCompleted 7 | import Control.Lens ((?=), (.=)) 8 | import Control.Monad 9 | import Data.Monoid 10 | import Francium 11 | import Francium.CSS 12 | import Francium.HTML 13 | import IdiomExp 14 | import NewItemAdder 15 | import OpenItemCount 16 | import Prelude hiding (div, span) 17 | import StateFilter 18 | import ToDoList 19 | import ToggleAll 20 | 21 | -- | 'app' defines our TodoMVC clone's top-level definition. To Francium, web 22 | -- applications are simply time-varying HTML documents, and we can see this from 23 | -- the type of 'app' - after building an event network in the 'Moment' monad, it 24 | -- returns a single 'Behavior' containing 'HTML' values. 25 | -- 26 | -- Inside our 'app' function, we simply build all the necessary components for 27 | -- the TodoMVC application, and wire them together appropriately. 28 | app :: Frameworks t => Moment t (Behavior t HTML) 29 | app = 30 | mdo 31 | -- The newItemAdder component allows users to append new items to their 32 | -- to-do list. 33 | newItemAdder <- construct NewItemAdder 34 | -- The state filter component allows users to show all to-do items, or 35 | -- only complete/incomplete items. 36 | stateFilter <- construct StateFilter 37 | -- The clearCompleted component provides a button that will remove all 38 | -- completed to-do items, leaving just incomplete items. 39 | clearCompleted <- construct ClearCompleted 40 | -- The openItemCount component simply displays the count of incomplete 41 | -- todo items. 42 | -- 43 | -- Here we see our first component that requires external inputs. 44 | -- Specifically, the openItemCount component needs to know which to-do 45 | -- items are present. To provide it with this information, we simply 46 | -- proxy this data through from the contents of the toDoList component, 47 | -- which we construct next. (Note that we can refer to declarations 48 | -- created later by using @mdo@ syntax). 49 | openItemCount <- 50 | construct OpenItemCount {OpenItemCount.items = 51 | allItems (outputs toDoList)} 52 | -- The toggle all component is a checkbox that updates the status of all 53 | -- to-do items. If any are incomplete, then toggling it will mark all 54 | -- items as complete. If all items are complete, toggling it will mark all 55 | -- items as incomplete. 56 | -- 57 | -- Here we see our first component that requires external inputs. 58 | -- Specifically, the ToggleAll component needs to know the status of items 59 | -- in the to-do list. We simply this data by proxying through the contents 60 | -- of the ToDoList component, which we construct next. (Note that we can 61 | -- refer to declarations created later by using @mdo@ syntax). 62 | toggleAll <- 63 | construct (ToggleAll {ToggleAll.items = 64 | allItems (outputs toDoList)}) 65 | -- Finally, we construct the toDoList component, which renders all known 66 | -- to-do items, along with managing the state and persistance of the to-do 67 | -- list. 68 | -- 69 | -- This component has many external inputs: 70 | toDoList <- 71 | construct (ToDoList {ToDoList.addItem = 72 | -- An event to add a new item to the to-do list. 73 | NewItemAdder.addItem (outputs newItemAdder) 74 | ,ToDoList.clearCompleted = 75 | -- An event to clear all completed to-do items by 76 | -- removing them from the list. 77 | ClearCompleted.clearCompleted (outputs clearCompleted) 78 | ,statusFilter = 79 | -- A function (that changes over time) indicating 80 | -- which to-do items the user wishes to view. 81 | StateFilter.stateFilterF (outputs stateFilter) 82 | ,setStatuses = 83 | -- An event that updates the status of all to-do 84 | -- items. 85 | toggleUpdate (outputs toggleAll)}) 86 | -- Now that we have constructed all the necessary components, the 87 | -- remaining step is to lay them out accordingly. To do so, we use 88 | -- applicative syntax to snapshot the renderings of each child component 89 | -- at the same point in time, and then lay this out in 'appView'. 90 | return 91 | $(i [|appView $(i [|AppView {avNewItemAdder = render newItemAdder 92 | ,avToDoList = render toDoList 93 | ,avHasItems = 94 | -- $(i [|(not . null) (allItems (outputs toDoList))|]) 95 | fmap (not . null) 96 | (allItems (outputs toDoList)) 97 | ,avToDoSummary = 98 | $(i [|ToDoSummary {tdsOpenItemCounter = render openItemCount 99 | ,tdsStateFilter = render stateFilter 100 | ,tdsClearCompleted = render clearCompleted}|]) 101 | ,avToggleAll = render toggleAll}|])|]) 102 | 103 | -- | Now that we have declared our application's event network, the only 104 | -- remaining step is to execute it. To do that, we simply apply 'react' to 105 | -- 'app'. 'react' will watch 'app's HTML 'Behavior', and - whenever it changes - 106 | -- render this into the browsers DOM. 107 | main :: IO () 108 | main = react app 109 | 110 | data AppView = 111 | AppView {avNewItemAdder :: HTML 112 | ,avToDoList :: HTML 113 | ,avHasItems :: Bool 114 | ,avToDoSummary :: ToDoSummary 115 | ,avToggleAll :: HTML} 116 | 117 | -- | The 'appView' function simply stiches together all renderings of child 118 | -- components into the main HTML of the document. Francium encourages the use 119 | -- of inline styles, but that requires discipline in making small functions. 120 | -- Here we see that most of the elements that we're adding content to are 121 | -- abstract HTML values. 122 | appView :: AppView -> HTML 123 | appView AppView{..} = 124 | into mainContainer 125 | [into rootSection 126 | (into header_ [pageTitle,avNewItemAdder] : 127 | if avHasItems 128 | then [into toDoSection [avToggleAll,avToDoList] 129 | ,toDoSummary avToDoSummary] 130 | else []) 131 | ,pageFooter] 132 | 133 | -- | The application itself is rendered into the of the document. Here 134 | -- we style the body accordingly. 135 | mainContainer :: HTML 136 | mainContainer = 137 | with body_ 138 | (style .= 139 | do sym padding (px 0) 140 | sym2 margin (px 0) auto 141 | fontWeight (weight 300) 142 | maxWidth (px 550) 143 | minWidth (px 230) 144 | color (rgb 77 77 77) 145 | lineHeight (em 1.4) 146 | fontFamily ["Helvetica Neue","Helvetica","Arial"] 147 | [sansSerif] 148 | fontSize (px 14) 149 | "font-stretch" -: "normal" 150 | fontVariant normal 151 | fontStyle normal 152 | backgroundColor (rgb 245 245 245)) 153 | [] 154 | 155 | -- | The root section contains the application, and gives the distinctive 156 | -- todo-mvc container look. 157 | rootSection :: HTML 158 | rootSection = 159 | with section_ 160 | (style .= 161 | do boxShadows 162 | [(px 0,px 2,px 4,rgba 0 0 0 51),(px 0,px 25,px 50,rgba 0 0 0 25)] 163 | position relative 164 | margin (px 130) 165 | (px 0) 166 | (px 40) 167 | (px 0) 168 | backgroundColor (rgb 255 255 255)) 169 | [] 170 | 171 | -- | The to-do section contains the to-do list, and also overlaps the 172 | -- "complete all" checkbox. 173 | toDoSection :: HTML 174 | toDoSection = 175 | with section_ 176 | (style .= 177 | do borderTop solid 178 | (px 1) 179 | (rgb 230 230 230) 180 | zIndex 2 181 | position relative) 182 | [] 183 | 184 | -- | The page title is a header that shows the user they are viewing the todo-mvc 185 | -- application. 186 | pageTitle :: HTML 187 | pageTitle = 188 | with h1_ 189 | (style .= 190 | do color (rgba 175 47 47 39) 191 | textAlign (alignSide sideCenter) 192 | fontWeight (weight 100) 193 | fontSize (px 100) 194 | width (pct 100) 195 | top (px (-155)) 196 | position absolute) 197 | ["todos"] 198 | 199 | -- | The ToDoSummary provides a little information under the to-do list, 200 | -- allowing the user to either filter the to-do list, see how many incomplete 201 | -- items they have, and to clear all completed items. 202 | data ToDoSummary = 203 | ToDoSummary {tdsOpenItemCounter :: HTML 204 | ,tdsStateFilter :: HTML 205 | ,tdsClearCompleted :: HTML} 206 | 207 | toDoSummary :: ToDoSummary -> HTML 208 | toDoSummary ToDoSummary{..} = 209 | with footer_ 210 | (style .= 211 | do borderTopColor (rgb 230 230 230) 212 | borderTopStyle solid 213 | borderTopWidth (px 1) 214 | textAlign (alignSide sideCenter) 215 | height (px 20) 216 | sym2 padding 217 | (px 10) 218 | (px 15) 219 | color (rgb 119 119 119)) 220 | [with div_ 221 | (style .= 222 | do position absolute 223 | right (px 0) 224 | bottom (px 0) 225 | left (px 0) 226 | height (px 50) 227 | boxShadows4 228 | [(px 0,px 1,px 1,px 0,rgba 0 0 0 50) 229 | ,(px 0,px 8,px 0,px (-3),rgb 246 246 246) 230 | ,(px 0,px 9,px 1,px (-3),rgba 0 0 0 50) 231 | ,(px 0,px 16,px 0,px (-6),rgb 246 246 246) 232 | ,(px 0,px 17,px 2,px (-6),rgba 0 0 0 50)] 233 | overflow hidden) 234 | [] 235 | ,tdsOpenItemCounter 236 | ,tdsStateFilter 237 | ,tdsClearCompleted 238 | ,with button_ 239 | (style .= 240 | do verticalAlign baseline 241 | fontSize (pct 100) 242 | borderWidth (px 0) 243 | sym padding (px 0) 244 | sym margin (px 0) 245 | outlineStyle none 246 | position relative 247 | visibility hidden 248 | cursor pointer 249 | textDecorationLine none 250 | lineHeight (px 20) 251 | float floatRight 252 | backgroundImage none) 253 | []] 254 | 255 | pageFooter :: HTML 256 | pageFooter = 257 | with footer_ 258 | (style .= 259 | do textAlign (alignSide sideCenter) 260 | textShadow (px 0) 261 | (px 1) 262 | (px 0) 263 | (rgba 255 255 255 127) 264 | fontSize (px 10) 265 | color (rgb 191 191 191) 266 | sym3 margin 267 | (px 65) 268 | auto 269 | (px 0)) 270 | [with p_ 271 | (style .= 272 | lineHeight (1 :: Size Abs)) 273 | ["Double-click to edit a todo"] 274 | ,with p_ 275 | (style .= 276 | lineHeight (1 :: Size Abs)) 277 | ["Template by " 278 | ,with a_ 279 | (do style .= 280 | do fontWeight (weight 400) 281 | textDecorationLine none 282 | href_ ?= "http://sindresorhus.com") 283 | ["Sindre Sorhus"]] 284 | ,with p_ 285 | (style .= 286 | lineHeight (1 :: Size Abs)) 287 | ["Created by " 288 | ,with a_ 289 | (do style .= 290 | do fontWeight (weight 400) 291 | textDecorationLine none 292 | href_ ?= "http://todomvc.com") 293 | ["you"]] 294 | ,with p_ 295 | (style .= 296 | lineHeight (1 :: Size Abs)) 297 | ["Part of " 298 | ,with a_ 299 | (do style .= 300 | do fontWeight (weight 400) 301 | textDecorationLine none 302 | href_ ?= "http://todomvc.com") 303 | ["TodoMVC"]]] 304 | 305 | boxShadows4 :: [(Size a, Size a, Size a, Size a, Color)] -> Css 306 | boxShadows4 = 307 | prefixed (browsers <> "box-shadow") . 308 | map (\(a,b,c,d,e) -> a ! b ! c ! d ! e) 309 | -------------------------------------------------------------------------------- /todo-mvc/NewItemAdder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module NewItemAdder (NewItemAdder(..), addItem) where 6 | 7 | import Control.Lens ((?=), (.=)) 8 | import Francium 9 | import Francium.CSS 10 | import Francium.Component 11 | import Francium.HTML 12 | import Francium.Hooks 13 | import GHCJS.Types 14 | import Prelude hiding (div, span) 15 | import TextInput 16 | 17 | -- | The 'NewItemAdder' component allows users to add new items to their to-do 18 | -- list. Visually, it appears as an box, and fires the 'addItem' event 19 | -- when the user presses the return key on their keyboard. 20 | data NewItemAdder t = 21 | NewItemAdder 22 | 23 | instance Component NewItemAdder where 24 | data Output behavior event NewItemAdder = NewItemOutput{addItem :: 25 | event JSString} 26 | construct NewItemAdder = 27 | mdo 28 | -- Construct an input field component. 29 | inputComponent <- 30 | construct (TextInput {initialText = "" 31 | ,updateText = 32 | fmap (const (const "")) returnPressed}) 33 | -- We add a new "hook" to the event network to observe whenever the user 34 | -- presses a key. Later, we will filter this event stream to only fire 35 | -- when return is pressed. 36 | (hookKeyPress,keyPressed) <- newKeyPressHook 37 | let 38 | -- The keyPressed event gives us an event whenever a key is pressed. 39 | -- We only need to know when the user presses return, so we filter 40 | -- the event stream accordingly. 41 | returnPressed = listenForReturn keyPressed 42 | -- The itemValue is the title of the to-do item being added. We 43 | -- pass through the behavior from the TextInput component, which 44 | -- provides us with the contents of the text box. 45 | itemValue = 46 | TextInput.value (outputs inputComponent) 47 | reactimate (fmap print keyPressed) 48 | return Instantiation {render = 49 | -- To render the component, we simply reskin the 50 | -- TextInput component 51 | fmap 52 | (applyHooks hookKeyPress . 53 | modifyElement inputAttributes) 54 | (render inputComponent) 55 | ,outputs = 56 | -- The outputs of this component is an Event 57 | -- that samples the contents of the input field 58 | -- whenever return is pressed. 59 | NewItemOutput {addItem = itemValue <@ 60 | returnPressed}} 61 | where inputAttributes = 62 | do style .= 63 | (do boxSizing borderBox 64 | insetBoxShadow inset 65 | (px 0) 66 | (px (-2)) 67 | (px 1) 68 | (rgba 0 0 0 7) 69 | borderStyle none 70 | padding (px 15) 71 | (px 15) 72 | (px 15) 73 | (px 60) 74 | outlineStyle none 75 | lineHeight (em 1.5) 76 | fontSize (px 24) 77 | width (pct 100) 78 | sym margin (px 0) 79 | position relative 80 | backgroundColor (rgba 0 0 0 0)) 81 | placeholder_ ?= "What needs to be done?" 82 | autofocus_ ?= "" 83 | 84 | listenForReturn :: (Num a, Eq a) => Event t a -> Event t a 85 | listenForReturn = filterE (== returnKeyCode) 86 | where returnKeyCode = 13 87 | -------------------------------------------------------------------------------- /todo-mvc/OpenItemCount.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module OpenItemCount where 5 | 6 | import Control.Lens ((.=)) 7 | import Francium 8 | import Francium.CSS hiding (filter) 9 | import Francium.Component 10 | import Francium.HTML 11 | import Prelude hiding (span) 12 | import ToDoItem (Status(..)) 13 | 14 | data OpenItemCount t = 15 | OpenItemCount {items :: Behavior t [Status]} 16 | 17 | instance Component OpenItemCount where 18 | data Output behavior event OpenItemCount = OpenItemCountOutput 19 | construct oic = 20 | do let openItemCount = 21 | fmap (length . 22 | filter (== Incomplete)) 23 | (items oic) 24 | return Instantiation {outputs = OpenItemCountOutput 25 | ,render = 26 | fmap (\n -> 27 | with span_ 28 | (style .= 29 | (do textAlign (alignSide sideLeft) 30 | float floatLeft)) 31 | [with strong_ 32 | (style .= 33 | fontWeight (weight 300)) 34 | [text (show n)] 35 | ," " 36 | ,if n == 1 37 | then "item" 38 | else "items" 39 | ," left"]) 40 | openItemCount} 41 | -------------------------------------------------------------------------------- /todo-mvc/StateFilter.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE RecursiveDo #-} 6 | {-# LANGUAGE TemplateHaskell #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | module StateFilter (StateFilter(..), stateFilterF) where 10 | 11 | import Control.Lens ((.=)) 12 | import Data.Monoid ((<>)) 13 | import Data.Traversable (for) 14 | import Francium 15 | import Francium.CSS hiding (Filter) 16 | import Francium.Component 17 | import Francium.HTML 18 | import Francium.Hooks 19 | import IdiomExp 20 | import Prelude hiding (div, span) 21 | import ToDoItem (Status(..)) 22 | 23 | -------------------------------------------------------------------------------- 24 | data StateFilter t = 25 | StateFilter 26 | 27 | instance Component StateFilter where 28 | data Output behavior event 29 | StateFilter = StateFilterOutputs{stateFilterF :: 30 | behavior (Status -> Bool)} 31 | construct StateFilter = 32 | mdo stateFilters <- 33 | for [minBound .. maxBound] 34 | (\filter_ -> 35 | do let active = 36 | fmap (filter_ ==) currentState 37 | construct (FilterSelector {filterType = filter_ 38 | ,isActive = active})) 39 | let currentState = 40 | stepper initialState (unions (fmap (filterClicked . outputs) stateFilters)) 41 | return Instantiation {render = 42 | fmap (into container . 43 | fmap (into selectorCell . pure)) 44 | (traverse render stateFilters) 45 | ,outputs = 46 | StateFilterOutputs 47 | (fmap (\case 48 | All -> 49 | const True 50 | Active -> (== Incomplete) 51 | Completed -> (== Complete)) 52 | currentState)} 53 | where container = 54 | with ul_ 55 | (style .= 56 | do left (px 0) 57 | right (px 0) 58 | position absolute 59 | listStyleType none 60 | padding (px 0) 61 | (px 0) 62 | (px 0) 63 | (px 0) 64 | margin (px 0) 65 | (px 0) 66 | (px 0) 67 | (px 0)) 68 | [] 69 | selectorCell = 70 | with li_ (style .= display inline) [] 71 | initialState = All 72 | 73 | -------------------------------------------------------------------------------- 74 | data Filter 75 | = All 76 | | Active 77 | | Completed 78 | deriving (Bounded,Enum,Eq,Ord,Show) 79 | 80 | data FilterSelector t = 81 | FilterSelector {filterType :: Filter 82 | ,isActive :: Behavior t Bool} 83 | 84 | data FilterSelectorState 85 | = Selected 86 | | Hover 87 | | NoSelection 88 | 89 | instance Component FilterSelector where 90 | data Output behavior event 91 | FilterSelector = FilterOutput{filterClicked :: event Filter} 92 | construct fc = 93 | do (hoverHook,isHovering) <- newHoverHook 94 | (clickHook,clicked) <- newClickHook 95 | let selectionState = 96 | $(i [|case $(i [|(isActive fc,isHovering)|]) of 97 | (True,_) -> Selected 98 | (_,True) -> Hover 99 | (_,False) -> NoSelection|]) 100 | return Instantiation {outputs = 101 | FilterOutput {filterClicked = filterType fc <$ 102 | clicked} 103 | ,render = 104 | $(i [|modifyElement 105 | $(i [|renderStateSelector selectionState|]) 106 | (pure (into (applyHooks 107 | (hoverHook <> clickHook) 108 | a_) 109 | [text (show (filterType fc))]))|])} 110 | where renderStateSelector selectionState = 111 | style .= 112 | do borderWidth (px 1) 113 | borderStyle solid 114 | textDecorationLine none 115 | padding (px 3) 116 | (px 7) 117 | (px 3) 118 | (px 7) 119 | margin (px 3) 120 | (px 3) 121 | (px 3) 122 | (px 3) 123 | color inherit 124 | borderColor 125 | (case selectionState of 126 | NoSelection -> transparent 127 | Hover -> rgba 175 47 47 26 128 | Selected -> rgba 175 47 47 51) 129 | -------------------------------------------------------------------------------- /todo-mvc/Storage.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module Storage where 5 | 6 | import Data.Aeson (ToJSON(..), FromJSON(..), encode, decodeStrict) 7 | import Data.ByteString.Lazy (toStrict) 8 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 9 | import GHC.Generics 10 | import GHCJS.Foreign 11 | import GHCJS.Types 12 | 13 | data ToDoItem = ToDoItem { title :: String, complete :: Bool } 14 | deriving (Generic, Show) 15 | 16 | instance ToJSON ToDoItem 17 | instance FromJSON ToDoItem 18 | 19 | store :: [ToDoItem] -> IO () 20 | store = localStorageSetItem localStorageKey . toJSString . decodeUtf8 . toStrict . 21 | encode 22 | 23 | retrieve :: IO (Maybe [ToDoItem]) 24 | retrieve = 25 | fmap (decodeStrict . encodeUtf8 . fromJSString) 26 | (localStorageGetItem localStorageKey) 27 | 28 | localStorageKey :: JSString 29 | localStorageKey = "francium-todos" 30 | 31 | foreign import javascript unsafe 32 | "localStorage.setItem($1, $2)" 33 | localStorageSetItem :: JSString -> JSString -> IO () 34 | 35 | foreign import javascript unsafe 36 | "localStorage.getItem($1)" 37 | localStorageGetItem :: JSString -> IO JSString 38 | -------------------------------------------------------------------------------- /todo-mvc/TODO.org: -------------------------------------------------------------------------------- 1 | * Persistance 2 | Needs to persist to local storage. 3 | -------------------------------------------------------------------------------- /todo-mvc/TextInput.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module TextInput (TextInput(..), TextInput.value) where 6 | 7 | import Francium 8 | import Francium.Component 9 | import Francium.Components.Form.Input 10 | import GHCJS.Types 11 | 12 | data TextInput t = 13 | TextInput {initialText :: JSString 14 | ,updateText :: Event t (JSString -> JSString)} 15 | 16 | instance Component TextInput where 17 | data Output b e TextInput = TextInputOutput{value :: b JSString} 18 | construct ti = 19 | mdo input <- 20 | construct Input {inputValue = value} 21 | let value = 22 | accumB (initialText ti) 23 | ((const <$> 24 | inputChanged (outputs input)) `union` 25 | (updateText ti)) 26 | return Instantiation {render = render input 27 | ,outputs = 28 | TextInputOutput value} 29 | -------------------------------------------------------------------------------- /todo-mvc/ToDoItem.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE LambdaCase #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE StandaloneDeriving #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | 10 | module ToDoItem where 11 | 12 | import Control.Lens ((?=), (.=), at) 13 | import Control.Monad (void) 14 | import Data.Bool (bool) 15 | import Data.Monoid ((<>)) 16 | import Francium 17 | import Francium.CSS 18 | import Francium.Component 19 | import Francium.HTML 20 | import Francium.Hooks 21 | import GHC.Generics 22 | import GHCJS.DOM.Element (elementFocus) 23 | import GHCJS.Foreign 24 | import GHCJS.Types 25 | import IdiomExp 26 | import Prelude hiding (div, map, span) 27 | import TextInput 28 | 29 | data Status = Complete | Incomplete 30 | deriving (Bounded, Enum, Eq, Ord, Show) 31 | 32 | negateStatus :: Status -> Status 33 | negateStatus = 34 | \case 35 | Incomplete -> Complete 36 | Complete -> Incomplete 37 | 38 | deriving instance Generic (Output b e ToDoItem) 39 | instance TrimOutput ToDoItem 40 | 41 | data State = Viewing | Editing deriving (Eq) 42 | 43 | -------------------------------------------------------------------------------- 44 | data ToDoItem t = 45 | ToDoItem {initialContent :: JSString 46 | ,setStatus :: Event t Status} 47 | 48 | instance Component ToDoItem where 49 | data Output behavior event ToDoItem = ToDoItemOutput{status :: 50 | behavior Status, 51 | destroy :: event (), 52 | steppedContent :: behavior JSString} 53 | construct toDoItem = 54 | do (hookHoverContainer,isHoveringRow) <- newHoverHook 55 | (hookKeyPresses,keyPressed) <- newKeyPressHook 56 | (hookFocus,lostFocus) <- newBlurHook 57 | (clickHook,click) <- newClickHook 58 | (hookEditFieldRender,editFieldRendered) <- newRenderHook 59 | reactimate (fmap (nextTick . elementFocus) editFieldRendered) 60 | textInput <- 61 | construct (TextInput (initialContent toDoItem) never) 62 | destroyButton <- 63 | construct (Button ["\215"]) 64 | statusCheckbox <- 65 | do let toggle = 66 | fmap (\case 67 | Incomplete -> False 68 | Complete -> True) 69 | (setStatus toDoItem) 70 | construct (ToDoCheckbox toggle) 71 | let switchToEditing = 72 | whenE ((Viewing ==) <$> state) click 73 | switchToViewing = 74 | whenE (fmap (Editing ==) state) 75 | (unions [lostFocus 76 | ,void (filterE (`elem` [13,27]) keyPressed)]) 77 | state = 78 | accumB Viewing 79 | (unions [const Editing <$ 80 | switchToEditing 81 | ,const Viewing <$ 82 | switchToViewing]) 83 | showDestroy = 84 | $(i [|$(i [|pure Viewing == 85 | state|]) && 86 | isHoveringRow|]) 87 | itemValue = 88 | TextInput.value (outputs textInput) 89 | selfDestruct = 90 | unions [clicked (outputs destroyButton) 91 | ,whenE (fmap isEmptyString itemValue) switchToViewing] 92 | self = 93 | Instantiation {render = 94 | itemRenderer clickHook <$> render destroyButton <*> 95 | render statusCheckbox <*> 96 | pure (applyHooks hookHoverContainer div_) <*> 97 | showDestroy <*> 98 | state <*> 99 | fmap (applyHooks 100 | (hookKeyPresses <> hookFocus <> 101 | hookEditFieldRender)) 102 | (render textInput) <*> 103 | itemValue <*> 104 | (status (outputs self)) 105 | ,outputs = 106 | ToDoItemOutput {status = 107 | accumB Incomplete 108 | (unions [fmap (\b _ -> 109 | bool Incomplete Complete b) 110 | (toggled (outputs statusCheckbox)) 111 | ,const <$> 112 | (setStatus toDoItem)]) 113 | ,destroy = selfDestruct 114 | ,steppedContent = 115 | stepper (initialContent toDoItem) 116 | (itemValue <@ 117 | switchToViewing)}} 118 | return self 119 | where itemRenderer labelClick destroyButton statusCheckbox container showDestroy state textInput inputValue currentStatus = 120 | let svgCheckbox = 121 | case state of 122 | Viewing -> 123 | [with svg 124 | (do width_ ?= "40" 125 | height_ ?= "40" 126 | attributes . 127 | at "viewBox" ?= 128 | "-10 -18 100 135") 129 | (case currentStatus of 130 | Complete -> 131 | [checkCircle 132 | ,with path 133 | (do attributes . 134 | at "fill" ?= 135 | "#5dc2af" 136 | attributes . 137 | at "d" ?= 138 | "M72 25L42 71 27 56l-4 4 20 20 34-52z") 139 | []] 140 | Incomplete -> 141 | [checkCircle])] 142 | Editing -> [] 143 | items = 144 | case state of 145 | Viewing -> 146 | [with (applyHooks labelClick label_) 147 | (do case currentStatus of 148 | Incomplete -> labelStyle 149 | Complete -> completeLabelStyle) 150 | [text inputValue] 151 | ,modifyElement 152 | (if showDestroy 153 | then buttonStyle 154 | else hiddenButtonStyle) 155 | destroyButton] 156 | Editing -> 157 | [modifyElement 158 | inputStyle 159 | --takesFocus) XXX 160 | textInput] 161 | in into container 162 | (modifyElement checkboxStyle statusCheckbox : 163 | items) 164 | inputStyle = 165 | style .= 166 | do boxSizing borderBox 167 | insetBoxShadow inset 168 | (px 0) 169 | (px (-1)) 170 | (px 5) 171 | (rgba 0 0 0 51) 172 | borderWidth (px 1) 173 | borderStyle solid 174 | borderColor (rgb 153 153 153) 175 | padding (px 13) 176 | (px 17) 177 | (px 12) 178 | (px 17) 179 | outlineStyle none 180 | lineHeight (em 1.4) 181 | fontSize (px 24) 182 | width (px 506) 183 | margin (px 0) 184 | (px 0) 185 | (px 0) 186 | (px 43) 187 | position relative 188 | checkboxStyle = 189 | style .= 190 | do textAlign (other "centre") 191 | width (px 40) 192 | height auto 193 | position absolute 194 | top (px 0) 195 | bottom (px 0) 196 | margin auto 197 | (px 0) 198 | auto 199 | (px 0) 200 | borderStyle none 201 | labelStyle = 202 | style .= 203 | do transition "color" 204 | (sec 0.4) 205 | auto 206 | auto 207 | lineHeight (1.2 :: Size Abs) 208 | display block 209 | marginLeft (px 45) 210 | padding (px 15) 211 | (px 60) 212 | (px 15) 213 | (px 15) 214 | "word-break" -: "break-word" 215 | whiteSpace pre 216 | completeLabelStyle = 217 | style .= 218 | do transition "color" 219 | (sec 0.4) 220 | auto 221 | auto 222 | lineHeight (1.2 :: Size Abs) 223 | display block 224 | marginLeft (px 45) 225 | padding (px 15) 226 | (px 60) 227 | (px 15) 228 | (px 15) 229 | "word-break" -: "break-word" 230 | whiteSpace pre 231 | color (rgb 217 217 217) 232 | textDecoration lineThrough 233 | buttonStyle = 234 | style .= 235 | do verticalAlign baseline 236 | fontSize (px 30) 237 | borderWidth (px 0) 238 | sym padding (px 0) 239 | sym3 margin 240 | auto 241 | (px 0) 242 | (px 11) 243 | outlineStyle none 244 | transition "color" 245 | (sec 0.2) 246 | easeOut 247 | (sec 0) 248 | color (rgb 204 154 154) 249 | height (px 40) 250 | width (px 40) 251 | bottom (px 0) 252 | right (px 10) 253 | top (px 0) 254 | position absolute 255 | display block 256 | backgroundImage none 257 | backgroundColor inherit 258 | hiddenButtonStyle = 259 | style .= 260 | do verticalAlign baseline 261 | fontSize (px 30) 262 | borderWidth (px 0) 263 | sym padding (px 0) 264 | sym3 margin 265 | auto 266 | (px 0) 267 | (px 11) 268 | outlineStyle none 269 | transition "color" 270 | (sec 0.2) 271 | easeOut 272 | (sec 0) 273 | color (rgb 204 154 154) 274 | height (px 40) 275 | width (px 40) 276 | bottom (px 0) 277 | right (px 10) 278 | top (px 0) 279 | position absolute 280 | display block 281 | backgroundImage none 282 | backgroundColor inherit 283 | display none 284 | checkCircle = 285 | with circle 286 | (do attributes . 287 | at "cx" ?= 288 | "50" 289 | attributes . 290 | at "cy" ?= 291 | "50" 292 | attributes . 293 | at "r" ?= 294 | "50" 295 | attributes . 296 | at "fill" ?= 297 | "none" 298 | attributes . 299 | at "stroke" ?= 300 | "#bddad5" 301 | attributes . 302 | at "stroke-width" ?= 303 | "3") 304 | [] 305 | svgElement x = 306 | with (emptyElement (x :: JSString)) 307 | (namespace .= "http://www.w3.org/2000/svg") 308 | [] 309 | svg = svgElement "svg" 310 | circle = svgElement "circle" 311 | path = svgElement "path" 312 | isEmptyString x = 313 | null (fromJSString x :: String) 314 | 315 | -------------------------------------------------------------------------------- 316 | data ToDoCheckbox t = ToDoCheckbox { reset :: Event t Bool } 317 | 318 | instance Component ToDoCheckbox where 319 | data Output behavior event 320 | ToDoCheckbox = ToDoCheckboxOutput{toggled :: event Bool} 321 | construct c = 322 | do (clickHook,click) <- newClickHook 323 | let toggled_ = 324 | accumE False (unions [not <$ click,const <$> reset c]) 325 | isChecked = stepper False toggled_ 326 | return Instantiation {outputs = 327 | ToDoCheckboxOutput toggled_ 328 | ,render = 329 | fmap (\b -> 330 | with (applyHooks clickHook input_) 331 | (do checked .= b 332 | type_ ?= "checkbox") 333 | []) 334 | isChecked} 335 | 336 | -------------------------------------------------------------------------------- 337 | data Button t = Button [HTML] 338 | 339 | instance Component Button where 340 | data Output behavior event Button = ButtonOutput{clicked :: 341 | event ()} 342 | construct (Button buttonLabel) = 343 | do (clickHook,click) <- newClickHook 344 | return Instantiation {outputs = 345 | ButtonOutput click 346 | ,render = 347 | pure (into (applyHooks clickHook button_) buttonLabel)} 348 | -------------------------------------------------------------------------------- /todo-mvc/ToDoList.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecursiveDo #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | 6 | module ToDoList where 7 | 8 | import Control.Arrow ((&&&)) 9 | import Control.Lens ((.=)) 10 | import Data.Maybe 11 | import Data.Traversable (for) 12 | import Francium 13 | import Francium.CSS hiding (filter) 14 | import Francium.Component 15 | import Francium.HTML 16 | import GHCJS.Foreign 17 | import GHCJS.Types 18 | import IdiomExp 19 | import ToDoItem 20 | import qualified Storage 21 | 22 | data ToDoList t = 23 | ToDoList {addItem :: Event t JSString 24 | ,setStatuses :: Event t Status 25 | ,statusFilter :: Behavior t (Status -> Bool) 26 | ,clearCompleted :: Event t ()} 27 | 28 | instance Component ToDoList where 29 | data Output behavior event ToDoList = ToDoListOutput{allItems :: 30 | behavior [Status]} 31 | construct tdi = 32 | mdo let addNonEmptyItem = 33 | filterE (not . isEmptyString . fromJSString) 34 | (addItem tdi) 35 | eAddItem <- 36 | do setStatusesLater <- 37 | trim (setStatuses tdi) 38 | execute (fmap (\x -> 39 | FrameworksMoment 40 | (do setStatuses' <- now setStatusesLater 41 | trimComponent =<< 42 | construct (ToDoItem x setStatuses'))) 43 | addNonEmptyItem) 44 | openingStorage <- 45 | liftIO (fmap (fromMaybe []) Storage.retrieve) 46 | initialItems <- 47 | for openingStorage 48 | (\item -> 49 | do component <- 50 | trimComponent =<< 51 | construct (ToDoItem (toJSString (Storage.title item)) 52 | (setStatuses tdi)) 53 | return (component 54 | ,(if Storage.complete item 55 | then Complete 56 | else Incomplete))) 57 | startingView <- 58 | fmap sequenceA 59 | (for initialItems 60 | (\(item,_) -> 61 | do render_ <- 62 | now (render item) 63 | status_ <- 64 | now (status (outputs item)) 65 | return $(i [|(render_,status_)|]))) 66 | let eItemsChanged = 67 | accumE (map fst initialItems) 68 | (unions [fmap append eAddItem 69 | ,destroyItem 70 | ,fmap const (incompleteItems <@ clearCompleted tdi)]) 71 | incompleteItems = 72 | switchB (pure (map fst (filter (((== Incomplete) . snd)) initialItems))) 73 | (fmap (fmap (map snd . 74 | filter ((== Incomplete) . fst))) 75 | (fmap (sequenceA . 76 | map (\item -> 77 | fmap (id &&& const item) 78 | (status (outputs item)))) 79 | eItemsChanged)) 80 | items = 81 | switchB startingView 82 | (fmap (sequenceA . 83 | fmap (\item -> 84 | $(i [|(render item,status (outputs item))|]))) 85 | eItemsChanged) 86 | destroyItem = 87 | switchE (fmap (\events -> 88 | anyMoment (fmap (unions . 89 | (zipWith (\x -> (deleteElem x <$)) 90 | [0 ..])) 91 | (mapM now events))) 92 | (fmap (map (ToDoItem.destroy . outputs)) eItemsChanged)) 93 | visibleItems = 94 | $(i [|map (pure fst) 95 | $(i [|filter $(i [|statusFilter tdi . pure snd|]) items|])|]) 96 | stableData = 97 | switchB (pure openingStorage) 98 | (fmap (traverse (\item -> 99 | $(i [|Storage.ToDoItem 100 | (fmap fromJSString (steppedContent (outputs item))) 101 | (fmap (== Complete) (status (outputs item)))|]))) 102 | eItemsChanged) 103 | stableDataChanged <- changes stableData 104 | reactimate' (fmap (fmap Storage.store) stableDataChanged) 105 | return Instantiation {render = 106 | fmap (into toDoContainer . 107 | map (into itemContainer . pure)) 108 | visibleItems 109 | ,outputs = 110 | ToDoListOutput {allItems = 111 | fmap (fmap snd) items}} 112 | 113 | itemContainer :: HTML 114 | itemContainer = 115 | with li_ 116 | (style .= 117 | do borderBottomColor (rgb 237 237 237) 118 | borderBottomStyle none 119 | borderBottomWidth (px 1) 120 | fontSize (px 24) 121 | position relative) 122 | [] 123 | 124 | toDoContainer :: HTML 125 | toDoContainer = 126 | with ul_ 127 | (style .= 128 | do listStyleType none 129 | sym padding (px 0) 130 | sym margin (px 0)) 131 | [] 132 | 133 | 134 | isEmptyString :: JSString -> Bool 135 | isEmptyString x = null (fromJSString x :: String) 136 | 137 | 138 | append :: a -> [a] -> [a] 139 | append x xs = xs ++ [x] 140 | 141 | deleteElem :: Int -> [a] -> [a] 142 | deleteElem _ [] = [] 143 | deleteElem j (x:xs) 144 | | j < 0 = xs 145 | | j > length xs = xs 146 | | j == 0 = xs 147 | | otherwise = x : deleteElem (j - 1) xs 148 | -------------------------------------------------------------------------------- /todo-mvc/ToggleAll.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | 4 | module ToggleAll where 5 | 6 | import Control.Lens ((?=), (.=)) 7 | import Data.Bool 8 | import Francium 9 | import Francium.CSS hiding (all) 10 | import Francium.Component 11 | import Francium.HTML 12 | import Francium.Hooks 13 | import ToDoItem (Status(..)) 14 | 15 | data ToggleAll t = 16 | ToggleAll {items :: Behavior t [Status]} 17 | 18 | instance Component ToggleAll where 19 | data Output behavior event ToggleAll = ToggleAllOut{toggleUpdate :: 20 | event Status} 21 | construct tAll = 22 | do let allComplete = 23 | fmap (all (== Complete)) 24 | (items tAll) 25 | (clickHook,toggle) <- newClickHook 26 | return Instantiation {outputs = 27 | ToggleAllOut 28 | (fmap (bool Complete Incomplete) 29 | (allComplete <@ toggle)) 30 | ,render = 31 | fmap (\c -> 32 | with (applyHooks clickHook input_) 33 | (do type_ ?= "checkbox" 34 | style .= 35 | do outlineStyle none 36 | borderStyle none 37 | textAlign (other "center") 38 | height (px 34) 39 | width (px 60) 40 | left (px (-12)) 41 | top (px (-55)) 42 | position absolute 43 | backgroundImage none 44 | checked .= c) 45 | []) 46 | allComplete} 47 | -------------------------------------------------------------------------------- /todo-mvc/shell.nix: -------------------------------------------------------------------------------- 1 | with (import {}).pkgs; 2 | let modifiedHaskellPackages = haskell-ng.packages.ghcjs.override { 3 | overrides = self: super: { 4 | francium = self.callPackage ../. {}; 5 | todo-mvc = self.callPackage ./. {}; 6 | virtual-dom = self.callPackage ../../virtual-dom {}; 7 | }; 8 | }; 9 | in modifiedHaskellPackages.todo-mvc.env 10 | -------------------------------------------------------------------------------- /todo-mvc/todo-mvc.cabal: -------------------------------------------------------------------------------- 1 | name: todo-mvc 2 | version: 0.1 3 | build-type: Simple 4 | cabal-version: >= 1.20 5 | 6 | executable todo-mvc 7 | build-depends: 8 | base >= 4 && < 5, 9 | aeson, bytestring, francium, lens, ghcjs-base, text, transformers, mtl, template-haskell, ghcjs-dom 10 | default-language: Haskell2010 11 | main-is: Main.hs 12 | ghc-options: -Wall 13 | --------------------------------------------------------------------------------