@@ -0,0 +1,151 @@
1+{-# LANGUAGE OverloadedStrings, MultiParamTypeClasses, FlexibleInstances, GeneralizedNewtypeDeriving, UndecidableInstances, FunctionalDependencies, DataKinds, TypeFamilies, RankNTypes, ConstraintKinds, TypeOperators, FlexibleContexts, LambdaCase, ScopedTypeVariables, PolyKinds, EmptyDataDecls #-}
2+module Reflex.Dom.Builder.Static where
3+
4+import Reflex
5+import Reflex.Host.Class
6+import Reflex.Dom.Builder.Class
7+import Reflex.Dom.PerformEvent.Base
8+import Reflex.Dom.PerformEvent.Class
9+import Reflex.Dom.PostBuild.Class
10+import Reflex.Dom.Widget.Basic (applyMap)
11+import Control.Monad.Ref
12+import Control.Monad.Identity
13+import Data.Dependent.Sum (DSum (..))
14+
15+import Data.Monoid
16+import Data.Text (Text)
17+import qualified Data.Map as Map
18+import Data.Map (Map)
19+import Control.Lens hiding (element)
20+import qualified Data.ByteString.Lazy as BL
21+import qualified Data.ByteString.Char8 as B8
22+import Data.ByteString (ByteString)
23+import Control.Monad.State.Strict
24+import Control.Monad.Trans.Control
25+import Data.ByteString.Builder (toLazyByteString)
26+import Blaze.ByteString.Builder.Html.Utf8
27+import Data.Text.Encoding
28+import Control.Monad.Exception
29+
30+
31+newtype StaticDomBuilderT t m a = StaticDomBuilderT
32+ { unStaticDomBuilderT :: StateT [Behavior t ByteString] m a -- Accumulated Html will be in revesed order
33+ }
34+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
35+
36+instance MonadTransControl (StaticDomBuilderT t) where
37+ type StT (StaticDomBuilderT t) a = StT (StateT [Behavior t ByteString]) a
38+ liftWith = defaultLiftWith StaticDomBuilderT unStaticDomBuilderT
39+ restoreT = defaultRestoreT StaticDomBuilderT
40+
41+instance MonadTrans (StaticDomBuilderT t) where
42+ lift = StaticDomBuilderT . lift
43+
44+runStaticDomBuilderT :: (Monad m, Reflex t) => StaticDomBuilderT t m a -> m (a, Behavior t ByteString)
45+runStaticDomBuilderT (StaticDomBuilderT a) = do
46+ (result, a') <- runStateT a []
47+ return (result, mconcat $ reverse a')
48+
49+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (StaticDomBuilderT t m) where
50+ {-# INLINABLE newEventWithTrigger #-}
51+ newEventWithTrigger = lift . newEventWithTrigger
52+ {-# INLINABLE newFanEventWithTrigger #-}
53+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
54+
55+instance PerformEvent t m => PerformEvent t (StaticDomBuilderT t m) where
56+ type Performable (StaticDomBuilderT t m) = Performable m
57+ {-# INLINABLE performEvent_ #-}
58+ performEvent_ e = lift $ performEvent_ e
59+ {-# INLINABLE performEvent #-}
60+ performEvent e = lift $ performEvent e
61+
62+instance MonadSample t m => MonadSample t (StaticDomBuilderT t m) where
63+ {-# INLINABLE sample #-}
64+ sample = lift . sample
65+
66+instance MonadHold t m => MonadHold t (StaticDomBuilderT t m) where
67+ {-# INLINABLE hold #-}
68+ hold v0 v' = lift $ hold v0 v'
69+ {-# INLINABLE holdDyn #-}
70+ holdDyn v0 v' = lift $ holdDyn v0 v'
71+ {-# INLINABLE holdIncremental #-}
72+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
73+
74+instance (Reflex t, Monad m, MonadHold t (StateT [Behavior t ByteString] m)) => Deletable t (StaticDomBuilderT t m) where
75+ {-# INLINABLE deletable #-}
76+ deletable delete (StaticDomBuilderT a) = StaticDomBuilderT $ do
77+ (result, a') <- lift $ runStateT a []
78+ let html = mconcat $ reverse a'
79+ b <- hold html (mempty <$ delete)
80+ modify (join b:)
81+ return result
82+
83+instance (Monad m, Ref m ~ Ref IO, Reflex t) => TriggerEvent t (StaticDomBuilderT t m) where
84+ {-# INLINABLE newTriggerEvent #-}
85+ newTriggerEvent = return (never, const $ return ())
86+ {-# INLINABLE newTriggerEventWithOnComplete #-}
87+ newTriggerEventWithOnComplete = return (never, \_ _ -> return ())
88+ {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
89+ newEventWithLazyTriggerWithOnComplete _ = return never
90+
91+type SupportsStaticDomBuilder t m = (Reflex t, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, Performable m ~ m, MonadReflexCreateTrigger t m, Deletable t m, MonadRef m, Ref m ~ Ref IO)
92+
93+data StaticDomSpace
94+instance DomSpace StaticDomSpace where
95+ type RawElement StaticDomSpace = ByteString
96+
97+instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where
98+ type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace
99+ {-# INLINABLE textNode #-}
100+ textNode (TextNodeConfig contents) = StaticDomBuilderT $ do
101+ modify $ (:) $ constant $ BL.toStrict $ toLazyByteString $ fromHtmlEscapedText contents
102+ return TextNode
103+
104+ {-# INLINABLE element #-}
105+ element elementTag cfg child = do
106+ let toAttr (_mns, k) v = encodeUtf8 k <> "=\"" <> (BL.toStrict $ toLazyByteString $ fromHtmlEscapedText v) <> "\""
107+ es <- newFanEventWithTrigger $ \_ _ -> return (return ())
108+ StaticDomBuilderT $ do
109+ (result, innerHtml) <- lift $ runStaticDomBuilderT child
110+ attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
111+ let attrs1 = ffor (current attrs0) $ mconcat . fmap (\(k, v) -> " " <> toAttr k v) . Map.toList
112+ let tag = encodeUtf8 elementTag
113+ let open = mconcat [constant ("<" <> tag <> " "), attrs1, constant ">"]
114+ let close = constant $ "</" <> tag <> ">" -- TODO handle elements without closing tags
115+ modify $ (:) $ mconcat $ [open, innerHtml, close]
116+ return (Element es (error "Static.element RawElement was used"), result)
117+
118+ {-# INLINABLE placeholder #-}
119+ placeholder (PlaceholderConfig toInsertAbove _delete) = StaticDomBuilderT $ do
120+ result <- lift $ performEvent (fmap runStaticDomBuilderT toInsertAbove)
121+ acc <- foldDyn (:) [] (fmap snd result)
122+ modify $ (:) $ join $ fmap (mconcat . reverse) $ current acc
123+ return $ Placeholder (fmap fst result) never
124+
125+ {-# INLINABLE inputElement #-}
126+ inputElement cfg = do
127+ (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
128+ let v0 = constDyn $ cfg ^. inputElementConfig_initialValue
129+ let c0 = constDyn $ cfg ^. inputElementConfig_initialChecked
130+ let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
131+ return $ InputElement v0 c0 never hasFocus e
132+
133+ {-# INLINABLE textAreaElement #-}
134+ textAreaElement cfg = do
135+ (e, _domElement) <- element "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
136+ let v0 = constDyn $ cfg ^. textAreaElementConfig_initialValue
137+ let hasFocus = constDyn False -- TODO should this be coming from initialAtttributes
138+ return $ TextAreaElement v0 never hasFocus e
139+
140+--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better
141+type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))
142+
143+renderStatic :: StaticWidget x a -> IO (a, ByteString)
144+renderStatic w = do
145+ runSpiderHost $ do
146+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
147+ ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild)
148+ mPostBuildTrigger <- readRef postBuildTriggerRef
149+ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
150+ bs' <- sample bs
151+ return (res, bs')