Skip to content

Commit 29755f8

Browse files
soupisoupi
committed
Moving to smolder + signal
1 parent 8acb1d3 commit 29755f8

File tree

5 files changed

+193
-97
lines changed

5 files changed

+193
-97
lines changed

‎bower.json

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -24,7 +24,8 @@
2424
"purescript-maybe": "^1.0.0",
2525
"purescript-control": "^1.0.0",
2626
"purescript-foldable-traversable": "^1.0.0",
27-
"purescript-halogen": "^0.9.0"
27+
"purescript-signal": "^6.1.0",
28+
"purescript-smolder": "^4.0.1"
2829
},
2930
"resolutions": {
3031
"purescript-prelude": "^1.0.1",

‎index.html

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@
55
<link rel="stylesheet" type="text/css" href="style.css">
66
</head>
77
<body>
8+
<div id="main"></div>
89
<script src="app.js"></script>
910
</body>
1011
</html>

‎src/Slides.js

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
exports.setHtml = function(html) {
2+
return function() {
3+
document.getElementById("main").outerHTML = html;
4+
}
5+
};

‎src/Slides.purs

Lines changed: 67 additions & 96 deletions
Original file line numberDiff line numberDiff line change
@@ -3,7 +3,6 @@
33
module Slides
44
( runSlides
55
, mkSlides
6-
, ui
76
, Move()
87
, Slides()
98
, Slide()
@@ -29,89 +28,75 @@ module Slides
2928

3029
import Prelude
3130
import Data.List.Zipper as Z
31+
import Slides.Internal.Input as I
3232
import Control.Comonad (extract)
3333
import Control.Monad.Eff (Eff)
34+
import DOM (DOM)
3435
import Data.Array ((:), uncons, singleton)
35-
import Data.Foldable (foldr)
36+
import Data.Foldable (foldMap, fold, foldr)
3637
import Data.Functor (($>))
3738
import Data.Generic (class Generic, gShow)
3839
import Data.List (List(..), length)
3940
import Data.Maybe (Maybe(..), fromMaybe)
40-
import Halogen (ComponentDSL, ComponentHTML, Component, HalogenEffects, component, modify, runUI)
41-
import Halogen.HTML (className) as H
42-
import Halogen.HTML.Events.Handler (preventDefault) as Events
43-
import Halogen.HTML.Events.Indexed (onKeyPress, input_, onClick) as Events
44-
import Halogen.HTML.Indexed (HTML(Element), className, span, li_, ul_, img, text, p, a, h2_, span_, div, button) as Html
45-
import Halogen.HTML.Properties (id_, class_) as H
46-
import Halogen.HTML.Properties.Indexed (class_, src, href) as Html
47-
import Halogen.Query (action)
48-
import Halogen.Util (awaitBody, runHalogenAff)
49-
41+
import Signal (foldp, runSignal) as S
42+
import Text.Smolder.HTML (p, div, img, a, h2, ul, li, span) as H
43+
import Text.Smolder.HTML.Attributes (className, id, src, href) as H
44+
import Text.Smolder.Markup (Markup, text) as H
45+
import Text.Smolder.Markup ((!))
46+
import Text.Smolder.Renderer.String (render) as H
5047

5148
-------------
5249
-- Running --
5350
-------------
5451

52+
5553
-- | run a component for a presentation
56-
runSlides :: Slides -> Eff (HalogenEffects ()) Unit
57-
runSlides slides = runHalogenAff do
58-
body <- awaitBody
59-
runUI ui slides body
60-
61-
-- | Halogen UI component for a presentation
62-
ui :: forall g. Component Slides Move g
63-
ui = component { render, eval }
64-
where
65-
66-
render :: Slides -> ComponentHTML Move
67-
render (Slides state) =
68-
Html.span []
69-
[ Html.button [ keyboardEvent, Events.onClick (Events.input_ Back) ] [ Html.text "Back" ]
70-
, Html.button [ keyboardEvent, Events.onClick (Events.input_ Next) ] [ Html.text "Next" ]
71-
, Html.span
72-
[ Html.class_ $ Html.className "counter" ]
73-
[ Html.text $ show (position state + 1) <> " / " <> show (zipLength state) ]
74-
, renderSlides (extract state)
75-
]
76-
77-
eval :: Move ~> (ComponentDSL Slides Move g)
78-
eval move = do
79-
modify (\(Slides slides) -> Slides $ moveSlides move slides)
80-
pure (getNext move)
81-
82-
keyMapping = case _ of
83-
35.0 -> Events.preventDefault $> map action (Just End) -- End key
84-
36.0 -> Events.preventDefault $> map action (Just Start) -- Home key
85-
37.0 -> Events.preventDefault $> map action (Just Back) -- Left Arrow key
86-
39.0 -> Events.preventDefault $> map action (Just Next) -- Right Arrow key
87-
_ -> pure Nothing
88-
89-
keyboardEvent = Events.onKeyPress \e -> keyMapping e.keyCode
90-
91-
data Move a
92-
= Back a
93-
| Next a
94-
| Start a
95-
| End a
96-
97-
getNext :: forall a. Move a -> a
98-
getNext = case _ of
99-
Back a -> a
100-
Next a -> a
101-
Start a -> a
102-
End a -> a
103-
104-
moveSlides :: forall a. Move a -> SlidesInternal -> SlidesInternal
105-
moveSlides (Back _) slides =
54+
runSlides :: forall e. Slides -> Eff ( dom :: DOM | e ) Unit
55+
runSlides (Slides slides) = do
56+
inn <- I.input
57+
let ui = S.foldp update slides inn
58+
S.runSignal (setHtml <<< H.render <<< render <$> ui)
59+
60+
61+
-- Rendering
62+
63+
render :: SlidesInternal -> H.Markup
64+
render slides =
65+
H.div ! H.id "main" $ do
66+
H.span ! H.className "counter" $
67+
H.text $ show (position slides + 1) <> " / " <> show (zipLength slides)
68+
renderSlides (extract slides)
69+
70+
foreign import setHtml :: forall e. String -> Eff ( dom :: DOM | e ) Unit
71+
72+
73+
-- Update
74+
75+
update :: I.Input -> SlidesInternal -> SlidesInternal
76+
update i slides
77+
| I.clickOrHold (i.arrows.right) = moveSlides Next slides
78+
| I.clickOrHold (i.arrows.left) = moveSlides Back slides
79+
| I.clickOrHold (i.arrows.down) = moveSlides Start slides
80+
| I.clickOrHold (i.arrows.up) = moveSlides End slides
81+
| otherwise = slides
82+
83+
data Move
84+
= Back
85+
| Next
86+
| Start
87+
| End
88+
89+
moveSlides :: Move -> SlidesInternal -> SlidesInternal
90+
moveSlides Back slides =
10691
fromMaybe slides (Z.up slides)
10792

108-
moveSlides (Next _) slides =
93+
moveSlides Next slides =
10994
fromMaybe slides (Z.down slides)
11095

111-
moveSlides (Start _) slides =
96+
moveSlides Start slides =
11297
Z.beginning slides
11398

114-
moveSlides (End _) slides =
99+
moveSlides End slides =
115100
Z.end slides
116101

117102

@@ -244,66 +229,52 @@ italic = withClass "italicEl" <<< group <<< singleton
244229
-- Rendering --
245230
---------------
246231

247-
renderSlides :: forall p i. Slide -> Html.HTML p i
232+
renderSlides :: Slide -> H.Markup
248233
renderSlides (Slide el) =
249-
Html.div (giveClass "slide") [renderE el]
234+
H.div ! H.className "slide" $ renderE el
250235

251-
renderE :: forall p i. Element -> Html.HTML p i
236+
renderE :: Element -> H.Markup
252237
renderE element =
253238
case element of
254239
Empty ->
255-
Html.span_ []
240+
H.span (H.text "")
256241

257242
Title tl ->
258-
Html.span (giveClass "title") [ Html.h2_ [ Html.text tl ] ]
243+
H.span ! H.className "title" $ H.h2 (H.text tl)
259244

260245
Link l el ->
261-
Html.a [ Html.href l ] [ renderE el ]
246+
H.a ! H.href l $ renderE el
262247

263248
Text str ->
264-
Html.p marwidStyle [ Html.text str ]
249+
H.p ! H.className "marwid" $ H.text str
265250

266251
Image url ->
267-
Html.img (marwidStyle <> [ Html.src url ])
252+
H.img ! H.className "marwid" ! H.src url
268253

269254
VAlign els ->
270-
Html.span colFlexStyle (applyRest block $ map renderE els)
255+
H.span ! H.className "colflex" $ fold $ applyRest block $ map renderE els
271256

272257
HAlign els ->
273-
Html.span rowFlexStyle (map renderE els)
258+
H.span ! H.className "rowflex" $ foldMap renderE els
274259

275260
UList els ->
276-
Html.span [] [ Html.ul_ $ map (Html.li_ <<< singleton <<< renderE) els ]
261+
H.span $ H.ul $ foldMap (H.li <<< renderE) els
277262

278263
Group els ->
279-
Html.span [] $ map renderE els
264+
H.span $ foldMap renderE els
280265

281266
Class c e ->
282-
case renderE e of
283-
Html.Element nm tn props els ->
284-
Html.Element nm tn (props <> [ H.class_ $ H.className c ]) els
285-
el ->
286-
el
267+
renderE e ! H.className c
287268

288269
Id i e ->
289-
case renderE e of
290-
Html.Element nm tn props els ->
291-
Html.Element nm tn (props <> giveId i) els
292-
el ->
293-
el
270+
renderE e ! H.id i
294271

295-
giveClasses = map (Html.class_ <<< Html.className)
296-
giveClass = singleton <<< Html.class_ <<< Html.className
297-
giveId = singleton <<< H.id_
298-
299-
marwidStyle = giveClass "marwid"
300-
rowFlexStyle = giveClass "rowflex"
301-
colFlexStyle = giveClass "colflex"
302-
303-
block x = Html.span (giveClass "block") [ x ]
272+
block :: H.Markup -> H.Markup
273+
block = H.span ! H.className "block"
304274

305275
applyRest :: forall a. (a -> a) -> Array a -> Array a
306276
applyRest f xs =
307277
case uncons xs of
308278
Nothing -> xs
309279
Just list -> list.head : map f list.tail
280+

‎src/Slides/Internal/Input.purs

Lines changed: 118 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,118 @@
1+
module Slides.Internal.Input where
2+
3+
import Prelude
4+
import Control.Monad.Eff (Eff)
5+
import DOM (DOM)
6+
7+
import Signal (Signal, foldp) as S
8+
import Signal.DOM (keyPressed) as S
9+
10+
type Input =
11+
{ arrows :: Arrows BtnAction
12+
}
13+
14+
type Arrows a =
15+
{ right :: a
16+
, left :: a
17+
, down :: a
18+
, up :: a
19+
}
20+
21+
data BtnAction
22+
= Click
23+
| Hold
24+
| Idle
25+
| Release
26+
27+
clickOrHold :: BtnAction -> Boolean
28+
clickOrHold = case _ of
29+
Click -> true
30+
Hold -> true
31+
_ -> false
32+
33+
instance showBtnAction :: Show BtnAction where
34+
show Idle = "Idle"
35+
show Hold = "Hold"
36+
show Click = "Click"
37+
show Release = "Release"
38+
39+
instance eqBtnAction :: Eq BtnAction where
40+
eq Hold Hold = true
41+
eq Click Click = true
42+
eq Idle Idle = true
43+
eq Release Release = true
44+
eq _ _ = false
45+
46+
47+
showArrows :: Arrows BtnAction -> String
48+
showArrows arrows =
49+
"Arrows "
50+
<> show arrows.left
51+
<> " "
52+
<> show arrows.down
53+
<> " "
54+
<> show arrows.up
55+
<> " "
56+
<> show arrows.right
57+
58+
showInput :: Input -> String
59+
showInput i = "Input\n " <> showArrows i.arrows
60+
61+
input :: forall e. Eff (dom :: DOM | e) (S.Signal Input)
62+
input = do
63+
arrows <- arrowsSignal
64+
pure $
65+
S.foldp updateInput initInput arrows
66+
67+
initInput :: Input
68+
initInput =
69+
{ arrows:
70+
{ right: Idle
71+
, left: Idle
72+
, down: Idle
73+
, up: Idle
74+
}
75+
}
76+
77+
updateInput :: Arrows Boolean -> Input -> Input
78+
updateInput arrI state =
79+
{ arrows: arrFold arrI state.arrows
80+
}
81+
82+
arrFold :: Arrows Boolean -> Arrows BtnAction -> Arrows BtnAction
83+
arrFold inp arrows =
84+
{ right: btnStateUpdate inp.right arrows.right
85+
, left: btnStateUpdate inp.left arrows.left
86+
, down: btnStateUpdate inp.down arrows.down
87+
, up: btnStateUpdate inp.up arrows.up
88+
}
89+
90+
btnStateUpdate :: Boolean -> BtnAction -> BtnAction
91+
btnStateUpdate false Hold = Release
92+
btnStateUpdate false _ = Idle
93+
btnStateUpdate true Idle = Click
94+
btnStateUpdate true _ = Hold
95+
96+
arrowsSignal :: forall e. Eff (dom :: DOM | e) (S.Signal (Arrows Boolean))
97+
arrowsSignal = do
98+
rightArrow <- S.keyPressed rightKeyCode
99+
leftArrow <- S.keyPressed leftKeyCode
100+
downArrow <- S.keyPressed downKeyCode
101+
upArrow <- S.keyPressed upKeyCode
102+
pure $ { left: _, right: _, down: _, up: _ }
103+
<$> leftArrow
104+
<*> rightArrow
105+
<*> downArrow
106+
<*> upArrow
107+
108+
leftKeyCode :: Int
109+
leftKeyCode = 37
110+
111+
upKeyCode :: Int
112+
upKeyCode = 38
113+
114+
rightKeyCode :: Int
115+
rightKeyCode = 39
116+
117+
downKeyCode :: Int
118+
downKeyCode = 40

0 commit comments

Comments
 (0)