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
writeDefs $ astDefs ast
writeStatement $ astRootStatement ast
writeFooter
getOutputMode :: PWS OutputMode
getOutputMode = gets pwsOutputMode
unsafeSetOutputMode :: OutputMode -> PWS ()
unsafeSetOutputMode m = do
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 = 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 '_'
writePreamble :: PWS ()
writePreamble = do
let src = BS8.unpack $(embedFile "snippets/php/preamble.php")
unsafeSetOutputMode PHP
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
writeLn $ "function " ++ funcName ++ "($context) {"
pushIndent
WrapClass -> do
let className =
if null templateName
then "Template"
else "Template_" ++ templateName
writeLn $ "class " ++ className ++ " {"
pushIndent
writeLn $ "public function __invoke($context) {"
pushIndent
otherwise -> return ()
pushScope
vid <- defineVariable "."
writeLn "if (isset($context)) {"
withIndent $ do
writeIndent
write "$"
write $ toVarname vid
write " = $context;"
endl
writeLn "}"
writeLn "else {"
withIndent $ do
writeIndent
write "$"
write $ toVarname vid
write " = array();"
endl
writeLn "}"
writeLn "$_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 " = '"
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 "eval("
when (wrapMode == WrapClass) $ write "self::"
write "$_macro_"
write identifier
write ");"
endl
SourcePositionStatement fn ln -> return ()
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
writeIndent
write "$"
write $ toVarname id
write " = "
writeExpression expr
write ";"
endl
writePushScopeVar identifier
writeStatement stmt
writeIndent
write "unset($"
write $ toVarname id
write ");";
endl
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 ";"
endl
writeLn "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 ") {"
endl
withIndent $ do
writePushScopeVar identifier
writeStatement stmt
writePopScope
writeLn "}"
writeIndent
write "unset($"
write $ toVarname id
write ");";
endl
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 "))"
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 "
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 "))"
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]