diff --git a/HStringTemplateHelpers.cabal b/HStringTemplateHelpers.cabal --- a/HStringTemplateHelpers.cabal +++ b/HStringTemplateHelpers.cabal @@ -1,5 +1,5 @@ Name: HStringTemplateHelpers -Version: 0.0.6 +Version: 0.0.7 License: GPL License-file: gpl.txt Description: Convenience functions and instances for HStringTemplate. I will deprecate this package if its contents are integrated into HStringTemplate. @@ -9,7 +9,7 @@ Stability: Beta Copyright: Copyright (c) 2006-2008 Thomas Hartman Exposed-Modules: Text.StringTemplate.Helpers -Build-Depends: base, HStringTemplate, filepath, directory, containers, HSH, mtl, safe, strict +Build-Depends: base, HStringTemplate, filepath, directory, containers, HSH, mtl, safe, strict, FileManip Category: Text Build-type: Simple diff --git a/Text/StringTemplate/Helpers.hs b/Text/StringTemplate/Helpers.hs --- a/Text/StringTemplate/Helpers.hs +++ b/Text/StringTemplate/Helpers.hs @@ -5,9 +5,10 @@ More usage examples can be found by grep -r \"Text.StringTemplate.Helpers\" in happs-tutorial, on hackage. -} -module Text.StringTemplate.Helpers ( - directoryGroupSafer - , directoryGroupsSafer +module Text.StringTemplate.Helpers ( + directoryGroups' + , directoryGroups + , directoryGroups2 , dirgroupKeys , getTemplateGroup , renderTemplateDirGroup @@ -22,7 +23,7 @@ where -import Text.StringTemplate --hiding (directoryGroup) +import Text.StringTemplate import Text.StringTemplate.Base import System.Directory import System.FilePath @@ -31,12 +32,12 @@ import Data.List (find) import Data.Char import Control.Monad.Reader -import HSH +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 {- | Chooses a template from an STGroup, or errors if not found. @@ -63,9 +64,9 @@ --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 +--t :: IO [FilePath] +--t = do (map :: M.Map FilePath (STGroup String)) <- ( directoryGroupsSafer "/home/thartman/testtemplates" ) +-- return $ M.keys map --getST @@ -81,24 +82,34 @@ 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 +directoryGroups = directoryGroups' directoryGroup +directoryGroups' :: (FilePath -> IO a) -> FilePath -> IO (M.Map FilePath a) +directoryGroups' f' 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 + f d = do g <- f' 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 - + findDirectories d = Find.find Find.always (Find.fileType Find.==? Find.Directory) d +directoryGroups2 = directoryGroups' directoryGroup2 +{- | I think this does the same thing as directoryGroup (modulo IO strictness), + which uses an applicative idiom that melts my brain. + Not a direct translation, but it's easier for me to understand when written + Important change: readFile is strict. If it is left lazy, appkiller.sh causes happstutorial to crash + when in dynamicTemplateReload mode. + I think this needs to be fixed in HStringTemplate distribution as well. +-} +directoryGroup2 :: Stringable a => FilePath -> IO (STGroup a) +directoryGroup2 path = do + fs <- return . ( filter ((".st" ==) . takeExtension) ) =<< getDirectoryContents path + templates <- mapM g fs + stmapping <- return . zip (map dropExtension fs) $ templates + return $ groupStringTemplates stmapping + -- For a while when debugging a problem in HAppS I thought this had to be + -- System.IO.Strict.ReadFile, but now I think it makes no difference + where g f = do contents <- Strict.readFile $ path f + return . newSTMP $ contents {- | 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. @@ -121,28 +132,6 @@ 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) @@ -150,7 +139,7 @@ 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 @@ -162,29 +151,7 @@ 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 --} - +-- useful for HAppS, eg for dynamic menus readTmplTuples :: STGroup String -> String -> [(String, String)] readTmplTuples = readTmplDef [("readTutTuples error","")] @@ -197,3 +164,5 @@ safeRead :: (Monad m, Read a) => String -> m a safeRead s = maybe (fail $ "safeRead: " ++ s) return . readMay $ s + +