-
19 |
31 |
32 | stack build --exec "pandoc -f markdown -i other/index.md -t html -o index.html --filter pandoc-include" --exec "java -jar $(stack path --local-bin)/closure-compiler-v20170124.jar --js_output_file=other/mvc-todo-auto.js $(stack path --local-install-root)/bin/mvc-todo-auto.jsexe/all.js" --exec "java -jar $(stack path --local-bin)/closure-compiler-v20170124.jar --js_output_file=other/mvc-todo.js $(stack path --local-install-root)/bin/mvc-todo.jsexe/all.js"
33 |
34 |
35 |
36 | [mvc]: https://hackage.haskell.org/package/mvc
37 | [lens]: https://hackage.haskell.org/package/lens
38 | [ghcjs]: https://github.com/ghcjs/ghcjs
39 |
40 |
--------------------------------------------------------------------------------
/readme.md:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 | Haskell TodoMVC Example
5 | =======================
6 |
7 | > Haskell is a strongly-typed, lazily-evaluated, functional programming
8 | > language.
9 |
10 | - [live demo](other/mvc-todo.html)
11 |
12 | - with [automation](other/mvc-todo-auto.html)
13 |
14 | This example demonstrates an idiomatic haskell approach to the TodoMVC
15 | problem domain involving:
16 |
17 | - compilation of haskell to javascript using
18 | [ghcjs](https://github.com/ghcjs/ghcjs).
19 | - The specification of a `Model` representing the problem domain,
20 | consisting of
21 | - specification of Abstract Data Types (ADTs) for inputs, state and
22 | outputs.
23 | - an algebra between state and actions.
24 | - Use of the [mvc](https://hackage.haskell.org/package/mvc) library
25 | for specification, asynchronicity and separation of model, view and
26 | controllers.
27 | - The creation of `View`s that consume model outputs, by using vanilla
28 | javascript effects.
29 | - The creation of `Controller`s that produce model inputs, by
30 | listening for Dom events using vanilla javascript.
31 |
32 | recipe
33 | ======
34 |
35 | The recipe below handles the bits and bobs you need to do every
36 | re-compile. This includes a compression step via
37 | [closure](http://dl.google.com/closure-compiler).
38 |
39 |
40 |
41 | stack build --exec "pandoc -f markdown -i other/index.md -t html -o index.html --filter pandoc-include" --exec "java -jar $(stack path --local-bin)/closure-compiler-v20170124.jar --js_output_file=other/mvc-todo-auto.js $(stack path --local-install-root)/bin/mvc-todo-auto.jsexe/all.js" --exec "java -jar $(stack path --local-bin)/closure-compiler-v20170124.jar --js_output_file=other/mvc-todo.js $(stack path --local-install-root)/bin/mvc-todo.jsexe/all.js"
42 |
43 |
44 |
45 |
--------------------------------------------------------------------------------
/index.html:
--------------------------------------------------------------------------------
1 | 2 |
4 |6 |Haskell is a strongly-typed, lazily-evaluated, functional programming language.
5 |
with automation
This example demonstrates an idiomatic haskell approach to the TodoMVC problem domain involving:
11 |Model representing the problem domain, consisting ofViews that consume model outputs, by using vanilla javascript effects.Controllers that produce model inputs, by listening for Dom events using vanilla javascript.The recipe below handles the bits and bobs you need to do every re-compile. This includes a compression step via closure.
22 |
23 |
24 | stack build --exec "pandoc -f markdown -i other/index.md -t html -o index.html --filter pandoc-include" --exec "java -jar $(stack path --local-bin)/closure-compiler-v20170124.jar --js_output_file=other/mvc-todo-auto.js $(stack path --local-install-root)/bin/mvc-todo-auto.jsexe/all.js" --exec "java -jar $(stack path --local-bin)/closure-compiler-v20170124.jar --js_output_file=other/mvc-todo.js $(stack path --local-install-root)/bin/mvc-todo.jsexe/all.js"
25 |
26 |
27 |
--------------------------------------------------------------------------------
/other/node_modules/todomvc-common/base.css:
--------------------------------------------------------------------------------
1 | hr {
2 | margin: 20px 0;
3 | border: 0;
4 | border-top: 1px dashed #c5c5c5;
5 | border-bottom: 1px dashed #f7f7f7;
6 | }
7 |
8 | .learn a {
9 | font-weight: normal;
10 | text-decoration: none;
11 | color: #b83f45;
12 | }
13 |
14 | .learn a:hover {
15 | text-decoration: underline;
16 | color: #787e7e;
17 | }
18 |
19 | .learn h3,
20 | .learn h4,
21 | .learn h5 {
22 | margin: 10px 0;
23 | font-weight: 500;
24 | line-height: 1.2;
25 | color: #000;
26 | }
27 |
28 | .learn h3 {
29 | font-size: 24px;
30 | }
31 |
32 | .learn h4 {
33 | font-size: 18px;
34 | }
35 |
36 | .learn h5 {
37 | margin-bottom: 0;
38 | font-size: 14px;
39 | }
40 |
41 | .learn ul {
42 | padding: 0;
43 | margin: 0 0 30px 25px;
44 | }
45 |
46 | .learn li {
47 | line-height: 20px;
48 | }
49 |
50 | .learn p {
51 | font-size: 15px;
52 | font-weight: 300;
53 | line-height: 1.3;
54 | margin-top: 0;
55 | margin-bottom: 0;
56 | }
57 |
58 | #issue-count {
59 | display: none;
60 | }
61 |
62 | .quote {
63 | border: none;
64 | margin: 20px 0 60px 0;
65 | }
66 |
67 | .quote p {
68 | font-style: italic;
69 | }
70 |
71 | .quote p:before {
72 | content: '“';
73 | font-size: 50px;
74 | opacity: .15;
75 | position: absolute;
76 | top: -20px;
77 | left: 3px;
78 | }
79 |
80 | .quote p:after {
81 | content: '”';
82 | font-size: 50px;
83 | opacity: .15;
84 | position: absolute;
85 | bottom: -42px;
86 | right: 3px;
87 | }
88 |
89 | .quote footer {
90 | position: absolute;
91 | bottom: -40px;
92 | right: 0;
93 | }
94 |
95 | .quote footer img {
96 | border-radius: 3px;
97 | }
98 |
99 | .quote footer a {
100 | margin-left: 5px;
101 | vertical-align: middle;
102 | }
103 |
104 | .speech-bubble {
105 | position: relative;
106 | padding: 10px;
107 | background: rgba(0, 0, 0, .04);
108 | border-radius: 5px;
109 | }
110 |
111 | .speech-bubble:after {
112 | content: '';
113 | position: absolute;
114 | top: 100%;
115 | right: 30px;
116 | border: 13px solid transparent;
117 | border-top-color: rgba(0, 0, 0, .04);
118 | }
119 |
120 | .learn-bar > .learn {
121 | position: absolute;
122 | width: 272px;
123 | top: 8px;
124 | left: -300px;
125 | padding: 10px;
126 | border-radius: 5px;
127 | background-color: rgba(255, 255, 255, .6);
128 | transition-property: left;
129 | transition-duration: 500ms;
130 | }
131 |
132 | @media (min-width: 899px) {
133 | .learn-bar {
134 | width: auto;
135 | padding-left: 300px;
136 | }
137 |
138 | .learn-bar > .learn {
139 | left: 8px;
140 | }
141 | }
142 |
--------------------------------------------------------------------------------
/src/Todo/Controllers.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# LANGUAGE TemplateHaskell #-}
3 | {-# OPTIONS_GHC -fno-warn-type-defaults#-}
4 |
5 | module Todo.Controllers where
6 |
7 | import Todo.Vanilla
8 | ( docElement
9 | , onWindow
10 | , on
11 | , delegate
12 | , Element(..)
13 | , keyCode
14 | , itemId
15 | , getHash
16 | , elementOf
17 | , getValue
18 | , JSVal
19 | , toJSVal)
20 |
21 | import MVC hiding ((<>))
22 | import Todo.Model
23 | import Protolude hiding (on)
24 |
25 | data Keys = Escape | Enter | SomethingElse deriving (Eq)
26 |
27 | toKeys :: Int -> Keys
28 | toKeys n = case n of
29 | 13 -> Enter
30 | 27 -> Escape
31 | _ -> SomethingElse
32 |
33 | sendAction :: a -> Output a -> IO ()
34 | sendAction action o = void $ atomically $ send o action
35 |
36 | controllers :: Output Action -> IO ()
37 | controllers o = do
38 | toggleAll <- docElement ".toggle-all"
39 | clearCompleted <- docElement ".clear-completed"
40 | newTodo <- docElement ".new-todo"
41 | todos' <- docElement ".todo-list"
42 | onWindow "load" (const $ sendAction Refresh o)
43 | onWindow "hashchange" (const $ ctlHash o)
44 | on toggleAll "click" (const $ const $ sendAction ToggleAll o)
45 | on clearCompleted "click" (const $ const $ sendAction ClearCompleted o)
46 | on newTodo "keyup" (ctlNewItem o)
47 | delegate todos' ".destroy" "click" (\el _ -> ctlId DeleteItem o el)
48 | delegate todos' ".toggle" "change" (\el _ -> ctlId Toggle o el)
49 | delegate todos' "label" "dblclick" (\el _ -> ctlId EditItem o el)
50 | delegate todos' ".edit" "blur" (ctlEditItemDone o)
51 | delegate todos' ".edit" "keyup" (ctlEditKeyup o)
52 |
53 | ctlId :: (ItemId -> Action) -> Output Action -> Element -> IO ()
54 | ctlId action o el = do
55 | a_ <- idTagged action el
56 | sendAction a_ o
57 |
58 | idTagged :: (ItemId -> Action) -> Element -> IO Action
59 | idTagged action el = do
60 | id' <- itemId el
61 | case id' of
62 | Nothing -> pure NoAction
63 | Just x -> pure (action (ItemId x))
64 |
65 | ctlEditKeyup :: Output Action -> Element -> JSVal -> IO ()
66 | ctlEditKeyup o el ev = do
67 | code <- keyCode ev
68 | case toKeys code of
69 | Enter -> ctlEditItemDone o el ev
70 | Escape -> ctlId EditItemCancel o el
71 | _ -> pure ()
72 |
73 | ctlEditItemDone :: Output Action -> Element -> JSVal -> IO ()
74 | ctlEditItemDone o el _ = do
75 | box <- elementOf el ".edit"
76 | value <- getValue (Element box)
77 | a_ <- idTagged (\x -> EditItemDone x value) el
78 | sendAction a_ o
79 |
80 | ctlHash :: Output Action -> IO ()
81 | ctlHash o = do
82 | hash <- getHash
83 | let path = takeWhile (not . (== '/')) . drop 1 . dropWhile (not . (== '/')) $ (show hash)
84 | let path_ =
85 | case path of
86 | "completed" -> Just Completed
87 | "active" -> Just Active
88 | _ -> Nothing
89 | sendAction (Filter path_) o
90 |
91 | ctlNewItem :: Output Action -> Element -> JSVal -> IO ()
92 | ctlNewItem o el ev = do
93 | code <- keyCode ev
94 | value <- getValue el
95 | if toKeys code == Enter && value /= mempty
96 | then (sendAction (NewItem value) o)
97 | else pure ()
98 |
--------------------------------------------------------------------------------
/apps/mvc-todo-auto.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE RankNTypes #-}
2 | {-# OPTIONS_GHC -fno-warn-type-defaults #-}
3 | {-# LANGUAGE OverloadedStrings #-}
4 | {-# LANGUAGE TemplateHaskell #-}
5 |
6 | module Main where
7 |
8 | import Control.Concurrent (threadDelay)
9 | import Control.Lens
10 | import Control.Monad.Trans.State.Strict (State, StateT)
11 | import Data.IORef
12 | import MVC hiding ((<>))
13 | import MVC.Prelude as MVC
14 | import Protolude hiding (State, StateT, on)
15 | import Test.QuickCheck
16 | import Todo.Arbitrary ()
17 | import Todo.Controllers (controllers)
18 | import Todo.Model (Todos(..), Action(..), ItemStatus(..), Item(..), ItemId(..), apply)
19 | import Todo.Vanilla
20 | import Todo.Views (render)
21 | import qualified Data.Map as Map
22 |
23 | data Auto = Manual
24 | | Automatic
25 | deriving (Show, Eq)
26 |
27 | toggle :: Auto -> Auto
28 | toggle Manual = Automatic
29 | toggle Automatic = Manual
30 |
31 | data In = AutoIn Auto
32 | | ActionIn Action
33 | deriving (Eq, Show)
34 |
35 | data Out
36 | = TodosOut Todos
37 | | InOut In
38 | | AutoOut Auto
39 | deriving (Show, Eq)
40 |
41 | data StateAuto = StateAuto { _sTodos :: Todos, _sAuto :: Auto } deriving (Show, Eq)
42 |
43 | makeClassy ''StateAuto
44 |
45 | makePrisms ''In
46 | makePrisms ''Out
47 |
48 | initialState :: StateAuto
49 | initialState = StateAuto
50 | (Todos "" Nothing (ItemId 3) Nothing
51 | (Map.fromList $
52 | zip (ItemId <$> [0 ..])
53 | [ Item Completed "learn functional programming"
54 | , Item Completed "invent ADTs"
55 | , Item Completed "discover algebra between ADTs"
56 | , Item Active "automate everything else"
57 | ]))
58 | Manual
59 |
60 | ctlAuto :: Output Auto -> IO ()
61 | ctlAuto o = do
62 | toggleAuto <- docElement ".toggle-auto"
63 | on toggleAuto "click" (\el _ -> do
64 | ch <- checked el
65 | -- print ch
66 | let auto = if ch then Automatic else Manual
67 | void $ atomically $ send o auto)
68 |
69 | modifyState :: In -> ListT (State StateAuto) Out
70 | modifyState i = case i of
71 | (AutoIn auto) -> lift (modify (set sAuto auto)) >> pure (AutoOut auto)
72 | (ActionIn NoAction) -> mzero
73 | (ActionIn action) -> do
74 | s <- lift get
75 | let tds = view sTodos s
76 | let tds' = apply action tds
77 | lift $ put $ set sTodos tds' s
78 | pure (TodosOut tds')
79 |
80 | model' :: In -> ListT (State StateAuto) Out
81 | model' i =
82 | (modifyState i) `mappend` (InOut <$> pure i)
83 |
84 | run :: IO StateAuto
85 | run = do
86 | print "running auto ..."
87 | (o, i) <- spawn unbounded
88 | (oAuto, iAuto) <- spawn unbounded
89 | doAuto <- newIORef (view sAuto initialState)
90 | controllers o
91 | ctlAuto oAuto
92 | print initialState
93 | runMVC initialState (asPipe $ loop model')
94 | ((,) <$> pure (asSink (render' doAuto)) <*> pure (cAuto iAuto) `mappend` (fmap ActionIn <$> cAction i doAuto))
95 |
96 | render' :: IORef Auto -> Out -> IO ()
97 | render' _ (InOut i) = print i
98 | render' _ (TodosOut tds) = do
99 | print tds
100 | render tds
101 | render' ref (AutoOut auto) = do
102 | modifyIORef ref toggle
103 | renderAuto auto
104 |
105 | renderAuto :: Auto -> IO ()
106 | renderAuto auto = do
107 | print auto
108 | el <- docElement ".toggle-auto"
109 | case auto of
110 | Automatic -> setValue el "on"
111 | Manual -> setValue el "off"
112 |
113 | cAuto :: Input Auto -> Controller In
114 | cAuto iAuto = AutoIn <$> asInput iAuto
115 |
116 | cAction :: Input Action -> IORef Auto -> Managed (Controller Action)
117 | cAction iAction doAuto =
118 | (pure (asInput iAction) `mappend`
119 | producer unbounded (yield Refresh) `mappend`
120 | producer unbounded
121 | (forever $ do
122 | lift (threadDelay (1000000 * 3))
123 | ref <- lift $ readIORef doAuto
124 | when (ref == Automatic) $ do
125 | x <- lift (generate arbitrary)
126 | yield x))
127 |
128 | main :: IO ()
129 | main = onload (void run)
130 |
--------------------------------------------------------------------------------
/src/Todo/Model.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveDataTypeable #-}
2 | {-# LANGUAGE DeriveFoldable #-}
3 | {-# LANGUAGE DeriveGeneric #-}
4 | {-# LANGUAGE DeriveTraversable #-}
5 | {-# LANGUAGE FlexibleContexts #-}
6 | {-# LANGUAGE FlexibleInstances #-}
7 | {-# LANGUAGE FunctionalDependencies #-}
8 | {-# LANGUAGE MultiParamTypeClasses #-}
9 | {-# LANGUAGE OverloadedStrings #-}
10 | {-# LANGUAGE TemplateHaskell #-}
11 | {-# OPTIONS_GHC-fno-warn-type-defaults#-}
12 |
13 | module Todo.Model
14 | ( Todos(..)
15 | , HasTodos(..)
16 | , Action(..)
17 | , Out(..)
18 | , _StateOut
19 | , _ActionOut
20 | , Item(..)
21 | , HasItem(..)
22 | , ItemId(..)
23 | , ItemStatus(..)
24 | , toggleStatus
25 | , apply
26 | , model
27 | ) where
28 |
29 | import Control.Lens
30 | import Control.Monad.Trans.State.Strict (State, StateT)
31 | import Data.Default
32 | import Pipes
33 | import Protolude hiding (State, StateT, loop)
34 |
35 | import qualified Data.Map as Map
36 |
37 | -- * ADTs
38 | data ItemStatus
39 | = Active
40 | | Completed
41 | deriving (Show, Eq)
42 |
43 | toggleStatus :: ItemStatus -> ItemStatus
44 | toggleStatus Active = Completed
45 | toggleStatus Completed = Active
46 |
47 | newtype ItemId = ItemId { unItemId :: Int }
48 | deriving (Show, Eq, Ord)
49 |
50 | data Item = Item { _itemStatus :: ItemStatus, _itemText :: Text }
51 | deriving (Show, Eq)
52 |
53 | data Todos =
54 | Todos
55 | { _todosNewItem :: Text -- drafted new todo item
56 | , _todosEditing :: Maybe ItemId -- a todo item is being edited
57 | , _todosNextId :: ItemId -- an item id source
58 | , _todosFilter :: Maybe ItemStatus -- maybe a filter is in place
59 | , _todosItems :: Map.Map ItemId Item -- the todo items
60 | }
61 | deriving (Show, Eq)
62 |
63 | makeClassy ''Item
64 |
65 | makeClassy ''Todos
66 |
67 | instance Default Todos where
68 | def = Todos mempty Nothing (ItemId 0) Nothing Map.empty
69 |
70 | data Action
71 | = ClearCompleted
72 | | DeleteItem ItemId
73 | | EditItem ItemId
74 | | EditItemCancel ItemId
75 | | EditItemDone ItemId Text
76 | | Filter (Maybe ItemStatus)
77 | | NewItem Text
78 | | NoAction
79 | | Refresh
80 | | Toggle ItemId
81 | | ToggleAll
82 | deriving (Show, Eq)
83 |
84 | -- * algebra | apply an action to the todo model
85 | apply :: Action -> Todos -> Todos
86 | apply ClearCompleted tds =
87 | over todosItems (Map.filter (\x -> view itemStatus x /= Completed)) tds
88 | apply (DeleteItem x) tds = over todosItems (Map.delete x) tds
89 | apply (EditItem x) tds = set todosEditing (Just x) tds
90 | apply (EditItemCancel _) tds = set todosEditing Nothing tds
91 | apply (EditItemDone x t) tds = over todosItems adjustOrDelete $ set todosEditing Nothing tds
92 | where
93 | adjustOrDelete =
94 | if t == mempty
95 | then Map.delete x
96 | else Map.adjust (set itemText t) x
97 | apply (Filter f) tds = set todosFilter f tds
98 | apply (NewItem t) tds =
99 | if t == mempty
100 | then tds
101 | else
102 | over todosItems
103 | (Map.insert (view todosNextId tds) (Item Active t)) $
104 | over todosNextId (\(ItemId x) -> (ItemId (x + 1))) $
105 | set todosNewItem mempty tds
106 | apply NoAction tds = tds
107 | apply Refresh tds = tds
108 | apply (Toggle x) tds =
109 | over todosItems (Map.adjust (over itemStatus toggleStatus) x) tds
110 | apply ToggleAll tds =
111 | over todosItems (over (traverse . itemStatus) toggleStatus) tds
112 |
113 | modifyState :: Action -> ListT (State Todos) Todos
114 | modifyState action = case action of
115 | NoAction -> mzero
116 | _ -> do
117 | tds <- lift get
118 | let tds' = apply action tds
119 | lift $ put tds'
120 | pure tds'
121 |
122 | data Out
123 | = StateOut Todos
124 | | ActionOut Action
125 | deriving (Show, Eq)
126 |
127 | makePrisms ''Out
128 |
129 | -- | apply the incoming action to state and pass through the action (just so it can be console logged)
130 | model :: Action -> ListT (State Todos) Out
131 | model action =
132 | (StateOut <$> modifyState action) `mappend` (ActionOut <$> pure action)
133 |
134 |
--------------------------------------------------------------------------------
/mvc-todo.cabal:
--------------------------------------------------------------------------------
1 | name:
2 | mvc-todo
3 | version:
4 | 1.0.0
5 | synopsis:
6 | See readme.lhs
7 | description:
8 | See readme.lhs for description.
9 | category:
10 | project
11 | homepage:
12 | https://github.com/tonyday567/mvc-todo
13 | license:
14 | BSD3
15 | license-file:
16 | LICENSE
17 | author:
18 | Tony Day
19 | maintainer:
20 | tonyday567@gmail.com
21 | copyright:
22 | Tony Day
23 | build-type:
24 | Simple
25 | cabal-version:
26 | >=1.14
27 | extra-source-files:
28 | stack.yaml
29 | library
30 | default-language:
31 | Haskell2010
32 | ghc-options:
33 | hs-source-dirs:
34 | src
35 | exposed-modules:
36 | Todo.Vanilla,
37 | Todo.Arbitrary,
38 | Todo.Controllers,
39 | Todo.Model,
40 | Todo.Views
41 | build-depends:
42 | base >= 4.7 && < 5,
43 | protolude,
44 | clay,
45 | text,
46 | lucid,
47 | lens,
48 | mtl,
49 | data-default,
50 | containers,
51 | pipes,
52 | QuickCheck,
53 | errors,
54 | mmorph,
55 | either,
56 | mvc,
57 | ghcjs-base,
58 | transformers
59 | default-extensions:
60 | NoImplicitPrelude,
61 | UnicodeSyntax,
62 | BangPatterns,
63 | BinaryLiterals,
64 | DeriveFoldable,
65 | DeriveFunctor,
66 | DeriveGeneric,
67 | DeriveTraversable,
68 | DisambiguateRecordFields,
69 | EmptyCase,
70 | FlexibleContexts,
71 | FlexibleInstances,
72 | FunctionalDependencies,
73 | GADTSyntax,
74 | InstanceSigs,
75 | KindSignatures,
76 | LambdaCase,
77 | MonadComprehensions,
78 | MultiParamTypeClasses,
79 | MultiWayIf,
80 | NegativeLiterals,
81 | OverloadedStrings,
82 | ParallelListComp,
83 | PartialTypeSignatures,
84 | PatternSynonyms,
85 | RankNTypes,
86 | RecordWildCards,
87 | RecursiveDo,
88 | ScopedTypeVariables,
89 | TupleSections,
90 | TypeFamilies,
91 | TypeOperators
92 |
93 | executable mvc-todo
94 | default-language:
95 | Haskell2010
96 | ghc-options:
97 | -funbox-strict-fields
98 | -fforce-recomp
99 | -threaded
100 | -rtsopts
101 | -with-rtsopts=-N
102 | hs-source-dirs:
103 | apps
104 | main-is:
105 | mvc-todo.hs
106 | build-depends:
107 | base >= 4.7 && < 5,
108 | protolude,
109 | mvc-todo,
110 | ghcjs-base,
111 | containers,
112 | mvc,
113 | transformers
114 | default-extensions:
115 | NoImplicitPrelude,
116 | UnicodeSyntax,
117 | BangPatterns,
118 | BinaryLiterals,
119 | DeriveFoldable,
120 | DeriveFunctor,
121 | DeriveGeneric,
122 | DeriveTraversable,
123 | DisambiguateRecordFields,
124 | EmptyCase,
125 | FlexibleContexts,
126 | FlexibleInstances,
127 | FunctionalDependencies,
128 | GADTSyntax,
129 | InstanceSigs,
130 | KindSignatures,
131 | LambdaCase,
132 | MonadComprehensions,
133 | MultiParamTypeClasses,
134 | MultiWayIf,
135 | NegativeLiterals,
136 | OverloadedStrings,
137 | ParallelListComp,
138 | PartialTypeSignatures,
139 | PatternSynonyms,
140 | RankNTypes,
141 | RecordWildCards,
142 | RecursiveDo,
143 | ScopedTypeVariables,
144 | TupleSections,
145 | TypeFamilies,
146 | TypeOperators
147 |
148 | executable mvc-todo-auto
149 | default-language:
150 | Haskell2010
151 | ghc-options:
152 | -funbox-strict-fields
153 | -fforce-recomp
154 | -threaded
155 | -rtsopts
156 | -with-rtsopts=-N
157 | hs-source-dirs:
158 | apps
159 | main-is:
160 | mvc-todo-auto.hs
161 | build-depends:
162 | base >= 4.7 && < 5,
163 | protolude,
164 | mvc-todo,
165 | ghcjs-base,
166 | containers,
167 | mvc,
168 | transformers,
169 | lens,
170 | QuickCheck
171 | default-extensions:
172 | NoImplicitPrelude,
173 | UnicodeSyntax,
174 | BangPatterns,
175 | BinaryLiterals,
176 | DeriveFoldable,
177 | DeriveFunctor,
178 | DeriveGeneric,
179 | DeriveTraversable,
180 | DisambiguateRecordFields,
181 | EmptyCase,
182 | FlexibleContexts,
183 | FlexibleInstances,
184 | FunctionalDependencies,
185 | GADTSyntax,
186 | InstanceSigs,
187 | KindSignatures,
188 | LambdaCase,
189 | MonadComprehensions,
190 | MultiParamTypeClasses,
191 | MultiWayIf,
192 | NegativeLiterals,
193 | OverloadedStrings,
194 | ParallelListComp,
195 | PartialTypeSignatures,
196 | PatternSynonyms,
197 | RankNTypes,
198 | RecordWildCards,
199 | RecursiveDo,
200 | ScopedTypeVariables,
201 | TupleSections,
202 | TypeFamilies,
203 | TypeOperators
204 |
205 | source-repository head
206 | type:
207 | git
208 | location:
209 | https://github.com/tonyday567/ghcjs-testing
210 |
--------------------------------------------------------------------------------
/src/Todo/Views.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# OPTIONS_GHC-fno-warn-type-defaults#-}
3 |
4 | module Todo.Views
5 | ( render
6 | ) where
7 |
8 | import Todo.Vanilla
9 | ( Element(..)
10 | , docElement
11 | , addClass
12 | , removeClass
13 | , Selector
14 | , setValue
15 | , setHtml
16 | , focus
17 | , elementOf
18 | )
19 |
20 | import Control.Lens hiding (element, elementOf, itemText, itemStatus)
21 | import Control.Monad (join)
22 | import Data.Foldable (sequenceA_)
23 | import Data.Text (pack)
24 | import Lucid hiding (for_)
25 | import Protolude hiding (on, Selector)
26 | import Todo.Model
27 | import qualified Clay.Selector as Clay
28 | import qualified Data.Map as Map
29 |
30 | render :: Todos -> IO ()
31 | render = sequenceRenderers renderers
32 |
33 | sequenceRenderers :: [Todos -> IO ()] -> Todos -> IO ()
34 | sequenceRenderers rs tds = sequenceA_ $ ($) <$> rs <*> pure tds
35 |
36 | renderers :: [Todos -> IO ()]
37 | renderers =
38 | [ renderClearCompleted
39 | , renderFilter
40 | , renderHideStuff
41 | , renderNewItem
42 | , renderTodoCount
43 | , renderTodoList
44 | , renderFocus
45 | ]
46 |
47 | renderClearCompleted :: Todos -> IO ()
48 | renderClearCompleted tds = do
49 | el <- docElement ".clear-completed"
50 | action el hidden
51 | where
52 | hidden = "hidden" :: Selector
53 | numCompleted =
54 | getSum $
55 | foldMap
56 | (\x -> Sum (if view itemStatus x == Completed then 1 else 0))
57 | (view todosItems tds)
58 | action = if numCompleted == 0
59 | then addClass
60 | else removeClass
61 |
62 | renderFilter :: Todos -> IO ()
63 | renderFilter tds = do
64 | el <- docElement ".filters .selected"
65 | removeClass el selected
66 | newSelection <- docElement
67 | (Clay.element $ ".filters [href='#/" <> currentPage <> "']")
68 | addClass newSelection selected
69 | where
70 | selected = "selected" :: Selector
71 | currentPage =
72 | case view todosFilter tds of
73 | Nothing -> ""
74 | Just Active -> "active"
75 | Just Completed -> "completed"
76 |
77 | renderHideStuff :: Todos -> IO ()
78 | renderHideStuff tds = do
79 | main <- docElement ".main"
80 | foot <- docElement ".footer"
81 | action main hidden
82 | action foot hidden
83 | where
84 | hidden = "hidden" :: Selector
85 | action =
86 | if null (view todosItems tds)
87 | then addClass
88 | else removeClass
89 |
90 | renderNewItem :: Todos -> IO ()
91 | renderNewItem tds = do
92 | el <- docElement ".new-todo"
93 | setValue el (tds^.todosNewItem)
94 |
95 | renderTodoCount :: Todos -> IO ()
96 | renderTodoCount tds = do
97 | el <- docElement ".todo-count"
98 | setHtml el itemsLeft
99 | where
100 | itemsLeft = strong_ (toHtml $ (show n :: Text)) <> " item" <> s <> " left"
101 | n = getSum $
102 | foldMap
103 | (\x -> Sum (if view itemStatus x == Active then 1 else 0))
104 | (view todosItems tds) :: Integer
105 | s = if n == 1
106 | then ""
107 | else "s"
108 |
109 | renderTodoList :: Todos -> IO ()
110 | renderTodoList tds = do
111 | el <- docElement ".todo-list"
112 | setHtml el (htmlItems tds)
113 |
114 | renderFocus :: Todos -> IO ()
115 | renderFocus tds =
116 | case view todosEditing tds of
117 | Nothing -> pure ()
118 | Just _ -> do
119 | el <- docElement ".todo-list"
120 | elEditing <- elementOf el ".editing .edit"
121 | focus (Element elEditing)
122 |
123 | htmlItems :: Todos -> Html ()
124 | htmlItems tds =
125 | mconcat $
126 | fmap
127 | (\(ItemId id', item') ->
128 | htmlItem item' id' (editing == Just (ItemId id')) (visible item'))
129 | items
130 | where
131 | items = Map.toAscList (view todosItems tds)
132 | editing = view todosEditing tds
133 | visible item' =
134 | case view todosFilter tds of
135 | Nothing -> True
136 | Just Active -> view itemStatus item' == Active
137 | Just Completed -> view itemStatus item' == Completed
138 |
139 | htmlItem :: Item -> Int -> Bool -> Bool -> Html ()
140 | htmlItem item' id' editing visible =
141 | li_ (liClass <> [data_ "id" (pack $ show id')])
142 | (div_ itemClass
143 | (input_ ([class_ "toggle", type_ "checkbox"] ++ checked)
144 | <> label_ (toHtml (view itemText item'))
145 | <> button_ [class_ "destroy"] mempty)
146 | <> input_ [class_ "edit", value_ (view itemText item')])
147 | where
148 | liClass
149 | | editing && (view itemStatus item' == Completed) =
150 | [class_ "editing completed"]
151 | | editing = [class_ "editing"]
152 | | view itemStatus item' == Completed = [class_ "completed"]
153 | | otherwise = []
154 | itemClass =
155 | if visible
156 | then [class_ "view"]
157 | else [class_ "hidden"]
158 | checked =
159 | case view itemStatus item' of
160 | Completed -> [checked_]
161 | Active -> []
162 |
--------------------------------------------------------------------------------
/src/Todo/Arbitrary.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# LANGUAGE FlexibleInstances #-}
3 | {-# OPTIONS_GHC -fno-warn-unused-imports #-}
4 | {-# OPTIONS_GHC -fno-warn-type-defaults #-}
5 | {-# OPTIONS_GHC -fno-warn-orphans #-}
6 |
7 | module Todo.Arbitrary where
8 |
9 | import Todo.Model
10 |
11 | import Protolude hiding (Show(..), show)
12 | import Control.Applicative
13 | import Control.Monad
14 | -- import Data.Monoid
15 | import Data.Default (def)
16 | import Test.QuickCheck
17 | import qualified Data.Map as Map
18 | import Data.String
19 | import Data.List (nub)
20 | import Prelude (Show(..))
21 | import Data.Text (pack)
22 |
23 |
24 | instance Arbitrary ItemStatus where
25 | arbitrary =
26 | elements
27 | [ Active
28 | , Completed
29 | ]
30 |
31 | instance Arbitrary ItemId where
32 | arbitrary = do
33 | let maxI = 10
34 | ItemId <$> choose (0,maxI)
35 |
36 | instance Arbitrary Item where
37 | arbitrary = Item <$> arbitrary <*> (pack . show <$> (arbitrary :: Gen TodoStatement))
38 |
39 | instance Arbitrary Todos where
40 | arbitrary =
41 | Todos <$>
42 | (pack . show <$> (arbitrary :: Gen HaskellVerb)) <*>
43 | frequency
44 | [ (8, pure Nothing)
45 | , (2, Just <$> arbitrary)
46 | ] <*>
47 | arbitrary <*>
48 | frequency
49 | [ (6, pure Nothing)
50 | , (4, Just <$> arbitrary)
51 | ] <*>
52 | (Map.fromList <$> (: []) <$> ((,) <$> arbitrary <*> arbitrary))
53 |
54 | instance Arbitrary Action where
55 | arbitrary = frequency
56 | [ (10, Toggle <$> arbitrary)
57 | , (2, pure ToggleAll)
58 | , (6, NewItem <$> (pack . show <$> (arbitrary :: Gen TodoStatement)))
59 | , (6, EditItem <$> arbitrary)
60 | , (6, EditItemCancel <$> arbitrary)
61 | , (6, EditItemDone <$> arbitrary <*> (pack . show <$> (arbitrary :: Gen TodoStatement)))
62 | , (2, Filter <$> arbitrary)
63 | , (4, DeleteItem <$> arbitrary)
64 | , (1, pure ClearCompleted)
65 | ]
66 |
67 | testApply :: IO [Todos]
68 | testApply =
69 | zipWith apply <$>
70 | sample' arbitrary <*>
71 | sample' arbitrary
72 |
73 | data TodoStatement = TodoStatement HaskellVerb HaskellNoun
74 |
75 | instance Show TodoStatement where
76 | show (TodoStatement verb noun) = show verb <> " " <> show noun
77 |
78 | newtype HaskellVerb = HaskellVerb { unVerb :: Text } deriving (Show, Eq)
79 |
80 | instance IsString HaskellVerb where
81 | fromString = HaskellVerb . fromString
82 |
83 | newtype HaskellPrefix = HaskellPrefix { unPrefix :: Text } deriving (Show, Eq)
84 | newtype Haskellism = Haskellism { unHaskellism :: Text }
85 | deriving (Show, Eq)
86 | newtype HaskellSuffix = HaskellSuffix { unSuffix :: Text } deriving (Show, Eq)
87 | data HaskellNoun = HaskellNoun [HaskellPrefix] Haskellism [HaskellSuffix]
88 |
89 | instance Show HaskellNoun where
90 | show (HaskellNoun ps h ss) = show $ mconcat (unPrefix <$> ps) <> unHaskellism h <> mconcat (unSuffix <$> ss)
91 |
92 | instance IsString HaskellNoun where
93 | fromString s = HaskellNoun [] (Haskellism (pack s)) []
94 |
95 | instance IsString Haskellism where
96 | fromString = Haskellism . fromString
97 |
98 | instance Arbitrary (TodoStatement) where
99 | arbitrary = TodoStatement <$> arbitrary <*> arbitrary
100 |
101 | instance Arbitrary (HaskellNoun) where
102 | arbitrary = frequency $
103 | [ (20, HaskellNoun <$> ((take 2 . nub) <$> arbitrary) <*> arbitrary <*> ((take 1) <$> arbitrary))
104 | , (1, pure "cabal hell")
105 | , (1, pure "ADTs")
106 | , (1, pure "everything")
107 | , (5, HaskellNoun <$> pure [] <*> arbitrary <*> pure [])
108 | ]
109 |
110 | instance Arbitrary (HaskellVerb) where
111 | arbitrary = frequency $ (\(x,y) -> (x, pure y)) <$>
112 | [ (3, "invent")
113 | , (3, "ponder")
114 | , (5, "code")
115 | , (1, "beta-reduce")
116 | , (1, "lambdify")
117 | , (3, "refactor")
118 | , (2, "reduce")
119 | , (1, "DeBruijnize")
120 | , (2, "curry")
121 | , (1, "howard-curry")
122 | , (1, "simplify")
123 | , (1, "complexificate")
124 | , (2, "git the")
125 | , (1, "build")
126 | , (1, "prettify")
127 | , (1, "compile")
128 | , (1, "generalize")
129 | , (1, "abstract")
130 | , (1, "ignore")
131 | , (1, "saturate")
132 | -- , (3, show <$> (arbitrary :: Gen Haskellism))
133 | ]
134 |
135 | instance Arbitrary (HaskellPrefix) where
136 | arbitrary = frequency $ (\(x,y) -> (x, pure (HaskellPrefix y))) <$>
137 | [ (1, "homo-")
138 | , (1, "functo-")
139 | , (2, "contra-")
140 | , (2, "bi-")
141 | , (3, "iso-")
142 | , (2, "pro-")
143 | , (4, "co-")
144 | , (4, "free-")
145 | , (1, "endo-")
146 | , (1, "morphic-")
147 | , (10, "")
148 | ]
149 |
150 | instance Arbitrary (HaskellSuffix) where
151 | arbitrary = frequency $ (\(x,y) -> (x, pure (HaskellSuffix y))) <$>
152 | [ (1, "-ism")
153 | , (1, "-orial")
154 | , (1, "-ic")
155 | , (12, "")
156 | ]
157 |
158 | instance Arbitrary (Haskellism) where
159 | arbitrary = frequency $ (\(x,y) -> (x, pure (Haskellism y))) <$>
160 | [ (6, "functor")
161 | , (4, "monoid")
162 | , (1, "dimap")
163 | , (3, "applicative")
164 | , (2, "arrow")
165 | , (3, "monad")
166 | , (1, "something")
167 | ]
168 |
169 |
170 |
171 |
172 |
173 |
174 |
175 |
--------------------------------------------------------------------------------
/other/node_modules/todomvc-common/base.js:
--------------------------------------------------------------------------------
1 | /* global _ */
2 | (function () {
3 | 'use strict';
4 |
5 | /* jshint ignore:start */
6 | // Underscore's Template Module
7 | // Courtesy of underscorejs.org
8 | var _ = (function (_) {
9 | _.defaults = function (object) {
10 | if (!object) {
11 | return object;
12 | }
13 | for (var argsIndex = 1, argsLength = arguments.length; argsIndex < argsLength; argsIndex++) {
14 | var iterable = arguments[argsIndex];
15 | if (iterable) {
16 | for (var key in iterable) {
17 | if (object[key] == null) {
18 | object[key] = iterable[key];
19 | }
20 | }
21 | }
22 | }
23 | return object;
24 | }
25 |
26 | // By default, Underscore uses ERB-style template delimiters, change the
27 | // following template settings to use alternative delimiters.
28 | _.templateSettings = {
29 | evaluate : /<%([\s\S]+?)%>/g,
30 | interpolate : /<%=([\s\S]+?)%>/g,
31 | escape : /<%-([\s\S]+?)%>/g
32 | };
33 |
34 | // When customizing `templateSettings`, if you don't want to define an
35 | // interpolation, evaluation or escaping regex, we need one that is
36 | // guaranteed not to match.
37 | var noMatch = /(.)^/;
38 |
39 | // Certain characters need to be escaped so that they can be put into a
40 | // string literal.
41 | var escapes = {
42 | "'": "'",
43 | '\\': '\\',
44 | '\r': 'r',
45 | '\n': 'n',
46 | '\t': 't',
47 | '\u2028': 'u2028',
48 | '\u2029': 'u2029'
49 | };
50 |
51 | var escaper = /\\|'|\r|\n|\t|\u2028|\u2029/g;
52 |
53 | // JavaScript micro-templating, similar to John Resig's implementation.
54 | // Underscore templating handles arbitrary delimiters, preserves whitespace,
55 | // and correctly escapes quotes within interpolated code.
56 | _.template = function(text, data, settings) {
57 | var render;
58 | settings = _.defaults({}, settings, _.templateSettings);
59 |
60 | // Combine delimiters into one regular expression via alternation.
61 | var matcher = new RegExp([
62 | (settings.escape || noMatch).source,
63 | (settings.interpolate || noMatch).source,
64 | (settings.evaluate || noMatch).source
65 | ].join('|') + '|$', 'g');
66 |
67 | // Compile the template source, escaping string literals appropriately.
68 | var index = 0;
69 | var source = "__p+='";
70 | text.replace(matcher, function(match, escape, interpolate, evaluate, offset) {
71 | source += text.slice(index, offset)
72 | .replace(escaper, function(match) { return '\\' + escapes[match]; });
73 |
74 | if (escape) {
75 | source += "'+\n((__t=(" + escape + "))==null?'':_.escape(__t))+\n'";
76 | }
77 | if (interpolate) {
78 | source += "'+\n((__t=(" + interpolate + "))==null?'':__t)+\n'";
79 | }
80 | if (evaluate) {
81 | source += "';\n" + evaluate + "\n__p+='";
82 | }
83 | index = offset + match.length;
84 | return match;
85 | });
86 | source += "';\n";
87 |
88 | // If a variable is not specified, place data values in local scope.
89 | if (!settings.variable) source = 'with(obj||{}){\n' + source + '}\n';
90 |
91 | source = "var __t,__p='',__j=Array.prototype.join," +
92 | "print=function(){__p+=__j.call(arguments,'');};\n" +
93 | source + "return __p;\n";
94 |
95 | try {
96 | render = new Function(settings.variable || 'obj', '_', source);
97 | } catch (e) {
98 | e.source = source;
99 | throw e;
100 | }
101 |
102 | if (data) return render(data, _);
103 | var template = function(data) {
104 | return render.call(this, data, _);
105 | };
106 |
107 | // Provide the compiled function source as a convenience for precompilation.
108 | template.source = 'function(' + (settings.variable || 'obj') + '){\n' + source + '}';
109 |
110 | return template;
111 | };
112 |
113 | return _;
114 | })({});
115 |
116 | if (location.hostname === 'todomvc.com') {
117 | (function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){
118 | (i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o),
119 | m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m)
120 | })(window,document,'script','https://www.google-analytics.com/analytics.js','ga');
121 | ga('create', 'UA-31081062-1', 'auto');
122 | ga('send', 'pageview');
123 | }
124 | /* jshint ignore:end */
125 |
126 | function redirect() {
127 | if (location.hostname === 'tastejs.github.io') {
128 | location.href = location.href.replace('tastejs.github.io/todomvc', 'todomvc.com');
129 | }
130 | }
131 |
132 | function findRoot() {
133 | var base = location.href.indexOf('examples/');
134 | return location.href.substr(0, base);
135 | }
136 |
137 | function getFile(file, callback) {
138 | if (!location.host) {
139 | return console.info('Miss the info bar? Run TodoMVC from a server to avoid a cross-origin error.');
140 | }
141 |
142 | var xhr = new XMLHttpRequest();
143 |
144 | xhr.open('GET', findRoot() + file, true);
145 | xhr.send();
146 |
147 | xhr.onload = function () {
148 | if (xhr.status === 200 && callback) {
149 | callback(xhr.responseText);
150 | }
151 | };
152 | }
153 |
154 | function Learn(learnJSON, config) {
155 | if (!(this instanceof Learn)) {
156 | return new Learn(learnJSON, config);
157 | }
158 |
159 | var template, framework;
160 |
161 | if (typeof learnJSON !== 'object') {
162 | try {
163 | learnJSON = JSON.parse(learnJSON);
164 | } catch (e) {
165 | return;
166 | }
167 | }
168 |
169 | if (config) {
170 | template = config.template;
171 | framework = config.framework;
172 | }
173 |
174 | if (!template && learnJSON.templates) {
175 | template = learnJSON.templates.todomvc;
176 | }
177 |
178 | if (!framework && document.querySelector('[data-framework]')) {
179 | framework = document.querySelector('[data-framework]').dataset.framework;
180 | }
181 |
182 | this.template = template;
183 |
184 | if (learnJSON.backend) {
185 | this.frameworkJSON = learnJSON.backend;
186 | this.frameworkJSON.issueLabel = framework;
187 | this.append({
188 | backend: true
189 | });
190 | } else if (learnJSON[framework]) {
191 | this.frameworkJSON = learnJSON[framework];
192 | this.frameworkJSON.issueLabel = framework;
193 | this.append();
194 | }
195 |
196 | this.fetchIssueCount();
197 | }
198 |
199 | Learn.prototype.append = function (opts) {
200 | var aside = document.createElement('aside');
201 | aside.innerHTML = _.template(this.template, this.frameworkJSON);
202 | aside.className = 'learn';
203 |
204 | if (opts && opts.backend) {
205 | // Remove demo link
206 | var sourceLinks = aside.querySelector('.source-links');
207 | var heading = sourceLinks.firstElementChild;
208 | var sourceLink = sourceLinks.lastElementChild;
209 | // Correct link path
210 | var href = sourceLink.getAttribute('href');
211 | sourceLink.setAttribute('href', href.substr(href.lastIndexOf('http')));
212 | sourceLinks.innerHTML = heading.outerHTML + sourceLink.outerHTML;
213 | } else {
214 | // Localize demo links
215 | var demoLinks = aside.querySelectorAll('.demo-link');
216 | Array.prototype.forEach.call(demoLinks, function (demoLink) {
217 | if (demoLink.getAttribute('href').substr(0, 4) !== 'http') {
218 | demoLink.setAttribute('href', findRoot() + demoLink.getAttribute('href'));
219 | }
220 | });
221 | }
222 |
223 | document.body.className = (document.body.className + ' learn-bar').trim();
224 | document.body.insertAdjacentHTML('afterBegin', aside.outerHTML);
225 | };
226 |
227 | Learn.prototype.fetchIssueCount = function () {
228 | var issueLink = document.getElementById('issue-count-link');
229 | if (issueLink) {
230 | var url = issueLink.href.replace('https://github.com', 'https://api.github.com/repos');
231 | var xhr = new XMLHttpRequest();
232 | xhr.open('GET', url, true);
233 | xhr.onload = function (e) {
234 | var parsedResponse = JSON.parse(e.target.responseText);
235 | if (parsedResponse instanceof Array) {
236 | var count = parsedResponse.length;
237 | if (count !== 0) {
238 | issueLink.innerHTML = 'This app has ' + count + ' open issues';
239 | document.getElementById('issue-count').style.display = 'inline';
240 | }
241 | }
242 | };
243 | xhr.send();
244 | }
245 | };
246 |
247 | redirect();
248 | getFile('learn.json', Learn);
249 | })();
250 |
--------------------------------------------------------------------------------
/other/node_modules/todomvc-app-css/index.css:
--------------------------------------------------------------------------------
1 | html,
2 | body {
3 | margin: 0;
4 | padding: 0;
5 | }
6 |
7 | button {
8 | margin: 0;
9 | padding: 0;
10 | border: 0;
11 | background: none;
12 | font-size: 100%;
13 | vertical-align: baseline;
14 | font-family: inherit;
15 | font-weight: inherit;
16 | color: inherit;
17 | -webkit-appearance: none;
18 | appearance: none;
19 | -webkit-font-smoothing: antialiased;
20 | -moz-font-smoothing: antialiased;
21 | font-smoothing: antialiased;
22 | }
23 |
24 | body {
25 | font: 14px 'Helvetica Neue', Helvetica, Arial, sans-serif;
26 | line-height: 1.4em;
27 | background: #f5f5f5;
28 | color: #4d4d4d;
29 | min-width: 230px;
30 | max-width: 550px;
31 | margin: 0 auto;
32 | -webkit-font-smoothing: antialiased;
33 | -moz-font-smoothing: antialiased;
34 | font-smoothing: antialiased;
35 | font-weight: 300;
36 | }
37 |
38 | button,
39 | input[type="checkbox"] {
40 | outline: none;
41 | }
42 |
43 | .hidden {
44 | display: none;
45 | }
46 |
47 | .todoapp {
48 | background: #fff;
49 | margin: 130px 0 40px 0;
50 | position: relative;
51 | box-shadow: 0 2px 4px 0 rgba(0, 0, 0, 0.2),
52 | 0 25px 50px 0 rgba(0, 0, 0, 0.1);
53 | }
54 |
55 | .todoapp input::-webkit-input-placeholder {
56 | font-style: italic;
57 | font-weight: 300;
58 | color: #e6e6e6;
59 | }
60 |
61 | .todoapp input::-moz-placeholder {
62 | font-style: italic;
63 | font-weight: 300;
64 | color: #e6e6e6;
65 | }
66 |
67 | .todoapp input::input-placeholder {
68 | font-style: italic;
69 | font-weight: 300;
70 | color: #e6e6e6;
71 | }
72 |
73 | .todoapp h1 {
74 | position: absolute;
75 | top: -155px;
76 | width: 100%;
77 | font-size: 100px;
78 | font-weight: 100;
79 | text-align: center;
80 | color: rgba(175, 47, 47, 0.15);
81 | -webkit-text-rendering: optimizeLegibility;
82 | -moz-text-rendering: optimizeLegibility;
83 | text-rendering: optimizeLegibility;
84 | }
85 |
86 | .new-todo,
87 | .edit {
88 | position: relative;
89 | margin: 0;
90 | width: 100%;
91 | font-size: 24px;
92 | font-family: inherit;
93 | font-weight: inherit;
94 | line-height: 1.4em;
95 | border: 0;
96 | outline: none;
97 | color: inherit;
98 | padding: 6px;
99 | border: 1px solid #999;
100 | box-shadow: inset 0 -1px 5px 0 rgba(0, 0, 0, 0.2);
101 | box-sizing: border-box;
102 | -webkit-font-smoothing: antialiased;
103 | -moz-font-smoothing: antialiased;
104 | font-smoothing: antialiased;
105 | }
106 |
107 | .new-todo {
108 | padding: 16px 16px 16px 60px;
109 | border: none;
110 | background: rgba(0, 0, 0, 0.003);
111 | box-shadow: inset 0 -2px 1px rgba(0,0,0,0.03);
112 | }
113 |
114 | .main {
115 | position: relative;
116 | z-index: 2;
117 | border-top: 1px solid #e6e6e6;
118 | }
119 |
120 | label[for='toggle-all'] {
121 | display: none;
122 | }
123 |
124 | .toggle-all {
125 | position: absolute;
126 | top: -55px;
127 | left: -12px;
128 | width: 60px;
129 | height: 34px;
130 | text-align: center;
131 | border: none; /* Mobile Safari */
132 | }
133 |
134 | .toggle-all:before {
135 | content: '❯';
136 | font-size: 22px;
137 | color: #e6e6e6;
138 | padding: 10px 27px 10px 27px;
139 | }
140 |
141 | .toggle-all:checked:before {
142 | color: #737373;
143 | }
144 |
145 | .todo-list {
146 | margin: 0;
147 | padding: 0;
148 | list-style: none;
149 | }
150 |
151 | .todo-list li {
152 | position: relative;
153 | font-size: 24px;
154 | border-bottom: 1px solid #ededed;
155 | }
156 |
157 | .todo-list li:last-child {
158 | border-bottom: none;
159 | }
160 |
161 | .todo-list li.editing {
162 | border-bottom: none;
163 | padding: 0;
164 | }
165 |
166 | .todo-list li.editing .edit {
167 | display: block;
168 | width: 506px;
169 | padding: 13px 17px 12px 17px;
170 | margin: 0 0 0 43px;
171 | }
172 |
173 | .todo-list li.editing .view {
174 | display: none;
175 | }
176 |
177 | .todo-list li .toggle {
178 | text-align: center;
179 | width: 40px;
180 | /* auto, since non-WebKit browsers doesn't support input styling */
181 | height: auto;
182 | position: absolute;
183 | top: 0;
184 | bottom: 0;
185 | margin: auto 0;
186 | border: none; /* Mobile Safari */
187 | -webkit-appearance: none;
188 | appearance: none;
189 | }
190 |
191 | .todo-list li .toggle:after {
192 | content: url('data:image/svg+xml;utf8,');
193 | }
194 |
195 | .todo-list li .toggle:checked:after {
196 | content: url('data:image/svg+xml;utf8,');
197 | }
198 |
199 | .todo-list li label {
200 | white-space: pre-line;
201 | word-break: break-all;
202 | padding: 15px 60px 15px 15px;
203 | margin-left: 45px;
204 | display: block;
205 | line-height: 1.2;
206 | transition: color 0.4s;
207 | }
208 |
209 | .todo-list li.completed label {
210 | color: #d9d9d9;
211 | text-decoration: line-through;
212 | }
213 |
214 | .todo-list li .destroy {
215 | display: none;
216 | position: absolute;
217 | top: 0;
218 | right: 10px;
219 | bottom: 0;
220 | width: 40px;
221 | height: 40px;
222 | margin: auto 0;
223 | font-size: 30px;
224 | color: #cc9a9a;
225 | margin-bottom: 11px;
226 | transition: color 0.2s ease-out;
227 | }
228 |
229 | .todo-list li .destroy:hover {
230 | color: #af5b5e;
231 | }
232 |
233 | .todo-list li .destroy:after {
234 | content: '×';
235 | }
236 |
237 | .todo-list li:hover .destroy {
238 | display: block;
239 | }
240 |
241 | .todo-list li .edit {
242 | display: none;
243 | }
244 |
245 | .todo-list li.editing:last-child {
246 | margin-bottom: -1px;
247 | }
248 |
249 | .footer {
250 | color: #777;
251 | padding: 10px 15px;
252 | height: 20px;
253 | text-align: center;
254 | border-top: 1px solid #e6e6e6;
255 | }
256 |
257 | .footer:before {
258 | content: '';
259 | position: absolute;
260 | right: 0;
261 | bottom: 0;
262 | left: 0;
263 | height: 50px;
264 | overflow: hidden;
265 | box-shadow: 0 1px 1px rgba(0, 0, 0, 0.2),
266 | 0 8px 0 -3px #f6f6f6,
267 | 0 9px 1px -3px rgba(0, 0, 0, 0.2),
268 | 0 16px 0 -6px #f6f6f6,
269 | 0 17px 2px -6px rgba(0, 0, 0, 0.2);
270 | }
271 |
272 | .todo-count {
273 | float: left;
274 | text-align: left;
275 | }
276 |
277 | .todo-count strong {
278 | font-weight: 300;
279 | }
280 |
281 | .filters {
282 | margin: 0;
283 | padding: 0;
284 | list-style: none;
285 | position: absolute;
286 | right: 0;
287 | left: 0;
288 | }
289 |
290 | .filters li {
291 | display: inline;
292 | }
293 |
294 | .filters li a {
295 | color: inherit;
296 | margin: 3px;
297 | padding: 3px 7px;
298 | text-decoration: none;
299 | border: 1px solid transparent;
300 | border-radius: 3px;
301 | }
302 |
303 | .filters li a.selected,
304 | .filters li a:hover {
305 | border-color: rgba(175, 47, 47, 0.1);
306 | }
307 |
308 | .filters li a.selected {
309 | border-color: rgba(175, 47, 47, 0.2);
310 | }
311 |
312 | .clear-completed,
313 | html .clear-completed:active {
314 | float: right;
315 | position: relative;
316 | line-height: 20px;
317 | text-decoration: none;
318 | cursor: pointer;
319 | position: relative;
320 | }
321 |
322 | .clear-completed:hover {
323 | text-decoration: underline;
324 | }
325 |
326 | .info {
327 | margin: 65px auto 0;
328 | color: #bfbfbf;
329 | font-size: 10px;
330 | text-shadow: 0 1px 0 rgba(255, 255, 255, 0.5);
331 | text-align: center;
332 | }
333 |
334 | .info p {
335 | line-height: 1;
336 | }
337 |
338 | .info a {
339 | color: inherit;
340 | text-decoration: none;
341 | font-weight: 400;
342 | }
343 |
344 | .info a:hover {
345 | text-decoration: underline;
346 | }
347 |
348 | /*
349 | Hack to remove background from Mobile Safari.
350 | Can't use it globally since it destroys checkboxes in Firefox
351 | */
352 | @media screen and (-webkit-min-device-pixel-ratio:0) {
353 | .toggle-all,
354 | .todo-list li .toggle {
355 | background: none;
356 | }
357 |
358 | .todo-list li .toggle {
359 | height: 40px;
360 | }
361 |
362 | .toggle-all {
363 | -webkit-transform: rotate(90deg);
364 | transform: rotate(90deg);
365 | -webkit-appearance: none;
366 | appearance: none;
367 | }
368 | }
369 |
370 | @media (max-width: 430px) {
371 | .footer {
372 | height: 50px;
373 | }
374 |
375 | .filters {
376 | bottom: 10px;
377 | }
378 | }
379 |
--------------------------------------------------------------------------------
/src/Todo/Vanilla.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP #-}
2 | {-# LANGUAGE TypeSynonymInstances #-}
3 | {-# LANGUAGE FlexibleInstances #-}
4 | {-# OPTIONS_GHC -fno-warn-orphans #-}
5 | {-# LANGUAGE OverloadedStrings #-}
6 | {-# OPTIONS_GHC -fno-warn-type-defaults #-}
7 |
8 | module Todo.Vanilla
9 | ( Element(..)
10 | , Selector
11 | , consoleLog
12 | , alert
13 | , onload
14 | , addClass
15 | , removeClass
16 | , setHtml
17 | , docElement
18 | , elementsOf
19 | , elementOf
20 | , getValue
21 | , setValue
22 | , itemId
23 | , focus
24 | , checked
25 | , keyCode
26 | , getHash
27 | , on
28 | , onWindow
29 | , delegate
30 | , JSVal
31 | , toJSVal
32 | ) where
33 |
34 | import Clay.Render (renderSelector)
35 | import Clay.Selector (Selector)
36 | import Data.Char
37 | import Data.Foldable
38 | import Data.Maybe (fromJust)
39 | import Data.Typeable
40 | import Lucid
41 | import Protolude hiding (Selector, on)
42 | import Unsafe.Coerce (unsafeCoerce)
43 |
44 | import qualified Data.Text.Lazy as LText
45 | import qualified Text.Read as Text
46 |
47 | import GHCJS.Types
48 | import GHCJS.Marshal
49 | import GHCJS.Foreign
50 | import GHCJS.Foreign.Callback
51 | import GHCJS.Nullable (maybeToNullable, nullableToMaybe, Nullable)
52 | import Data.JSString.Text (textToJSString, textFromJSString, lazyTextToJSString, lazyTextFromJSString)
53 |
54 | data Element = Element JSVal
55 |
56 | fromHtml = lazyTextToJSString . renderText
57 |
58 | fromSel = lazyTextToJSString . renderSelector
59 |
60 | -- * the big 3
61 | -- | console.log
62 | foreign import javascript unsafe
63 | "console.log($1)"
64 | js_consoleLog :: JSString -> IO ()
65 |
66 | consoleLog :: Text -> IO ()
67 | consoleLog a = js_consoleLog (textToJSString a)
68 |
69 | foreign import javascript unsafe
70 | "alert($1)" js_alert :: JSString -> IO ()
71 |
72 | alert :: Text -> IO ()
73 | alert t = js_alert (textToJSString t)
74 |
75 | foreign import javascript unsafe "window.onload = $1"
76 | js_onload :: Callback (IO ()) -> IO ()
77 |
78 | onload :: IO () -> IO ()
79 | onload f = do
80 | f_ <- asyncCallback f
81 | js_onload f_
82 |
83 |
84 | -- * element manipulation
85 | foreign import javascript unsafe
86 | "$1.classList.add($2)"
87 | js_classListAdd :: JSVal -> JSString -> IO ()
88 |
89 | addClass :: Element -> Selector -> IO ()
90 | addClass (Element el) sel =
91 | js_classListAdd el (fromSel sel)
92 |
93 | foreign import javascript unsafe
94 | "$1.classList.remove($2)"
95 | js_classListRemove :: JSVal -> JSString -> IO ()
96 |
97 | removeClass :: Element -> Selector -> IO ()
98 | removeClass (Element el) sel =
99 | js_classListRemove el (fromSel sel)
100 |
101 | foreign import javascript unsafe
102 | "$1.innerHTML = $2"
103 | js_innerHtml :: JSVal -> JSString -> IO ()
104 |
105 | setHtml :: Element -> Html () -> IO ()
106 | setHtml (Element el) html =
107 | js_innerHtml el (fromHtml html)
108 |
109 | foreign import javascript unsafe
110 | "document.querySelector($1)"
111 | js_docQuerySelector :: JSString -> IO JSVal
112 |
113 | -- | element selection
114 | docElement :: Selector -> IO Element
115 | docElement sel =
116 | Element <$> js_docQuerySelector (fromSel sel)
117 |
118 | foreign import javascript unsafe
119 | "$1.querySelectorAll($2)"
120 | js_querySelectorAll :: JSVal -> JSString -> IO JSVal
121 |
122 | elementsOf :: Element -> Selector -> IO JSVal
123 | elementsOf (Element el) sel = js_querySelectorAll el (fromSel sel)
124 |
125 | foreign import javascript unsafe
126 | "$1.querySelector($2)"
127 | js_querySelector :: JSVal -> JSString -> IO JSVal
128 |
129 | elementOf :: Element -> Selector -> IO JSVal
130 | elementOf (Element el) sel = js_querySelector el (fromSel sel)
131 |
132 | foreign import javascript unsafe
133 | "$1.value"
134 | js_getValue :: JSVal -> IO JSString
135 |
136 | getValue :: Element -> IO Text
137 | getValue (Element el) = textFromJSString <$> js_getValue el
138 |
139 | foreign import javascript unsafe
140 | "$1.value = $2"
141 | js_setValue :: JSVal -> JSString -> IO ()
142 |
143 | setValue :: Element -> Text -> IO ()
144 | setValue (Element el) val = js_setValue el (textToJSString val)
145 |
146 | foreign import javascript unsafe
147 | "$1.dataset.id"
148 | js_getDatasetId :: JSVal -> IO JSString
149 |
150 | itemId :: Element -> IO (Maybe Int)
151 | itemId (Element el) = do
152 | i <- js_getDatasetId el
153 | pure $ readMaybe (LText.unpack $ lazyTextFromJSString i)
154 |
155 | foreign import javascript unsafe
156 | "$1.focus()"
157 | js_focus :: JSVal -> IO ()
158 |
159 | focus :: Element -> IO ()
160 | focus (Element el) = js_focus el
161 |
162 | foreign import javascript unsafe
163 | "$1.item($2)"
164 | js_getItem :: JSVal -> Int -> IO (Nullable JSVal)
165 |
166 | -- getItem :: NodeList -> Int -> IO (Maybe Node)
167 | getItem :: JSVal -> Int -> IO (Maybe JSVal)
168 | getItem list n =
169 | nullableToMaybe <$> js_getItem list n
170 |
171 | foreign import javascript unsafe
172 | "$1.keyCode"
173 | js_keyCode :: JSVal -> IO Int
174 |
175 | keyCode :: JSVal -> IO Int
176 | keyCode ev = js_keyCode ev
177 |
178 | foreign import javascript unsafe
179 | "document.location.hash"
180 | js_getHash :: IO JSString
181 |
182 | getHash :: IO JSString
183 | getHash = js_getHash
184 |
185 | foreign import javascript unsafe
186 | "$1.checked"
187 | js_checked :: JSVal -> IO Bool
188 |
189 | checked :: Element -> IO Bool
190 | checked (Element el) = js_checked el
191 |
192 | -- * event listening
193 | foreign import javascript unsafe
194 | "$1.addEventListener($2,$3,$4)"
195 | js_addEventListener :: JSVal -> JSString -> Callback (JSVal -> IO ()) -> Bool -> IO ()
196 |
197 | on :: Element -> Text -> (Element -> JSVal -> IO ()) -> IO ()
198 | on (Element el) uiAction handler = do
199 | handler' <- asyncCallback1 (handler (Element el))
200 | js_addEventListener el (textToJSString uiAction) handler' False
201 |
202 | foreign import javascript unsafe
203 | "window.addEventListener($1,$2,$3)"
204 | jsWindowAddEventListener :: JSString -> Callback (JSVal -> IO ()) -> Bool -> IO ()
205 |
206 | -- null = maybeToNullable Nothing
207 |
208 | onWindow :: LText.Text -> (JSVal -> IO ()) -> IO ()
209 | onWindow uiAction handler = do
210 | handler' <- asyncCallback1 handler
211 | jsWindowAddEventListener
212 | (lazyTextToJSString uiAction)
213 | handler'
214 | False
215 |
216 | delegate :: Element -> Selector -> Text -> (Element -> JSVal -> IO ()) -> IO ()
217 | delegate (Element base) pattern0 ev action = do
218 | let useCapture = ev == "blur" || ev == "focus"
219 | dispatch <- asyncCallback1 $ applyIn (Element base) pattern0 action
220 | js_addEventListener base (textToJSString ev) dispatch useCapture
221 |
222 | foreign import javascript unsafe
223 | "$1.target"
224 | js_target :: JSVal -> IO JSVal
225 |
226 | foreign import javascript unsafe
227 | "$1===$2"
228 | js_eq :: JSVal -> JSVal -> IO Bool
229 |
230 | foreign import javascript unsafe
231 | "$1.length"
232 | js_length :: JSVal -> IO Int
233 |
234 | applyIn :: Element -> Selector -> (Element -> JSVal -> IO ()) -> JSVal -> IO ()
235 | applyIn base pattern0 action ev = do
236 | t <- js_target ev
237 | p <- elementsOf base pattern0
238 | n <- js_length p
239 | elem' <- findM
240 | (\x -> do
241 | item <- getItem p x
242 | case item of
243 | Nothing -> pure False
244 | Just item' -> js_eq t item') [0..n]
245 | case elem' of
246 | Nothing -> pure ()
247 | Just iElem -> do
248 | eitem <- getItem p iElem
249 | case eitem of
250 | Nothing -> pure ()
251 | Just eitem' -> do
252 | li <- findUp (Element eitem') "li"
253 | case li of
254 | Nothing -> print "no li parent???"
255 | Just li' -> action li' ev
256 |
257 | foreign import javascript unsafe
258 | "$1.parentElement"
259 | js_parentElement :: JSVal -> IO (Nullable JSVal)
260 |
261 | foreign import javascript unsafe
262 | "$1.tagName"
263 | js_tagName :: JSVal -> IO JSString
264 |
265 | -- | go up the tree and find an element, if it exists
266 | findUp :: Element -> LText.Text -> IO (Maybe Element)
267 | findUp (Element base) sel = do
268 | parent <- nullableToMaybe <$> js_parentElement base
269 | case parent of
270 | Nothing -> pure Nothing
271 | Just parent' -> do
272 | name <- js_tagName parent'
273 | if (LText.toLower $ lazyTextFromJSString name) == (LText.toLower sel)
274 | then pure $ Just (Element parent')
275 | else findUp (Element parent') sel
276 |
277 | findM :: (Monad m, Traversable t) => (a -> m Bool) -> t a -> m (Maybe a)
278 | findM p = fmap (getFirst . fold) . mapM
279 | (fmap First . (\x -> do
280 | p' <- p x
281 | pure $ if p' then Just x else Nothing))
282 |
--------------------------------------------------------------------------------