module Text.StringTemplate.Group
(groupStringTemplates, addSuperGroup, addSubGroup, setEncoderGroup,
mergeSTGroups, directoryGroup, directoryGroupExt, optInsertGroup,
directoryGroupLazy, directoryGroupLazyExt, directoryGroupRecursive,
directoryGroupRecursiveExt, directoryGroupRecursiveLazy,
directoryGroupRecursiveLazyExt,
unsafeVolatileDirectoryGroup, nullGroup
) where
import Control.Applicative
import Control.Arrow
import qualified Control.Exception as CE
import Control.Monad
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 System.IO.UTF8 as U
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)
(<$$>) = (<$>) . (<$>)
readFile' :: FilePath -> IO String
readFile' f = do
x <- U.readFile f
length x `seq` return x
groupFromFiles :: Stringable a => (FilePath -> IO String) -> [(FilePath,String)] -> IO (STGroup a)
groupFromFiles rf fs = groupStringTemplates <$> forM fs (\(f,fname) -> do
stmp <- newSTMP <$> rf f
return (fname, stmp))
getTmplsRecursive :: FilePath -> FilePath -> FilePath -> IO [(FilePath, FilePath)]
getTmplsRecursive ext base fp = do
dirContents <- filter (not . isPrefixOf ".") <$> getDirectoryContents fp
subDirs <- filterM (doesDirectoryExist . (fp </>)) dirContents
subs <- concat <$> mapM (\x -> getTmplsRecursive ext (base </> x) (fp </> x)) subDirs
return $ (map ((fp </>) &&& (\x -> base </> dropExtensions x)) $
filter ((ext ==) . takeExtension) dirContents)
++ subs
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 = directoryGroupExt ".st"
directoryGroupExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a)
directoryGroupExt ext path =
groupFromFiles readFile' .
map ((</>) path &&& takeBaseName) . filter ((ext ==) . takeExtension) =<<
getDirectoryContents path
directoryGroupLazy :: (Stringable a) => FilePath -> IO (STGroup a)
directoryGroupLazy = directoryGroupLazyExt ".st"
directoryGroupLazyExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a)
directoryGroupLazyExt ext path =
groupFromFiles U.readFile .
map ((</>) path &&& takeBaseName) . filter ((ext ==) . takeExtension) =<<
getDirectoryContents path
directoryGroupRecursive :: (Stringable a) => FilePath -> IO (STGroup a)
directoryGroupRecursive = directoryGroupRecursiveExt ".st"
directoryGroupRecursiveExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a)
directoryGroupRecursiveExt ext path = groupFromFiles readFile' =<< getTmplsRecursive ext "" path
directoryGroupRecursiveLazy :: (Stringable a) => FilePath -> IO (STGroup a)
directoryGroupRecursiveLazy = directoryGroupRecursiveLazyExt ".st"
directoryGroupRecursiveLazyExt :: (Stringable a) => FilePath -> FilePath -> IO (STGroup a)
directoryGroupRecursiveLazyExt ext path = groupFromFiles U.readFile =<< getTmplsRecursive ext "" 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) => (a -> a) -> 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 => FilePath -> Int -> IO (STGroup a)
unsafeVolatileDirectoryGroup path m = return . flip addSubGroup extraTmpls $ cacheSTGroup stfg
where stfg = StFirst . Just . newSTMP . unsafePerformIO . flip CE.catch
(return . (\e -> "IO Error: " ++ show (ioeGetFileName e) ++ " -- " ++ ioeGetErrorString e))
. U.readFile . (path </>) . (++".st")
extraTmpls = addSubGroup (groupStringTemplates [("dumpAttribs", dumpAttribs)]) nullGroup
cacheSTGroup :: STGroup a -> STGroup a
cacheSTGroup g = unsafePerformIO $ do
!ior <- newIORef M.empty
return $ \s -> unsafePerformIO $ do
mp <- readIORef ior
curtime <- getClockTime
let udReturn now = do
let st = g s
atomicModifyIORef ior $
flip (,) () . M.insert s (now, st)
return st
case M.lookup s mp of
Nothing -> udReturn curtime
Just (t, st) ->
if (tdSec . normalizeTimeDiff $
diffClockTimes curtime t) > m
then udReturn curtime
else return st