diff --git a/Data/Variant.hs b/Data/Variant.hs new file mode 100644 --- /dev/null +++ b/Data/Variant.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE FlexibleInstances #-} +module Data.Variant + ( Variant (..) + , flatten + , toInteger + , toDouble + , toBool + , toAList + , (~==) + , (~/=) + , lookup + , elem + , keyExists + , merge + , scopeMerge + , keys + , values + , vmap + , wrapf, wrapfs + , wrapf1, wrapfs1 + , call, callMaybe, callDef + ) +where + +import Prelude hiding (toInteger, lookup, elem) +import Data.List hiding (lookup, elem) +import qualified Data.List as List +import Data.Maybe +import Safe +import Text.Printf + +data Variant = Null + | Integer Integer + | Double Double + | String String + | Bool Bool + | List [Variant] + | AList [(Variant, Variant)] + | Function ([Variant] -> Variant) + deriving (Show, Eq) + +instance Show ([Variant] -> Variant) + where show _ = "<>" + +instance Eq ([Variant] -> Variant) + where (==) a b = False + +flatten :: Variant -> String +flatten (String s) = s +flatten (Integer i) = show i +flatten (Double d) = cullFracPart . printf "%f" $ d +flatten (Bool True) = "1" +flatten (Bool False) = "" +flatten Null = "" +flatten (List xs) = concat . intersperse " " . map flatten $ xs +flatten (AList xs) = flatten . List . map snd $ xs + +cullFracPart :: String -> String +cullFracPart str = reverse $ dropWhile (`List.elem` ['0', '.']) $ reverse str + +toMaybeInteger :: Variant -> Maybe Integer +toMaybeInteger (String s) = maybeRead s +toMaybeInteger (Integer i) = Just i +toMaybeInteger (Double d) = Just $ round d +toMaybeInteger (Bool True) = Just 1 +toMaybeInteger (Bool False) = Just 0 +toMaybeInteger _ = Nothing + +toInteger :: Variant -> Integer +toInteger = fromMaybe 0 . toMaybeInteger + +toMaybeDouble :: Variant -> Maybe Double +toMaybeDouble (String s) = maybeRead s +toMaybeDouble (Integer i) = Just $ fromIntegral i +toMaybeDouble (Double d) = Just d +toMaybeDouble (Bool True) = Just 1 +toMaybeDouble (Bool False) = Just 0 +toMaybeDouble _ = Nothing + +toDouble :: Variant -> Double +toDouble = fromMaybe 0 . toMaybeDouble + +toBool :: Variant -> Bool +toBool (Bool b) = b +toBool (Double d) = d /= 0 +toBool a = toInteger a /= 0 + +toAList :: Variant -> [(Variant, Variant)] +toAList (AList xs) = xs +toAList (List xs) = zip (map Integer [0..]) xs +toAList _ = [] + +instance Num Variant where + (+) = varAdd + (-) = varSub + (*) = varMul + abs = varAbs + signum = varSignum + fromInteger = Integer + +varAdd :: Variant -> Variant -> Variant +varAdd (Double a) b = Double $ a + toDouble b +varAdd a (Double b) = Double $ toDouble a + b +varAdd a b = Integer $ toInteger a + toInteger b + +varSub :: Variant -> Variant -> Variant +varSub (Double a) b = Double $ a - toDouble b +varSub a (Double b) = Double $ toDouble a - b +varSub a b = Integer $ toInteger a - toInteger b + +varMul :: Variant -> Variant -> Variant +varMul (Double a) b = Double $ a * toDouble b +varMul a (Double b) = Double $ toDouble a * b +varMul a b = Integer $ toInteger a * toInteger b + +varAbs :: Variant -> Variant +varAbs (Integer i) = Integer (-i) +varAbs (Double i) = Double (-i) +varAbs b = b + +varSignum :: Variant -> Variant +varSignum (Integer i) = Integer $ signum i +varSignum (Double i) = Double $ signum i +varSignum a = Integer 1 + +maybeRead :: Read a => String -> Maybe a +maybeRead s = + let xs = reads s + in if null xs then Nothing else (Just . fst . head) xs + +(~==) :: Variant -> Variant -> Bool +(~==) a b = flatten a == flatten b + +(~/=) a b = flatten a /= flatten b + +lookup :: Variant -> Variant -> Variant +lookup key (List xs) = + let index = fromIntegral . toInteger $ key + in atDef Null xs index +lookup key (AList xs) = + let mayVal = List.lookup key xs + in fromMaybe Null mayVal +lookup _ _ = Null + +keyExists :: Variant -> Variant -> Bool +keyExists key (List xs) = + let index = fromIntegral . toInteger $ key + in (index < length xs) && (index >= 0) +keyExists key (AList xs) = + key `List.elem` map fst xs +keyExists _ _ = False + +elem :: Variant -> Variant -> Variant +elem key (List xs) = Bool $ List.elem key xs +elem key (AList xs) = Bool $ List.elem key $ map snd xs +elem _ _ = Bool False + +merge :: Variant -> Variant -> Variant +merge a b = + let al = toAList a + bl = toAList b + in AList (al ++ bl) + +-- Scope merge: First operand has precedence over second; if first argument is +-- scalar, then it becomes the new scope, otherwise both scopes are merged, the +-- first one taking precedence. +scopeMerge :: Variant -> Variant -> Variant +scopeMerge a@(AList xs) b = merge a b +scopeMerge a@(List xs) b = merge a b +scopeMerge Null b = b +scopeMerge a b = a + +keys :: Variant -> [Variant] +keys v = map fst $ toAList v + +values :: Variant -> [Variant] +values v = map snd $ toAList v + +vmap :: (Variant -> a) -> Variant -> [a] +vmap f v = map f $ values v + +wrapfs :: (Variant -> [Variant] -> Variant) -> Variant -> Variant +wrapfs f s = Function $ f s + +wrapf :: ([Variant] -> Variant) -> Variant +wrapf = Function + +wrapfs1 :: (Variant -> Variant -> Variant) -> Variant -> Variant +wrapfs1 f s = wrapf (\(a:_) -> f s a) + +wrapf1 :: (Variant -> Variant) -> Variant +wrapf1 f = wrapf (\(a:_) -> f a) + +callMaybe :: Variant -> [Variant] -> Maybe Variant +callMaybe (Function f) args = Just $ f args +callMaybe _ _ = Nothing + +callDef :: Variant -> [Variant] -> Variant -> Variant +callDef f args def = fromMaybe def $ callMaybe f args + +call :: Variant -> [Variant] -> Variant +call f args = callDef f args Null diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Tobias Dammers + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Tobias Dammers nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Text/HPaco/AST.hs b/Text/HPaco/AST.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/AST.hs @@ -0,0 +1,9 @@ +module Text.HPaco.AST ( Expression + , Statement + , AST + ) +where + +import Text.HPaco.AST.AST +import Text.HPaco.AST.Expression +import Text.HPaco.AST.Statement diff --git a/Text/HPaco/AST/AST.hs b/Text/HPaco/AST/AST.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/AST/AST.hs @@ -0,0 +1,10 @@ +module Text.HPaco.AST.AST where + +import Text.HPaco.AST.Statement +import Text.HPaco.AST.Identifier (Identifier) + +data AST = + AST { astRootStatement :: Statement + , astDefs :: [(Identifier,Statement)] + } + deriving (Show) diff --git a/Text/HPaco/AST/Expression.hs b/Text/HPaco/AST/Expression.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/AST/Expression.hs @@ -0,0 +1,43 @@ +module Text.HPaco.AST.Expression +where + +data Expression = StringLiteral String + | BooleanLiteral Bool + | IntLiteral Integer + | FloatLiteral Double + | ListExpression [Expression] + | AListExpression [(Expression,Expression)] + | VariableReference String + | EscapeExpression EscapeMode Expression + | BinaryExpression BinaryOperator Expression Expression + | UnaryExpression UnaryOperator Expression + | FunctionCallExpression Expression [Expression] + deriving (Show, Eq) + +data EscapeMode = EscapeHTML + | EscapeURL + deriving (Show, Eq) + +data UnaryOperator = OpNot + deriving (Show, Eq) + +data BinaryOperator = OpEquals + | OpNotEquals + | OpLooseEquals + | OpLooseNotEquals + | OpGreater + | OpLess + | OpNotGreater + | OpNotLess + | OpPlus + | OpMinus + | OpMul + | OpDiv + | OpMod + | OpMember + | OpBooleanAnd + | OpBooleanOr + | OpBooleanXor + | OpInList + | Flipped BinaryOperator + deriving (Show, Eq) diff --git a/Text/HPaco/AST/Identifier.hs b/Text/HPaco/AST/Identifier.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/AST/Identifier.hs @@ -0,0 +1,3 @@ +module Text.HPaco.AST.Identifier where + +type Identifier = String diff --git a/Text/HPaco/AST/Statement.hs b/Text/HPaco/AST/Statement.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/AST/Statement.hs @@ -0,0 +1,14 @@ +module Text.HPaco.AST.Statement where + +import Text.HPaco.AST.Expression (Expression) +import Text.HPaco.AST.Identifier (Identifier) + +data Statement = NullStatement + | StatementSequence [Statement] + | PrintStatement Expression + | IfStatement Expression Statement Statement + | LetStatement Identifier Expression Statement + | ForStatement Identifier Expression Statement + | CallStatement Identifier + | SwitchStatement Expression [(Expression, Statement)] + deriving (Show, Eq) diff --git a/Text/HPaco/Optimizer.hs b/Text/HPaco/Optimizer.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/Optimizer.hs @@ -0,0 +1,101 @@ +module Text.HPaco.Optimizer + ( optimize + ) +where + +import Text.HPaco.AST.AST +import Text.HPaco.AST.Expression +import Text.HPaco.AST.Statement +import qualified Text.HPaco.Writers.Run as Run +import Data.Variant +import Control.Monad.State +import System.IO.Unsafe (unsafePerformIO) + +optimize :: AST -> AST +optimize ast = ast + { astRootStatement = optimizeStatement . astRootStatement $ ast + , astDefs = map (\(i, s) -> (i, optimizeStatement s)) . astDefs $ ast + } + +optimizeStatement :: Statement -> Statement + +-- Reduce constants +optimizeStatement (PrintStatement (IntLiteral i)) = PrintStatement . StringLiteral . show $ i +optimizeStatement (PrintStatement (FloatLiteral i)) = PrintStatement . StringLiteral . show $ i +optimizeStatement (PrintStatement (StringLiteral [])) = NullStatement +optimizeStatement (PrintStatement e) = + let e' = optimizeExpression e + in if e == e' + then PrintStatement e + else optimizeStatement $ PrintStatement e' + +optimizeStatement (StatementSequence xs) = + let xs' = filter (/= NullStatement) (map optimizeStatement xs) + in case xs' of + -- flatten nested statement sequences + (StatementSequence ss):rem -> optimizeStatement . StatementSequence $ ss ++ rem + -- combine print statements + (PrintStatement (StringLiteral lhs)):(PrintStatement (StringLiteral rhs)):rem -> + optimizeStatement . StatementSequence $ + (PrintStatement $ StringLiteral (lhs ++ rhs)):rem + -- remove empty statement sequences + [] -> NullStatement + otherwise -> StatementSequence xs' +optimizeStatement (IfStatement cond true false) = + let true' = optimizeStatement true + false' = optimizeStatement false + cond' = optimizeExpression cond + in case cond' of + BooleanLiteral True -> true' + BooleanLiteral False -> false' + otherwise -> IfStatement cond' true' false' + +optimizeStatement (LetStatement id e stmt) = + let e' = optimizeExpression e + stmt' = optimizeStatement stmt + in LetStatement id e' stmt' + +optimizeStatement (ForStatement id e stmt) = + let e' = optimizeExpression e + stmt' = optimizeStatement stmt + in ForStatement id e' stmt' + +optimizeStatement (SwitchStatement e branches) = + let e' = optimizeExpression e + branches' = map (\(k,v) -> (optimizeExpression k, optimizeStatement v)) branches + in SwitchStatement e' branches' + +optimizeStatement s = s + + +optimizeExpression :: Expression -> Expression +optimizeExpression e = + if isConst e + then evaluateConstExpression e + else e + +isConst :: Expression -> Bool +isConst (StringLiteral _) = True +isConst (IntLiteral _) = True +isConst (FloatLiteral _) = True +isConst (BooleanLiteral _) = True +isConst (ListExpression xs) = all isConst xs +isConst (AListExpression xs) = all (\(k,v) -> isConst k && isConst v) xs +isConst (EscapeExpression _ e) = isConst e +isConst (UnaryExpression _ e) = isConst e +isConst (BinaryExpression _ a b) = isConst a && isConst b +isConst e = False + +evaluateConstExpression :: Expression -> Expression +evaluateConstExpression e = + let rs = Run.RunState { Run.rsScope = Null, Run.rsAST = AST { astDefs = [], astRootStatement = NullStatement }, Run.rsOptions = Run.defaultOptions } + v = unsafePerformIO $ evalStateT (Run.runExpression e) rs + in fromVariant v + +fromVariant :: Variant -> Expression +fromVariant (String s) = StringLiteral s +fromVariant (Integer i) = IntLiteral i +fromVariant (Double d) = FloatLiteral d +fromVariant (Bool b) = BooleanLiteral b +fromVariant (List xs) = ListExpression $ map fromVariant xs +fromVariant (AList xs) = AListExpression $ map (\(k,v) -> (fromVariant k, fromVariant v)) xs diff --git a/Text/HPaco/Reader.hs b/Text/HPaco/Reader.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/Reader.hs @@ -0,0 +1,7 @@ +module Text.HPaco.Reader (Reader) +where + +import Text.HPaco.AST (AST) + +type SourceName = String +type Reader = SourceName -> String -> IO AST diff --git a/Text/HPaco/Readers/Paco.hs b/Text/HPaco/Readers/Paco.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/Readers/Paco.hs @@ -0,0 +1,523 @@ +{-#LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +module Text.HPaco.Readers.Paco + ( readPaco + ) +where + +import Control.Monad +import Control.Monad.IO.Class +import Text.HPaco.Reader +import Text.HPaco.AST.AST +import Text.HPaco.AST.Statement +import Text.HPaco.AST.Expression +import Text.Parsec.Prim +import Text.Parsec.Char +import Text.Parsec.Combinator +import Text.Parsec.Pos (SourcePos, sourceLine, sourceColumn) +import Text.Parsec.String hiding (Parser) +import Text.Parsec.Error (ParseError) +import Control.Exception (throw, Exception) +import Data.Typeable +import System.IO (withFile, IOMode (ReadMode)) +import System.IO.Strict +import System.FilePath + +instance Exception ParseError +deriving instance Typeable ParseError + +data PacoState = PacoState + { psBasePath :: FilePath + , psDefs :: [(String, Statement)] + , psIncludeExtension :: Maybe String + } + +type Parser a = ParsecT String PacoState IO a + +defaultPacoState :: PacoState +defaultPacoState = PacoState + { psBasePath = "" + , psDefs = [] + , psIncludeExtension = Nothing + } + +readPaco :: Reader +readPaco filename = + let pstate = defaultPacoState + { psBasePath = takeDirectory filename + , psIncludeExtension = renull $ takeExtension filename + } + in readPacoWithState pstate filename + where renull "" = Nothing + renull x = Just x + +readPacoWithState :: PacoState -> Reader +readPacoWithState pstate filename src = do + result <- runParserT document pstate filename src + either + throw + return + result + +document :: Parser AST +document = do + stmts <- many statement + eof + pstate <- getState + return $ AST + { astRootStatement = StatementSequence stmts + , astDefs = psDefs pstate + } + +-- Statement parsers + +statement :: Parser Statement +statement = try ifStatement + <|> try withStatement + <|> try switchStatement + <|> try forStatement + <|> try defStatement + <|> try callStatement + <|> try commentStatement + <|> try includeStatement + <|> try interpolateStatement + <|> try newlineStatement + <|> try escapeSequenceStatement + <|> rawTextStatement + +commentStatement :: Parser Statement +commentStatement = do + string "{%--" + manyTill + (try (discard commentStatement) <|> discard anyChar) + (try $ string "--%}") + return NullStatement + +includeStatement :: Parser Statement +includeStatement = do + (basename, innerContext) <- complexTag "include" inner + dirname <- psBasePath `liftM` getState + extension <- psIncludeExtension `liftM` getState + let fn0 = joinPath [ dirname, basename ] + let fn = maybe fn0 (fillExtension fn0) extension + src <- liftIO $ withFile fn ReadMode hGetContents + subAst <- liftIO $ readPaco fn src + let stmt = astRootStatement subAst + return $ maybe stmt (\(ident, expr) -> LetStatement ident expr stmt) innerContext + where + path :: Parser String + path = many1 $ try $ noneOf " \t\r\n%" + + inner :: Parser (String, Maybe (String, Expression)) + inner = do + basename <- path + ss_ + innerContext <- optionMaybe $ try (ss_ >> string "with" >> ss_ >> letPair) + return (basename, innerContext) + +interpolateStatement :: Parser Statement +interpolateStatement = do + char '{' + em <- option (Just EscapeHTML) escapeMode + ss_ + expr <- expression + ss_ + char '}' + let expr' = maybe + expr + (\m -> EscapeExpression m expr) + em + return $ PrintStatement $ expr' + +rawTextStatement :: Parser Statement +rawTextStatement = do + chrs <- many1 $ noneOf "{\\\n" + return $ PrintStatement $ StringLiteral chrs + +newlineStatement :: Parser Statement +newlineStatement = do + char '\n' + ss_ + return $ PrintStatement $ StringLiteral "\n" + +escapeSequenceStatement :: Parser Statement +escapeSequenceStatement = do + char '\\' + c <- anyChar + case c of + '\n' -> return NullStatement + otherwise -> return $ PrintStatement $ StringLiteral [ '\\', c ] + +ifStatement :: Parser Statement +ifStatement = do + cond <- complexTag "if" expression + trueStmts <- many statement + let trueBranch = StatementSequence trueStmts + falseBranch <- option NullStatement $ try elseBranch + simpleTag "endif" + return $ IfStatement cond trueBranch falseBranch + where elseBranch = + do + simpleTag "else" + stmts <- many statement + return . StatementSequence $ stmts + +withStatement :: Parser Statement +withStatement = withOrForStatement LetStatement "with" + +forStatement :: Parser Statement +forStatement = withOrForStatement ForStatement "for" + +withOrForStatement :: (String -> Expression -> Statement -> Statement) -> String -> Parser Statement +withOrForStatement ctor keyword = do + (ident, expr) <- complexTag keyword letPair + stmts <- many $ try statement + simpleTag $ "end" ++ keyword + return $ ctor ident expr $ StatementSequence stmts + +letPair :: Parser (String, Expression) +letPair = do + expr <- expression + ss_ + ident <- option "." $ try $ char ':' >> ss_ >> identifier + ss_ + return (ident, expr) + +switchStatement :: Parser Statement +switchStatement = do + masterExpr <- complexTag "switch" expression + ss_ + branches <- many switchBranch + ss_ + simpleTag "endswitch" + return $ SwitchStatement masterExpr branches + where switchBranch = do + ss_ + switchExpr <- complexTag "case" expression + stmts <- many statement + simpleTag "endcase" + ss_ + return (switchExpr, StatementSequence stmts) + +defStatement :: Parser Statement +defStatement = do + name <- complexTag "def" identifier + body <- many statement + simpleTag "enddef" + addDef name $ StatementSequence body + return NullStatement + +callStatement :: Parser Statement +callStatement = do + name <- complexTag "call" identifier + optional $ char '\n' + return $ CallStatement name + +simpleTag tag = complexTag tag (return ()) +complexTag tag inner = + let go = do + string "{%" + ss_ + string tag + ss_ + i <- inner + ss_ + string "%}" + return i + standalone = do + assertStartOfLine + ss_ + v <- go + char '\n' + return v + + in try standalone <|> try go + + +-- Expression parsers + +expression = booleanExpression + +booleanExpression = + binaryExpression + [("&&", OpBooleanAnd), + ("||", OpBooleanOr), + ("^^", OpBooleanXor)] + setOperationExpression + +setOperationExpression = + binaryExpression + [("in", OpInList), + ("contains", Flipped OpInList)] + comparativeExpression + +comparativeExpression = + binaryExpression + [("==", OpEquals), + ("!==", OpNotEquals), + ("=", OpLooseEquals), + ("!=", OpLooseNotEquals), + (">=", OpNotLess), + (">", OpGreater), + ("<=", OpNotGreater), + ("<", OpLess)] + additiveExpression + +additiveExpression = + binaryExpression + [("+", OpPlus), ("-", OpMinus)] + multiplicativeExpression + +multiplicativeExpression = + binaryExpression + [("*", OpMul), ("/", OpDiv), ("%", OpMod)] + (try traditionalFunctionCallExpression <|> postfixExpression) + +binaryExpression :: [(String, BinaryOperator)] -> (Parser Expression) -> Parser Expression +binaryExpression opMap innerParser = do + let rem :: Parser (BinaryOperator, Expression) + rem = do + ss_ + opStr <- foldl1 (<|>) $ map (try . string . fst) opMap + ss_ + let Just op = lookup opStr opMap + e <- innerParser + return (op, e) + left <- innerParser + right <- many $ try rem + return $ foldl combine left right + where + combine :: Expression -> (BinaryOperator, Expression) -> Expression + combine lhs (op, rhs) = BinaryExpression op lhs rhs + +traditionalFunctionCallExpression = do + char '$' + args <- manySepBy (try expression) ss_ + return $ FunctionCallExpression (head args) (tail args) + +postfixExpression = do + left <- (try prefixExpression <|> simpleExpression) + postfixes <- many postfix + return $ foldl combine left postfixes + where + combine :: Expression -> (Expression -> Expression) -> Expression + combine l f = f l + +prefixExpression = do + ss_ + operator <- unaryOperator + ss_ + expr <- (try prefixExpression <|> simpleExpression) + return $ UnaryExpression operator expr + +unaryOperator = do + let opMap = [("not", OpNot)] + opStr <- foldl1 (<|>) $ map (try . string . fst) opMap + let Just op = lookup opStr opMap + return op + +postfix = try memberAccessPostfix + <|> try indexPostfix + <|> try functionCallPostfix + +memberAccessPostfix :: Parser (Expression -> Expression) +memberAccessPostfix = do + char '.' + expr <- StringLiteral `liftM` identifier + return $ \l -> BinaryExpression OpMember l expr + +indexPostfix :: Parser (Expression -> Expression) +indexPostfix = do + ss_ + char '[' + e <- expression + char ']' + ss_ + return $ \l -> BinaryExpression OpMember l e + +functionCallPostfix :: Parser (Expression -> Expression) +functionCallPostfix = do + char '(' + args <- manySepBy (try expression) (try $ ss_ >> char ',' >> ss_) + ss_ + char ')' + return $ \l -> FunctionCallExpression l args + +simpleExpression :: Parser Expression +simpleExpression = floatLiteral + <|> intLiteral + <|> stringLiteral + <|> listExpression + <|> alistExpression + <|> varRefExpr + <|> bracedExpression + +bracedExpression :: Parser Expression +bracedExpression = do + char '(' + ss_ + inner <- expression + ss_ + char ')' + return inner + +listExpression :: Parser Expression +listExpression = do + char '[' + ss_ + items <- manySepBy expression (ss_ >> char ',' >> ss_) + ss_ + optional $ char ',' >> ss_ + char ']' + return $ ListExpression items + +alistExpression :: Parser Expression +alistExpression = do + char '{' + ss_ + items <- option [] $ try $ manySepBy elem $ char ',' + ss_ + optional $ char ',' >> ss_ + char '}' + return $ AListExpression items + where + elem :: Parser (Expression, Expression) + elem = do + ss_ + key <- expression + ss_ >> char ':' >> ss_ + value <- expression + ss_ + return (key, value) + +intLiteral :: Parser Expression +intLiteral = do + sign <- option '+' $ oneOf "+-" + str <- many1 digit + let str' = if sign == '-' then sign:str else str + return . IntLiteral . read $ str' + +floatLiteral :: Parser Expression +floatLiteral = do + str <- (try dpd <|> try pd) + return . FloatLiteral . read $ str + where + dpd = do + sign <- option '+' $ oneOf "+-" + intpart <- many1 digit + char '.' + fracpart <- many digit + let str = intpart ++ "." ++ fracpart + return $ if sign == '-' then sign:str else str + pd = do + sign <- option '+' $ oneOf "+-" + char '.' + fracpart <- many1 digit + let str = "0." ++ fracpart + return $ if sign == '-' then sign:str else str + +stringLiteral :: Parser Expression +stringLiteral = do + str <- anyQuotedString + return . StringLiteral $ str + +varRefExpr :: Parser Expression +varRefExpr = do + id <- (string "." <|> identifier) + return $ VariableReference id + +-- Parser state management + +addDef :: String -> Statement -> Parser () +addDef name value = + modifyState (\s -> s { psDefs = ((name, value):psDefs s) }) + +resolveDef :: String -> Parser Statement +resolveDef name = do + defs <- psDefs `liftM` getState + let val = lookup name defs + maybe + (unexpected $ name ++ " is not defined.") + return + val + +-- Auxiliary parsers + +ss :: a -> Parser a +ss a = skipMany space >> return a + +ss_ :: Parser () +ss_ = ss () + +braces :: Parser a -> Parser a +braces inner = do + char '{' + ss_ + v <- inner + ss_ + char '}' + return v + +escapeMode :: Parser (Maybe EscapeMode) +escapeMode = (char '!' >> return Nothing) + <|> (char '@' >> return (Just EscapeURL)) + +identifier :: Parser String +identifier = do + x <- letter <|> char '_' + xs <- many $ letter <|> digit <|> char '_' + return $ x:xs + +anyQuotedString = singleQuotedString <|> doubleQuotedString + +singleQuotedString = quotedString '\'' +doubleQuotedString = quotedString '"' + +quotedString qc = do + char qc + str <- many $ quotedStringChar qc + char qc + return str + +quotedStringChar qc = + try escapedChar + <|> noneOf [qc] + +escapedChar = do + char '\\' + c2 <- anyChar + return $ case c2 of + 'n' -> '\n' + 'r' -> '\r' + 'b' -> '\b' + 't' -> '\t' + otherwise -> c2 + +discard :: Parser a -> Parser () +discard p = p >> return () + +manySepBy :: Parser a -> Parser b -> Parser [a] +manySepBy elem sep = do + h <- try elem + t <- many (try $ sep >> elem) + return $ h:t + +assertStartOfInput :: Parser () +assertStartOfInput = do + pos <- getPosition + if sourceLine pos == 1 && sourceColumn pos == 1 + then return () + else unexpected "start of input" + +assertStartOfLine :: Parser () +assertStartOfLine = do + pos <- getPosition + if sourceColumn pos == 1 + then return () + else unexpected "start of line" + +fillExtension :: FilePath -> String -> FilePath +fillExtension fp ext = + let ext0 = takeExtension fp + in if null ext0 + then replaceExtension fp ext + else fp diff --git a/Text/HPaco/Writer.hs b/Text/HPaco/Writer.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/Writer.hs @@ -0,0 +1,8 @@ +module Text.HPaco.Writer (Writer) where + +import Text.HPaco.AST (AST) + +data WriterError = + WriterError { writerErrorMessage :: String } + deriving (Show) +type Writer = AST -> String diff --git a/Text/HPaco/Writers/Internal/WrapMode.hs b/Text/HPaco/Writers/Internal/WrapMode.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/Writers/Internal/WrapMode.hs @@ -0,0 +1,6 @@ +module Text.HPaco.Writers.Internal.WrapMode + ( WrapMode (..) + ) +where + +data WrapMode = WrapNone | WrapFunction | WrapClass diff --git a/Text/HPaco/Writers/Javascript.hs b/Text/HPaco/Writers/Javascript.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/Writers/Javascript.hs @@ -0,0 +1,382 @@ +{-#LANGUAGE TemplateHaskell #-} +module Text.HPaco.Writers.Javascript + ( writeJavascript + , WriterOptions (..) + , defaultWriterOptions + , WrapMode (..) + ) +where + +import Control.Monad.RWS +import Data.FileEmbed +import Data.List (intersperse) +import Data.Maybe +import Data.Typeable +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 + , woWrapMode :: WrapMode + , woExposeAllFunctions :: Bool + , woWriteFunc :: String + } + +defaultWriterOptions = + WriterOptions { woPrettyPrint = False + , woIndentStr = "\t" + , woTemplateName = "" + , woWrapMode = WrapNone + , woExposeAllFunctions = False + , woWriteFunc = "_write" + } + +data JavascriptWriterState = + JavascriptWriterState + { jwsIndent :: Int + , jwsAST :: AST + } + +defaultJavascriptWriterState = + JavascriptWriterState + { jwsIndent = 0 + , jwsAST = AST + { astRootStatement = NullStatement + , astDefs = [] + } + } + +type PWS = RWS WriterOptions String JavascriptWriterState + +writeJavascript :: WriterOptions -> Writer +writeJavascript opts ast = + let (s, w) = execRWS (writeAST ast) opts defaultJavascriptWriterState { jwsAST = ast} + in w + +writeAST :: AST -> PWS () +writeAST ast = do + writeHeader + writeStatement $ astRootStatement ast + writeFooter + +write :: String -> PWS () +write = tell + +pushIndent :: PWS () +pushIndent = modify (\s -> s { jwsIndent = jwsIndent s + 1 }) + +popIndent :: PWS () +popIndent = modify (\s -> s { jwsIndent = jwsIndent s - 1 }) + +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 jwsIndent + 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/js/preamble.js") + write src + writeNewline + +writeHeader :: PWS () +writeHeader = do + templateName <- woTemplateName `liftM` ask + wrapMode <- woWrapMode `liftM` ask + + case wrapMode of + WrapFunction -> do + let funcName = + if null templateName + then "runTemplate" + else "runTemplate_" ++ templateName + writeIndentedLn $ "function " ++ funcName ++ "(context) {" + pushIndent + otherwise -> return () + writeIndentedLn "(function(){" + pushIndent + writePreamble + + +writeFooter :: PWS () +writeFooter = do + wrapMode <- woWrapMode `liftM` ask + + popIndent + writeIndentedLn "}).apply(context);" + + case wrapMode of + WrapFunction -> do + popIndent + writeIndentedLn "}" + otherwise -> return () + +writeStatement :: Statement -> PWS () +writeStatement stmt = + case stmt of + StatementSequence ss -> mapM_ writeStatement ss + PrintStatement expr -> do + wfunc <- woWriteFunc `liftM` ask + writeIndent + write $ wfunc ++ "(_f(" + writeExpression expr + write "));" + writeNewline + NullStatement -> return () + IfStatement { } -> writeIf stmt + LetStatement identifier expr stmt -> writeLet identifier expr stmt + ForStatement identifier expr stmt -> writeFor identifier expr stmt + SwitchStatement masterExpr branches -> writeSwitch masterExpr branches + CallStatement identifier -> do + ast <- gets jwsAST + let body = fromMaybe NullStatement $ lookup identifier $ astDefs ast + writeStatement body + +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 + writeWithScope identifier (writeExpression expr) stmt + + +writeFor :: String -> Expression -> Statement -> PWS () +writeFor identifier expr stmt = do + writeIndent + write "_iteree = " + writeExpression expr + write ";" + writeNewline + writeIndentedLn "for (_index in _iteree) {" + withIndent $ writeWithScope identifier (write "_iteree[_index]") stmt + writeIndentedLn "}" + +writeWithScope :: String -> (PWS ()) -> Statement -> PWS () +writeWithScope identifier rhs stmt = do + if identifier == "." + then do + writeIndent + write "_scope = " + rhs + write ";" + writeNewline + else do + writeIndent + write "_scope = {'" + write identifier + write "':" + rhs + write "};" + writeNewline + writeIndentedLn "_scope.prototype = this;" + writeIndentedLn "(function(){" + withIndent $ writeStatement stmt + writeIndentedLn "}).apply(_scope);" + +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 "[" + sequence_ $ + intersperse (write ", ") $ + map writeExpression items + write "]" + + AListExpression items -> do + write "{" + sequence_ $ + intersperse (write ", ") $ + map writeElem items + write "}" + where + writeElem (key, value) = do + writeExpression key + write " : " + writeExpression value + + VariableReference vn -> do + if vn == "." + then write "this" + else do + write "this['" + write vn + write "']" + + EscapeExpression mode e -> do + let escapefunc = + case mode of + EscapeHTML -> "_htmlencode" + EscapeURL -> "encodeURI" + write escapefunc + write "(_f(" + writeExpression e + write "))" + + BinaryExpression (Flipped op) left right -> + writeExpression $ BinaryExpression op right left + + BinaryExpression OpMember left right -> do + writeExpression left + write "[" + writeExpression right + write "]" + + BinaryExpression OpInList left right -> do + write "_in(" + writeExpression left + write ", " + writeExpression right + write ")" + + BinaryExpression OpBooleanXor left right -> do + write "(function(a,b){return (a||b) && !(a&&b);})(" + 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 -> "||" + if o `elem` numericOps + then write "(Number(" + else write "((" + writeExpression left + write ")" + write opstr + if o `elem` numericOps + then write "Number(" + else write "(" + writeExpression right + write "))" + where numericOps = [ + OpPlus, + OpMinus, + OpMul, + OpDiv, + OpMod, + OpGreater, + OpLess, + OpNotGreater, + OpNotLess ] + + UnaryExpression o e -> do + let opstr = case o of + OpNot -> "!" + write "(" + write opstr + write "(" + writeExpression e + write "))" + + FunctionCallExpression (VariableReference "library") (libnameExpr:_) -> do + write "(_loadlib(" + writeExpression libnameExpr + write "))" + + FunctionCallExpression fn args -> do + write "(" + writeExpression fn + write "(" + sequence_ . intersperse (write ",") $ map writeExpression args + write "))" + + +singleQuoteString :: String -> String +singleQuoteString str = + "'" ++ escape str ++ "'" + where + escapeChar '\'' = "\\'" + escapeChar '\n' = "' + \"\\n\" + '" + escapeChar '\t' = "' + \"\\t\" + '" + escapeChar '\r' = "' + \"\\r\" + '" + escapeChar x = [x] + escape = concat . map escapeChar diff --git a/Text/HPaco/Writers/PHP.hs b/Text/HPaco/Writers/PHP.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/Writers/PHP.hs @@ -0,0 +1,500 @@ +{-#LANGUAGE TemplateHaskell #-} +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 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 + +data PHPWriterState = + PHPWriterState { pwsIndent :: Int + , pwsLocalScope :: [M.Map String Integer] + , pwsNextLocalVariableID :: Integer + , pwsAST :: AST + , pwsOutputMode :: OutputMode + } + +defaultPHPWriterState = + PHPWriterState { pwsIndent = 0 + , pwsLocalScope = [] + , pwsNextLocalVariableID = 0 + , pwsAST = AST + { astRootStatement = NullStatement + , astDefs = [] + } + , pwsOutputMode = Html + } + +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 + writeStatement $ astRootStatement ast + writeFooter + +write :: String -> PWS () +write = tell + +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 "> writeNewline + (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) }) + +scopeResolve :: String -> PWS (Maybe Integer) +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 :: Integer -> String +toVarname i = "_lv" ++ show i + +defineVariable :: String -> PWS Integer +defineVariable key = do + vid <- nextVarID + 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 + +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 + writeNewline + +writeHeader :: PWS () +writeHeader = do + templateName <- woTemplateName `liftM` ask + includePreamble <- woIncludePreamble `liftM` ask + wrapMode <- woWrapMode `liftM` ask + + setOutputMode PHP + + when includePreamble writePreamble + + 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 + +writePushScope = do + vid <- resolveVariable "." + writeIndentedLn $ "$_scope = new _S($" ++ vid ++ ", $_scope);" + +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 + -- writeIndent >> write "/* " >> write (show stmt) >> write " */" >> writeNewline + 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 identifier expr stmt -> writeFor identifier expr stmt + SwitchStatement masterExpr branches -> writeSwitch masterExpr branches + CallStatement identifier -> do + ast <- gets pwsAST + let body = fromMaybe NullStatement $ lookup identifier $ astDefs ast + writeStatement body + +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 + writeIndent + write "$_tmp = " + writeExpression expr + write ";" + writeNewline + pushScope + id <- defineVariable identifier + + writeIndent + write "$" + write $ toVarname id + write " = $_tmp;" + writeNewline + + if identifier == "." + then writePushScope + else return () + + writeStatement stmt + + writeIndent + write "unset($" + write $ toVarname id + write ");"; + writeNewline + + popScope + if identifier == "." + then writePopScope + else return () + + +writeFor :: String -> Expression -> Statement -> PWS () +writeFor 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 $" + write $ toVarname id + write ") {" + writeNewline + + withIndent $ do + when (identifier == ".") + writePushScope + writeStatement stmt + when (identifier == ".") + writePushScope + + 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 ++ " : null)") + 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 diff --git a/Text/HPaco/Writers/Run.hs b/Text/HPaco/Writers/Run.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/Writers/Run.hs @@ -0,0 +1,193 @@ +{-#LANGUAGE ScopedTypeVariables #-} +module Text.HPaco.Writers.Run + ( run + , RunState (..) + , RunOptions (..) + , defaultOptions + , runAST + , runStatement + , runExpression + ) +where + +import Prelude hiding (toInteger) +import Data.Variant +import qualified Data.Variant as V +import Data.Maybe +import qualified Data.List as List +import Control.Monad.State +import Safe +import Text.HPaco.Writers.Run.Encode +import Text.HPaco.AST +import Text.HPaco.AST.AST +import Text.HPaco.AST.Statement +import Text.HPaco.AST.Expression + +data RunOptions = RunOptions + { roTemplateName :: String + } + +defaultOptions = RunOptions + { roTemplateName = "unnamed" + } + +data RunState = RunState + { rsScope :: Variant + , rsOptions :: RunOptions + , rsAST :: AST + } + +type Run a = StateT RunState IO a + +run :: RunOptions -> AST -> IO () +run opts ast = do + let st = RunState { rsScope = AList [], rsOptions = opts , rsAST = ast } + execStateT (runAST ast) st + return () + +getVar :: String -> Run Variant +getVar "." = gets rsScope +getVar key = liftM (V.lookup $ String key) (gets rsScope) + +runAST :: AST -> Run () +runAST ast = do + runStatement . astRootStatement $ ast + +-- Statements + +runStatement :: Statement -> Run () +runStatement (PrintStatement e) = do + d <- runExpression e + liftIO . putStr . flatten $ d +runStatement (StatementSequence ss) = mapM_ runStatement ss +runStatement (IfStatement cond true false) = do + b <- liftM toBool $ runExpression cond + runStatement $ if b then true else false +runStatement (LetStatement ident expr stmt) = + runExpression expr >>= \e -> withIdentifiedScope ident e (runStatement stmt) +runStatement (ForStatement ident expr stmt) = do + es <- runExpression expr + sequence_ $ vmap (\e -> withIdentifiedScope ident e (runStatement stmt)) es +runStatement (SwitchStatement expr branches) = do + ev <- runExpression expr + tests <- mapM runExpression $ map fst branches + let f test stmt = if ev ~== test then Just stmt else Nothing + branch = headMay $ catMaybes $ zipWith f tests (map snd branches) + maybe (return ()) runStatement branch +runStatement NullStatement = return () +runStatement (CallStatement identifier) = do + ast <- gets rsAST + let body = fromMaybe NullStatement $ List.lookup identifier $ astDefs ast + runStatement body + +-- Scope helpers + +-- Run with a completely independent scope; do not inherit parent scope +withScope :: Variant -> Run a -> Run a +withScope scope inner = do + oldScope <- gets rsScope + modify (\s -> s { rsScope = scope }) + a <- inner + modify (\s -> s { rsScope = oldScope }) + return a + +-- Run with a merged scope, based on local scope and parent scope. The local +-- scope has precedence over the inherited one. +withInheritingScope :: Variant -> Run a -> Run a +withInheritingScope scope inner = do + oldScope <- gets rsScope + let newScope = V.scopeMerge scope oldScope + withScope newScope inner + +withLocalVar :: Variant -> Variant -> Run a -> Run a +withLocalVar key val inner = + withInheritingScope (AList [(key, val)]) inner + +withIdentifiedScope :: String -> Variant -> Run a -> Run a +withIdentifiedScope key val inner = + if key == "." + then withInheritingScope val inner + else withLocalVar (String key) val inner + +-- Expressions + +runExpression :: Expression -> Run Variant +runExpression (StringLiteral str) = return $ String str +runExpression (BooleanLiteral str) = return $ Bool str +runExpression (IntLiteral str) = return $ Integer str +runExpression (FloatLiteral str) = return $ Double str +runExpression (ListExpression items) = List `liftM` mapM runExpression items +runExpression (AListExpression items) = do + let (keys, values) = unzip items + keys' <- mapM runExpression keys + values' <- mapM runExpression values + return . AList $ zip keys' values' +runExpression (EscapeExpression EscapeHTML e) = (String . htmlEncode . flatten) `liftM` runExpression e +runExpression (EscapeExpression EscapeURL e) = (String . urlEncode . flatten) `liftM` runExpression e +runExpression (BinaryExpression op left right) = do + lhs <- runExpression left + rhs <- runExpression right + return $ applyBinaryOperation op lhs rhs +runExpression (UnaryExpression op arg) = do + applyUnaryOperation op `liftM` runExpression arg +runExpression (VariableReference varname) = getVar varname +runExpression (FunctionCallExpression (VariableReference "library") (libnameExpr:_)) = do + libname <- runExpression libnameExpr + loadLibrary $ V.flatten libname +runExpression (FunctionCallExpression fn argExprs) = do + func <- runExpression fn + args <- mapM runExpression argExprs + return $ V.call func args + +loadLibrary :: String -> Run Variant +loadLibrary "std" = + return $ + AList [ ( String "count", wrapf1 (Integer . fromIntegral . List.length . V.toAList) ) + , ( String "join", wrapf (\(sep:lst:_) -> String . List.concat . List.intersperse (V.flatten sep) . map V.flatten . V.values $ lst) ) + ] +loadLibrary other = return Null + +applyBinaryOperation :: BinaryOperator -> Variant -> Variant -> Variant +applyBinaryOperation OpPlus = (+) +applyBinaryOperation OpMinus = (-) +applyBinaryOperation OpMul = (*) +applyBinaryOperation OpDiv = \l -> \r -> + if toDouble r == 0.0 + then Null + else Double $ toDouble l / toDouble r +applyBinaryOperation OpMod = \l -> \r -> + if toInteger r == 0 + then Null + else Integer $ toInteger l `mod` toInteger r +applyBinaryOperation OpEquals = \l -> \r -> + Bool $ l == r +applyBinaryOperation OpNotEquals = \l -> \r -> + Bool $ l /= r +applyBinaryOperation OpLooseEquals = \l -> \r -> + Bool $ l ~== r +applyBinaryOperation OpLooseNotEquals = \l -> \r -> + Bool $ l ~/= r +applyBinaryOperation OpLess = \l -> \r -> + Bool $ toDouble l < toDouble r +applyBinaryOperation OpNotLess = \l -> \r -> + Bool $ toDouble l >= toDouble r +applyBinaryOperation OpGreater = \l -> \r -> + Bool $ toDouble l > toDouble r +applyBinaryOperation OpNotGreater = \l -> \r -> + Bool $ toDouble l <= toDouble r +applyBinaryOperation (Flipped op) = \l -> \r -> + applyBinaryOperation op r l + +applyBinaryOperation OpMember = flip V.lookup +applyBinaryOperation OpInList = V.elem + +applyBinaryOperation OpBooleanAnd = \l -> \r -> + Bool $ toBool l && toBool r +applyBinaryOperation OpBooleanOr = \l -> \r -> + Bool $ toBool l || toBool r +applyBinaryOperation OpBooleanXor = \l -> \r -> + let lb = toBool l + rb = toBool r + in Bool $ (lb || rb) && not (lb && rb) + +applyUnaryOperation OpNot arg = Bool . not . V.toBool $ arg diff --git a/Text/HPaco/Writers/Run/Encode.hs b/Text/HPaco/Writers/Run/Encode.hs new file mode 100644 --- /dev/null +++ b/Text/HPaco/Writers/Run/Encode.hs @@ -0,0 +1,42 @@ +module Text.HPaco.Writers.Run.Encode +where + +import Data.Char +import Data.Maybe +import Data.List.Split +import Numeric + +htmlEncode :: String -> String +htmlEncode = encode mapping + where mapping x = lookup x + [ ('<', "<") + , ('>', ">") + , ('&', "&") + , ('"', """) + , ('\'', "'") + ] + +urlEncode :: String -> String +urlEncode = encode mapping + where mapping x + | (ord x > 127) || (ord x <= 32) = Just $ fixHexStr (flip showHex "" . ord $ x) + | isAlphaNum x = Nothing + | otherwise = Just $ fixHexStr (flip showHex "" . ord $ x) + +encode _ [] = "" +encode mapping (x:xs) = + let mapped = mapping x + xs' = encode mapping xs + in maybe (x:xs') (++xs') mapped + +fixHexStr :: String -> String +fixHexStr str = + if odd $ length str + then fixHexStr $ '0':str + else concat . map ('%':) . splitEvery 2 $ str + +padLeft :: a -> Int -> [a] -> [a] +padLeft p c xs = + if length xs < c + then (take (c - length xs) $ repeat p) ++ xs + else take c xs diff --git a/hpaco-lib.cabal b/hpaco-lib.cabal new file mode 100644 --- /dev/null +++ b/hpaco-lib.cabal @@ -0,0 +1,47 @@ +name: hpaco-lib +version: 0.11.0.6 +synopsis: Modular template compiler library +description: Template compiler library, compiles template code into + PHP or Javascript, or interprets it directly. +homepage: https://bitbucket.org/tdammers/hpaco +license: BSD3 +license-file: LICENSE +author: Tobias Dammers +maintainer: tdammers@gmail.com +-- copyright: +category: Development +build-type: Simple +cabal-version: >=1.8 + +extra-source-files: + snippets/php/*.php + snippets/js/*.js + +library + exposed-modules: Text.HPaco.Optimizer + , Text.HPaco.Readers.Paco + , Text.HPaco.Writers.Javascript + , Text.HPaco.Writers.Run + , Text.HPaco.Writers.PHP + , Text.HPaco.Writers.Internal.WrapMode + , Text.HPaco.Writers.Run.Encode + , Text.HPaco.AST + , Text.HPaco.AST.Statement + , Text.HPaco.AST.Identifier + , Text.HPaco.AST.AST + , Text.HPaco.AST.Expression + , Text.HPaco.Writer + , Text.HPaco.Reader + , Data.Variant + -- other-modules: + build-depends: base == 4.* + , bytestring == 0.9.* + , parsec == 3.* + , mtl == 2.1.* + , containers >= 0.2 && < 0.5 + , transformers == 0.3.* + , strict == 0.3.* + , filepath >= 1.1 && < 1.4 + , split >= 0.1 && < 0.2 + , safe >= 0.3.3 && < 0.4 + , file-embed == 0.0.4.* diff --git a/snippets/js/preamble.js b/snippets/js/preamble.js new file mode 100644 --- /dev/null +++ b/snippets/js/preamble.js @@ -0,0 +1,34 @@ + var _htmlencode = function(str){ + return String(str) + .replace(/&/g, '&') + .replace(/"/g, '"') + .replace(/'/g, ''') + .replace(//g, '>'); + }; + var _f = function(str){ + if (Array.isArray(str)) { + var res = ''; + for (var i = 0; i < str.length; ++i) { if (i > 0) { res += ' '; } res += _f(str[i]); } + return res; + } + return String(str); + }; + var _in = function(a,b) { + if (!Array.isArray(b)){return false;} + for (var i = 0; i < b.length; ++i) { if (a == b[i]) return true; } + return false; + }; + var _loadlib = function (libname) { + switch (libname) { + case 'std': + return { + 'count' : function(a){return a.length;} +, 'join' : function(s,a){return a.join(s);} + }; + default: throw new Exception('No such library: ' + libname); + } + } + var _scope = context; + var _iteree = null; + var _index = null; diff --git a/snippets/php/preamble.php b/snippets/php/preamble.php new file mode 100644 --- /dev/null +++ b/snippets/php/preamble.php @@ -0,0 +1,81 @@ +t = $t; $this->p = $p; } + public function __isset($key) { + return ( + (is_array($this->t) && isset($this->t[$key])) || + (is_object($this->t) && isset($this->t->$key)) || + (is_array($this->p) && isset($this->p[$key])) || + (is_object($this->p) && isset($this->p->$key))); + } + public function __get($key) { + if (is_array($this->t) && isset($this->t[$key])) return $this->t[$key]; + if (is_object($this->t) && isset($this->t->$key)) return $this->t->$key; + if (is_array($this->p) && isset($this->p[$key])) return $this->p[$key]; + if (is_object($this->p) && isset($this->p->$key)) return $this->p->$key; + return null; + } + } +} +if (!class_exists('_LF', false)) { + class _LF { + public $f; + public function __construct($f) { $this->f = $f; } + public function __invoke() { return call_user_func_array($this->f, func_get_args()); } + public function __toString() { return '<>'; } + } +} +if (!class_exists('_LL', false)) { + class _LL { + public function __invoke($libname) { + switch ($libname) { + case 'std': + return array( + 'count' => new _LF('count'), + 'join' => new _LF('implode'), + ); + default: throw new Exception('No such library: ' . $libname); + } + } + } +} +if (!is_callable('_r')) { + function _r($context, $key) { + if ($key === '.') return $context; + if ($key === 'library') return new _LL; + if (is_array($context)) { + if (isset($context[$key])) return $context[$key]; + } + if (is_object($context)) { + if (isset($context->$key)) return $context->$key; + } + return null; + } +} +if (!is_callable('_in')) { + function _in($elem, $list) { + if (is_array($list)) { + return in_array($elem, $list); + } + return false; + } +} +if (!is_callable('_f')) { + function _f($val) { + if (is_array($val)) { + return implode(' ', $val); + } + return (string)$val; + } +} +if (!is_callable('_call')) { + function _call($func, $args) { + if ($func instanceof FunctionPointer || $func instanceof _LL || $func instanceof _LF) { + return call_user_func_array($func, $args); + } + return null; + } +}