{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell, PolyKinds, TypeOperators, DeriveFunctor, LambdaCase, CPP, ForeignFunctionInterface, DeriveDataTypeable, ConstraintKinds #-} module Reflex.Dom.Class where import Prelude hiding (mapM, mapM_, sequence, concat) import Reflex import Reflex.Host.Class import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence) import Data.Map (Map) import qualified Data.Map as Map import Data.Foldable import Control.Monad.Ref import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence) import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence) import Data.Dependent.Sum (DSum (..)) import GHCJS.DOM.Types hiding (Event) import GHCJS.DOM (WebView) import Control.Monad.Exception -- | Alias for Data.Map.singleton (=:) :: k -> a -> Map k a (=:) = Map.singleton keycodeEnter :: Int keycodeEnter = 13 keycodeEscape :: Int keycodeEscape = 27 class ( Reflex t, MonadHold t m, MonadIO m, MonadAsyncException m, Functor m, MonadReflexCreateTrigger t m , HasDocument m, HasWebView m, HasWebView (WidgetHost m), HasWebView (GuiAction m) , MonadIO (WidgetHost m), MonadAsyncException (WidgetHost m), MonadIO (GuiAction m), MonadAsyncException (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m) , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, HasPostGui t (GuiAction m) (GuiAction m) , MonadRef m, MonadRef (WidgetHost m) , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO , MonadFix m ) => MonadWidget t m | m -> t where type WidgetHost m :: * -> * type GuiAction m :: * -> * askParent :: m Node subWidget :: Node -> m a -> m a subWidgetWithVoidActions :: Node -> m a -> m (a, Event t (WidgetHost m ())) liftWidgetHost :: WidgetHost m a -> m a --TODO: Is this a good idea? schedulePostBuild :: WidgetHost m () -> m () addVoidAction :: Event t (WidgetHost m ()) -> m () getRunWidget :: IsNode n => m (n -> m a -> WidgetHost m (a, WidgetHost m (), Event t (WidgetHost m ()))) class Monad m => HasDocument m where askDocument :: m HTMLDocument instance HasDocument m => HasDocument (ReaderT r m) where askDocument = lift askDocument instance HasDocument m => HasDocument (StateT r m) where askDocument = lift askDocument class Monad m => HasWebView m where askWebView :: m WebView instance HasWebView m => HasWebView (ReaderT r m) where askWebView = lift askWebView instance HasWebView m => HasWebView (StateT r m) where askWebView = lift askWebView newtype Restore m = Restore { restore :: forall a. m a -> IO a } class Monad m => MonadIORestore m where askRestore :: m (Restore m) instance MonadIORestore m => MonadIORestore (ReaderT r m) where askRestore = do r <- ask parentRestore <- lift askRestore return $ Restore $ \a -> restore parentRestore $ runReaderT a r class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where askPostGui :: m (h () -> IO ()) askRunWithActions :: m ([DSum (EventTrigger t) Identity] -> h ()) runFrameWithTriggerRef :: (HasPostGui t h m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m () runFrameWithTriggerRef r a = do postGui <- askPostGui runWithActions <- askRunWithActions liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef r instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where askPostGui = lift askPostGui askRunWithActions = lift askRunWithActions instance MonadWidget t m => MonadWidget t (ReaderT r m) where type WidgetHost (ReaderT r m) = WidgetHost m type GuiAction (ReaderT r m) = GuiAction m askParent = lift askParent subWidget n w = do r <- ask lift $ subWidget n $ runReaderT w r subWidgetWithVoidActions n w = do r <- ask lift $ subWidgetWithVoidActions n $ runReaderT w r liftWidgetHost = lift . liftWidgetHost schedulePostBuild = lift . schedulePostBuild addVoidAction = lift . addVoidAction getRunWidget = do r <- ask runWidget <- lift getRunWidget return $ \rootElement w -> do (a, postBuild, voidActions) <- runWidget rootElement $ runReaderT w r return (a, postBuild, voidActions) performEvent_ :: MonadWidget t m => Event t (WidgetHost m ()) -> m () performEvent_ = addVoidAction performEvent :: (MonadWidget t m, Ref m ~ Ref IO) => Event t (WidgetHost m a) -> m (Event t a) performEvent e = do (eResult, reResultTrigger) <- newEventWithTriggerRef addVoidAction $ ffor e $ \o -> do result <- o runFrameWithTriggerRef reResultTrigger result return eResult performEventAsync :: forall t m a. MonadWidget t m => Event t ((a -> IO ()) -> WidgetHost m ()) -> m (Event t a) performEventAsync e = do (eResult, reResultTrigger) <- newEventWithTriggerRef addVoidAction $ ffor e $ \o -> do postGui <- askPostGui runWithActions <- askRunWithActions o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef reResultTrigger return eResult getPostBuild :: MonadWidget t m => m (Event t ()) getPostBuild = do (e, trigger) <- newEventWithTriggerRef schedulePostBuild $ runFrameWithTriggerRef trigger () return e -------------------------------------------------------------------------------- -------------------------------------------------------------------------------- {- class HasRunFrame t m | m -> t where askRunFrame :: m (DMap (EventTrigger t) -> IO ()) type MonadWidget t h m = (MonadWidget' t h m, MonadWidget' t h (WidgetEventM m)) --TODO: Remove Spider hardcoding class (t ~ Spider, Reflex t, MonadHold t m, ReflexHost t, HasRunFrame t h, MonadReflexHost t h, MonadIO h, MonadRef h, Ref h ~ IORef, MonadFix h, HasDocument h, MonadSample t (WidgetEventM m), WidgetEventM m ~ WidgetEventM (WidgetEventM m), MonadFix m) => MonadWidget' t h m | m -> t h where type WidgetEventM m :: * -> * -- | Warning: dAttributes should not contain "id" attributes elDynAttr' :: String -> Dynamic t (Map String String) -> m a -> m (El t, a) performEvent :: Event t (h a) -> m (Event t a) performEvent_ :: Event t (h ()) -> m () getEInit :: m (Event t ()) putEChildren :: Event t [Node] -> m () dyn :: Dynamic t (WidgetEventM m a) -> m (Event t a) --TODO: Should probably return Dynamic t a listWithKey :: (Ord k, Show k) => Dynamic t (Map k v) -> (k -> Dynamic t v -> WidgetEventM m v') -> m (Dynamic t (Map k v')) text :: String -> m () dynText :: Dynamic t String -> m () {-# INLINABLE performEventAsync #-} performEventAsync :: forall t h m a. (MonadWidget t h m) => Event t ((a -> IO ()) -> h ()) -> m (Event t a) performEventAsync eAction = do let setup mAction = do (eResult, reResultTrigger) <- newEventWithTriggerRef runFrame <- askRunFrame let runAction a = a $ \x -> readRef reResultTrigger >>= mapM_ (\eResultTrigger -> runFrame $ DMap.singleton eResultTrigger x) maybe (return ()) runAction mAction return (eResult, runAction) eSetup <- performEvent . fmap (setup . (^?here)) . align eAction =<< getEInit dRunAction <- holdDyn Nothing $ fmap (Just . snd) eSetup performEvent_ $ attachDynWith (\mRunAction a -> maybe (return ()) ($ a) mRunAction) dRunAction eAction -- Note: this will never fire while eInit is firing, but that situation should be handled in setup; this relies on all the results from the first performEvent being fired simultaneously; otherwise, an eAction could potentially sneak in between setup being sent to performEvent and the result coming back switchPromptly never (fmap fst eSetup) data TextInput t = TextInput { _textInput_value :: Dynamic t String , _textInput_keypress :: Event t Int , _textInput_keydown :: Event t Int , _textInput_keyup :: Event t Int , _textInput_hasFocus :: Dynamic t Bool , _textInput_element :: Dynamic t (Maybe HTMLInputElement) } textInputGetEnter :: Reflex t => TextInput t -> Event t () textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i setElementAttributes :: IsElement self => self -> Map String String -> IO () setElementAttributes e attrs = do oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet attrs) $ elementRemoveAttribute e iforM_ attrs $ elementSetAttribute e wrapDomEvent :: (HasRunFrame t h, MonadIO m, MonadReflexHost t h, MonadIO h) => e -> (e -> m () -> IO (IO ())) -> m a -> h (Event t a) wrapDomEvent self elementOnevent getValue = do runFrame <- askRunFrame e <- newEventWithTrigger $ \et -> do unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent self $ {-# SCC "c" #-} do v <- {-# SCC "d" #-} getValue liftIO $ runFrame $ DMap.singleton et v return $ liftIO $ do {-# SCC "e" #-} unsubscribe return $! {-# SCC "f" #-} e {-# INLINABLE input #-} input' :: MonadWidget t h m => String -> Event t String -> Dynamic t (Map String String) -> m (TextInput t) input' inputType eSetValue dAttrs = do dEffectiveAttrs <- mapDyn (Map.insert "type" inputType) dAttrs let mkSelf (initialValue, initialAttrs) = do doc <- askDocument Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input" liftIO $ htmlInputElementSetValue e initialValue iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e runFrame <- askRunFrame eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do runFrame $ DMap.singleton eChangeFocusTrigger False unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do runFrame $ DMap.singleton eChangeFocusTrigger True return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event return (e, eChange, eKeypress, eKeydown, eKeyup, eChangeFocus) dInitialValue <- holdDyn "" eSetValue dInitial <- combineDyn (,) dInitialValue dEffectiveAttrs eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit dMyElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated performEvent_ . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dEffectiveAttrs putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlInputElementSetValue e v) $ attachWith (\e v -> case e of Nothing -> Nothing Just e' -> Just (e',v)) (current dMyElement) eSetValue eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated dFocus <- holdDyn False . switch =<< hold never (fmap (^. _6) eCreated) --TODO: Check that 'False' is always the correct starting value - i.e.: an element will always receive an 'onfocus' event, even if it gets focus immediately dValue <- holdDyn "" $ leftmost [eSetValue, eChange] eKeypress <- liftM switch $ hold never $ fmap (^. _3) eCreated eKeydown <- liftM switch $ hold never $ fmap (^. _4) eCreated eKeyup <- liftM switch $ hold never $ fmap (^. _5) eCreated return $ TextInput dValue eKeypress eKeydown eKeyup dFocus dMyElement input :: MonadWidget t h m => String -> Map String String -> m (TextInput t) input t as = input' t never (constDyn as) data TextArea t = TextArea { _textArea_value :: Dynamic t String , _textArea_element :: Dynamic t (Maybe HTMLTextAreaElement) } textArea' :: MonadWidget t h m => Event t String -> Dynamic t (Map String String) -> m (TextArea t) textArea' eSetValue dAttrs = do let mkSelf (initialValue, initialAttrs) = do doc <- askDocument Just e <- liftIO $ liftM (fmap castToHTMLTextAreaElement) $ documentCreateElement doc "textarea" liftIO $ htmlTextAreaElementSetValue e initialValue iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e return (e, eChange) dInitialValue <- holdDyn "" eSetValue dInitial <- combineDyn (,) dInitialValue dAttrs eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit dMyElement <- holdDyn Nothing $ fmap (Just . fst) eCreated --performEvent . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dAttrs putEChildren $ fmap ((:[]) . toNode . fst) eCreated performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlTextAreaElementSetValue e v) $ attachWith (\e v -> case e of Nothing -> Nothing Just e' -> Just (e',v)) (current dMyElement) eSetValue eChange <- liftM switch $ hold never $ fmap snd eCreated dValue <- holdDyn "" $ leftmost [eSetValue, eChange] return $ TextArea dValue dMyElement data Checkbox t = Checkbox { _checkbox_checked :: Dynamic t Bool } checkbox :: MonadWidget t h m => Bool -> Map String String -> m (Checkbox t) checkbox checked attrs = do let mkSelf = do doc <- askDocument Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input" liftIO $ elementSetAttribute e "type" "checkbox" iforM_ attrs $ \attr value -> liftIO $ elementSetAttribute e attr value if checked == True then liftIO $ elementSetAttribute e "checked" "true" else return () eChange <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e return ([toNode e], eChange) eCreated <- performEvent . fmap (const mkSelf) =<< getEInit putEChildren $ fmap (^. _1) eCreated eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated dValue <- holdDyn checked eChange return $ Checkbox dValue checkboxView :: MonadWidget t h m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t ()) checkboxView dAttrs dValue = do dEffectiveAttrs <- mapDyn (Map.insert "type" "checkbox") dAttrs let mkSelf (initialValue, initialAttrs) = do doc <- askDocument Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input" iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value liftIO $ htmlInputElementSetChecked e initialValue eClicked <- wrapDomEvent e elementOnclick preventDefault return (e, eClicked) dInitial <- combineDyn (,) dValue dEffectiveAttrs eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated dElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated performEvent_ . updated =<< combineDyn (\me a -> forM_ me $ \e -> liftIO $ setElementAttributes e a) dElement dEffectiveAttrs performEvent_ . updated =<< combineDyn (\v me -> maybe (return ()) (\e -> liftIO $ htmlInputElementSetChecked e v) me) dValue dElement liftM switch $ hold never $ fmap (^. _2) eCreated {-# INLINABLE textInput #-} textInput :: MonadWidget t h m => m (TextInput t) textInput = input "text" $ Map.singleton "class" "form-control" data Dropdown t k = Dropdown { _dropdown_value :: Dynamic t k } setInnerText :: (HasDocument m, IsHTMLElement self, MonadIO m) => self -> String -> m (Maybe Node) setInnerText e s = do liftIO $ htmlElementSetInnerHTML e "" doc <- askDocument t <- liftIO $ documentCreateTextNode doc s liftIO $ nodeAppendChild e t --TODO: Retain set value when allowed values changes {-# INLINABLE dropdown #-} dropdown :: forall t h m k. (MonadWidget t h m, Show k, Read k) => Dynamic t (Map k String) -> m (Dropdown t (Maybe k)) dropdown dOptions = do let triggerChange (e, reChangeTrigger) runFrame = do v <- htmlSelectElementGetValue e readRef reChangeTrigger >>= mapM_ (\eChangeTrigger -> runFrame $ DMap.singleton eChangeTrigger $ readMay v) let mkSelf = do doc <- askDocument Just e <- liftIO $ liftM (fmap castToHTMLSelectElement) $ documentCreateElement doc "select" liftIO $ elementSetAttribute e "class" "form-control" runFrame <- askRunFrame reChangeTrigger <- newRef Nothing eChange <- newEventWithTrigger $ \eChangeTrigger -> do writeRef reChangeTrigger $ Just eChangeTrigger unsubscribe <- liftIO $ elementOnchange e $ liftIO $ triggerChange (e, reChangeTrigger) runFrame return $ do writeRef reChangeTrigger Nothing liftIO unsubscribe return ((e, reChangeTrigger), eChange) eCreated <- performEvent . fmap (const mkSelf) =<< getEInit dState <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated putEChildren $ fmap ((:[]) . toNode . fst . (^. _1)) eCreated let updateOptions :: Map k String -> Maybe (HTMLSelectElement, Ref h (Maybe (EventTrigger t (Maybe k)))) -> h () updateOptions options = maybe (return ()) $ \myState@(selectElement, _) -> do doc <- askDocument liftIO $ htmlElementSetInnerHTML selectElement "" iforM_ options $ \k optionText -> do Just optionElement <- liftIO $ liftM (fmap castToHTMLOptionElement) $ documentCreateElement doc "option" liftIO $ elementSetAttribute optionElement "value" $ show k _ <- setInnerText optionElement optionText liftIO $ nodeAppendChild selectElement $ Just optionElement runFrame <- askRunFrame liftIO $ triggerChange myState runFrame performEvent_ . updated =<< combineDyn updateOptions dOptions dState eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated dValue <- holdDyn Nothing eChange return $ Dropdown dValue data Link t = Link { _link_clicked :: Event t () } linkClassWithExtraSetup :: MonadWidget t h m => (HTMLElement -> h ()) -> String -> String -> m (Link t) linkClassWithExtraSetup extraSetup s c = do let mkSelf = do doc <- askDocument Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "a" _ <- setInnerText e s liftIO $ elementSetAttribute e "class" c eClicked <- wrapDomEvent e elementOnclick $ return () extraSetup e return ([toNode e], eClicked) eCreated <- performEvent . fmap (const mkSelf) =<< getEInit putEChildren $ fmap (^. _1) eCreated eClicked <- liftM switch $ hold never $ fmap (^. _2) eCreated return $ Link eClicked {-# INLINABLE linkClass #-} linkClass :: MonadWidget t h m => String -> String -> m (Link t) linkClass = linkClassWithExtraSetup $ const $ return () {-# INLINABLE link #-} link :: MonadWidget t h m => String -> m (Link t) link s = linkClass s "" {-# INLINABLE button #-} button :: MonadWidget t h m => String -> m (Link t) button s = linkClass s "btn btn-primary" {-# INLINABLE elAttr #-} elAttr :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m a elAttr elementTag attrs child = liftM snd $ elAttr' elementTag attrs child {-# INLINABLE el' #-} el' :: forall t h m a. MonadWidget t h m => String -> m a -> m (El t, a) el' elementTag child = elAttr' elementTag Map.empty child {-# INLINABLE elAttr' #-} elAttr' :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m (El t, a) elAttr' elementTag attrs child = do dAttributes <- holdDyn attrs never elDynAttr' elementTag dAttributes child {-# INLINABLE elDynAttr #-} elDynAttr :: forall t h m a. MonadWidget t h m => String -> Dynamic t (Map String String) -> m a -> m a elDynAttr elementTag dAttributes child = liftM snd $ elDynAttr' elementTag dAttributes child {-# INLINABLE el #-} el :: forall t h m a. MonadWidget t h m => String -> m a -> m a el elementTag child = elAttr elementTag Map.empty child newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } workflowView :: forall t h m a. MonadWidget t h m => Workflow t (WidgetEventM m) a -> m (Event t a) workflowView w0 = do rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace eReplace <- liftM switch $ hold never $ fmap snd eResult eResult `seq` eReplace `seq` return () return $ fmap fst eResult insertNext :: (Ord k, Enum k) => v -> Map k v -> Map k v insertNext v m = let k = case Map.maxViewWithKey m of Nothing -> toEnum 0 Just ((k0, _), _) -> succ k0 in Map.insert k v m {-# INLINABLE oldList #-} oldList :: (MonadWidget t h m, MonadWidget t h (WidgetEventM m), Ord k, Show k) => Dynamic t (Map k (WidgetEventM m v')) -> m (Dynamic t (Map k ())) oldList dm = el "ul" $ list dm (\dv -> el "li" (dyn dv) >> return ()) {-# INLINABLE list #-} list :: forall t m h k v v'. (MonadWidget t h m, Ord k, Show k) => Dynamic t (Map k v) -> (Dynamic t v -> WidgetEventM m v') -> m (Dynamic t (Map k v')) list dm mkChild = listWithKey dm (\_ dv -> mkChild dv) instance MonadWidget' t h m => MonadWidget' t h (ReaderT r m) where type WidgetEventM (ReaderT r m) = ReaderT r (WidgetEventM m) elDynAttr' tag dAttrs = mapReaderT (elDynAttr' tag dAttrs) performEvent = lift . performEvent performEvent_ = lift . performEvent_ getEInit = lift getEInit putEChildren = lift . putEChildren dyn d = do r <- ask lift $ dyn =<< mapDyn (flip runReaderT r) d listWithKey d w = do r <- ask lift $ listWithKey d $ \k dv -> runReaderT (w k dv) r text = lift . text dynText = lift . dynText -}