{-# 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  (
  directoryGroups'
  , directoryGroups
  -- uses function from HStringTemplate which isn't strict, and I believe should be fixed in distribution.
  , 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
{- | 
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\"
-} 
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
{- | 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.
-}
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
    -- 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.
-}
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

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 [("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

-- useful for HAppS, eg for dynamic menus
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