@@ -1,27 +1,200 @@
11{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE GADTs #-}
5+{-# LANGUAGE LambdaCase #-}
26{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE TemplateHaskell #-}
38{-# LANGUAGE TypeApplications #-}
9+{-# LANGUAGE TypeFamilies #-}
410module Frontend where
511
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)
627import qualified Data.Text as T
728import Obelisk.Frontend
829import Obelisk.Route
930import Reflex.Dom.Core
31+import Reflex.Patch.DMapWithMove
1032
1133import Common.Api
1234import Common.Route
1335import Obelisk.Generated.Static
1436
37+tshow :: Show a => a -> Text
38+tshow = T.pack . show
1539
1640frontend :: Frontend (R FrontendRoute)
1741frontend = Frontend
18− { _frontend_head = el "title" $ text "Obelisk Minimal Example"
42+ { _frontend_head = pure () -- el "title" $ text "Obelisk Minimal Example"
1943 , _frontend_body = do
2044 text "Welcome to Obelisk!"
2145 el "p" $ text $ T.pack commonStuff
22− elAttr "img" ("src" =: static @"obelisk.jpg") blank
23− e <- button "click"
24− el "p" $ display =<< count e
46+ (e, ()) <- elAttr' "img" ("src" =: static @"obelisk.jpg") blank
47+ clicks <- count $ domEvent Click e
48+ performEvent $ liftIO . print <$> updated clicks
49+ el "p" $ text "Clicks: " >> el "span" (display clicks) -- TODO multiple text bug
50+
51+ timer <- tickLossy 1 =<< liftIO getCurrentTime
52+ seconds <- count timer
53+ el "p" $ display seconds
54+ text "-----------------------------------------------"
55+
56+-- elAttr "article" ("style" =: "background: lightcoral") $ do
57+-- prerender
58+-- (prerender
59+-- (el "span" $ text "Server span")
60+-- (el "a" $ text "JS link"))
61+-- (el "a" $ text "JS link")
62+
2563 pb <- getPostBuild
26− widgetHold_ (el "div" $ text "first") $ ffor pb $ \() -> el "div" $ text "second"
64+ pure ()
65+
66+ elAttr "article" ("style" =: "background: moccasin") $ do
67+ widgetHold_ (el "div" $ text "first") $ ffor pb $ \() -> display seconds
68+
69+-- elAttr "article" ("style" =: "background: lightgreen") $ do
70+-- widgetHold_ (do prerender (liftIO $ putStrLn "-------- server missiles") (liftIO $ putStrLn "-------- client missiles"); el "div" $ text "first") never
71+
72+ elAttr "article" ("style" =: "background: paleturquoise") $ do
73+ dyn_ $ ffor clicks $ \x -> case x `mod` 2 of
74+ 0 -> el "span" $ text "Even"
75+ 1 -> el "span" $ text "Odd"
76+
77+ elAttr "article" ("style" =: "background: cornflowerblue") $ do
78+ widgetHold (text "first") $ ffor (updated clicks) $ \x -> case x `mod` 2 of
79+ 0 -> do
80+ dyn_ $ ffor seconds $ \x -> case x `mod` 2 of
81+ 0 -> el "span" $ text "Even"
82+ 1 -> text "Odd"
83+ 1 -> el "span" $ text "Odd inner"
84+
85+ pure ()
86+
87+ -- These will be squashed into a single text node by the static renderer
88+-- text "Test"
89+-- text "Test"
90+-- text "Test"
91+-- text "Test"
92+-- text "Test"
93+
94+ {-
95+ --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'))
96+ elAttr "article" ("style" =: "background: thistle") $ do
97+ (m', e') <- traverseDMapWithKeyWithAdjust (\k v -> has @Show k $ dkeyWidget k v) keyMap $ ffor (updated clicks) $ \x -> case x `mod` 2 of
98+ 0 -> PatchDMap $ DMap.singleton Key_Int (ComposeMaybe $ Just $ Identity x)
99+ 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))
100+ pure ()
101+-}
102+
103+ {-
104+ elAttr "article" ("style" =: "background: maroon") $ do
105+ widgetHold (text "first") $ ffor pb $ \_ -> do
106+ (m', e') <- traverseDMapWithKeyWithAdjust (\k v -> has @Show k $ dkeyWidget k v) keyMap $ ffor (updated clicks) $ \x -> case x `mod` 2 of
107+ 0 -> PatchDMap $ DMap.singleton Key_Int (ComposeMaybe $ Just $ Identity x)
108+ 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))
109+ pure ()
110+
111+ move <- button "Move"
112+ ins <- button "Insert"
113+ del <- button "Delete"
114+
115+ --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'))
116+ elAttr "article" ("style" =: "background: yellow") $ do
117+ (m', e') <- traverseDMapWithKeyWithAdjustWithMove (\k v -> has @Show k $ dkeyWidget k v) keyMap $ leftmost
118+ -- TODO: move causes JSException here and in Immediate builder
119+ [ ffor move $ \() -> moveDMapKey Key_Int2 Key_Int
120+ , ffor ins $ \() -> insertDMapKey Key_Int (Identity 4)
121+ , ffor del $ \() -> deleteDMapKey Key_Int
122+ ]
123+ pure ()
124+
125+ elAttr "article" ("style" =: "background: cyan") $ do
126+ (m', e') <- traverseIntMapWithKeyWithAdjust (\k v -> intkeyWidget k v) intMap $ leftmost
127+ -- TODO: move causes JSException here and in Immediate builder
128+ [ ffor move $ \() -> PatchIntMap $ IntMap.singleton 1 (Just 'Z')
129+ , ffor ins $ \() -> PatchIntMap $ IntMap.singleton 5 (Just 'Z')
130+ , ffor del $ \() -> PatchIntMap $ IntMap.singleton 3 Nothing
131+ ]
132+ pure ()
133+
134+-}
135+
136+-- el "footer" $ text "Footer"
27137 }
138+
139+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 ()
140+intkeyWidget k v = el "div" $ do
141+ el "span" (text $ T.pack $ show k)
142+ case k of
143+ 5 -> do
144+ seconds <- count =<< tickLossy 1 =<< liftIO getCurrentTime
145+ text " -> "
146+ dyn_ $ ffor seconds $ el "span" . text . tshow
147+ _ -> text $ " -> " <> tshow v
148+ pure ()
149+
150+intMap :: IntMap Char
151+intMap = IntMap.fromList
152+ [ (1, 'A')
153+ , (2, 'B')
154+ , (3, 'C')
155+ , (4, 'D')
156+ ]
157+
158+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)
159+dkeyWidget k (Identity v) = el "div" $ do
160+ el "span" (text $ textKey k)
161+ case k of
162+ Key_Bool | v -> do
163+ seconds <- count =<< tickLossy 1 =<< liftIO getCurrentTime
164+ text " -> "
165+ dyn_ $ ffor seconds $ el "span" . text . tshow
166+ _ -> text $ " -> " <> tshow v
167+ pure $ Identity v
168+
169+keyMap :: DMap DKey Identity
170+keyMap = DMap.fromList
171+ [ Key_Int ==> -1
172+ , Key_Int2 ==> -100
173+ , Key_Bool ==> False
174+ , Key_Char ==> 'A'
175+ ]
176+
177+data DKey a where
178+ Key_Int :: DKey Int
179+ Key_Char :: DKey Char
180+ Key_Bool :: DKey Bool
181+ Key_Int2 :: DKey Int
182+
183+instance ArgDict DKey where
184+ type ConstraintsFor DKey c = (c Int, c Char, c Bool)
185+ argDict = \case
186+ Key_Int -> Dict
187+ Key_Int2 -> Dict
188+ Key_Char -> Dict
189+ Key_Bool -> Dict
190+
191+textKey :: DKey a -> Text
192+textKey = \case
193+ Key_Int -> "Key_Int"
194+ Key_Int2 -> "Key_Int2"
195+ Key_Char -> "Key_Char"
196+ Key_Bool -> "Key_Bool"
197+
198+deriveGEq ''DKey
199+deriveGCompare ''DKey
200+--deriveArgDict ''DKey