git.iko.soy/reflex-dom
on develop help sign in
Add InputDisabledT
ad56cafRyan Trinkle
reflex-dom.cabal+1
compare with develop
unifiedsplit
@@ -78,6 +78,7 @@ library
78 Reflex.Dom.Builder.Class
78 Reflex.Dom.Builder.Class
79 Reflex.Dom.Builder.Class.Events
79 Reflex.Dom.Builder.Class.Events
80 Reflex.Dom.Builder.Immediate
80 Reflex.Dom.Builder.Immediate
81+ Reflex.Dom.Builder.InputDisabled
81 Reflex.Dom.Builder.Static
82 Reflex.Dom.Builder.Static
82 Reflex.Dom.Class
83 Reflex.Dom.Class
83 Reflex.Dom.Internal
84 Reflex.Dom.Internal
src/Reflex/Dom.hs+1
@@ -3,6 +3,7 @@ module Reflex.Dom (module X) where
3import Reflex as X
3import Reflex as X
4import Reflex.Dom.Builder.Class as X
4import Reflex.Dom.Builder.Class as X
5import Reflex.Dom.Builder.Immediate as X
5import Reflex.Dom.Builder.Immediate as X
6+import Reflex.Dom.Builder.InputDisabled as X
6import Reflex.Dom.Builder.Static as X
7import Reflex.Dom.Builder.Static as X
7import Reflex.Dom.Class as X
8import Reflex.Dom.Class as X
8import Reflex.Dom.Internal as X
9import Reflex.Dom.Internal as X
src/Reflex/Dom/Builder/InputDisabled.hsnew file+90
@@ -0,0 +1,90 @@
1+{-# LANGUAGE StandaloneDeriving #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE TypeFamilies #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE UndecidableInstances #-}
8+module Reflex.Dom.Builder.InputDisabled where
9+
10+import Control.Lens
11+import Control.Monad.Fix
12+import Control.Monad.Ref
13+import Control.Monad.Trans
14+import Control.Monad.Trans.Control
15+import qualified Data.Map as Map
16+import Foreign.JavaScript.TH
17+import Reflex
18+import Reflex.Deletable.Class
19+import Reflex.Dom.Builder.Class
20+import Reflex.Host.Class
21+
22+-- | A DomBuilder transformer that disables all 'inputElement's,
23+-- 'textAreaElement's, and 'selectElement's by adding the "disabled" HTML
24+-- attribute. Note that 'element's that happen to have "input", "textarea", or
25+-- "select" as their tag will NOT be disabled.
26+newtype InputDisabledT m a = InputDisabledT { runInputDisabledT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)
27+
28+deriving instance MonadSample t m => MonadSample t (InputDisabledT m)
29+deriving instance MonadHold t m => MonadHold t (InputDisabledT m)
30+
31+instance MonadTrans InputDisabledT where
32+ lift = InputDisabledT
33+
34+instance MonadTransControl InputDisabledT where
35+ type StT InputDisabledT a = a
36+ liftWith f = InputDisabledT $ f runInputDisabledT
37+ restoreT = InputDisabledT
38+
39+instance MonadRef m => MonadRef (InputDisabledT m) where
40+ type Ref (InputDisabledT m) = Ref m
41+ newRef = lift . newRef
42+ readRef = lift . readRef
43+ writeRef ref = lift . writeRef ref
44+
45+instance PerformEvent t m => PerformEvent t (InputDisabledT m) where
46+ type Performable (InputDisabledT m) = Performable m
47+ performEvent_ = lift . performEvent_
48+ performEvent = lift . performEvent
49+
50+disableElementConfig :: Reflex t => ElementConfig er t m -> ElementConfig er t m
51+disableElementConfig cfg = cfg
52+ { _elementConfig_initialAttributes = Map.insert "disabled" "disabled" $ _elementConfig_initialAttributes cfg
53+ , _elementConfig_modifyAttributes = Map.delete "disabled" <$> _elementConfig_modifyAttributes cfg
54+ }
55+
56+instance Deletable t m => Deletable t (InputDisabledT m) where
57+ deletable d = liftThrough $ deletable d
58+
59+instance PostBuild t m => PostBuild t (InputDisabledT m) where
60+ getPostBuild = lift getPostBuild
61+
62+deriving instance TriggerEvent t m => TriggerEvent t (InputDisabledT m)
63+
64+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (InputDisabledT m) where
65+ newEventWithTrigger = lift . newEventWithTrigger
66+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
67+
68+instance DomBuilder t m => DomBuilder t (InputDisabledT m) where
69+ type DomBuilderSpace (InputDisabledT m) = DomBuilderSpace m
70+ placeholder cfg = lift $ placeholder $ cfg
71+ & placeholderConfig_insertAbove %~ fmap runInputDisabledT
72+ inputElement cfg = lift $ inputElement $ cfg
73+ { _inputElementConfig_elementConfig = liftElementConfig $ disableElementConfig $ _inputElementConfig_elementConfig cfg
74+ }
75+ textAreaElement cfg = lift $ textAreaElement $ cfg
76+ { _textAreaElementConfig_elementConfig = liftElementConfig $ disableElementConfig $ _textAreaElementConfig_elementConfig cfg
77+ }
78+ selectElement cfg child = do
79+ let cfg' = cfg
80+ { _selectElementConfig_elementConfig = liftElementConfig $ disableElementConfig $ _selectElementConfig_elementConfig cfg
81+ }
82+ lift $ selectElement cfg' $ runInputDisabledT child
83+
84+instance HasWebView m => HasWebView (InputDisabledT m) where
85+ type WebViewPhantom (InputDisabledT m) = WebViewPhantom m
86+ askWebView = lift askWebView
87+
88+instance HasJS js m => HasJS js (InputDisabledT m) where
89+ type JSM (InputDisabledT m) = JSM m
90+ liftJS = lift . liftJS