packages feed

hpaco-lib (empty) → 0.11.0.6

raw patch · 20 files changed

+2237/−0 lines, 20 filesdep +basedep +bytestringdep +containerssetup-changed

Dependencies added: base, bytestring, containers, file-embed, filepath, mtl, parsec, safe, split, strict, transformers

Files

+ Data/Variant.hs view
@@ -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 _ = "<<function>>"++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
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Text/HPaco/AST.hs view
@@ -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
+ Text/HPaco/AST/AST.hs view
@@ -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)
+ Text/HPaco/AST/Expression.hs view
@@ -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)
+ Text/HPaco/AST/Identifier.hs view
@@ -0,0 +1,3 @@+module Text.HPaco.AST.Identifier where++type Identifier = String
+ Text/HPaco/AST/Statement.hs view
@@ -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)
+ Text/HPaco/Optimizer.hs view
@@ -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
+ Text/HPaco/Reader.hs view
@@ -0,0 +1,7 @@+module Text.HPaco.Reader (Reader)+where++import Text.HPaco.AST (AST)++type SourceName = String+type Reader = SourceName -> String -> IO AST
+ Text/HPaco/Readers/Paco.hs view
@@ -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
+ Text/HPaco/Writer.hs view
@@ -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
+ Text/HPaco/Writers/Internal/WrapMode.hs view
@@ -0,0 +1,6 @@+module Text.HPaco.Writers.Internal.WrapMode+            ( WrapMode (..)+            )+where++data WrapMode = WrapNone | WrapFunction | WrapClass
+ Text/HPaco/Writers/Javascript.hs view
@@ -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
+ Text/HPaco/Writers/PHP.hs view
@@ -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 "<?php" >> 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
+ Text/HPaco/Writers/Run.hs view
@@ -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
+ Text/HPaco/Writers/Run/Encode.hs view
@@ -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+                                    [ ('<', "&lt;")+                                    , ('>', "&gt;")+                                    , ('&', "&amp;")+                                    , ('"', "&quot;")+                                    , ('\'', "&apos;")+                                    ]++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
+ hpaco-lib.cabal view
@@ -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.*
+ snippets/js/preamble.js view
@@ -0,0 +1,34 @@+	var _htmlencode = function(str){+		return String(str)+			.replace(/&/g, '&amp;')+			.replace(/"/g, '&quot;')+			.replace(/'/g, '&#39;')+			.replace(/</g, '&lt;')+			.replace(/>/g, '&gt;');+	};+	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;
+ snippets/php/preamble.php view
@@ -0,0 +1,81 @@+<?php+if (!class_exists('_S', false)) {+	class _S {+		public $t;+		public $p;+		public function __construct($t, $p) { $this->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 '<<function>>'; }+	}+}+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;+	}+}