@@ -0,0 +1,124 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DataKinds #-}
3+{-# LANGUAGE DefaultSignatures #-}
4+{-# LANGUAGE DeriveFunctor #-}
5+{-# LANGUAGE FlexibleContexts #-}
6+{-# LANGUAGE FlexibleInstances #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+{-# LANGUAGE MultiParamTypeClasses #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE RankNTypes #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
13+module Obelisk.Configs
14+ ( HasConfigs(..)
15+ , ConfigsT
16+ , runConfigsT
17+ , mapConfigsT
18+ ) where
19+
20+import Control.Applicative
21+import Control.Monad
22+import Control.Monad.Base
23+import Control.Monad.Fix
24+import Control.Monad.Primitive
25+import Control.Monad.Ref
26+import Control.Monad.IO.Class
27+import Control.Monad.Trans.Class
28+import Control.Monad.Trans.Control
29+import Control.Monad.Trans.Reader
30+import Data.ByteString (ByteString)
31+import Data.Map (Map)
32+import qualified Data.Map as Map
33+import Data.Text (Text)
34+import Reflex
35+import Reflex.Host.Class
36+import Reflex.Dom
37+#ifndef ghcjs_HOST_OS
38+import Language.Javascript.JSaddle (MonadJSM)
39+#endif
40+
41+class Monad m => HasConfigs m where
42+ getConfigs :: m (Map Text ByteString)
43+ default getConfigs :: (HasConfigs m', m ~ t m', MonadTrans t) => m (Map Text ByteString)
44+ getConfigs = lift getConfigs
45+ getConfig :: Text -> m (Maybe ByteString)
46+ getConfig k = do
47+ configs <- getConfigs
48+ return $ Map.lookup k configs
49+
50+instance Monad m => HasConfigs (ConfigsT m) where
51+ getConfigs = ConfigsT ask
52+
53+instance HasConfigs m => HasConfigs (BehaviorWriterT t w m)
54+instance HasConfigs m => HasConfigs (DynamicWriterT t w m)
55+instance HasConfigs m => HasConfigs (EventWriterT t w m)
56+instance HasConfigs m => HasConfigs (PostBuildT t m)
57+instance HasConfigs m => HasConfigs (QueryT t q m)
58+instance HasConfigs m => HasConfigs (ReaderT r m)
59+instance HasConfigs m => HasConfigs (RequesterT t request response m)
60+instance HasConfigs m => HasConfigs (StaticDomBuilderT t m)
61+instance HasConfigs m => HasConfigs (TriggerEventT t m)
62+
63+newtype ConfigsT m a = ConfigsT { unConfigsT :: ReaderT (Map Text ByteString) m a }
64+ deriving
65+ ( Functor
66+ , Applicative
67+ , Monad
68+ , MonadPlus
69+ , Alternative
70+ , MonadFix
71+ , MonadIO
72+ , MonadBase m'
73+ , MonadBaseControl m'
74+ , MonadRef
75+ , MonadTrans
76+ , DomBuilder t
77+ , MonadHold t
78+ , MonadReflexCreateTrigger t
79+ , MonadSample t
80+ , NotReady t
81+ , PostBuild t
82+ , TriggerEvent t
83+ , HasDocument
84+ , DomRenderHook t
85+ , HasJSContext
86+ , HasJS js
87+#ifndef ghcjs_HOST_OS
88+ , MonadJSM
89+#endif
90+ )
91+
92+instance PerformEvent t m => PerformEvent t (ConfigsT m) where
93+ type Performable (ConfigsT m) = ConfigsT (Performable m)
94+ performEvent e = ConfigsT $ ReaderT $ \configs ->
95+ performEvent $ runConfigsT configs <$> e
96+ performEvent_ e = ConfigsT $ ReaderT $ \configs ->
97+ performEvent_ $ runConfigsT configs <$> e
98+
99+instance Adjustable t m => Adjustable t (ConfigsT m) where
100+ runWithReplace a e = ConfigsT $ runWithReplace (unConfigsT a) (unConfigsT <$> e)
101+ traverseDMapWithKeyWithAdjust f m e = ConfigsT $ traverseDMapWithKeyWithAdjust (\k v -> unConfigsT $ f k v) m e
102+ traverseIntMapWithKeyWithAdjust f m e = ConfigsT $ traverseIntMapWithKeyWithAdjust (\k v -> unConfigsT $ f k v) m e
103+ traverseDMapWithKeyWithAdjustWithMove f m e = ConfigsT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unConfigsT $ f k v) m e
104+
105+instance Prerender js t m => Prerender js t (ConfigsT m) where
106+ type Client (ConfigsT m) = ConfigsT (Client m)
107+ prerender server client = ConfigsT $ ReaderT $ \configs ->
108+ prerender (runConfigsT configs server) (runConfigsT configs client)
109+
110+instance PrimMonad m => PrimMonad (ConfigsT m) where
111+ type PrimState (ConfigsT m) = PrimState m
112+ primitive = lift . primitive
113+
114+runConfigsT
115+ :: Map Text ByteString
116+ -> ConfigsT m a
117+ -> m a
118+runConfigsT cs child = runReaderT (unConfigsT child) cs
119+
120+mapConfigsT
121+ :: (forall x. m x -> n x)
122+ -> ConfigsT m a
123+ -> ConfigsT n a
124+mapConfigsT f (ConfigsT x) = ConfigsT $ mapReaderT f x