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.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 Data.Time
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 </> dropExtension 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 <- getCurrentTime
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 (round . realToFrac $
diffUTCTime curtime t) > m
then udReturn curtime
else return st