-
Notifications
You must be signed in to change notification settings - Fork 1
/
Apps.hs
166 lines (121 loc) · 5.31 KB
/
Apps.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
module Apps where
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import Control.Category (Category (..))
import Miso hiding (View)
import qualified Miso.Html as H
import Miso.String (MisoString, pack, ms)
import Data.Semigroup (Sum (..))
import Data.List (zipWith)
import Prelude hiding (id, product, (.))
import Elmlens
import Data.Map (singleton)
data IntU
instance UpdateStructure IntU where
type Model IntU = Int
type Msg IntU = Sum Int
upd _ n (Sum m) = n + m
data IntU'
data IncDec = Incr | Decr deriving Eq
instance UpdateStructure IntU' where
type Model IntU' = Int
type Msg IntU' = [ IncDec ]
upd _ n [] = n
upd u n (Incr:xs) = upd u (n+1) xs
upd u n (Decr:xs) = upd u (n-1) xs
counter :: ElmApp IntU IntU Html
counter = fromView (\x -> Html $ H.div_ [] [
H.button_ [ H.onClick $ Sum 1 ] [ H.text "+" ],
H.text (ms x),
H.button_ [ H.onClick $ Sum (-1) ] [ H.text "-" ] ])
counterApp :: Maybe MisoString -> App (Model IntU) (Msg IntU)
counterApp = render counter 0
data RepU (a :: Type)
data ScratchMsg a = Replace a | Keep deriving (Eq, Show)
instance Semigroup (ScratchMsg a) where
Keep <> b = b
Replace a <> Keep = Replace a
Replace _ <> Replace b = Replace b
instance Monoid (ScratchMsg a) where
mempty = Keep
instance (Eq a) => UpdateStructure (RepU a) where
type Model (RepU a) = a
type Msg (RepU a) = ScratchMsg a
upd _ a Keep = a
upd _ _ (Replace a) = a
type IntU'' = RepU Int
-- value == (5, 1)
value = upd (Proxy :: Proxy (ProdU IntU'' IntU'')) (1, 1) (Replace 5, Keep)
type BoolU = RepU Bool
checkButton :: ElmApp BoolU BoolU Html
checkButton = fromView (\b -> Html $ H.input_ [ H.type_ "checkbox", H.class_ "uk-checkbox", H.checked_ b, H.onChecked (\(Checked x) -> Replace x) ] )
type StringU = RepU MisoString
highlightButton :: ElmApp (RepU ()) (RepU ()) (ListV Attr :~> Html)
highlightButton = fromView (\_ -> Holed $ \f (ListV properties) -> Html $ H.button_ (fmap (\(Attr p) -> p) properties) ["Click here"])
highlightProperties :: ElmApp (ProdU (RepU Int) (ListU (RepU ()))) (ProdU (RepU Int) (ListU (RepU ()))) (ListV (ListV Attr))
highlightProperties = fromView (\(i, list) -> ListV $ fmap (f i) [0..(Prelude.length list)])
where
f i n = if n == i then ListV [Attr $ H.class_ "chosen"]
else ListV [Attr $ H.class_ "not_chosen", Attr $ H.onClick (Replace n, mempty)]
highlightDemo = vmap f $ dup (lmap (proj2L 0) (list highlightButton )) highlightProperties
where
f :: View (ProdV (ListV (v :~> Html)) (ListV v)) m -> View Html m
f (ProdV (ListV buttons) (ListV properties)) =
Html $ H.div_ [] ((\(Html h) -> h) <$> Prelude.zipWith (<~|) buttons properties)
highlightDemoApp = render highlightDemo (0, [(), (), (), (), ()])
data UnitU (a :: Type)
instance (Monoid a, Eq a) => UpdateStructure (UnitU a) where
type Model (UnitU a) = ()
type Msg (UnitU a) = a
upd _ _ _ = ()
unitL :: (UpdateStructure u) => Model u -> ULens u (UnitU a)
unitL m = ULens { get = const (), trans = const mempty, create = const m }
type NameU = RepU MisoString
type AddrU = RepU MisoString
nameApp :: ElmApp NameU NameU Html
nameApp = fromView $ \name -> Html $ H.div_ [] [
H.label_ [] [ H.text "Name: " ],
H.input_ [ H.value_ name, H.onInput Replace ] ]
addrApp :: ElmApp AddrU AddrU Html
addrApp = fromView $ \addr -> Html $ H.div_ [] [
H.label_ [] [ H.text "Addr: " ],
H.input_ [ H.value_ addr, H.onInput Replace ] ]
formApp :: ElmApp (ProdU NameU AddrU) (ProdU NameU AddrU) Html
formApp = vmap f $ product nameApp addrApp
where
f :: View (ProdV Html Html) m -> View Html m
f (ProdV (Html vname) (Html vaddr)) = Html $ H.div_ [] [ vname, vaddr ]
data ChildU
newtype Child = Child Int deriving Eq
instance UpdateStructure ChildU where
type Model ChildU = Child
type Msg ChildU = Sum Int
upd _ (Child model) (Sum msg) = Child (model + msg)
data ParentU
newtype Parent = Parent Bool deriving Eq
instance UpdateStructure ParentU where
type Model ParentU = Parent
type Msg ParentU = Sum Int
upd _ (Parent True) (Sum msg) = Parent (even msg)
upd _ (Parent False) (Sum msg) = Parent (odd msg)
childApp :: ElmApp ChildU ChildU (Attr :~> Html)
childApp = fromView $ \(Child model) -> Holed $ \f (Attr attr) -> Html $ H.div_ [] [
H.button_ [ H.onClick $ f $ Sum 1 ] [ H.text "To Child " ],
H.label_ [] [ H.text $ pack ("Child: " ++ show model) ],
H.button_ [ attr ] [ H.text "To Parent" ] ]
parentApp :: ElmApp ParentU ParentU (ProdV Attr (Html :~> Html))
parentApp = fromView $ \(Parent model) -> ProdV (Attr $ onClick $ Sum 1) (Holed $ \f (Html child) -> Html $
H.div_ [ H.style_ $ singleton "background" $ if model then "red" else "blue" ] [ child ] )
themeApp:: ElmApp (ProdU ChildU ParentU) (ProdU ChildU ParentU) Html
themeApp = vmap f $ product childApp parentApp
where
f :: View (ProdV (Attr :~> Html) (ProdV Attr (Html :~> Html))) m -> View Html m
f (ProdV childTemplate (ProdV onClick parentTemplate)) = parentTemplate <~| (childTemplate <~| onClick)
clickToUpdateChild :: View Attr ()
clickToUpdateChild = Attr $ H.onClick ()
-- template :: View (Html :~> Html) ()
-- template = Holed $ \f (Html child) -> Html $ H.div_ [] [ child ]