{-# OPTIONS_HADDOCK not-home #-} module Text.StringTemplate.Group (groupStringTemplates, addSuperGroup, addSubGroup, setEncoderGroup, mergeSTGroups, directoryGroup, optInsertGroup, directoryGroupLazy, unsafeVolatileDirectoryGroup, nullGroup ) where import Control.Applicative hiding ((<|>),many) import Control.Arrow import Data.Monoid import Data.List import System.Time import System.FilePath import System.Directory import Data.IORef import System.IO.Unsafe import System.IO.Error import qualified Data.Map as M import Text.StringTemplate.Base import Text.StringTemplate.Classes {-------------------------------------------------------------------- Utilities --------------------------------------------------------------------} (<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b) (<$$>) x y = ((<$>) . (<$>)) x y {-------------------------------------------------------------------- Group API --------------------------------------------------------------------} -- | Given a list of named of StringTemplates, returns a group which generates -- them such that they can call one another. groupStringTemplates :: [(String,StringTemplate a)] -> STGroup a groupStringTemplates xs = newGen where newGen s = StFirst (M.lookup s ng) ng = M.fromList $ map (second $ inSGen (`mappend` newGen)) xs -- | Given a path, returns a group which generates all files in said directory -- which have the proper \"st\" extension. -- This function is strict, with all files read once. As it performs file IO, -- expect it to throw the usual exceptions. directoryGroup :: (Stringable a) => FilePath -> IO (STGroup a) directoryGroup path = groupStringTemplates <$> (fmap <$> zip . (map dropExtension) <*> mapM (newSTMP <$$> (readFile . (path </>))) =<< filter ((".st" ==) . takeExtension) <$> getDirectoryContents path) -- | Given a path, returns a group which generates all files in said directory -- which have the proper \"st\" extension. -- This function is lazy in the same way that readFile is lazy, with all -- files read on demand, but no more than once. As it performs file IO, -- expect it to throw the usual exceptions. And, as it is lazy, expect -- these exceptions in unexpected places. directoryGroupLazy :: (Stringable a) => FilePath -> IO (STGroup a) directoryGroupLazy path = groupStringTemplates <$> (fmap <$> zip . (map dropExtension) <*> mapM (unsafeInterleaveIO . (newSTMP <$$> (readFile . (path </>)))) =<< filter ((".st" ==) . takeExtension) <$> getDirectoryContents path) -- | Adds a supergroup to any StringTemplate group such that templates from -- the original group are now able to call ones from the supergroup as well. addSuperGroup :: STGroup a -> STGroup a -> STGroup a addSuperGroup f g = inSGen (`mappend` g) <$$> f -- | Adds a \"subgroup\" to any StringTemplate group such that templates from -- the original group now have template calls \"shadowed\" by the subgroup. addSubGroup :: STGroup a -> STGroup a -> STGroup a addSubGroup f g = inSGen (g `mappend`) <$$> f -- | Merges two groups into a single group. This function is left-biased, -- prefering bindings from the first group when there is a conflict. mergeSTGroups :: STGroup a -> STGroup a -> STGroup a mergeSTGroups f g = addSuperGroup f g `mappend` addSubGroup g f -- | Adds a set of global options to a group optInsertGroup :: [(String, String)] -> STGroup a -> STGroup a optInsertGroup opts f = (inSGen (optInsertGroup opts) . optInsertTmpl opts) <$$> f -- | Sets an encoding function of a group that all values are -- rendered with in each enclosed template setEncoderGroup :: (Stringable a) => (String -> String) -> STGroup a -> STGroup a setEncoderGroup x f = (inSGen (setEncoderGroup x) . setEncoder x) <$$> f -- | For any requested template, returns a message that the template was -- unable to be found. Useful to add as a super group for a set of templates -- under development, to aid in debugging. nullGroup :: Stringable a => STGroup a nullGroup = \x -> StFirst . Just . newSTMP $ "Could not find template: " ++ x -- | Given an integral amount of seconds and a path, returns a group generating -- all files in said directory with the proper \"st\" extension, -- cached for that amount of seconds. IO errors are \"swallowed\" by this so -- that exceptions don't arise in unexpected places. -- This violates referential transparency, but can be very useful in developing -- templates for any sort of server application. It should be swapped out for -- production purposes. The dumpAttribs template is added to the returned group -- by default, as it should prove useful for debugging and developing templates. unsafeVolatileDirectoryGroup :: Stringable a => String -> Int -> IO (STGroup a) unsafeVolatileDirectoryGroup path m = return . flip addSubGroup extraTmpls $ cacheSTGroup stfg where stfg = StFirst . Just . STMP (SEnv M.empty [] stfg id) . parseSTMP ('$', '$') . unsafePerformIO . flip catch (return . (\e -> "IO Error: " ++ show (ioeGetFileName e) ++ " -- " ++ ioeGetErrorString e)) . readFile . (path </>) . (++".st") extraTmpls = addSubGroup (groupStringTemplates [("dumpAttribs", dumpAttribs)]) nullGroup cacheSTGroup :: STGroup a -> STGroup a cacheSTGroup g = unsafePerformIO $ go <$> newIORef M.empty where go r s = unsafePerformIO $ do mp <- readIORef r now <- getClockTime maybe (udReturn now) (\(t, st) -> if (tdSec . normalizeTimeDiff $ diffClockTimes now t) > m then udReturn now else return st) . M.lookup s $ mp where udReturn now = do let st = g s atomicModifyIORef r $ flip (,) () . M.insert s (now, st) return st