{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, NoMonomorphismRestriction,
ScopedTypeVariables, UndecidableInstances #-}
{- |
Functions I found useful for doing webapps with HStringTemplate.
More usage examples can be found by grep -r \"Text.StringTemplate.Helpers\" in happs-tutorial, on hackage.
-}
module Text.StringTemplate.Helpers (
directoryGroupSafer
, directoryGroupsSafer
, dirgroupKeys
, getTemplateGroup
, renderTemplateDirGroup
, lookupDirgroup
, renderTemplateGroup
, render1
, STDirGroups
, readTmplDef
, readTmplM
, readTmplTuples
)
where
import Text.StringTemplate --hiding (directoryGroup)
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
import qualified Data.Map as M
import Text.StringTemplate.Classes
import Safe
{- |
Chooses a template from an STGroup, or errors if not found.
Render that template using attrs.
If a template k/v pair is repeated, it appears twice. (Perhaps a clue to buggy behavior?)
Repeated keys could be eliminated by running clean:
> clean = nubBy (\(a1,b1) (a2,b2) -> a1 == a2) . sortBy (\(a1,b1) (a2,b2) -> a1 `compare` a2)
The ToSElem type is probably either String or [String]
-}
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
-- can this be done for Bytestrings? Below doesn't work, need an instance for (ToSElem B.ByteString)
--renderTemplateGroupB :: STGroup String -> [(String, B.ByteString)] -> [Char] -> String
--renderTemplateGroupB = renderTemplateGroup
t :: IO [FilePath]
t = do (map :: M.Map FilePath (STGroup String)) <- ( directoryGroupsSafer "/home/thartman/testtemplates" )
return $ M.keys map
--getST
type STDirGroups a = M.Map FilePath (STGroup a)
{- |
calculate a map of directory groups from a top-level directory
Each directory gives rise to its own groups.
Groups are independent; groups from higher in the directory structure do not have access to groups lower.
The top group has key \".\" (mnemonic, current directory), other groups have key names of subdirectories, including the starting ., eg \".\/templates\/path\/to/\subdir\"
-}
--directoryGroupsSafer :: (Stringable a) => FilePath -> IO (STDirGroups a)
directoryGroupsSafer d = bracketCD d $ do
subDirs <- findDirectories $ "."
-- attempt to make strict, but doesn't make any difference
--putStrLn . show . last $ show subDirs
return . M.fromList =<< mapM f subDirs
where
f d = do g <- directoryGroupSafer d
return (d,g)
-- this seems suspect. Perhaps try using the find module on hackage?
-- | wrapper over find \/path\/to\/top\/dir -type d
findDirectories :: FilePath -> IO [FilePath]
findDirectories d = runStrings $ render1 [("d",d)] "find $d$ -type d"
where
runStrings :: String -> IO [String]
runStrings = ( return . lines =<< ) . run
{- |
The STGroup can't be shown in a useful way because it's a function type, but you can at least show the directories via Data.Map.keys.
-}
dirgroupKeys :: (Stringable a) => STDirGroups a -> [FilePath]
dirgroupKeys = M.keys
lookupDirgroup :: (Stringable a) => FilePath -> STDirGroups a -> Maybe (STGroup a)
lookupDirgroup d = M.lookup d
-- | > example: getTG "./baselayout" ts'
getTemplateGroup :: (Stringable a) => FilePath -> STDirGroups a -> STGroup a
getTemplateGroup dir tdg = maybe (error $ "getTG, bad dir:" ++ dir) id . lookupDirgroup dir $ tdg
-- | > example: renderTemplateDirGroup ts' "./baselayout" "base"
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
-- | calculate the STGroup for a given directory, filtering out files that are probably errors (eg emacs backups)
--directoryGroupSafer :: (Stringable a) => FilePath -> IO (STGroup a)
directoryGroupSafer :: FilePath -> IO (String -> StFirst (StringTemplate String) )
directoryGroupSafer path = do
files <- mapM checkTmplName =<< return . filter isTemplateFile =<< getDirectoryContents path
contents <- mapM Strict.readFile $ map (path </>) files
-- does this make it strict? what's the right way to do it?
-- mm, the buggy behavior persists.
--putStrLn . show . last . show $ contents
let sts = map newSTMP contents
tnames = map dropExtension files
return $ groupStringTemplates $ zip tnames sts
where
checkTmplName t = if ( badTmplVarName . takeBaseName ) t
then fail $ "directoryGroupSafer, bad template name: " ++ t
else return t
isTemplateFile f = ( (".st" ==) . takeExtension $ f )
&& (not . or . map (=='#') $ f ) {-filename doesn't contain naughty emacs backup character-}
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)
(<$$>) = fmap . fmap
badTmplVarName :: String -> Bool
badTmplVarName t = or . map (not . isAlpha) $ t
{- |
> render1 [("name","Bill")] "Hi, my name is $name$"
> render1 attribs tmpl = render . setManyAttrib attribs . newSTMP $ tmpl
-}
render1 :: [(String,String)] -> String -> String
render1 attribs tmpl = render . setManyAttrib attribs . newSTMP $ tmpl
--type StringTemplateReader a = ReaderT (StringTemplate a)
--t :: (Stringable a, Monad m) => ReaderT (StringTemplate a) m a
--renderArrg :: String -> ReaderT (StringTemplate String) IO (StringTemplate String)
renderArrg name = do
(e :: StringTemplate String) <- return . newSTMP $ "aaarg, $name$"
named <- local $ setAttribute "name" name
return named
--t2 :: IO String
--t2 = renderArrg "Matey"
{- |
> readTmplTuples = readTmplDef [("readTutTuples error","")]
use ST machinery to store key/val configuration information, eg as a configuration hack or in web apps
-}
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