{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Text.StringTemplates.Fields ( Fields(..)
, runFields
, value
, valueM
, object
, objects
) where
import Control.Monad.Base (MonadBase)
import Control.Monad.Catch
import Control.Monad.Reader
import Control.Monad.State.Strict
import Control.Monad.Trans.Control (MonadBaseControl(..), MonadTransControl(..), ComposeSt, defaultLiftBaseWith, defaultRestoreM, defaultLiftWith, defaultRestoreT)
import Data.Int
import Data.Word
import Text.StringTemplate.Base hiding (render)
import Text.StringTemplate.Classes
import qualified Data.Map as M
type InnerFields = StateT [(String, SElem String)]
newtype Fields m a = Fields { unFields :: InnerFields m a }
deriving (Applicative, Functor, Monad, MonadBase b, MonadTrans, MonadThrow, MonadCatch, MonadMask)
instance MonadBaseControl b m => MonadBaseControl b (Fields m) where
#if MIN_VERSION_monad_control(1,0,0)
type StM (Fields m) a = ComposeSt Fields m a
liftBaseWith = defaultLiftBaseWith
restoreM = defaultRestoreM
#else
newtype StM (Fields m) a = StM { unStM :: ComposeSt Fields m a }
liftBaseWith = defaultLiftBaseWith StM
restoreM = defaultRestoreM unStM
#endif
{-# INLINE liftBaseWith #-}
{-# INLINE restoreM #-}
instance MonadTransControl Fields where
#if MIN_VERSION_monad_control(1,0,0)
type StT Fields m = StT InnerFields m
liftWith = defaultLiftWith Fields unFields
restoreT = defaultRestoreT Fields
#else
newtype StT Fields m = StT { unStT :: StT InnerFields m }
liftWith = defaultLiftWith Fields unFields StT
restoreT = defaultRestoreT Fields unStT
#endif
{-# INLINE liftWith #-}
{-# INLINE restoreT #-}
runFields :: Monad m => Fields m () -> m [(String, SElem String)]
runFields (Fields f) = execStateT f []
value :: (Monad m, ToSElem a) => String -> a -> Fields m ()
value name val = Fields $ modify ((name, toSElem val) :)
valueM :: (Monad m, ToSElem a) => String -> m a -> Fields m ()
valueM name mval = lift mval >>= value name
object :: Monad m => String -> Fields m () -> Fields m ()
object name obj = Fields $ do
val <- M.fromList `liftM` lift (runFields obj)
modify ((name, toSElem val) :)
objects :: Monad m => String -> [Fields m ()] -> Fields m ()
objects name objs = Fields $ do
vals <- mapM (liftM M.fromList . lift . runFields) objs
modify ((name, toSElem vals) :)
instance ToSElem Int16 where
toSElem = STR . show
instance ToSElem Int32 where
toSElem = STR . show
instance ToSElem Int64 where
toSElem = STR . show
instance ToSElem Word where
toSElem = STR . show
instance ToSElem Word8 where
toSElem = STR . show
instance ToSElem Word16 where
toSElem = STR . show
instance ToSElem Word32 where
toSElem = STR . show
instance ToSElem Word64 where
toSElem = STR . show
instance Stringable a => ToSElem (SElem a) where
toSElem (STR a) = (STR a)
toSElem (BS a) = (BS a)
toSElem (STSH a) = (STSH a)
toSElem (SM a) = (SM $ fmap (toSElem) a)
toSElem (LI a) = (LI $ fmap (toSElem) a)
toSElem (SBLE a) = (SBLE $ convert a)
toSElem (SNAT a) = (SNAT $ convert a)
toSElem (TXT a) = (TXT a)
toSElem SNull = SNull
convert :: (Stringable a, Stringable b) => a -> b
convert = stFromString . stToString