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
(<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b)
(<$$>) x y = ((<$>) . (<$>)) x y
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
directoryGroup :: (Stringable a) => FilePath -> IO (STGroup a)
directoryGroup path = groupStringTemplates <$>
(fmap <$> zip . (map dropExtension)
<*> mapM (newSTMP <$$> (readFile . (path </>)))
=<< filter ((".st" ==) . takeExtension)
<$> getDirectoryContents path)
directoryGroupLazy :: (Stringable a) => FilePath -> IO (STGroup a)
directoryGroupLazy path = groupStringTemplates <$>
(fmap <$> zip . (map dropExtension)
<*> mapM (unsafeInterleaveIO .
(newSTMP <$$> (readFile . (path </>))))
=<< filter ((".st" ==) . takeExtension)
<$> getDirectoryContents path)
addSuperGroup :: STGroup a -> STGroup a -> STGroup a
addSuperGroup f g = inSGen (`mappend` g) <$$> f
addSubGroup :: STGroup a -> STGroup a -> STGroup a
addSubGroup f g = inSGen (g `mappend`) <$$> f
mergeSTGroups :: STGroup a -> STGroup a -> STGroup a
mergeSTGroups f g = addSuperGroup f g `mappend` addSubGroup g f
optInsertGroup :: [(String, String)] -> STGroup a -> STGroup a
optInsertGroup opts f = (inSGen (optInsertGroup opts) . optInsertTmpl opts) <$$> f
setEncoderGroup :: (Stringable a) => (String -> String) -> STGroup a -> STGroup a
setEncoderGroup x f = (inSGen (setEncoderGroup x) . setEncoder x) <$$> f
nullGroup :: Stringable a => STGroup a
nullGroup = \x -> StFirst . Just . newSTMP $ "Could not find template: " ++ x
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