module Text.HPaco.Writers.PHP
( writePHP
, defPHPWriterOptions
, 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 Text.HPaco.Writers.Internal.CodeWriter
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as M
data OutputMode = PHP | Html
type ScopeMap = [M.Map String String]
defPHPWriterOptions =
defaultWriterOptions { woWriteFunc = "print" }
data PHPWriterState =
PHPWriterState { pwsIndent :: Int
, pwsLocalScope :: ScopeMap
, pwsNextLocalVariableID :: Integer
, pwsAST :: AST
, pwsOutputMode :: OutputMode
, pwsEscapeFilters :: [String -> String]
}
defaultPHPWriterState =
PHPWriterState { pwsIndent = 0
, pwsLocalScope = []
, pwsNextLocalVariableID = 0
, pwsAST = defAST
, pwsOutputMode = Html
, pwsEscapeFilters = []
}
instance CodeWriterState PHPWriterState where
cwsGetIndent = pwsIndent
cwsSetIndent f s = s { pwsIndent = f }
cwsGetFilters = pwsEscapeFilters
cwsSetFilters f s = s { pwsEscapeFilters = f }
type PWS = RWS WriterOptions String PHPWriterState
writePHP :: WriterOptions -> Writer
writePHP opts ast =
runCodeWriter (writeAST ast) opts defaultPHPWriterState { pwsAST = ast}
writeAST :: AST -> PWS ()
writeAST ast = do
writeHeader ast
writeStatement $ astRootStatement ast
writeFooter
getOutputMode :: PWS OutputMode
getOutputMode = gets pwsOutputMode
unsafeSetOutputMode :: OutputMode -> PWS ()
unsafeSetOutputMode m =
modify (\s -> s { pwsOutputMode = m })
setOutputMode :: OutputMode -> PWS ()
setOutputMode m = do
m0 <- getOutputMode
unsafeSetOutputMode m
case (m0, m) of
(Html, PHP) -> write "<?php "
(PHP, Html) -> write " ?>\n"
otherwise -> return ()
withOutputMode :: OutputMode -> PWS a -> PWS a
withOutputMode m a = do
m0 <- getOutputMode
setOutputMode m
x <- a
setOutputMode m0
return x
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 = mapMaybe (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 '_'
writePreamble :: PWS ()
writePreamble = do
let src = BS8.unpack $(embedFile "snippets/php/preamble.php")
unsafeSetOutputMode PHP
write src
writeHeader :: AST -> PWS ()
writeHeader ast = 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
writeLn $ "function " ++ funcName ++ "($context) {"
withIndent $ writeDefs $ astDefs ast
pushIndent
WrapClass -> do
let className =
if null templateName
then "Template"
else "Template_" ++ templateName
writeLn $ "class " ++ className ++ " {"
writeDefs $ astDefs ast
pushIndent
writeLn $ "public function __invoke($context) {"
pushIndent
otherwise -> writeDefs $ astDefs ast
pushScope
vid <- defineVariable "."
writeLn "if (isset($context)) {"
withIndent $ writeVarAssignment vid $ write "$context"
writeLn "}"
writeLn "else {"
withIndent $ writeVarAssignment vid $ write "array()"
writeLn "}"
writeLn "$_scope = array();"
writePushScope
writeVar vid = do
write "$"
write $ toVarname vid
writeVarAssignment vid rhs = writeAssignment (writeVar vid) rhs
writeAssignment lhs rhs = do
writeIndent
lhs
write " = "
rhs
write ";"
endl
writeDefs defs = do
mapM_ writeDef defs
writeUnsetVar id = do
writeIndent
write "unset($"
write $ toVarname id
write ");";
endl
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 " = '"
endl
withFilter evalQuoteString $ withIndent $ writeStatement stmt
setOutputMode PHP
writeLn "';"
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);"
writeLn str
writePopScope =
writeLn "if ($_scope instanceof _S) { $_scope = $_scope->p; } else { $_scope = array(); }"
writeFooter :: PWS ()
writeFooter = do
wrapMode <- woWrapMode `liftM` ask
case wrapMode of
WrapFunction -> do
popIndent
writeLn "}"
WrapClass -> do
popIndent
writeLn "}"
popIndent
writeLn "}"
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 "print"
withParens $
case expr of
EscapeExpression _ _ -> writeExpression expr
StringLiteral _ -> writeExpression expr
IntLiteral _ -> writeExpression expr
FloatLiteral _ -> writeExpression expr
otherwise -> do
write "_f"
withParens $ writeExpression expr
write ";"
endl
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 "if (isset("
when (wrapMode == WrapClass) $ write "self::"
write "$_macro_"
write identifier
write ")) {"
endl
withIndent $ do
writeIndent
write "eval("
when (wrapMode == WrapClass) $ write "self::"
write "$_macro_"
write identifier
write ");"
endl
writeLn "}"
SourcePositionStatement fn ln -> do
c <- asks woSourcePositionComments
when c $ do
writeIndent
write "/* "
write fn
write ":"
write $ show ln
write " */"
endl
writeIf :: Statement -> PWS ()
writeIf (IfStatement cond true false) = do
writeIndent
write "if ("
writeExpression cond
write ") {"
endl
withIndent $ writeStatement true
writeLn "}"
if false == NullStatement
then return ()
else do
writeLn "else {"
withIndent $ writeStatement false
writeLn "}"
writeLet :: String -> Expression -> Statement -> PWS ()
writeLet identifier expr stmt = do
pushScope
id <- defineVariable identifier
writeVarAssignment id $ writeExpression expr
writePushScopeVar identifier
writeStatement stmt
writeUnsetVar id
popScope
writePopScope
writeFor :: Maybe String -> String -> Expression -> Statement -> PWS ()
writeFor iter identifier expr stmt = do
pushScope
writeAssignment (write "$_iteree") (writeExpression expr)
writeLn "if (is_array($_iteree) || ($_iteree instanceof Traversable)) {"
id <- defineVariable identifier
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 ") {"
endl
withIndent $ do
writePushScopeVar identifier
writeStatement stmt
writePopScope
writeLn "}"
writeUnsetVar id
writeLn "}"
popScope
writeSwitch :: Expression -> [(Expression, Statement)] -> PWS ()
writeSwitch masterExpr branches = do
writeIndent
write "switch ("
writeExpression masterExpr
write ") {"
endl
withIndent $
mapM writeSwitchBranch branches
writeLn "}"
where
writeSwitchBranch :: (Expression, Statement) -> PWS ()
writeSwitchBranch (expr, stmt) = do
writeIndent
write "case "
writeExpression expr
write ":"
endl
withIndent $ do
writeStatement stmt
writeLn "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 "))"
TernaryExpression cond trueBranch falseBranch -> do
write "(("
writeExpression cond
write ") ? ("
writeExpression trueBranch
write ") : ("
writeExpression falseBranch
write "))"
BinaryExpression (Flipped op) left right ->
writeExpression $ BinaryExpression op right left
BinaryExpression OpMember left right -> do
write "_r("
writeExpressionPair left right
write ")"
BinaryExpression OpInList left right -> do
write "_in("
writeExpressionPair left right
write ")"
BinaryExpression OpCoalesce left right -> do
write "(is_null("
writeExpression left
write ") ? ("
writeExpression right
write ") : ("
writeExpression left
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 "
OpConcat -> "."
withParens $ do
writeExpression left
write opstr
writeExpression right
UnaryExpression o e -> do
let opstr = case o of
OpNot -> "!"
withParens $ do
write opstr
withParens $ writeExpression e
FunctionCallExpression fn args -> do
write "_call("
writeExpression fn
write ", array("
mapM_ (\e -> writeExpression e >> write ", ") args
write "))"
writeExpressionPair :: Expression -> Expression -> PWS ()
writeExpressionPair lhs rhs = do
writeExpression lhs
write ","
writeExpression rhs
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]