module Text.StringTemplate.Helpers (
directoryGroups'
, directoryGroups
, directoryGroupsOld
, dirgroupKeys
, getTemplateGroup
, renderTemplateDirGroup
, lookupDirgroup
, renderTemplateGroup
, render1
, STDirGroups
, readTmplDef
, readTmplM
, readTmplTuples
, badTmplVarName
, directoryGroupNew'
)
where
import Text.StringTemplate
import Text.StringTemplate.Base
import System.Directory
import System.FilePath
import qualified System.IO.Strict as Strict
import Control.Applicative
import Data.List (find)
import Data.Char
import Control.Monad.Reader
import HSH (bracketCD)
import qualified Data.Map as M
import Text.StringTemplate.Classes
import Safe
import qualified System.FilePath.FindCompat as Find
import System.FilePath
renderTemplateGroup :: (ToSElem a) => STGroup String -> [(String, a)] -> [Char] -> String
renderTemplateGroup gr attrs tmpl =
maybe ( "template not found: " ++ tmpl )
( toString . setManyAttribSafer attrs )
( getStringTemplate tmpl gr )
renderTemplateGroupS :: STGroup String -> [(String, String)] -> [Char] -> String
renderTemplateGroupS = renderTemplateGroup
--getST
type STDirGroups a = M.Map FilePath (STGroup a)
directoryGroups' :: (FilePath -> IO a) -> FilePath -> IO (M.Map FilePath a)
directoryGroups' f' d = bracketCD d $ do
subDirs <- findDirectories $ "."
return . M.fromList =<< mapM f subDirs
where
f d = do g <- f' d
return (d,g)
findDirectories d = Find.find Find.always (Find.fileType Find.==? Find.Directory) d
directoryGroupsOld :: (Stringable a) => FilePath -> IO (M.Map FilePath (STGroup a))
directoryGroupsOld = directoryGroups' directoryGroup
directoryGroups :: (Stringable a) => FilePath -> IO (M.Map FilePath (STGroup a))
directoryGroups = directoryGroups' directoryGroupNew
directoryGroupNew :: (Stringable a) => FilePath -> IO (STGroup a)
directoryGroupNew = directoryGroupNew' (\_ -> False) (\_ -> False)
directoryGroupNew' :: (Stringable a) =>
(FilePath -> Bool)
-> (String -> Bool)
-> FilePath
-> IO (STGroup a)
directoryGroupNew' ignoreTemplate errorTemplate path = do
fs1 <- return . ( filter filt ) =<< getDirectoryContents path
fs <- mapM errT =<< return fs1
templates <- mapM readTemplate fs
stmapping <- return . zip (map dropExtension fs) $ templates
return $ groupStringTemplates stmapping
where
readTemplate f = do
contents <- Strict.readFile $ path </> f
return . newSTMP $ contents
errT t = if ( errorTemplate . takeBaseName ) t
then fail $ "directoryGroupNew', bad template name: " ++ t
else return t
filt f = ( ( (".st" ==) . takeExtension ) $ f)
&& ( (not . ignoreTemplate) $ f)
dirgroupKeys :: (Stringable a) => STDirGroups a -> [FilePath]
dirgroupKeys = M.keys
lookupDirgroup :: (Stringable a) => FilePath -> STDirGroups a -> Maybe (STGroup a)
lookupDirgroup d = M.lookup d
getTemplateGroup :: (Stringable a) => FilePath -> STDirGroups a -> STGroup a
getTemplateGroup dir tdg = maybe (error $ "getTG, bad dir:" ++ dir) id . lookupDirgroup dir $ tdg
renderTemplateDirGroup :: ToSElem a => STDirGroups String -> FilePath -> String -> [(String,a)] -> String
renderTemplateDirGroup tdg dir tname attrs =
let ts = getTemplateGroup dir tdg
in renderTemplateGroup ts attrs tname
setManyAttribSafer attrs st =
let mbFoundbadattr = find badTmplVarName . map fst $ attrs
in maybe (setManyAttrib attrs st)
(\mbA -> newSTMP . ("setManyAttribSafer, bad template atr: "++) $ mbA)
mbFoundbadattr
(<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b)
(<$$>) = (<$>) . (<$>)
badTmplVarName :: String -> Bool
badTmplVarName t = not . null . filter (not . isAlpha) $ t
render1 :: [(String,String)] -> String -> String
render1 attribs tmpl = render . setManyAttrib attribs . newSTMP $ tmpl
readTmplTuples :: STGroup String -> String -> [(String, String)]
readTmplTuples = readTmplDef [("readTutTuples error","")]
readTmplDef :: (Read b) => b -> STGroup String -> FilePath -> b
readTmplDef def ts f = either (const def) id ( readTmplM ts f :: Read a => Either String a)
readTmplM :: (Monad m, Read a) => STGroup String -> FilePath -> m a
readTmplM ts file = safeRead . renderTemplateGroup ts ([] :: [(String,String)] ) . concatMap escapequote $ file
where escapequote char = if char=='"' then "\\\"" else [char]
safeRead :: (Monad m, Read a) => String -> m a
safeRead s = maybe (fail $ "safeRead: " ++ s) return . readMay $ s