@@ -0,0 +1,168 @@
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 Control.Monad.Ref
11+import Control.Monad.Identity
12+import Data.Dependent.Sum (DSum (..))
13+
14+import Data.Monoid
15+import Data.Text (Text)
16+-- import Foreign.JavaScript.TH
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 = let key = encodeUtf8 k; val = BL.toStrict $ toLazyByteString $ fromHtmlEscapedText v in [key <> "=\"" <> val <> "\""]
107+ let attrs0 = Map.foldMapWithKey toAttr $ cfg ^. initialAttributes
108+ let attrs1 = if null attrs0 then "" else " " <> B8.intercalate " " attrs0
109+
110+ let tag' = encodeUtf8 elementTag
111+ let open' more = constant ("<" <> tag' <> attrs1 <> " ") <> more <> constant ">"
112+ let close' = constant $ "</" <> tag' <> ">"
113+
114+ es <- newFanEventWithTrigger $ \_ _ -> return (return ())
115+ StaticDomBuilderT $ do
116+ (result, innerHtml) <- lift $ runStaticDomBuilderT child
117+ initial <- lift $ performEvent $ ffor (cfg ^. modifyAttributes) $ ifoldrM (\r@(mAttrNamespace, n) mv acc -> case mAttrNamespace of
118+ Nothing -> do
119+ case mv of
120+ Just v -> do
121+ let [attr'] = toAttr r v
122+ return $ " " <> attr'
123+ Nothing -> return acc
124+ Just ns -> do
125+ error $ "modifyAttributes Just " ++ show ns) ""
126+
127+ -- attributes that were not available till PostBuild was fired
128+ -- TODO use map and merge with initial attributes?
129+ extraAttrs <- hold "" initial
130+ modify (open' extraAttrs <> innerHtml <> close' :)
131+ return (Element es (error "Static.element RawElement was used"), result)
132+
133+ {-# INLINABLE placeholder #-}
134+ placeholder (PlaceholderConfig toInsertAbove _delete) = StaticDomBuilderT $ do
135+ result <- lift $ performEvent (fmap runStaticDomBuilderT toInsertAbove)
136+ acc <- foldDyn (:) [] (fmap snd result)
137+ modify . (:) $ join $ fmap (mconcat . reverse) $ current acc
138+ return $ Placeholder (fmap fst result) never
139+
140+ {-# INLINABLE inputElement #-}
141+ inputElement cfg = do
142+ (e, _result) <- element "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
143+ let v0 = constDyn $ cfg ^. inputElementConfig_initialValue
144+ let c0 = constDyn $ cfg ^. inputElementConfig_initialChecked
145+ let valueChangedByUI = never
146+ let hasFocus = constDyn False -- XXX should this coming from initialAtttributes
147+ return $ InputElement v0 c0 valueChangedByUI hasFocus e
148+
149+ {-# INLINABLE textAreaElement #-}
150+ textAreaElement cfg = do
151+ (e, _domElement) <- element "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
152+ let v0 = constDyn $ cfg ^. textAreaElementConfig_initialValue
153+ let valueChangedByUI = never
154+ let hasFocus = constDyn False -- XXX should this be coming from initialAtttributes
155+ return $ TextAreaElement v0 valueChangedByUI hasFocus e
156+
157+--TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better
158+type StaticWidget x = PostBuildT Spider (StaticDomBuilderT Spider (PerformEventT Spider (SpiderHost Global)))
159+
160+renderStatic :: StaticWidget x a -> IO (a, ByteString)
161+renderStatic w = do
162+ runSpiderHost $ do
163+ (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
164+ ((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild)
165+ mPostBuildTrigger <- readRef postBuildTriggerRef
166+ forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
167+ bs' <- sample bs
168+ return (res, bs')