module Text.StringTemplate.Helpers (
directoryGroups'
, directoryGroups
, directoryGroupsOld
, dirgroupKeys
, getTemplateGroup
, renderTemplateDirGroup
, lookupDirgroup
, renderTemplateGroup
, render1
, STDirGroups
, readTmplDef
, readTmplM
, readTmplTuples
)
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.Find 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)
directoryGroupsOld = directoryGroups' directoryGroup
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
directoryGroups = directoryGroups' directoryGroupNew
directoryGroupNew :: Stringable a => FilePath -> IO (STGroup a)
directoryGroupNew path = do
fs <- return . ( filter ((".st" ==) . takeExtension) ) =<< getDirectoryContents path
templates <- mapM g fs
stmapping <- return . zip (map dropExtension fs) $ templates
return $ groupStringTemplates stmapping
where g f = do contents <- Strict.readFile $ path </> f
return . newSTMP $ contents
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 = or . map (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