@@ -1,272 +1,23 @@
11{-# LANGUAGE DataKinds #-}
2−{-# LANGUAGE FlexibleContexts #-}
3−{-# LANGUAGE FlexibleInstances #-}
4−{-# LANGUAGE GADTs #-}
5−{-# LANGUAGE LambdaCase #-}
62{-# LANGUAGE OverloadedStrings #-}
7−{-# LANGUAGE TemplateHaskell #-}
83{-# LANGUAGE TypeApplications #-}
9−{-# LANGUAGE TypeFamilies #-}
104module Frontend where
115
12−import Control.Monad.Fix
13−import Control.Monad.IO.Class
14−import Data.Constraint (Dict(..))
15−import Data.Constraint.Extras
16−import Data.Constraint.Extras.TH
17−import Data.Dependent.Sum (DSum(..), (==>))
18−import Data.Dependent.Map (DMap)
19−import Data.IntMap (IntMap)
20−import qualified Data.IntMap as IntMap
21−import Data.Functor.Misc
22−import Data.GADT.Compare.TH
23−import qualified Data.Dependent.Map as DMap
24−import Data.Functor.Identity
25−import Data.Time (getCurrentTime)
26−import Data.Text (Text)
276import qualified Data.Text as T
287import Obelisk.Frontend
298import Obelisk.Route
309import Reflex.Dom.Core
31−import Reflex.Patch.DMapWithMove
3210
3311import Common.Api
3412import Common.Route
3513import Obelisk.Generated.Static
3614
37−import Obelisk.Route.Frontend
38−
39−tshow :: Show a => a -> Text
40−tshow = T.pack . show
4115
4216frontend :: Frontend (R FrontendRoute)
4317frontend = Frontend
44− { _frontend_head = do
45− el "title" $ text "Obelisk Minimal Example"
46− elAttr "meta" mempty blank
18+ { _frontend_head = el "title" $ text "Obelisk Minimal Example"
4719 , _frontend_body = do
4820 text "Welcome to Obelisk!"
4921 el "p" $ text $ T.pack commonStuff
50− (e, ()) <- elAttr' "img" ("src" =: static @"obelisk.jpg") blank
51− clicks <- count $ domEvent Click e
52− performEvent $ liftIO . print <$> updated clicks
53− el "p" $ text "Clicks: " >> el "span" (display clicks) -- TODO multiple text bug
54−
55− pb <- getPostBuild
56−
57− -- Tests for adjacent/empty text
58− text "One"
59− text "Two"
60− text "Three"
61− text ""
62− text ""
63− text "Four"
64− text ""
65− el "span" $ text ""
66− el "span" $ text "" >> text "hi"
67− el "span" $ text "" >> el "span" (text "hi")
68− el "span" $ el "span" (text "hi") >> text ""
69−
70− timer <- tickLossy 1 =<< liftIO getCurrentTime
71− seconds <- count timer
72− el "p" $ display seconds
73− prerender blank $ setRoute never
74− textNode $ TextNodeConfig "0" (Just $ "pb" <$ pb)
75− textNode $ TextNodeConfig "0" (Just $ "" <$ pb)
76− textNode $ TextNodeConfig "" (Just $ "pb" <$ pb)
77− textNode $ TextNodeConfig "" (Just $ "" <$ pb)
78−-- text "-----------------------------------------------"
79−-- text "-----------------------------------------------"
80−-- text "-----------------------------------------------"
81−
82− do -- elAttr "article" ("style" =: "background: lightcoral") $ do
83− prerender
84− (do
85− pb <- getPostBuild
86− performEvent $ liftIO (putStrLn "hello server postBuild") <$ pb
87− el "span" $ text "Server span"
88− )
89− (do
90− liftIO (putStrLn "------------------- client missiles")
91− (e, _) <- el' "a" $ text "JS link"
92− performEvent $ liftIO (putStrLn "hello") <$ domEvent Click e
93− pb <- getPostBuild
94− performEvent $ liftIO (putStrLn "hello client postBuild") <$ pb
95− textInput def
96− pure ()
97− )
98−
99− text "===================================================="
100−
101−
102−-- elAttr "article" ("style" =: "background: moccasin") $ do
103−-- widgetHold_ (el "div" $ text "first") $ ffor pb $ \() -> display seconds
104−
105− elAttr "article" ("style" =: "background: lightgreen") $ do
106− widgetHold_ (do prerender (el "b" $ text "Server") (el "b" $ text "Client"); el "div" $ text "first") never
107−
108− elAttr "article" ("style" =: "background: green") $ do
109− widgetHold_ (pure ()) $ ffor pb $ \() -> do
110− prerender
111− (el "b" $ text "Server")
112− (el "b" $ text "Client")
113− el "div" $ text "first"
114−
115− prerender
116− (do
117− liftIO $ putStrLn "Server"
118− el "b" $ text "Server"
119− prerender
120− (do
121− liftIO $ putStrLn "Server->Server"
122− el "b" $ text "Server->Server"
123− )
124− (do
125− liftIO $ putStrLn "Server->Client"
126− el "b" $ text "Server->Client"
127− )
128− )
129− (do
130− liftIO $ putStrLn "Client"
131− el "b" $ text "Client"
132− prerender
133− (do
134− liftIO $ putStrLn "Client->Server"
135− el "b" $ text "Client->Server"
136− )
137− (do
138− liftIO $ putStrLn "Client->Client"
139− el "b" $ text "Client->Client"
140− )
141− )
142−-- elAttr "article" ("style" =: "background: paleturquoise") $ do
143−-- dyn_ $ ffor clicks $ \x -> case x `mod` 2 of
144−-- 0 -> el "span" $ text "Even"
145−-- 1 -> do
146−-- runWithReplace (el "span" $ text "Odd") never
147−-- pure ()
148−
149−-- elAttr "article" ("style" =: "background: cornflowerblue") $ do
150−-- widgetHold (text "first") $ ffor (updated clicks) $ \x -> case x `mod` 2 of
151−-- 0 -> do
152−-- dyn_ $ ffor seconds $ \x -> case x `mod` 2 of
153−-- 0 -> el "span" $ text "Even"
154−-- 1 -> text "Odd"
155−-- 1 -> el "span" $ text "Odd inner"
156−
157− -- These will be squashed into a single text node by the static renderer
158−-- text "Test"
159−-- text "Test"
160−-- text "Test"
161−-- text "Test"
162−-- text "Test"
163−
164− --traverseDMapWithKeyWithAdjust' :: (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))
165−-- elAttr "article" ("style" =: "background: thistle") $ do
166−-- (m', e') <- traverseDMapWithKeyWithAdjust (\k v -> has @Show k $ dkeyWidget k v) keyMap $ ffor (updated clicks) $ \x -> case x `mod` 2 of
167−-- 0 -> PatchDMap $ DMap.singleton Key_Int (ComposeMaybe $ Just $ Identity 10)
168−-- 1 -> PatchDMap $ DMap.singleton Key_Bool (ComposeMaybe $ case x `mod` 3 of 0 -> Nothing; _ -> Just $ Identity True) <> DMap.singleton Key_Char (ComposeMaybe $ Just $ Identity (toEnum $ fromEnum 'A' + x))
169−-- pure ()
170−--
171−--
172−-- elAttr "article" ("style" =: "background: thistle") $ do
173−-- (m', e') <- traverseDMapWithKeyWithAdjust (\k v -> has @Show k $ dkeyWidget k v) keyMap $
174−-- PatchDMap (DMap.singleton Key_Int (ComposeMaybe $ Just $ Identity 10)) <$ pb
175−-- pure ()
176−--
177−-- elAttr "article" ("style" =: "background: maroon") $ do
178−-- widgetHold (text "first") $ ffor pb $ \_ -> do
179−-- (m', e') <- traverseDMapWithKeyWithAdjust (\k v -> has @Show k $ dkeyWidget k v) keyMap $ ffor (updated clicks) $ \x -> case x `mod` 2 of
180−-- 0 -> PatchDMap $ DMap.singleton Key_Int (ComposeMaybe $ Just $ Identity x)
181−-- 1 -> PatchDMap $ DMap.singleton Key_Bool (ComposeMaybe $ case x `mod` 3 of 0 -> Nothing; _ -> Just $ Identity True) <> DMap.singleton Key_Char (ComposeMaybe $ Just $ Identity (toEnum $ fromEnum 'A' + x))
182−-- pure ()
183−--
184−-- move <- button "Move"
185−-- ins <- button "Insert"
186−-- del <- button "Delete"
187−
188− --traverseDMapWithKeyWithAdjust' :: (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))
189−-- elAttr "article" ("style" =: "background: yellow") $ do
190−-- (m', e') <- traverseDMapWithKeyWithAdjustWithMove (\k v -> has @Show k $ dkeyWidget k v) keyMap $ leftmost
191−-- -- TODO: move causes JSException here and in Immediate builder
192−-- [ ffor move $ \() -> moveDMapKey Key_Int2 Key_Int
193−-- , ffor ins $ \() -> insertDMapKey Key_Int (Identity 4)
194−-- , ffor del $ \() -> deleteDMapKey Key_Int
195−-- ]
196−-- pure ()
197−--
198−-- elAttr "article" ("style" =: "background: cyan") $ do
199−-- (m', e') <- traverseIntMapWithKeyWithAdjust (\k v -> intkeyWidget k v) intMap $ leftmost
200−-- -- TODO: move causes JSException here and in Immediate builder
201−-- [ ffor move $ \() -> PatchIntMap $ IntMap.singleton 1 (Just 'Z')
202−-- , ffor ins $ \() -> PatchIntMap $ IntMap.singleton 5 (Just 'Z')
203−-- , ffor del $ \() -> PatchIntMap $ IntMap.singleton 3 Nothing
204−-- ]
205−-- pure ()
206−
207−-- el "footer" $ text "Footer"
208− pure ()
22+ elAttr "img" ("src" =: static @"obelisk.jpg") blank
20923 }
210−
211−intkeyWidget :: (MonadHold t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, DomBuilder t m, MonadFix m, MonadIO m, MonadIO (Performable m)) => Int -> Char -> m ()
212−intkeyWidget k v = el "div" $ do
213− el "span" (text $ T.pack $ show k)
214− case k of
215− 5 -> do
216− seconds <- count =<< tickLossy 1 =<< liftIO getCurrentTime
217− text " -> "
218− dyn_ $ ffor seconds $ el "span" . text . tshow
219− _ -> text $ " -> " <> tshow v
220− pure ()
221−
222−intMap :: IntMap Char
223−intMap = IntMap.fromList
224− [ (1, 'A')
225− , (2, 'B')
226− , (3, 'C')
227− , (4, 'D')
228− ]
229−
230−dkeyWidget :: (MonadHold t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, DomBuilder t m, Show a, MonadFix m, MonadIO m, MonadIO (Performable m)) => DKey a -> Identity a -> m (Identity a)
231−dkeyWidget k (Identity v) = el "div" $ do
232− el "span" (text $ textKey k)
233− case k of
234− Key_Bool | v -> do
235− seconds <- count =<< tickLossy 1 =<< liftIO getCurrentTime
236− text " -> "
237− dyn_ $ ffor seconds $ el "span" . text . tshow
238− _ -> text $ " -> " <> tshow v
239− pure $ Identity v
240−
241−keyMap :: DMap DKey Identity
242−keyMap = DMap.fromList
243− [ Key_Int ==> -1
244− , Key_Int2 ==> -100
245− , Key_Bool ==> False
246− , Key_Char ==> 'A'
247− ]
248−
249−data DKey a where
250− Key_Int :: DKey Int
251− Key_Char :: DKey Char
252− Key_Bool :: DKey Bool
253− Key_Int2 :: DKey Int
254−
255−instance ArgDict DKey where
256− type ConstraintsFor DKey c = (c Int, c Char, c Bool)
257− argDict = \case
258− Key_Int -> Dict
259− Key_Int2 -> Dict
260− Key_Char -> Dict
261− Key_Bool -> Dict
262−
263−textKey :: DKey a -> Text
264−textKey = \case
265− Key_Int -> "Key_Int"
266− Key_Int2 -> "Key_Int2"
267− Key_Char -> "Key_Char"
268− Key_Bool -> "Key_Bool"
269−
270−deriveGEq ''DKey
271−deriveGCompare ''DKey
272−--deriveArgDict ''DKey