module Text.HPaco.Writers.PHP
( writePHP
, WriterOptions (..)
, defaultWriterOptions
, WrapMode (..)
)
where
import Control.Monad.RWS
import Data.FileEmbed
import Data.List (intersperse)
import Data.Maybe
import Data.Typeable
import Data.Char
import Text.HPaco.AST.AST
import Text.HPaco.AST.Expression
import Text.HPaco.AST.Statement
import Text.HPaco.Writer
import Text.HPaco.Writers.Internal.WrapMode
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as M
data WriterOptions =
WriterOptions { woPrettyPrint :: Bool
, woIndentStr :: String
, woTemplateName :: String
, woIncludePreamble :: Bool
, woWrapMode :: WrapMode
, woExposeAllFunctions :: Bool
}
defaultWriterOptions =
WriterOptions { woPrettyPrint = False
, woIndentStr = "\t"
, woTemplateName = ""
, woIncludePreamble = True
, woWrapMode = WrapNone
, woExposeAllFunctions = False
}
data OutputMode = PHP | Html
type ScopeMap = [M.Map String String]
data PHPWriterState =
PHPWriterState { pwsIndent :: Int
, pwsLocalScope :: ScopeMap
, pwsNextLocalVariableID :: Integer
, pwsAST :: AST
, pwsOutputMode :: OutputMode
, pwsEscapeFilter :: String -> String
}
defaultPHPWriterState =
PHPWriterState { pwsIndent = 0
, pwsLocalScope = []
, pwsNextLocalVariableID = 0
, pwsAST = defAST
, pwsOutputMode = Html
, pwsEscapeFilter = id
}
type PWS = RWS WriterOptions String PHPWriterState
writePHP :: WriterOptions -> Writer
writePHP opts ast =
let (s, w) = execRWS (writeAST ast) opts defaultPHPWriterState { pwsAST = ast}
in w
writeAST :: AST -> PWS ()
writeAST ast = do
writeHeader
writeDefs $ astDefs ast
writeStatement $ astRootStatement ast
writeFooter
write :: String -> PWS ()
write str = do
f <- gets pwsEscapeFilter
tell $ f str
withFilter :: (String -> String) -> PWS a -> PWS a
withFilter f ac = do
f0 <- gets pwsEscapeFilter
modify (\s -> s { pwsEscapeFilter = f0 . f })
r <- ac
modify (\s -> s { pwsEscapeFilter = f0 })
return r
getOutputMode :: PWS OutputMode
getOutputMode = gets pwsOutputMode
setOutputMode :: OutputMode -> PWS ()
setOutputMode m = do
m0 <- getOutputMode
modify (\s -> s { pwsOutputMode = m })
case (m0, m) of
(Html, PHP) -> write "<?php "
(PHP, Html) -> write "?>"
otherwise -> return ()
pushIndent :: PWS ()
pushIndent = modify (\s -> s { pwsIndent = pwsIndent s + 1 })
popIndent :: PWS ()
popIndent = modify (\s -> s { pwsIndent = pwsIndent s 1 })
pushScope :: PWS ()
pushScope = modify (\s -> s { pwsLocalScope = M.empty:pwsLocalScope s })
popScope :: PWS ()
popScope = modify (\s -> s { pwsLocalScope = tail (pwsLocalScope s) })
getScope :: PWS ScopeMap
getScope = gets pwsLocalScope
setScope :: ScopeMap -> PWS ()
setScope newScope = modify (\s -> s { pwsLocalScope = newScope })
scopeResolve :: String -> PWS (Maybe String)
scopeResolve key = do
scopeStack <- gets pwsLocalScope
return $ resolve key scopeStack
where
resolve key scopes =
let mr = catMaybes $ map (M.lookup key) scopes
in if null mr then Nothing else (Just . head) mr
resolveVariable :: String -> PWS String
resolveVariable key = do
strid <- scopeResolve key
return $ maybe key toVarname strid
maybeResolveVariable :: String -> PWS (Maybe String)
maybeResolveVariable key = do
strid <- scopeResolve key
return $ maybe Nothing (Just . toVarname) strid
nextVarID :: PWS Integer
nextVarID = do
id <- gets pwsNextLocalVariableID
modify (\s -> s { pwsNextLocalVariableID = 1 + pwsNextLocalVariableID s })
return id
toVarname :: String -> String
toVarname i = "_lv" ++ i
defineVariable :: String -> PWS String
defineVariable key = do
vidInt <- nextVarID
let vid = show vidInt ++ "_" ++ sanitizeIdentifier key
scope <- gets pwsLocalScope >>= \x -> return $ head x
let scope' = M.insert key vid . M.delete key $ scope
modify (\s -> s { pwsLocalScope = scope':tail (pwsLocalScope s) })
return vid
sanitizeIdentifier :: String -> String
sanitizeIdentifier str =
map sanitizeIdentifierChar str
where
sanitizeIdentifierChar c =
if isAlphaNum c
then c
else '_'
withIndent :: PWS a -> PWS a
withIndent a = do
pushIndent
x <- a
popIndent
return x
writeIndent :: PWS ()
writeIndent = do
pretty <- woPrettyPrint `liftM` ask
istr <- woIndentStr `liftM` ask
indent <- gets pwsIndent
if pretty
then write $ concat $ take indent $ repeat istr
else return ()
writeNewline :: PWS ()
writeNewline = do
pretty <- woPrettyPrint `liftM` ask
if pretty
then write "\n"
else write " "
writeIndented :: String -> PWS ()
writeIndented str = writeIndent >> write str
writeIndentedLn :: String -> PWS ()
writeIndentedLn str = writeIndent >> write str >> writeNewline
writePreamble :: PWS ()
writePreamble = do
let src = BS8.unpack $(embedFile "snippets/php/preamble.php")
setOutputMode Html
write src
writeHeader :: PWS ()
writeHeader = do
templateName <- woTemplateName `liftM` ask
includePreamble <- woIncludePreamble `liftM` ask
wrapMode <- woWrapMode `liftM` ask
when includePreamble writePreamble
setOutputMode PHP
case wrapMode of
WrapFunction -> do
let funcName =
if null templateName
then "runTemplate"
else "runTemplate_" ++ templateName
writeIndentedLn $ "function " ++ funcName ++ "($context) {"
pushIndent
WrapClass -> do
let className =
if null templateName
then "Template"
else "Template_" ++ templateName
writeIndentedLn $ "class " ++ className ++ " {"
pushIndent
writeIndentedLn $ "public function __invoke($context) {"
pushIndent
otherwise -> return ()
pushScope
vid <- defineVariable "."
writeIndentedLn "if (isset($context)) {"
withIndent $ do
writeIndent
write "$"
write $ toVarname vid
write " = $context;"
writeNewline
writeIndentedLn "}"
writeIndentedLn "else {"
withIndent $ do
writeIndent
write "$"
write $ toVarname vid
write " = array();"
writeNewline
writeIndentedLn "}"
writeIndentedLn "$_scope = array();"
writePushScope
writeDefs defs = do
mapM_ writeDef defs
withSealedScope inner = do
outerScope <- getScope
setScope []
result <- inner
setScope outerScope
return result
writeDef (ident, stmt) = do
setOutputMode PHP
wrapMode <- woWrapMode `liftM` ask
writeIndent
case wrapMode of
WrapClass -> write "private static $_macro_"
otherwise -> write "$_macro_"
write ident
write " = '"
writeNewline
withFilter evalQuoteString $ withIndent $ writeStatement stmt
setOutputMode PHP
writeIndentedLn "';"
writePushScope = writePushScopeVar "."
writePushScopeVar var = do
vid <- resolveVariable var
let str = if var == "."
then
"$_scope = new _S($" ++ vid ++ ", $_scope);"
else
"$_scope = new _S(array('" ++ var ++ "' => $" ++ vid ++ "), $_scope);"
writeIndentedLn str
writePopScope =
writeIndentedLn "if ($_scope instanceof _S) { $_scope = $_scope->p; } else { $_scope = array(); }"
writeFooter :: PWS ()
writeFooter = do
wrapMode <- woWrapMode `liftM` ask
case wrapMode of
WrapFunction -> do
popIndent
writeIndentedLn "}"
WrapClass -> do
popIndent
writeIndentedLn "}"
popIndent
writeIndentedLn "}"
otherwise -> return ()
writeIndentedStatement :: Statement -> PWS ()
writeIndentedStatement stmt = do
writeStatement stmt
writeStatement :: Statement -> PWS ()
writeStatement stmt = do
case stmt of
StatementSequence ss -> mapM_ writeStatement ss
PrintStatement expr -> do
writeIndent
write "echo "
case expr of
EscapeExpression _ _ -> writeExpression expr
StringLiteral _ -> writeExpression expr
IntLiteral _ -> writeExpression expr
FloatLiteral _ -> writeExpression expr
otherwise -> write "_f(" >> writeExpression expr >> write ")"
write ";"
writeNewline
NullStatement -> return ()
IfStatement { } -> writeIf stmt
LetStatement identifier expr stmt -> writeLet identifier expr stmt
ForStatement iter identifier expr stmt -> writeFor iter identifier expr stmt
SwitchStatement masterExpr branches -> writeSwitch masterExpr branches
CallStatement identifier -> do
wrapMode <- woWrapMode `liftM` ask
writeIndent
write "eval("
when (wrapMode == WrapClass) $ write "self::"
write "$_macro_"
write identifier
write ");"
writeNewline
SourcePositionStatement fn ln -> do
writeIndent
write "/* "
write fn
write ":"
write $ show ln
write " */"
writeNewline
writeIf :: Statement -> PWS ()
writeIf (IfStatement cond true false) = do
writeIndent
write "if ("
writeExpression cond
write ") {"
writeNewline
withIndent $ writeStatement true
writeIndentedLn "}"
if false == NullStatement
then return ()
else do
writeIndentedLn "else {"
withIndent $ writeStatement false
writeIndentedLn "}"
writeLet :: String -> Expression -> Statement -> PWS ()
writeLet identifier expr stmt = do
pushScope
id <- defineVariable identifier
writeIndent
write "$"
write $ toVarname id
write " = "
writeExpression expr
write ";"
writeNewline
writePushScopeVar identifier
writeStatement stmt
writeIndent
write "unset($"
write $ toVarname id
write ");";
writeNewline
popScope
writePopScope
writeFor :: Maybe String -> String -> Expression -> Statement -> PWS ()
writeFor iter identifier expr stmt = do
pushScope
id <- defineVariable identifier
writeIndent
write "$_iteree = "
writeExpression expr
write ";"
writeNewline
writeIndentedLn "if (is_array($_iteree) || ($_iteree instanceof Traversable)) {"
withIndent $ do
writeIndent
write "foreach ($_iteree as $"
case iter of
Just k -> do
kid <- defineVariable k
write $ toVarname kid
write " => $"
otherwise -> return ()
write $ toVarname id
write ") {"
writeNewline
withIndent $ do
writePushScopeVar identifier
writeStatement stmt
writePopScope
writeIndentedLn "}"
writeIndent
write "unset($"
write $ toVarname id
write ");";
writeNewline
writeIndentedLn "}"
popScope
writeSwitch :: Expression -> [(Expression, Statement)] -> PWS ()
writeSwitch masterExpr branches = do
writeIndent
write "switch ("
writeExpression masterExpr
write ") {"
writeNewline
withIndent $
mapM writeSwitchBranch branches
writeIndentedLn "}"
where
writeSwitchBranch :: (Expression, Statement) -> PWS ()
writeSwitchBranch (expr, stmt) = do
writeIndent
write "case "
writeExpression expr
write ":"
writeNewline
withIndent $ do
writeStatement stmt
writeIndentedLn "break;"
writeExpression :: Expression -> PWS ()
writeExpression expr =
case expr of
StringLiteral str -> write $ singleQuoteString str
IntLiteral i -> write $ show i
FloatLiteral i -> write $ show i
BooleanLiteral b -> write $ if b then "TRUE" else "FALSE"
ListExpression items -> do
write "array("
sequence_ $
intersperse (write ", ") $
map writeExpression items
write ")"
AListExpression items -> do
write "array("
sequence_ $
intersperse (write ", ") $
map writeElem items
write ")"
where
writeElem (key, value) = do
writeExpression key
write " => "
writeExpression value
VariableReference vn -> do
vid <- maybeResolveVariable vn
write $ maybe
("_r($_scope, '" ++ vn ++ "')")
(\v -> "(isset($" ++ v ++ ") ? $" ++ v ++ " : _r($_scope, '" ++ vn ++ "'))")
vid
EscapeExpression mode e -> do
let escapefunc =
case mode of
EscapeHTML -> "htmlspecialchars"
EscapeURL -> "rawurlencode"
write escapefunc
write "(_f("
writeExpression e
write "))"
BinaryExpression (Flipped op) left right ->
writeExpression $ BinaryExpression op right left
BinaryExpression OpMember left right -> do
write "_r("
writeExpression left
write ", "
writeExpression right
write ")"
BinaryExpression OpInList left right -> do
write "_in("
writeExpression left
write ", "
writeExpression right
write ")"
BinaryExpression o left right -> do
let opstr = case o of
OpPlus -> "+"
OpMinus -> "-"
OpMul -> "*"
OpDiv -> "/"
OpMod -> "%"
OpEquals -> "==="
OpLooseEquals -> "=="
OpNotEquals -> "!=="
OpLooseNotEquals -> "!="
OpGreater -> ">"
OpLess -> "<"
OpNotGreater -> "<="
OpNotLess -> ">="
OpBooleanAnd -> "&&"
OpBooleanOr -> "||"
OpBooleanXor -> " xor "
write "("
writeExpression left
write opstr
writeExpression right
write ")"
UnaryExpression o e -> do
let opstr = case o of
OpNot -> "!"
write "("
write opstr
write "("
writeExpression e
write "))"
FunctionCallExpression fn args -> do
write "_call("
writeExpression fn
write ", array("
mapM_ (\e -> writeExpression e >> write ", ") args
write "))"
singleQuoteString :: String -> String
singleQuoteString str =
"\"" ++ escape str ++ "\""
where
escapeChar '\"' = "\\\""
escapeChar '\n' = "\\n"
escapeChar '\t' = "\\t"
escapeChar '\r' = "\\r"
escapeChar '$' = "\\$"
escapeChar x = [x]
escape = concat . map escapeChar
evalQuoteString :: String -> String
evalQuoteString =
concat . map escapeChar
where
escapeChar '\'' = "\\\'"
escapeChar x = [x]