module Text.Hastache (
hastacheStr
, hastacheFile
, hastacheStrBuilder
, hastacheFileBuilder
, MuContext
, MuType(..)
, MuConfig(..)
, MuVar
, htmlEscape
, emptyEscape
, defaultConfig
, encodeStr
, encodeStrLBS
, decodeStr
, decodeStrLBS
) where
import Control.Monad (guard, when)
import Control.Monad.Reader (ask, runReaderT, MonadReader, ReaderT)
import Control.Monad.Trans (lift, liftIO, MonadIO)
import Data.ByteString hiding (map, foldl1)
import Data.Char (ord)
import Data.Int
import Data.IORef
import Data.Maybe (isJust)
import Data.Monoid (mappend, mempty)
import Data.Word
import Prelude hiding (putStrLn, readFile, length, drop, tail, dropWhile, elem,
head, last, reverse, take, span)
import System.Directory (doesFileExist)
import System.FilePath (combine)
import qualified Blaze.ByteString.Builder as BSB
import qualified Codec.Binary.UTF8.String as SU
import qualified Data.ByteString.Lazy as LZ
import qualified Data.List as List
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText
(~>) :: a -> (a -> b) -> b
x ~> f = f $ x
infixl 9 ~>
type MuContext m =
ByteString
-> MuType m
class Show a => MuVar a where
toLByteString :: a -> LZ.ByteString
instance MuVar ByteString where
toLByteString = toLBS
instance MuVar LZ.ByteString where
toLByteString = id
withShowToLBS a = show a ~> encodeStr ~> toLBS
instance MuVar Integer where toLByteString = withShowToLBS
instance MuVar Int where toLByteString = withShowToLBS
instance MuVar Float where toLByteString = withShowToLBS
instance MuVar Double where toLByteString = withShowToLBS
instance MuVar Int8 where toLByteString = withShowToLBS
instance MuVar Int16 where toLByteString = withShowToLBS
instance MuVar Int32 where toLByteString = withShowToLBS
instance MuVar Int64 where toLByteString = withShowToLBS
instance MuVar Word where toLByteString = withShowToLBS
instance MuVar Word8 where toLByteString = withShowToLBS
instance MuVar Word16 where toLByteString = withShowToLBS
instance MuVar Word32 where toLByteString = withShowToLBS
instance MuVar Word64 where toLByteString = withShowToLBS
instance MuVar Text.Text where
toLByteString t = Text.unpack t ~> encodeStr ~> toLBS
instance MuVar LText.Text where
toLByteString t = LText.unpack t ~> encodeStr ~> toLBS
instance MuVar Char where
toLByteString a = (a : "") ~> encodeStr ~> toLBS
instance MuVar a => MuVar [a] where
toLByteString a = (toLByteString '[') <+> cnvLst <+> (toLByteString ']')
where
cnvLst = (map toLByteString a) ~>
(LZ.intercalate (toLByteString ','))
(<+>) = LZ.append
instance MuVar [Char] where
toLByteString k = k ~> encodeStr ~> toLBS
data MuType m =
forall a. MuVar a => MuVariable a |
MuList [MuContext m] |
MuBool Bool |
forall a. MuVar a => MuLambda (ByteString -> a) |
forall a. MuVar a => MuLambdaM (ByteString -> m a) |
MuNothing
instance Show (MuType m) where
show (MuVariable a) = "MuVariable " ++ show a
show (MuList _) = "MuList [..]"
show (MuBool v) = "MuBool " ++ show v
show (MuLambda _) = "MuLambda <..>"
show (MuLambdaM _) = "MuLambdaM <..>"
show MuNothing = "MuNothing"
data MuConfig = MuConfig {
muEscapeFunc :: LZ.ByteString -> LZ.ByteString,
muTemplateFileDir :: Maybe FilePath,
muTemplateFileExt :: Maybe String
}
encodeStr :: String -> ByteString
encodeStr = pack . SU.encode
encodeStrLBS :: String -> LZ.ByteString
encodeStrLBS = LZ.pack . SU.encode
decodeStr :: ByteString -> String
decodeStr = SU.decode . unpack
decodeStrLBS :: LZ.ByteString -> String
decodeStrLBS = SU.decode . LZ.unpack
ord8 :: Char -> Word8
ord8 = fromIntegral . ord
isMuNothing MuNothing = True
isMuNothing _ = False
htmlEscape :: LZ.ByteString -> LZ.ByteString
htmlEscape str = LZ.unpack str ~> proc ~> LZ.pack
where
proc :: [Word8] -> [Word8]
proc (h:t)
| h == ord8 '&' = stp "&" t
| h == ord8 '\\'= stp "\" t
| h == ord8 '"' = stp """ t
| h == ord8 '\''= stp "'" t
| h == ord8 '<' = stp "<" t
| h == ord8 '>' = stp ">" t
| otherwise = h : (proc t)
proc [] = []
stp a t = (map ord8 a) ++ (proc t)
emptyEscape :: LZ.ByteString -> LZ.ByteString
emptyEscape = id
defaultConfig :: MuConfig
defaultConfig = MuConfig {
muEscapeFunc = htmlEscape,
muTemplateFileDir = Nothing,
muTemplateFileExt = Nothing
}
defOTag = encodeStr "{{"
defCTag = encodeStr "}}"
unquoteCTag = encodeStr "}}}"
findBlock ::
ByteString
-> ByteString
-> ByteString
-> Maybe (ByteString, Word8, ByteString, ByteString)
findBlock str otag ctag = do
guard (length fnd > (length otag))
Just (pre, symb, inTag, afterClose)
where
(pre, fnd) = breakSubstring otag str
symb = index fnd (length otag)
(inTag, afterClose)
| symb == ord8 '{' && ctag == defCTag =
breakSubstring unquoteCTag fnd ~> \(a,b) ->
(drop (length otag) a, drop 3 b)
| otherwise = breakSubstring ctag fnd ~> \(a,b) ->
(drop (length otag) a, drop (length ctag) b)
toLBS :: ByteString -> LZ.ByteString
toLBS v = LZ.fromChunks [v]
readVar [] _ = LZ.empty
readVar (context:parentCtx) name =
case context name of
MuVariable a -> toLByteString a
MuBool a -> show a ~> encodeStr ~> toLBS
MuNothing -> readVar parentCtx name
_ -> LZ.empty
findCloseSection ::
ByteString
-> ByteString
-> ByteString
-> ByteString
-> Maybe (ByteString, ByteString)
findCloseSection str name otag ctag = do
guard (length after > 0)
Just (before, drop (length close) after)
where
close = foldl1 append [otag, encodeStr "/", name, ctag]
(before, after) = breakSubstring close str
trimCharsTest :: Word8 -> Bool
trimCharsTest = (`elem` (encodeStr " \t"))
trimAll :: ByteString -> ByteString
trimAll str = span trimCharsTest str ~> snd ~> spanEnd trimCharsTest ~> fst
addRes :: MonadIO m => LZ.ByteString -> ReaderT (IORef BSB.Builder) m ()
addRes str = do
rf <- ask
b <- readIORef rf ~> liftIO
let l = mappend b (BSB.fromLazyByteString str)
writeIORef rf l ~> liftIO
return ()
addResBS :: MonadIO m => ByteString -> ReaderT (IORef BSB.Builder) m ()
addResBS str = toLBS str ~> addRes
addResLZ :: MonadIO m => LZ.ByteString -> ReaderT (IORef BSB.Builder) m ()
addResLZ = addRes
processBlock :: MonadIO m =>
ByteString
-> [ByteString -> MuType m]
-> ByteString
-> ByteString
-> MuConfig
-> ReaderT (IORef BSB.Builder) m ()
processBlock str contexts otag ctag conf = do
case findBlock str otag ctag of
Just (pre, symb, inTag, afterClose) -> do
addResBS pre
renderBlock contexts symb inTag afterClose
otag ctag conf
Nothing -> do
addResBS str
return ()
renderBlock:: MonadIO m =>
[ByteString -> MuType m]
-> Word8
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> MuConfig
-> ReaderT (IORef BSB.Builder) m ()
renderBlock contexts symb inTag afterClose otag ctag conf
| symb == ord8 '!' = next afterClose
| symb == ord8 '&' || (symb == ord8 '{' && otag == defOTag) = do
readVar contexts (tail inTag ~> trimAll) ~> addResLZ
next afterClose
| symb == ord8 '#' || symb == ord8 '^' =
let normalSection = symb == ord8 '#' in do
case findCloseSection afterClose (tail inTag) otag ctag of
Nothing -> next afterClose
Just (sectionContent', afterSection') ->
let
dropNL str =
if (length str) > 0 && (head str) == ord8 '\n'
then tail str
else str
sectionContent = dropNL sectionContent'
afterSection =
if ord8 '\n' `elem` sectionContent
then dropNL afterSection'
else afterSection'
tlInTag = tail inTag
readContext = map ($ tlInTag) contexts
~> List.find (not . isMuNothing)
in do
case readContext of
Just (MuList []) ->
if normalSection then do next afterSection
else do
processBlock sectionContent
contexts otag ctag conf
next afterSection
Just (MuList b) ->
if normalSection then do
mapM_ (\c -> processBlock sectionContent
(c:contexts) otag ctag conf) b
next afterSection
else do next afterSection
Just (MuBool True) ->
if normalSection then do
processBlock sectionContent
contexts otag ctag conf
next afterSection
else do next afterSection
Just (MuBool False) ->
if normalSection then do next afterSection
else do
processBlock sectionContent
contexts otag ctag conf
next afterSection
Just (MuLambda func) ->
if normalSection then do
func sectionContent ~> toLByteString ~> addResLZ
next afterSection
else do next afterSection
Just (MuLambdaM func) ->
if normalSection then do
res <- lift (func sectionContent)
toLByteString res ~> addResLZ
next afterSection
else do next afterSection
_ -> next afterSection
| symb == ord8 '=' =
let
lenInTag = length inTag
delimitersCommand = take (lenInTag 1) inTag ~> drop 1
getDelimiter = do
guard (lenInTag > 4)
guard ((index inTag $ lenInTag 1) == ord8 '=')
[newOTag,newCTag] <- Just $ split (ord8 ' ')
delimitersCommand
Just (newOTag, newCTag)
in do
case getDelimiter of
Nothing -> next afterClose
Just (newOTag, newCTag) ->
processBlock (trim' afterClose) contexts
newOTag newCTag conf
| symb == ord8 '>' =
let
fileName' = tail inTag ~> trimAll
fileName'' = case muTemplateFileExt conf of
Nothing -> fileName'
Just ext -> fileName' `append` (encodeStr ext)
fileName = decodeStr fileName''
fullFileName = case muTemplateFileDir conf of
Nothing -> fileName
Just path -> combine path fileName
in do
fe <- liftIO $ doesFileExist fullFileName
when fe $ do
cnt <- liftIO $ readFile fullFileName
next cnt
next (trim' afterClose)
| otherwise = do
readVar contexts (trimAll inTag) ~> muEscapeFunc conf ~> addResLZ
next afterClose
where
next t = processBlock t contexts otag ctag conf
trim' content =
dropWhile trimCharsTest content
~> \t -> if (length t > 0 && head t == ord8 '\n')
then tail t else content
hastacheStr :: (MonadIO m) =>
MuConfig
-> ByteString
-> MuContext m
-> m LZ.ByteString
hastacheStr conf str context =
hastacheStrBuilder conf str context >>= return . BSB.toLazyByteString
hastacheFile :: (MonadIO m) =>
MuConfig
-> FilePath
-> MuContext m
-> m LZ.ByteString
hastacheFile conf file_name context =
hastacheFileBuilder conf file_name context >>= return . BSB.toLazyByteString
hastacheStrBuilder :: (MonadIO m) =>
MuConfig
-> ByteString
-> MuContext m
-> m BSB.Builder
hastacheStrBuilder conf str context = do
rf <- newIORef mempty ~> liftIO
runReaderT (processBlock str [context] defOTag defCTag conf) rf
readIORef rf ~> liftIO
hastacheFileBuilder :: (MonadIO m) =>
MuConfig
-> FilePath
-> MuContext m
-> m BSB.Builder
hastacheFileBuilder conf file_name context = do
str <- readFile file_name ~> liftIO
hastacheStrBuilder conf str context