Permalink
Browse files

Fixes #6; support PHP anonymous functions

Well, I had to kill the module distinction between Expr and Stmt because
now there is a cyclic dependency.
To keep things manageable I split them up instead into Parse and Unparse.
It seems like Haskell compilation time is O(n^2) of the largest module size
or something.  StmtParse is still 800 lines which is too big, but I'm not
sure how to break it up further..

I made a few good simplifications too when I was adding anon functions and
moving stuff.

Tested on wordpress and:
<?php
function &(){} ;
$a = function &($c=4) use ( $b ) {};
  • Loading branch information...
1 parent 61a1b8b commit 9b601901fbe26473d7f9a3f88d128e5a5913a8bf @dancor dancor committed Sep 14, 2012
View
2 src/Lang/Php/Ast.hs
@@ -2,7 +2,6 @@
module Lang.Php.Ast (
module Lang.Php.Ast.Common,
- module Lang.Php.Ast.Expr,
module Lang.Php.Ast.Lex,
module Lang.Php.Ast.Stmt,
Ast
@@ -14,7 +13,6 @@ import Control.Arrow
import Control.Monad
import Data.Char
import Lang.Php.Ast.Common
-import Lang.Php.Ast.Expr
import Lang.Php.Ast.Lex
import Lang.Php.Ast.Stmt
import qualified Data.ByteString as BS
View
12 src/Lang/Php/Ast/ArgList.hs
@@ -7,6 +7,14 @@ import Lang.Php.Ast.Common
import Lang.Php.Ast.Lex
import qualified Data.Intercal as IC
+type ArgList a = Either WS [WSCap a]
+
+argListUnparser :: Unparse a => ArgList a -> String
+argListUnparser x =
+ tokLParen ++
+ either unparse (intercalate tokComma . map unparse) x ++
+ tokRParen
+
-- e.g. ($a, $b, $c) in f($a, $b, $c) or () in f()
argListParser :: Parser (a, WS) -> Parser (Either WS [WSCap a])
argListParser = fmap (map fromRight <$>) .
@@ -25,8 +33,8 @@ mbArgListParser :: Parser (a, WS) -> Parser (Either WS [Either WS (WSCap a)])
mbArgListParser = genArgListParser True False True True
-- e.g. ($a, $b, $c) in isset($a, $b, $c)
-issetListParser :: Parser (a, WS) -> Parser [WSCap a]
-issetListParser = fmap (map fromRight . fromRight) .
+reqArgListParser :: Parser (a, WS) -> Parser [WSCap a]
+reqArgListParser = fmap (map fromRight . fromRight) .
genArgListParser False False False True
-- todo: this can just be separate right?
View
13 src/Lang/Php/Ast/Common.hs
@@ -20,7 +20,7 @@ module Lang.Php.Ast.Common (
module Data.Maybe,
module FUtil,
WS, WS2, WSElem(..), WSCap(..), WSCap2, capify, wsNoNLParser, w2With,
- upToCharsOrEndParser) where
+ upToCharsOrEndParser, wsCapParser, toWsParser) where
import Control.Applicative hiding ((<|>), many, optional, Const)
import Control.Arrow
@@ -118,7 +118,16 @@ capify :: WS -> (a, WS) -> WSCap a
capify a (b, c) = WSCap a b c
instance (Parse (a, WS)) => Parse (WSCap a) where
- parse = liftM2 capify parse parse
+ parse = wsToWsCapParser parse
+
+toWsParser :: Parser a -> Parser (a, WS)
+toWsParser p = liftM2 (,) p parse
+
+wsToWsCapParser :: Parser (a, WS) -> Parser (WSCap a)
+wsToWsCapParser = liftM2 capify parse
+
+wsCapParser :: Parser a -> Parser (WSCap a)
+wsCapParser = wsToWsCapParser . toWsParser
instance Parse a => Parse (a, WS) where
parse = liftM2 (,) parse parse
View
7 src/Lang/Php/Ast/Expr.hs
@@ -1,7 +0,0 @@
-module Lang.Php.Ast.Expr (
- module Lang.Php.Ast.ExprParse,
- module Lang.Php.Ast.ExprTypes
- ) where
-
-import Lang.Php.Ast.ExprParse
-import Lang.Php.Ast.ExprTypes
View
595 src/Lang/Php/Ast/ExprParse.hs
@@ -1,595 +0,0 @@
-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
-module Lang.Php.Ast.ExprParse where
-
-import Control.Monad.Identity
-import Lang.Php.Ast.ArgList
-import Lang.Php.Ast.Common
-import Lang.Php.Ast.ExprTypes
-import Lang.Php.Ast.Lex
-import Text.ParserCombinators.Parsec.Expr
-import qualified Data.Intercal as IC
-
--- Val
-
-instance Unparse Var where
- unparse (Var s indexes) = tokDollar ++ s ++
- concatMap (\ (ws, (isBracket, expr)) -> unparse ws ++
- if isBracket
- then tokLBracket ++ unparse expr ++ tokRBracket
- else tokLBrace ++ unparse expr ++ tokRBrace
- ) indexes
- unparse (VarDyn ws var) = tokDollar ++ unparse ws ++ unparse var
- unparse (VarDynExpr ws expr) = tokDollar ++ unparse ws ++ tokLBrace ++
- unparse expr ++ tokRBrace
-
-instance Unparse Const where
- unparse (Const statics s) = concatMap (\ (s, (ws1, ws2)) -> s ++
- unparse ws1 ++ tokDubColon ++ unparse ws2) statics ++ s
-
-instance Unparse DynConst where
- unparse (DynConst statics var) = concatMap (\ (s, (ws1, ws2)) -> s ++
- unparse ws1 ++ tokDubColon ++ unparse ws2) statics ++ unparse var
-
-instance Unparse LRVal where
- unparse (LRValVar a) = unparse a
- unparse (LRValInd a w e) = unparse a ++ unparse w ++ tokLBracket ++
- unparse e ++ tokRBracket
- unparse (LRValMemb v (ws1, ws2) m) =
- unparse v ++ unparse ws1 ++ tokArrow ++ unparse ws2 ++ unparse m
- unparse (LRValStaMemb v (ws1, ws2) m) =
- unparse v ++ unparse ws1 ++ tokDubColon ++ unparse ws2 ++ unparse m
-
-instance Unparse LOnlyVal where
- unparse (LOnlyValList w args) = tokList ++ unparse w ++ tokLParen ++
- either unparse (intercalate tokComma . map unparse) args ++ tokRParen
- unparse (LOnlyValAppend v (ws1, ws2)) =
- unparse v ++ unparse ws1 ++ tokLBracket ++ unparse ws2 ++ tokRBracket
- unparse (LOnlyValInd v ws expr) =
- unparse v ++ unparse ws ++ tokLBracket ++ unparse expr ++ tokRBracket
- unparse (LOnlyValMemb v (ws1, ws2) m) =
- unparse v ++ unparse ws1 ++ tokArrow ++ unparse ws2 ++ unparse m
-
-instance Unparse ROnlyVal where
- unparse (ROnlyValConst a) = unparse a
- unparse (ROnlyValFunc v ws (Left w)) = unparse v ++ unparse ws ++
- tokLParen ++ unparse w ++ tokRParen
- unparse (ROnlyValFunc v ws (Right args)) = unparse v ++ unparse ws ++
- tokLParen ++ intercalate tokComma (map unparse args) ++ tokRParen
-
-instance Unparse Memb where
- unparse (MembExpr e) = tokLBrace ++ unparse e ++ tokRBrace
- unparse (MembStr s) = s
- unparse (MembVar a) = unparse a
-
-instance Unparse Val where
- unparse (ValLOnlyVal a) = unparse a
- unparse (ValROnlyVal a) = unparse a
- unparse (ValLRVal a) = unparse a
-
-instance Unparse LVal where
- unparse (LValLOnlyVal a) = unparse a
- unparse (LValLRVal a) = unparse a
-
-instance Unparse RVal where
- unparse (RValROnlyVal a) = unparse a
- unparse (RValLRVal a) = unparse a
-
-instance Parse (Var, WS) where
- parse = tokDollarP >> (undyn <|> dyn) where
- undyn = do
- i <- genIdentifierParser
- -- try is here unless we combine processing for [expr] vs []
- (inds, ws) <- IC.breakEnd <$> IC.intercalParser parse (try $
- (tokLBracketP >> (,) True <$> parse <* tokRBracketP) <|>
- (tokLBraceP >> (,) False <$> parse <* tokRBraceP))
- return (Var i inds, ws)
- dyn = do
- ws <- parse
- first (VarDyn ws) <$> parse <|> first (VarDynExpr ws) <$> liftM2 (,)
- (tokLBraceP >> parse <* tokRBraceP) parse
-
-parseABPairsUntilAOrC :: Parser a -> Parser b -> Parser c ->
- Parser ([(a, b)], Either a c)
-parseABPairsUntilAOrC a b c = (,) [] . Right <$> c <|> do
- aR <- a
- (b >>= \ bR -> first ((aR, bR):) <$> parseABPairsUntilAOrC a b c) <|>
- return ([], Left aR)
-
-dynConstOrConstParser :: Parser (Either DynConst Const, WS)
-dynConstOrConstParser = do
- (statics, cOrD) <-
- first (map (\ ((a, b), c) -> (a, (b, c)))) <$>
- parseABPairsUntilAOrC (liftM2 (,) (tokStaticP <|> identifierParser) parse)
- (tokDubColonP >> parse) parse
- return $ case cOrD of
- Left c -> first (Right . Const statics) c
- Right d -> first (Left . DynConst statics) d
-
-exprOrLValParser :: Parser (Either Expr LVal, WS)
-exprOrLValParser = try (first Left <$> parse) <|> first Right <$> parse
-
-instance Parse (Val, WS) where
- parse = listVal <|> otherVal where
- listVal = tokListP >> liftM2 (,)
- (ValLOnlyVal <$> liftM2 LOnlyValList parse (mbArgListParser parse))
- parse
- otherVal = do
- (dOrC, ws) <- dynConstOrConstParser
- valExtend =<< case dOrC of
- Left d -> return (ValLRVal $ LRValVar d, ws)
- Right c -> (first ValROnlyVal <$>) $
- liftM2 (,) (ROnlyValFunc (Right c) ws <$> argListParser exprOrLValParser) parse
- <|> return (ROnlyValConst c, ws)
-
-firstM :: (Monad m) => (a -> m b) -> (a, c) -> m (b, c)
-firstM = runKleisli . first . Kleisli
-
-instance Parse (LVal, WS) where
- parse = firstM f =<< parse where
- f r = case r of
- ValLOnlyVal v -> return $ LValLOnlyVal v
- ValROnlyVal _ -> fail "Expecting an LVal but found an ROnlyVal."
- ValLRVal v -> return $ LValLRVal v
-
-instance Parse (RVal, WS) where
- parse = firstM f =<< parse where
- f r = case r of
- ValLOnlyVal _ -> fail "Expecting an RVal but found an LOnlyVal."
- ValROnlyVal v -> return $ RValROnlyVal v
- ValLRVal v -> return $ RValLRVal v
-
-instance Parse (LRVal, WS) where
- parse = firstM f =<< parse where
- f r = case r of
- ValLOnlyVal _ -> fail "Expecting an LRVal but found an LOnlyVal."
- ValROnlyVal _ -> fail "Expecting an LRVal but found an ROnlyVal."
- ValLRVal v -> return v
-
--- val extending is like this:
--- L --member,index,append--> L
--- R --member--> LR
--- LR --member,index--> LR
--- LR --func--> R
--- LR --append--> L
-valExtend :: (Val, WS) -> Parser (Val, WS)
-valExtend v@(state, ws) = case state of
- ValLOnlyVal a ->
- do
- ws2 <- tokArrowP >> parse
- (memb, wsEnd) <- parse
- valExtend (ValLOnlyVal $ LOnlyValMemb a (ws, ws2) memb, wsEnd)
- <|> valExtendIndApp (LValLOnlyVal a) (ValLOnlyVal . LOnlyValInd a ws) ws
- <|> return v
- ValROnlyVal a -> valExtendMemb (RValROnlyVal a) ws
- <|> do
- ws2 <- tokLBracketP >> parse
- st <- ValLRVal . LRValInd (RValROnlyVal a) ws . capify ws2 <$>
- parse <* tokRBracketP
- valExtend =<< (,) st <$> parse
- <|> return v
- ValLRVal a ->
- do
- r <- liftM2 (,) (ValROnlyVal . ROnlyValFunc (Left a) ws <$>
- argListParser exprOrLValParser) parse
- valExtend r
- <|> valExtendIndApp (LValLRVal a) (ValLRVal . LRValInd (RValLRVal a) ws) ws
- <|> valExtendMemb (RValLRVal a) ws
- <|> return v
-
-valExtendMemb :: RVal -> WS -> Parser (Val, WS)
-valExtendMemb a ws = (tokArrowP >> do
- ws2 <- parse
- (memb, wsEnd) <- parse
- valExtend (ValLRVal $ LRValMemb a (ws, ws2) memb, wsEnd))
- <|> (tokDubColonP >> do
- ws2 <- parse
- (memb, wsEnd) <- parse
- valExtend (ValLRVal $ LRValStaMemb a (ws, ws2) memb, wsEnd))
-
-instance Parse (Memb, WS) where
- parse =
- liftM2 (,) (
- (tokLBraceP >> MembExpr <$> parse <* tokRBraceP) <|>
- MembStr <$> genIdentifierParser) parse <|>
- first MembVar <$> parse
-
-valExtendIndApp :: LVal -> (WSCap Expr -> Val) -> WS -> Parser (Val, WS)
-valExtendIndApp lVal mkVal ws = tokLBracketP >> do
- ws2 <- parse
- st <-
- (tokRBracketP >>
- return (ValLOnlyVal $ LOnlyValAppend lVal (ws, ws2))) <|>
- mkVal . capify ws2 <$> (parse <* tokRBracketP)
- valExtend =<< (,) st <$> parse
-
-varOrStringParser :: Parser (Either Var String, WS)
-varOrStringParser = first Left <$> parse <|>
- liftM2 (,) (Right <$> identifierParser) parse
-
-instance Parse (DynConst, WS) where
- parse = do
- statics <- many . liftM2 (,) identifierParser . liftM2 (,) parse $
- tokDubColonP >> parse
- first (DynConst statics) <$> parse
-
-instance Parse (Const, WS) where
- parse = first (uncurry Const) . rePairLeft . first (map rePairRight) .
- IC.breakEnd <$> IC.intercalParser (liftM2 (,) identifierParser parse)
- (tokDubColonP >> parse)
-
-lRValOrConstParser :: Parser (Either LRVal Const, WS)
-lRValOrConstParser = do
- (v, w) <- parse
- case v of
- ValLRVal a -> return (Left a, w)
- ValROnlyVal (ROnlyValConst a) -> return (Right a, w)
- _ -> fail "Expected LRVal or Const but fould a different Val type."
-
--- Expr
-
-instance Unparse Expr where
- unparse expr = case expr of
- ExprArray w elemsOrW -> tokArray ++ unparse w ++ tokLParen ++
- either unparse f elemsOrW ++ tokRParen where
- f (elems, wEnd) = intercalate tokComma .
- maybe id (flip (++) . (:[]) . unparse) wEnd $ map unparse elems
- ExprAssign o v w e -> unparse v ++ w2With (unparse o ++ tokEquals) w ++
- unparse e
- ExprBackticks a -> a
- ExprBinOp o e1 (w1, w2) e2 -> unparse e1 ++ unparse w1 ++ unparse o ++
- unparse w2 ++ unparse e2
- ExprCast (WSCap w1 t w2) w e -> tokLParen ++ unparse w1 ++ t ++
- unparse w2 ++ tokRParen ++ unparse w ++ unparse e
- ExprEmpty w e -> tokEmpty ++ unparse w ++ tokLParen ++ unparse e ++
- tokRParen
- ExprEval w e -> tokEval ++ unparse w ++ tokLParen ++ unparse e ++
- tokRParen
- ExprExit isExit a -> (if isExit then tokExit else tokDie) ++
- maybe "" (\ (w, x) -> unparse w ++ tokLParen ++
- either unparse unparse x ++ tokRParen) a
- ExprHereDoc a -> unparse a
- ExprInclude a b w e -> unparse a ++ unparse b ++ unparse w ++ unparse e
- ExprIndex a w b ->
- unparse a ++ unparse w ++ tokLBracket ++ unparse b ++ tokRBracket
- ExprInstOf e w t -> unparse e ++ w2With tokInstanceof w ++ unparse t
- ExprIsset w vs -> tokIsset ++ unparse w ++ tokLParen ++
- intercalate tokComma (map unparse vs) ++ tokRParen
- ExprNew w a argsMb -> tokNew ++ unparse w ++ unparse a ++ maybe ""
- (\ (wPre, args) -> unparse wPre ++ tokLParen ++ either unparse
- (intercalate tokComma . map unparse) args ++ tokRParen) argsMb
- ExprNumLit a -> unparse a
- ExprParen a -> tokLParen ++ unparse a ++ tokRParen
- ExprPostOp o e w -> unparse e ++ unparse w ++ unparse o
- ExprPreOp o w e -> unparse o ++ unparse w ++ unparse e
- ExprRef w v -> tokAmp ++ unparse w ++ unparse v
- ExprRVal a -> unparse a
- ExprStrLit a -> unparse a
- ExprTernaryIf a -> unparse a
- ExprXml a -> unparse a
-
-instance Unparse BinOpBy where
- unparse binOp = case binOp of
- BBitAnd -> tokAmp
- BBitOr -> tokBitOr
- BConcat -> tokConcat
- BDiv -> tokDiv
- BMinus -> tokMinus
- BMod -> tokMod
- BMul -> tokMul
- BPlus -> tokPlus
- BShiftL -> tokShiftL
- BShiftR -> tokShiftR
- BXor -> tokXor
-
-instance Unparse BinOp where
- unparse binOp = case binOp of
- BAnd -> tokAnd
- BAndWd -> tokAndWd
- BEQ -> tokEQ
- BGE -> tokGE
- BGT -> tokGT
- BID -> tokID
- BLE -> tokLE
- BLT -> tokLT
- BNE -> tokNE
- BNEOld -> tokNEOld
- BNI -> tokNI
- BOr -> tokOr
- BOrWd -> tokOrWd
- BXorWd -> tokXorWd
- BByable o -> unparse o
-
-instance Unparse PreOp where
- unparse preOp = case preOp of
- PrPrint -> tokPrint
- PrAt -> tokAt
- PrBitNot -> tokBitNot
- PrClone -> tokClone
- PrNegate -> tokMinus
- PrNot -> tokNot
- PrPos -> tokPlus
- PrSuppress -> tokAt
- PrIncr -> tokIncr
- PrDecr -> tokDecr
-
-instance Unparse PostOp where
- unparse postOp = case postOp of
- PoIncr -> tokIncr
- PoDecr -> tokDecr
-
-instance Unparse IncOrReq where
- unparse Inc = tokInclude
- unparse Req = tokRequire
-
-instance Unparse OnceOrNot where
- unparse Once = "_once"
- unparse NotOnce = ""
-
-instance Unparse DubArrowMb where
- unparse (DubArrowMb k v) = maybe "" (\ (e, (w1, w2)) -> unparse e ++
- unparse w1 ++ tokDubArrow ++ unparse w2) k ++ unparse v
-
-instance Unparse TernaryIf where
- unparse (TernaryIf e1 (w1, w2) e2 (w3, w4) e3) = unparse e1 ++ unparse w1 ++
- tokQMark ++ unparse w2 ++ unparse e2 ++ unparse w3 ++ tokColon ++
- unparse w4 ++ unparse e3
-
-instance Unparse Xml where
- unparse (Xml tag attrs content) = tokLT ++ tag ++
- IC.intercalUnparser unparse
- (\ (k, vMb) -> k ++
- maybe "" (\ (w, v) -> w2With tokEquals w ++
- either unparse ((tokLBrace ++) . (++ tokRBrace) . unparse) v) vMb)
- attrs ++
- maybe tokDiv (\ (c, hasExplicitCloseTag) ->
- tokGT ++ concatMap unparse c ++ tokLT ++ tokDiv ++
- if hasExplicitCloseTag then tag else "") content ++
- tokGT
-
-instance Unparse XmlLitOrExpr where
- unparse (XmlLit a) = a
- unparse (XmlExpr a) = tokLBrace ++ unparse a ++ tokRBrace
-
-instance Parse (Expr, WS) where
- parse = buildExpressionParser exprParserTable simpleExprParser
-
-simpleExprParser :: Parser (Expr, WS)
-simpleExprParser = assignOrRValParser
- <|> do
- ws1 <- tokLParenP >> parse
- ambigCastParser ws1 <|> castOrParenParser ws1
- <|> do
- ws1 <- tokNewP >> parse
- (v, ws2) <- parse
- argsWSMb <- optionMaybe $ argListParser parse
- case argsWSMb of
- Just args -> (,) (ExprNew ws1 v $ Just (ws2, args)) <$> parse
- _ -> return (ExprNew ws1 v Nothing, ws2)
- <|> includeParser
- <|> do
- isExit <- return True <$> tokExitP <|> return False <$> tokDieP
- ws1 <- parse
- argMb <- optionMaybe $ exitListParser parse
- case argMb of
- Just arg -> (,) (ExprExit isExit $ Just (ws1, arg)) <$> parse
- _ -> return (ExprExit isExit Nothing, ws1)
- <|> do
- w <- tokAmpP >> parse
- first (ExprRef w . Right) <$> parse <|> do
- (e, wEnd) <- parse
- case e of
- ExprNew _ _ _ -> return (ExprRef w (Left e), wEnd)
- _ -> fail "Expecting a Val or ExprNew."
- <|> liftM2 (,) (
- ExprStrLit <$> parse <|>
- ExprNumLit <$> parse <|>
- ExprHereDoc <$> parse <|>
- (tokArrayP >> liftM2 ExprArray parse (arrListParser parse)) <|>
- funclike1Parser ExprEmpty tokEmptyP <|>
- funclike1Parser ExprEval tokEvalP <|>
- (tokIssetP >> liftM2 ExprIsset parse (issetListParser parse)) <|>
- ExprBackticks <$> backticksParser <|>
- ExprXml <$> parse
- ) parse
-
-ambigCastParser :: WS -> Parser (Expr, WS)
-ambigCastParser ws1 = try $ do
- i <- identsCI ["array", "unset"]
- ws2 <- parse
- ws3 <- tokRParenP >> parse
- first (ExprCast (WSCap ws1 i ws2) ws3) <$> parse
-
-castOrParenParser :: WS -> Parser (Expr, WS)
-castOrParenParser ws1 = do
- iMb <- optionMaybe $ identsCI ["int", "integer", "bool", "boolean",
- "float", "double", "real", "string", "binary", "object"]
- case iMb of
- Just i -> do
- ws2 <- parse
- ws3 <- tokRParenP >> parse
- first (ExprCast (WSCap ws1 i ws2) ws3) <$> parse
- _ -> liftM2 (,) (ExprParen . capify ws1 <$> parse <* tokRParenP) parse
-
-assignOrRValParser :: Parser (Expr, WS)
-assignOrRValParser = do
- (val, w) <- parse
- case val of
- ValLOnlyVal v -> assignCont (LValLOnlyVal v) w
- ValLRVal v -> assignCont (LValLRVal v) w <|>
- return (ExprRVal $ RValLRVal v, w)
- ValROnlyVal v -> return (ExprRVal $ RValROnlyVal v, w)
-
-assignCont :: LVal -> WS -> Parser (Expr, WS)
-assignCont l w1 = do
- o <- (tokEqualsP >> return Nothing) <|> Just <$> (
- (tokPlusByP >> return BPlus) <|>
- (tokMinusByP >> return BMinus) <|>
- (tokMulByP >> return BMul) <|>
- (tokDivByP >> return BDiv) <|>
- (tokConcatByP >> return BConcat) <|>
- (tokModByP >> return BMod) <|>
- (tokBitAndByP >> return BBitAnd) <|>
- (tokBitOrByP >> return BBitOr) <|>
- (tokXorByP >> return BXor) <|>
- (tokShiftLByP >> return BShiftL) <|>
- (tokShiftRByP >> return BShiftR))
- w2 <- parse
- first (ExprAssign o l (w1, w2)) <$> parse
-
-includeParser :: Parser (Expr, WS)
-includeParser = try $ do
- i <- map toLower <$> genIdentifierParser
- f <- if i == tokRequireOnce then return $ ExprInclude Req Once else
- if i == tokIncludeOnce then return $ ExprInclude Inc Once else
- if i == tokRequire then return $ ExprInclude Req NotOnce else
- if i == tokInclude then return $ ExprInclude Inc NotOnce else
- fail "Expecting an include/require expression."
- ws <- parse
- first (f ws) <$> parse
-
-instance Parse (DubArrowMb, WS) where
- parse = do
- (k, ws) <- parse
- vMb <- optionMaybe (tokDubArrowP >> liftM2 (,) parse parse)
- return $ case vMb of
- Just (ws2, (v, ws3)) -> (DubArrowMb (Just (k, (ws, ws2))) v, ws3)
- _ -> (DubArrowMb Nothing k, ws)
-
-funclike1Parser :: (Parse (a, WS)) => (WS -> WSCap a -> b) -> Parser c ->
- Parser b
-funclike1Parser constr tokP = liftM2 constr (tokP >> parse)
- (tokLParenP >> parse <* tokRParenP)
-
-exprParserTable :: [[Oper (Expr, WS)]]
-exprParserTable = [
- [Postfix eptIndex],
- [Prefix eptClone],
- [Prefix eptPreIncr, Prefix eptPreDecr,
- Postfix eptPostIncr, Postfix eptPostDecr],
- [Postfix eptInstOf],
- [Prefix . preRep $ eptNot <|> eptBitNot <|> eptNegate <|> eptPos <|>
- eptSuppress],
- ial [eptMul, eptDiv, eptMod],
- ial [eptPlus, eptMinus, eptConcat],
- ial [eptShiftL, eptShiftR],
- ian [eptLT, eptLE, eptGT, eptGE, eptNEOld],
- ian [eptEQ, eptNE, eptID, eptNI],
- ial [eptBitAnd],
- ial [eptXor],
- ial [eptBitOr],
- [Prefix eptPrint],
- ial [eptAnd],
- ial [eptOr],
- [Postfix eptTernaryIf],
- ial [eptAndWd],
- ial [eptXorWd],
- ial [eptOrWd]]
-
-preRep, postRep :: Parser (a -> a) -> Parser (a -> a)
-preRep p = (p >>= \ f -> (f .) <$> preRep p) <|> return id
-postRep p = (p >>= \ f -> (. f) <$> postRep p) <|> return id
-
-ial, ian :: [Parser (a -> a -> a)] -> [Oper a]
-ial = map $ flip Infix AssocLeft
-ian = map $ flip Infix AssocNone
-
-eptClone = preOp PrClone tokCloneP
-eptPreIncr = preOp PrIncr tokIncrP
-eptPreDecr = preOp PrDecr tokDecrP
-eptPostIncr = postOp PoIncr tokIncrP
-eptPostDecr = postOp PoDecr tokDecrP
-
-preOp :: PreOp -> Parser a -> Parser ((Expr, WS) -> (Expr, WS))
-preOp o p = do
- ws1 <- p >> parse
- return . first $ ExprPreOp o ws1
-
-postOp :: PostOp -> Parser a -> Parser ((Expr, WS) -> (Expr, WS))
-postOp o p = do
- ws2 <- p >> parse
- return $ \ (e, ws1) -> (ExprPostOp o e ws1, ws2)
-
-binOp :: BinOp -> Parser a -> Parser ((Expr, WS) -> (Expr, WS) -> (Expr, WS))
-binOp o p = do
- ws2 <- p >> parse
- return $ \ (e1, ws1) (e2, ws3) -> (ExprBinOp o e1 (ws1, ws2) e2, ws3)
-
-eptBitNot = preOp PrBitNot tokBitNotP
-eptNegate = preOp PrNegate tokMinusP
-eptPos = preOp PrPos tokPlusP
-eptSuppress = preOp PrSuppress tokAtP
-
-eptInstOf = do
- tokInstanceofP
- ws2 <- parse
- (t, ws3) <- lRValOrConstParser
- return $ \ (e, ws1) -> (ExprInstOf e (ws1, ws2) t, ws3)
-
-eptNot = preOp PrNot tokNotP
-
-eptMul = binOp (BByable BMul) tokMulP
-eptDiv = binOp (BByable BDiv) tokDivP
-eptMod = binOp (BByable BMod) tokModP
-eptPlus = binOp (BByable BPlus) tokPlusP
-eptMinus = binOp (BByable BMinus) tokMinusP
-eptConcat = binOp (BByable BConcat) tokConcatP
-eptShiftL = binOp (BByable BShiftL) tokShiftLP
-eptShiftR = binOp (BByable BShiftR) tokShiftRP
-eptLT = binOp BLT tokLTP
-eptLE = binOp BLE tokLEP
-eptGT = binOp BGT tokGTP
-eptGE = binOp BGE tokGEP
-eptNEOld = binOp BNEOld tokNEOldP
-eptEQ = binOp BEQ tokEQP
-eptNE = binOp BNE tokNEP
-eptID = binOp BID tokIDP
-eptNI = binOp BNI tokNIP
-
-eptBitAnd = binOp (BByable BBitAnd) tokAmpP
-eptXor = binOp (BByable BXor) tokXorP
-eptBitOr = binOp (BByable BBitOr) tokBitOrP
-
-eptPrint = preOp PrPrint tokPrintP
-
-eptAnd = binOp BAnd tokAndP
-eptOr = binOp BOr tokOrP
-
-eptTernaryIf :: Parser ((Expr, WS) -> (Expr, WS))
-eptTernaryIf = do
- w2 <- tokQMarkP >> parse
- (e2, w3) <- maybe (Nothing, []) (first Just) <$> parse
- w4 <- tokColonP >> parse
- (e3, w5) <- parse
- return $ \ (e1, w1) ->
- (ExprTernaryIf $ TernaryIf e1 (w1, w2) e2 (w3, w4) e3, w5)
-
-eptAndWd = binOp BAndWd tokAndWdP
-eptXorWd = binOp BXorWd tokXorWdP
-eptOrWd = binOp BOrWd tokOrWdP
-
-eptIndex :: Parser ((Expr, WS) -> (Expr, WS))
-eptIndex = do
- e2 <- tokLBracketP >> parse
- w2 <- tokRBracketP >> parse
- return $ \ (e1, w1) -> (ExprIndex e1 w1 e2, w2)
-
-instance Parse Xml where
- parse = tokLTP >> do
- tag <- many1 . oneOf $
- -- i thought _ wasn't allowed but i guess when marcel's away e will play
- [':', '-', '_'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
- attrs <- IC.intercalParser parse . liftM2 (,) xmlIdentifierParser $
- Just <$> try (liftM2 (,) (liftM2 (,) parse (tokEqualsP >> parse)) $
- (tokLBraceP >> Right <$> parse <* tokRBraceP) <|>
- Left <$> parse) <|>
- return Nothing
- content <- (tokDivP >> tokGTP >> return Nothing) <|>
- Just <$> liftM2 (,)
- (tokGTP >> many (Right <$> try parse <|> Left <$> parse))
- (tokLTP >> tokDivP >> ((string tag >> return True) <|> return False))
- <* tokGTP
- return $ Xml tag attrs content
-
-instance Parse XmlLitOrExpr where
- parse = (tokLBraceP >> XmlExpr <$> parse <* tokRBraceP) <|>
- XmlLit <$> many1 (satisfy (`notElem` "<{"))
View
196 src/Lang/Php/Ast/ExprTypes.hs
@@ -1,196 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE TemplateHaskell #-}
-module Lang.Php.Ast.ExprTypes where
-
-import Text.PrettyPrint.GenericPretty
-
-import Lang.Php.Ast.Common
-import Lang.Php.Ast.Lex
-import qualified Data.Intercal as IC
-
--- Val's are defined to only contain: "$", identifiers, "[Expr]", "[]",
--- "(Exprs)", "${Expr}", "::", "->". The most important consideration is which
--- ones can be assigned to (LVal's) and which ones can be assigned from
--- (RVal's). In PHP, most but not all LVal's are also RVal's.
-
--- Note that this grammar allows "$$a[]->a = 5;" but Zend does not. However,
--- Zend allows "${$a}[]->a = 5;", and it's not clear what is gained by treating
--- $a and ${..} asymmetrically here. PHP also allows "${$a}[0]->a = 5" and
--- "$$a[0]->a = 5;". So we're regarding this as a by-product of the Zend
--- implementation. In particular, we think they simplify their job by slurping
--- all [Expr?]'s onto Var's and only later analyze things with regard to LVal
--- considerations, simply fataling if something is then awry.
---
--- Modeling that nuance is impractical under the clear division of
--- Var's, LVal's, and RVal's that we desire to make the AST nice for
--- refactoring.
-
-data Val = ValLOnlyVal LOnlyVal | ValROnlyVal ROnlyVal | ValLRVal LRVal
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data LVal = LValLOnlyVal LOnlyVal | LValLRVal LRVal
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data RVal = RValROnlyVal ROnlyVal | RValLRVal LRVal
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data Var =
- -- In php, indexing is oddly coupled very tightly with being a non-dyn var.
- Var String [((WS, (Bool, WSCap Expr)))] | -- "$a", "$a[0]", "$a[0][0]"
- VarDyn WS Var | -- "$$a"
- -- note: "$$a[0]()->a" == "${$a[0]}()->a"
- VarDynExpr WS (WSCap Expr) -- "${$a . '_'}"
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data DynConst = DynConst [(String, WS2)] Var -- "a::$a"
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data LRVal =
- LRValVar DynConst |
- LRValInd RVal WS (WSCap Expr) | -- "$a->a[0]"
- LRValMemb RVal WS2 Memb | -- $a->a
- LRValStaMemb RVal WS2 Memb -- $a::a
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data LOnlyVal =
- LOnlyValList WS (Either WS [Either WS (WSCap LVal)]) |
- LOnlyValAppend LVal WS2 | -- "$a[]"
- LOnlyValInd LOnlyVal WS (WSCap Expr) | -- "$a[][0]"
- LOnlyValMemb LOnlyVal WS2 Memb -- "$a[]->a"
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data Const = Const [(String, WS2)] String -- "a::a"
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data ROnlyVal =
- ROnlyValConst Const |
- -- "a()", "$a()"
- ROnlyValFunc (Either LRVal Const) WS (Either WS [WSCap (Either Expr LVal)])
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data Memb =
- MembStr String |
- MembVar Var |
- MembExpr (WSCap Expr)
- deriving (Data, Eq, Generic, Show, Typeable)
-
--- Expr's
-
-data Expr =
- ExprArray WS (Either WS ([WSCap DubArrowMb], Maybe WS)) |
- ExprAssign (Maybe BinOpBy) LVal WS2 Expr |
- ExprBackticks String |
- ExprBinOp BinOp Expr WS2 Expr |
- -- we're lazy so just String here instead of like PhpType
- ExprCast (WSCap String) WS Expr |
- ExprEmpty WS (WSCap LRVal) |
- ExprEval WS (WSCap Expr) |
- ExprExit Bool (Maybe (WS, Either WS (WSCap Expr))) |
- ExprHereDoc HereDoc |
- -- FIXME: this fb extension should be separated to a superclass-like Lang?
- ExprIndex Expr WS (WSCap Expr) |
- ExprInclude IncOrReq OnceOrNot WS Expr |
- -- true story: "instanceof" takes LRVal's but not non-Const ROnlyVal's..
- ExprInstOf Expr WS2 (Either LRVal Const) |
- ExprIsset WS [WSCap LRVal] |
- ExprNew WS RVal (Maybe (WS, Either WS [WSCap Expr])) |
- ExprNumLit NumLit |
- ExprParen (WSCap Expr) |
- ExprPostOp PostOp Expr WS |
- ExprPreOp PreOp WS Expr |
- -- note: "list"/"&" is actually more limited
- -- ("list() = &$a;" is nonsyntactic)
- ExprRef WS (Either Expr Val) |
- ExprRVal RVal |
- ExprStrLit StrLit |
- ExprTernaryIf TernaryIf |
- -- FIXME: this fb extension should be separated to a superclass-like Lang?
- ExprXml Xml
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data Xml = Xml String
- (IC.Intercal WS (String, Maybe (WS2, Either StrLit (WSCap Expr))))
- (Maybe ([Either XmlLitOrExpr Xml], Bool))
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data XmlLitOrExpr = XmlLit String | XmlExpr (WSCap Expr)
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data BinOp = BAnd | BAndWd | BEQ | BGE | BGT | BID | BLE | BLT | BNE |
- -- <> has different precedence than !=
- BNEOld | BNI | BOr | BOrWd | BXorWd | BByable BinOpBy
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data BinOpBy = BBitAnd | BBitOr | BConcat | BDiv | BMinus | BMod | BMul |
- BPlus | BShiftL | BShiftR | BXor
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data PreOp = PrPrint | PrAt | PrBitNot | PrClone | PrNegate | PrNot | PrPos |
- PrSuppress | PrIncr | PrDecr
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data PostOp = PoIncr | PoDecr
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data IncOrReq = Inc | Req
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data OnceOrNot = Once | NotOnce
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data TernaryIf = TernaryIf {
- ternaryIfCond :: Expr,
- ternaryIfWS1 :: WS2,
- ternaryIfThen :: Maybe Expr,
- ternaryIfWS2 :: WS2,
- ternaryIfElse :: Expr}
- deriving (Data, Eq, Generic, Show, Typeable)
-
-data DubArrowMb = DubArrowMb (Maybe (Expr, WS2)) Expr
- deriving (Data, Eq, Generic, Show, Typeable)
-
-instance Out BinOp
-instance Out BinOpBy
-instance Out Const
-instance Out DubArrowMb
-instance Out DynConst
-instance Out Expr
-instance Out IncOrReq
-instance Out LOnlyVal
-instance Out LRVal
-instance Out LVal
-instance Out Memb
-instance Out OnceOrNot
-instance Out PostOp
-instance Out PreOp
-instance Out ROnlyVal
-instance Out RVal
-instance Out TernaryIf
-instance Out Val
-instance Out Var
-instance Out Xml
-instance Out XmlLitOrExpr
-
-$(derive makeBinary ''BinOp)
-$(derive makeBinary ''BinOpBy)
-$(derive makeBinary ''Const)
-$(derive makeBinary ''DubArrowMb)
-$(derive makeBinary ''DynConst)
-$(derive makeBinary ''Expr)
-$(derive makeBinary ''IncOrReq)
-$(derive makeBinary ''LOnlyVal)
-$(derive makeBinary ''LRVal)
-$(derive makeBinary ''LVal)
-$(derive makeBinary ''Memb)
-$(derive makeBinary ''OnceOrNot)
-$(derive makeBinary ''PostOp)
-$(derive makeBinary ''PreOp)
-$(derive makeBinary ''ROnlyVal)
-$(derive makeBinary ''RVal)
-$(derive makeBinary ''TernaryIf)
-$(derive makeBinary ''Val)
-$(derive makeBinary ''Var)
-$(derive makeBinary ''Xml)
-$(derive makeBinary ''XmlLitOrExpr)
-
View
4 src/Lang/Php/Ast/Stmt.hs
@@ -1,7 +1,9 @@
module Lang.Php.Ast.Stmt (
module Lang.Php.Ast.StmtParse,
- module Lang.Php.Ast.StmtTypes
+ module Lang.Php.Ast.StmtTypes,
+ module Lang.Php.Ast.StmtUnparse
) where
import Lang.Php.Ast.StmtParse
import Lang.Php.Ast.StmtTypes
+import Lang.Php.Ast.StmtUnparse
View
705 src/Lang/Php/Ast/StmtParse.hs
@@ -1,203 +1,450 @@
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, FlexibleInstances,
- FlexibleContexts, UndecidableInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
module Lang.Php.Ast.StmtParse where
+import Control.Monad.Identity
import Lang.Php.Ast.ArgList
import Lang.Php.Ast.Common
-import Lang.Php.Ast.Expr
-import Lang.Php.Ast.ExprTypes
import Lang.Php.Ast.Lex
import Lang.Php.Ast.StmtTypes
+import Text.ParserCombinators.Parsec.Expr
import qualified Data.Intercal as IC
-instance Unparse Stmt where
- unparse stmt = case stmt of
- StmtBlock a -> unparse a
- StmtBreak iMb w end -> tokBreak ++ unparse iMb ++ unparse w ++ unparse end
- StmtClass a -> unparse a
- StmtContinue iMb w end -> tokContinue ++ unparse iMb ++ unparse w ++
- unparse end
- StmtDeclare a -> unparse a
- StmtDoWhile a -> unparse a
- StmtEcho a end -> tokEcho ++ intercalate tokComma (map unparse a) ++
- unparse end
- StmtExpr a b c -> unparse a ++ unparse b ++ unparse c
- StmtFor a -> unparse a
- StmtForeach a -> unparse a
- StmtFuncDef a -> unparse a
- StmtGlobal a end -> tokGlobal ++
- intercalate tokComma (map unparse a) ++ unparse end
- StmtIf a -> unparse a
- StmtInterface a -> unparse a
- StmtNamespace n end -> tokNamespace ++ unparse n ++ unparse end
- StmtNothing end -> unparse end
- StmtReturn rMb w end -> tokReturn ++ unparse rMb ++ unparse w ++
- unparse end
- StmtStatic a end -> tokStatic ++ intercalate tokComma (map unparse a) ++
- unparse end
- StmtSwitch a -> unparse a
- StmtThrow a end -> tokThrow ++ unparse a ++ unparse end
- StmtTry a cs -> tokTry ++ unparse a ++ unparse cs
- StmtUnset (WSCap w1 a w2) end -> tokUnset ++ unparse w1 ++ tokLParen ++
- intercalate tokComma (map unparse a) ++ tokRParen ++ unparse w2 ++
- unparse end
- StmtUse n end -> tokUse ++ unparse n ++ unparse end
- StmtWhile a -> unparse a
-
-instance Unparse StmtEnd where
- unparse StmtEndSemi = tokSemi
- unparse (StmtEndClose a) = tokClosePhp ++ unparse a
-
-instance Unparse TopLevel where
- unparse (TopLevel s echoOrTok) = s ++
- maybe "" (either ((tokOpenPhpEcho ++) . unparse) ("<?" ++)) echoOrTok
-
-instance (Unparse a) => Unparse (Block a) where
- unparse (Block a) = tokLBrace ++ unparse a ++ tokRBrace
-
-unparsePre :: [(String, WS)] -> String
-unparsePre = concatMap (\ (a, b) -> a ++ unparse b)
-
-instance Unparse Class where
- unparse (Class pre (WSCap w1 name w2) extends impls block) = concat [
- unparsePre pre, tokClass, unparse w1, name, unparse w2,
- maybe [] ((tokExtends ++) . unparse) extends,
- if null impls then []
- else tokImplements ++ intercalate tokComma (map unparse impls),
- unparse block]
-
-instance Unparse ClassStmt where
- unparse stmt = case stmt of
- CStmtVar pre a end -> IC.intercalUnparser id unparse pre ++
- intercalate tokComma (map unparse a) ++ unparse end
- CStmtConst a -> cStmtConstUnparser a
- CStmtFuncDef pre a -> unparsePre pre ++ unparse a
- CStmtAbstrFunc a -> unparse a
- CStmtCategory a -> tokCategory ++ a ++ tokSemi
- CStmtChildren a -> tokChildren ++ a ++ tokSemi
- CStmtAttribute a -> tokAttribute ++ a ++ tokSemi
-
-cStmtConstUnparser :: (Unparse a) => [a] -> String
-cStmtConstUnparser vars = tokConst ++
- intercalate tokComma (map unparse vars) ++ tokSemi
-
-instance Unparse AbstrFunc where
- unparse (AbstrFunc pre ref name args ws end) = concat [unparsePre pre,
- tokFunction, maybe "" ((++ tokAmp) . unparse) ref, unparse name, tokLParen,
- either unparse (intercalate tokComma . map unparse) args, tokRParen,
- unparse ws, unparse end]
-
-instance (Unparse a) => Unparse (VarEqVal a) where
- unparse (VarEqVal var w expr) = unparse var ++ w2With tokEquals w ++
- unparse expr
-
-instance Unparse FuncArg where
- unparse (FuncArg const refWs var) = concat [
- maybe [] (\ (c, w) -> maybe tokArray unparse c ++ unparse w) const,
- maybe [] ((tokAmp ++) . unparse) refWs, unparse var]
-
--- todo: the block form too? does anyone use it? declare is terrible anyway..
-instance Unparse Declare where
- unparse (Declare (WSCap w1 (name, expr) w2) end) = concat [tokDeclare,
- unparse w1, tokLParen, unparse name, tokEquals, unparse expr, tokRParen,
- unparse w2, unparse end]
-
-instance Unparse DoWhile where
- unparse (DoWhile block (WSCap w1 (WSCap w2 expr w3) w4) end) = concat [tokDo,
- unparse block, tokWhile, unparse w1, tokLParen, unparse w2, unparse expr,
- unparse w3, tokRParen, unparse w4, unparse end]
-
-instance Unparse For where
- unparse (For (WSCap w1 (inits, conds, incrs) w2) block) = concat [
- tokFor, unparse w1, tokLParen,
- intercalate tokSemi $ map unparse [inits, conds, incrs],
- tokRParen, unparse w2, unparse block]
-
-instance Unparse ForPart where
- unparse (ForPart e) = either unparse (intercalate tokComma . map unparse) e
-
-instance Unparse Foreach where
- unparse (Foreach (WSCap w1 (expr, dubArrow) w2) block) = concat [tokForeach,
- unparse w1, tokLParen, unparse expr, tokAs, unparse dubArrow, tokRParen,
- unparse w2, unparse block]
-
-instance Unparse Func where
- unparse (Func w1 ref name (WSCap w2 args w3) block) = concat [tokFunction,
- unparse w1, maybe [] ((tokAmp ++) . unparse) ref, name, unparse w2,
- tokLParen, argsUnparser args, tokRParen, unparse w3, unparse block]
-
-argsUnparser :: (Unparse t, Unparse s) => Either t [s] -> String
-argsUnparser = either unparse (intercalate tokComma . map unparse)
-
-instance Unparse If where
- unparse (If isColon ifAndIfelses theElse) =
- tokIf ++ unparseIfBlock isColon theIf ++
- concatMap doIfelse ifelses ++
- maybe [] (\ (w1And2, blockOrStmt) -> w2With tokElse w1And2 ++
- colonUnparseBlockOrStmt isColon blockOrStmt) theElse ++
- if isColon then tokEndif else ""
- where
- (theIf, ifelses) = IC.breakStart ifAndIfelses
- doElsery Nothing = tokElseif
- doElsery (Just ws) = tokElse ++ unparse ws ++ tokIf
- doIfelse ((ws, elsery), ifBlock) =
- unparse ws ++ doElsery elsery ++ unparseIfBlock isColon ifBlock
- mbColon = if isColon then tokColon else ""
-
-colonUnparseBlockOrStmt :: Bool -> BlockOrStmt -> String
-colonUnparseBlockOrStmt isColon (Right (Block body)) = if isColon
- then tokColon ++ unparse body
- else unparse (Block body)
-colonUnparseBlockOrStmt isColon (Left stmt) = if isColon
- -- We could just unparse the statement (which should be a one-statement
- -- block). But it's probably better to yell on this invariant violation.
- then error "Colon notation should only use blocks."
- else unparse stmt
-
-unparseIfBlock :: Bool -> IfBlock -> String
-unparseIfBlock isColon (IfBlock (WSCap w1 expr w2) blockOrStmt) =
- concat [unparse w1, tokLParen, unparse expr, tokRParen, unparse w2] ++
- colonUnparseBlockOrStmt isColon blockOrStmt
-
-instance Unparse Interface where
- unparse (Interface name extends block) = concat [tokInterface, unparse name,
- if null extends then []
- else tokExtends ++ intercalate tokComma (map unparse extends),
- unparse block]
-
-instance Unparse IfaceStmt where
- unparse (IfaceConst vars) = cStmtConstUnparser vars
- unparse (IfaceFunc a) = unparse a
-
-instance Unparse Namespace where
- unparse (Namespace n) = n
-
-instance Unparse Use where
- unparse (Use n) = n
-
-instance Unparse VarMbVal where
- unparse (VarMbVal var exprMb) = unparse var ++ maybe []
- (\ (w, expr) -> w2With tokEquals w ++ unparse expr) exprMb
-
-instance Unparse Switch where
- unparse (Switch (WSCap w1 expr w2) w3 cases) = concat [tokSwitch, unparse w1,
- tokLParen, unparse expr, tokRParen, unparse w2, tokLBrace, unparse w3,
- unparse cases, tokRBrace]
-
-instance Unparse Case where
- unparse (Case expr stmtList) =
- either ((tokDefault ++) . unparse) ((tokCase ++) . unparse) expr ++
- tokColon ++ unparse stmtList
-
-instance Unparse Catch where
- unparse (Catch (WSCap w1 (const, expr) w2) w3 block) = concat [tokCatch,
- unparse w1, tokLParen, unparse const, unparse expr,
- unparse w2, tokRParen, unparse w3, unparse block]
-
-instance Unparse While where
- unparse (While (WSCap w1 expr w2) block) = concat [tokWhile, unparse w1,
- tokLParen, unparse expr, tokRParen, unparse w2, unparse block]
+-- Val
+
+instance Parse (Var, WS) where
+ parse = tokDollarP >> (undyn <|> dyn) where
+ undyn = do
+ i <- genIdentifierParser
+ -- try is here unless we combine processing for [expr] vs []
+ (inds, ws) <- IC.breakEnd <$> IC.intercalParser parse (try $
+ (tokLBracketP >> (,) True <$> parse <* tokRBracketP) <|>
+ (tokLBraceP >> (,) False <$> parse <* tokRBraceP))
+ return (Var i inds, ws)
+ dyn = do
+ ws <- parse
+ first (VarDyn ws) <$> parse <|> first (VarDynExpr ws) <$> liftM2 (,)
+ (tokLBraceP >> parse <* tokRBraceP) parse
+
+parseABPairsUntilAOrC :: Parser a -> Parser b -> Parser c ->
+ Parser ([(a, b)], Either a c)
+parseABPairsUntilAOrC a b c = (,) [] . Right <$> c <|> do
+ aR <- a
+ (b >>= \ bR -> first ((aR, bR):) <$> parseABPairsUntilAOrC a b c) <|>
+ return ([], Left aR)
+
+dynConstOrConstParser :: Parser (Either DynConst Const, WS)
+dynConstOrConstParser = do
+ (statics, cOrD) <-
+ first (map (\ ((a, b), c) -> (a, (b, c)))) <$>
+ parseABPairsUntilAOrC (liftM2 (,) (tokStaticP <|> identifierParser) parse)
+ (tokDubColonP >> parse) parse
+ return $ case cOrD of
+ Left c -> first (Right . Const statics) c
+ Right d -> first (Left . DynConst statics) d
+
+exprOrLValParser :: Parser (Either Expr LVal, WS)
+exprOrLValParser = try (first Left <$> parse) <|> first Right <$> parse
+
+instance Parse (Val, WS) where
+ parse = listVal <|> otherVal where
+ listVal = tokListP >> liftM2 (,)
+ (ValLOnlyVal <$> liftM2 LOnlyValList parse (mbArgListParser parse))
+ parse
+ otherVal = do
+ (dOrC, ws) <- dynConstOrConstParser
+ valExtend =<< case dOrC of
+ Left d -> return (ValLRVal $ LRValVar d, ws)
+ Right c -> (first ValROnlyVal <$>) $
+ liftM2 (,)
+ (ROnlyValFunc (Right c) ws <$> argListParser exprOrLValParser)
+ parse
+ <|> return (ROnlyValConst c, ws)
+
+firstM :: (Monad m) => (a -> m b) -> (a, c) -> m (b, c)
+firstM = runKleisli . first . Kleisli
+
+instance Parse (LVal, WS) where
+ parse = firstM f =<< parse where
+ f r = case r of
+ ValLOnlyVal v -> return $ LValLOnlyVal v
+ ValROnlyVal _ -> fail "Expecting an LVal but found an ROnlyVal."
+ ValLRVal v -> return $ LValLRVal v
+
+instance Parse (RVal, WS) where
+ parse = firstM f =<< parse where
+ f r = case r of
+ ValLOnlyVal _ -> fail "Expecting an RVal but found an LOnlyVal."
+ ValROnlyVal v -> return $ RValROnlyVal v
+ ValLRVal v -> return $ RValLRVal v
+
+instance Parse (LRVal, WS) where
+ parse = firstM f =<< parse where
+ f r = case r of
+ ValLOnlyVal _ -> fail "Expecting an LRVal but found an LOnlyVal."
+ ValROnlyVal _ -> fail "Expecting an LRVal but found an ROnlyVal."
+ ValLRVal v -> return v
+
+-- | val extending works like this:
+-- - L --member,index,append--> L
+-- - R --member--> LR
+-- - LR --member,index--> LR
+-- - LR --func--> R
+-- - LR --append--> L
+valExtend :: (Val, WS) -> Parser (Val, WS)
+valExtend v@(state, ws) = case state of
+ ValLOnlyVal a ->
+ do
+ ws2 <- tokArrowP >> parse
+ (memb, wsEnd) <- parse
+ valExtend (ValLOnlyVal $ LOnlyValMemb a (ws, ws2) memb, wsEnd)
+ <|> valExtendIndApp (LValLOnlyVal a) (ValLOnlyVal . LOnlyValInd a ws) ws
+ <|> return v
+ ValROnlyVal a -> valExtendMemb (RValROnlyVal a) ws
+ <|> do
+ ws2 <- tokLBracketP >> parse
+ st <- ValLRVal . LRValInd (RValROnlyVal a) ws . capify ws2 <$>
+ parse <* tokRBracketP
+ valExtend =<< (,) st <$> parse
+ <|> return v
+ ValLRVal a ->
+ do
+ r <- liftM2 (,) (ValROnlyVal . ROnlyValFunc (Left a) ws <$>
+ argListParser exprOrLValParser) parse
+ valExtend r
+ <|> valExtendIndApp (LValLRVal a) (ValLRVal . LRValInd (RValLRVal a) ws) ws
+ <|> valExtendMemb (RValLRVal a) ws
+ <|> return v
+
+valExtendMemb :: RVal -> WS -> Parser (Val, WS)
+valExtendMemb a ws = (tokArrowP >> do
+ ws2 <- parse
+ (memb, wsEnd) <- parse
+ valExtend (ValLRVal $ LRValMemb a (ws, ws2) memb, wsEnd))
+ <|> (tokDubColonP >> do
+ ws2 <- parse
+ (memb, wsEnd) <- parse
+ valExtend (ValLRVal $ LRValStaMemb a (ws, ws2) memb, wsEnd))
+
+instance Parse (Memb, WS) where
+ parse =
+ liftM2 (,) (
+ (tokLBraceP >> MembExpr <$> parse <* tokRBraceP) <|>
+ MembStr <$> genIdentifierParser) parse <|>
+ first MembVar <$> parse
+
+valExtendIndApp :: LVal -> (WSCap Expr -> Val) -> WS -> Parser (Val, WS)
+valExtendIndApp lVal mkVal ws = tokLBracketP >> do
+ ws2 <- parse
+ st <-
+ (tokRBracketP >>
+ return (ValLOnlyVal $ LOnlyValAppend lVal (ws, ws2))) <|>
+ mkVal . capify ws2 <$> (parse <* tokRBracketP)
+ valExtend =<< (,) st <$> parse
+
+varOrStringParser :: Parser (Either Var String, WS)
+varOrStringParser = first Left <$> parse <|>
+ liftM2 (,) (Right <$> identifierParser) parse
+
+instance Parse (DynConst, WS) where
+ parse = do
+ statics <- many . liftM2 (,) identifierParser . liftM2 (,) parse $
+ tokDubColonP >> parse
+ first (DynConst statics) <$> parse
+
+instance Parse (Const, WS) where
+ parse = first (uncurry Const) . rePairLeft . first (map rePairRight) .
+ IC.breakEnd <$> IC.intercalParser (liftM2 (,) identifierParser parse)
+ (tokDubColonP >> parse)
+
+lRValOrConstParser :: Parser (Either LRVal Const, WS)
+lRValOrConstParser = do
+ (v, w) <- parse
+ case v of
+ ValLRVal a -> return (Left a, w)
+ ValROnlyVal (ROnlyValConst a) -> return (Right a, w)
+ _ -> fail "Expected LRVal or Const but fould a different Val type."
+
+-- Expr
+
+instance Parse (Expr, WS) where
+ parse = buildExpressionParser exprParserTable simpleExprParser
+
+simpleExprParser :: Parser (Expr, WS)
+simpleExprParser = assignOrRValParser
+ <|> do
+ ws1 <- tokLParenP >> parse
+ ambigCastParser ws1 <|> castOrParenParser ws1
+ <|> do
+ ws1 <- tokNewP >> parse
+ (v, ws2) <- parse
+ argsWSMb <- optionMaybe $ argListParser parse
+ case argsWSMb of
+ Just args -> (,) (ExprNew ws1 v $ Just (ws2, args)) <$> parse
+ _ -> return (ExprNew ws1 v Nothing, ws2)
+ <|> includeParser
+ <|> do
+ isExit <- return True <$> tokExitP <|> return False <$> tokDieP
+ ws1 <- parse
+ argMb <- optionMaybe $ exitListParser parse
+ case argMb of
+ Just arg -> (,) (ExprExit isExit $ Just (ws1, arg)) <$> parse
+ _ -> return (ExprExit isExit Nothing, ws1)
+ <|> do
+ w <- tokAmpP >> parse
+ first (ExprRef w . Right) <$> parse <|> do
+ (e, wEnd) <- parse
+ case e of
+ ExprNew _ _ _ -> return (ExprRef w (Left e), wEnd)
+ _ -> fail "Expecting a Val or ExprNew."
+ <|> liftM2 (,) (
+ ExprStrLit <$> parse <|>
+ ExprNumLit <$> parse <|>
+ ExprHereDoc <$> parse <|>
+ ExprAnonFunc <$> parse <|>
+ (tokArrayP >> liftM2 ExprArray parse (arrListParser parse)) <|>
+ funclike1Parser ExprEmpty tokEmptyP <|>
+ funclike1Parser ExprEval tokEvalP <|>
+ (tokIssetP >> liftM2 ExprIsset parse (reqArgListParser parse)) <|>
+ ExprBackticks <$> backticksParser <|>
+ ExprXml <$> parse
+ ) parse
+
+ambigCastParser :: WS -> Parser (Expr, WS)
+ambigCastParser ws1 = try $ do
+ i <- identsCI ["array", "unset"]
+ ws2 <- parse
+ ws3 <- tokRParenP >> parse
+ first (ExprCast (WSCap ws1 i ws2) ws3) <$> parse
+
+castOrParenParser :: WS -> Parser (Expr, WS)
+castOrParenParser ws1 = do
+ iMb <- optionMaybe $ identsCI ["int", "integer", "bool", "boolean",
+ "float", "double", "real", "string", "binary", "object"]
+ case iMb of
+ Just i -> do
+ ws2 <- parse
+ ws3 <- tokRParenP >> parse
+ first (ExprCast (WSCap ws1 i ws2) ws3) <$> parse
+ _ -> liftM2 (,) (ExprParen . capify ws1 <$> parse <* tokRParenP) parse
+
+assignOrRValParser :: Parser (Expr, WS)
+assignOrRValParser = do
+ (val, w) <- parse
+ case val of
+ ValLOnlyVal v -> assignCont (LValLOnlyVal v) w
+ ValLRVal v -> assignCont (LValLRVal v) w <|>
+ return (ExprRVal $ RValLRVal v, w)
+ ValROnlyVal v -> return (ExprRVal $ RValROnlyVal v, w)
+
+assignCont :: LVal -> WS -> Parser (Expr, WS)
+assignCont l w1 = do
+ o <- (tokEqualsP >> return Nothing) <|> Just <$> (
+ (tokPlusByP >> return BPlus) <|>
+ (tokMinusByP >> return BMinus) <|>
+ (tokMulByP >> return BMul) <|>
+ (tokDivByP >> return BDiv) <|>
+ (tokConcatByP >> return BConcat) <|>
+ (tokModByP >> return BMod) <|>
+ (tokBitAndByP >> return BBitAnd) <|>
+ (tokBitOrByP >> return BBitOr) <|>
+ (tokXorByP >> return BXor) <|>
+ (tokShiftLByP >> return BShiftL) <|>
+ (tokShiftRByP >> return BShiftR))
+ w2 <- parse
+ first (ExprAssign o l (w1, w2)) <$> parse
+
+includeParser :: Parser (Expr, WS)
+includeParser = try $ do
+ i <- map toLower <$> genIdentifierParser
+ f <- if i == tokRequireOnce then return $ ExprInclude Req Once else
+ if i == tokIncludeOnce then return $ ExprInclude Inc Once else
+ if i == tokRequire then return $ ExprInclude Req NotOnce else
+ if i == tokInclude then return $ ExprInclude Inc NotOnce else
+ fail "Expecting an include/require expression."
+ ws <- parse
+ first (f ws) <$> parse
+
+instance Parse (DubArrowMb, WS) where
+ parse = do
+ (k, ws) <- parse
+ vMb <- optionMaybe (tokDubArrowP >> liftM2 (,) parse parse)
+ return $ case vMb of
+ Just (ws2, (v, ws3)) -> (DubArrowMb (Just (k, (ws, ws2))) v, ws3)
+ _ -> (DubArrowMb Nothing k, ws)
+
+funclike1Parser :: (Parse (a, WS)) => (WS -> WSCap a -> b) -> Parser c ->
+ Parser b
+funclike1Parser constr tokP = liftM2 constr (tokP >> parse)
+ (tokLParenP >> parse <* tokRParenP)
+
+exprParserTable :: [[Oper (Expr, WS)]]
+exprParserTable = [
+ [Postfix eptIndex],
+ [Prefix eptClone],
+ [Prefix eptPreIncr, Prefix eptPreDecr,
+ Postfix eptPostIncr, Postfix eptPostDecr],
+ [Postfix eptInstOf],
+ [Prefix . preRep $ eptNot <|> eptBitNot <|> eptNegate <|> eptPos <|>
+ eptSuppress],
+ ial [eptMul, eptDiv, eptMod],
+ ial [eptPlus, eptMinus, eptConcat],
+ ial [eptShiftL, eptShiftR],
+ ian [eptLT, eptLE, eptGT, eptGE, eptNEOld],
+ ian [eptEQ, eptNE, eptID, eptNI],
+ ial [eptBitAnd],
+ ial [eptXor],
+ ial [eptBitOr],
+ [Prefix eptPrint],
+ ial [eptAnd],
+ ial [eptOr],
+ [Postfix eptTernaryIf],
+ ial [eptAndWd],
+ ial [eptXorWd],
+ ial [eptOrWd]]
+
+preRep, postRep :: Parser (a -> a) -> Parser (a -> a)
+preRep p = (p >>= \ f -> (f .) <$> preRep p) <|> return id
+postRep p = (p >>= \ f -> (. f) <$> postRep p) <|> return id
+
+ial, ian :: [Parser (a -> a -> a)] -> [Oper a]
+ial = map $ flip Infix AssocLeft
+ian = map $ flip Infix AssocNone
+
+eptClone = preOp PrClone tokCloneP
+eptPreIncr = preOp PrIncr tokIncrP
+eptPreDecr = preOp PrDecr tokDecrP
+eptPostIncr = postOp PoIncr tokIncrP
+eptPostDecr = postOp PoDecr tokDecrP
+
+preOp :: PreOp -> Parser a -> Parser ((Expr, WS) -> (Expr, WS))
+preOp o p = do
+ ws1 <- p >> parse
+ return . first $ ExprPreOp o ws1
+
+postOp :: PostOp -> Parser a -> Parser ((Expr, WS) -> (Expr, WS))
+postOp o p = do
+ ws2 <- p >> parse
+ return $ \ (e, ws1) -> (ExprPostOp o e ws1, ws2)
+
+binOp :: BinOp -> Parser a -> Parser ((Expr, WS) -> (Expr, WS) -> (Expr, WS))
+binOp o p = do
+ ws2 <- p >> parse
+ return $ \ (e1, ws1) (e2, ws3) -> (ExprBinOp o e1 (ws1, ws2) e2, ws3)
+
+eptBitNot = preOp PrBitNot tokBitNotP
+eptNegate = preOp PrNegate tokMinusP
+eptPos = preOp PrPos tokPlusP
+eptSuppress = preOp PrSuppress tokAtP
+
+eptInstOf = do
+ tokInstanceofP
+ ws2 <- parse
+ (t, ws3) <- lRValOrConstParser
+ return $ \ (e, ws1) -> (ExprInstOf e (ws1, ws2) t, ws3)
+
+eptNot = preOp PrNot tokNotP
+
+eptMul = binOp (BByable BMul) tokMulP
+eptDiv = binOp (BByable BDiv) tokDivP
+eptMod = binOp (BByable BMod) tokModP
+eptPlus = binOp (BByable BPlus) tokPlusP
+eptMinus = binOp (BByable BMinus) tokMinusP
+eptConcat = binOp (BByable BConcat) tokConcatP
+eptShiftL = binOp (BByable BShiftL) tokShiftLP
+eptShiftR = binOp (BByable BShiftR) tokShiftRP
+eptLT = binOp BLT tokLTP
+eptLE = binOp BLE tokLEP
+eptGT = binOp BGT tokGTP
+eptGE = binOp BGE tokGEP
+eptNEOld = binOp BNEOld tokNEOldP
+eptEQ = binOp BEQ tokEQP
+eptNE = binOp BNE tokNEP
+eptID = binOp BID tokIDP
+eptNI = binOp BNI tokNIP
+
+eptBitAnd = binOp (BByable BBitAnd) tokAmpP
+eptXor = binOp (BByable BXor) tokXorP
+eptBitOr = binOp (BByable BBitOr) tokBitOrP
+
+eptPrint = preOp PrPrint tokPrintP
+
+eptAnd = binOp BAnd tokAndP
+eptOr = binOp BOr tokOrP
+
+eptTernaryIf :: Parser ((Expr, WS) -> (Expr, WS))
+eptTernaryIf = do
+ w2 <- tokQMarkP >> parse
+ (e2, w3) <- maybe (Nothing, []) (first Just) <$> parse
+ w4 <- tokColonP >> parse
+ (e3, w5) <- parse
+ return $ \ (e1, w1) ->
+ (ExprTernaryIf $ TernaryIf e1 (w1, w2) e2 (w3, w4) e3, w5)
+
+eptAndWd = binOp BAndWd tokAndWdP
+eptXorWd = binOp BXorWd tokXorWdP
+eptOrWd = binOp BOrWd tokOrWdP
+
+eptIndex :: Parser ((Expr, WS) -> (Expr, WS))
+eptIndex = do
+ e2 <- tokLBracketP >> parse
+ w2 <- tokRBracketP >> parse
+ return $ \ (e1, w1) -> (ExprIndex e1 w1 e2, w2)
+
+instance Parse Xml where
+ parse = tokLTP >> do
+ tag <- many1 . oneOf $
+ -- i thought _ wasn't allowed but i guess when marcel's away e will play
+ [':', '-', '_'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
+ attrs <- IC.intercalParser parse . liftM2 (,) xmlIdentifierParser $
+ Just <$> try (liftM2 (,) (liftM2 (,) parse (tokEqualsP >> parse)) $
+ (tokLBraceP >> Right <$> parse <* tokRBraceP) <|>
+ Left <$> parse) <|>
+ return Nothing
+ content <- (tokDivP >> tokGTP >> return Nothing) <|>
+ Just <$> liftM2 (,)
+ (tokGTP >> many (Right <$> try parse <|> Left <$> parse))
+ (tokLTP >> tokDivP >> ((string tag >> return True) <|> return False))
+ <* tokGTP
+ return $ Xml tag attrs content
+
+instance Parse XmlLitOrExpr where
+ parse = (tokLBraceP >> XmlExpr <$> parse <* tokRBraceP) <|>
+ XmlLit <$> many1 (satisfy (`notElem` "<{"))
+
+instance Parse (FuncArg, WS) where
+ parse = do
+ t <- optionMaybe
+ (first Just <$> parse <|> (tokArrayP >> (,) Nothing <$> parse))
+ ref <- optionMaybe (tokAmpP >> parse)
+ first (FuncArg t ref) <$> parse
+
+instance Parse AnonFuncUse where
+ parse = tokUseP >>
+ AnonFuncUse <$> wsCapParser (reqArgListParser parse)
+
+-- We parse functions in two parts to disambiguate functions and anonymous
+-- functions at top-level without using (try).
+funcStartParser = tokFunctionP >> liftM2 (,)
+ parse
+ ((tokAmpP >> Just <$> parse) <|> return Nothing)
+
+anonFuncContParser (w, ampMb) = liftM3 (AnonFunc w ampMb)
+ (wsCapParser $ argListParser parse)
+ parse
+ parse
+
+funcContParser (w, ampMb) = liftM3 (Func w ampMb)
+ identifierParser
+ (wsCapParser $ argListParser parse)
+ parse
+
+instance Parse AnonFunc where
+ parse = funcStartParser >>= anonFuncContParser
+
+-- Stmt
stmtListP :: Parser StmtList
stmtListP = liftM2 IC.unbreakStart parse parse
@@ -221,8 +468,8 @@ simpleStmtParser =
StmtDoWhile <$> parse <|>
liftM2 StmtEcho (tokEchoP >> sepBy1 parse tokCommaP) parse <|>
(try $ liftM2 StmtStatic (tokStaticP >> sepBy1 parse tokCommaP) parse) <|>
- liftM2 (uncurry StmtExpr) parse parse <|>
- StmtFuncDef <$> parse <|>
+ funcParser <|>
+ stmtExprParser <|>
liftM2 StmtGlobal (tokGlobalP >> sepBy1 parse tokCommaP) parse <|>
liftM2 StmtNamespace (tokNamespaceP >> parse) parse <|>
liftM2 StmtUse (tokUseP >> parse) parse <|>
@@ -232,11 +479,17 @@ simpleStmtParser =
StmtSwitch <$> parse <|>
liftM2 StmtThrow (tokThrowP >> parse) parse <|>
liftM2 StmtUnset
- (tokUnsetP >> liftM3 WSCap parse (issetListParser parse) parse)
+ (tokUnsetP >> wsCapParser (reqArgListParser parse))
parse
+stmtExprParser :: Parser Stmt
+stmtExprParser = stmtExprContParser parse
+
+stmtExprContParser :: Parser (Expr, WS) -> Parser Stmt
+stmtExprContParser p = liftM2 (uncurry StmtExpr) p parse
+
ifCondP :: Parser (WSCap2 Expr)
-ifCondP = liftM3 WSCap parse (tokLParenP >> parse <* tokRParenP) parse
+ifCondP = wsCapParser $ tokLParenP >> parse <* tokRParenP
instance Parse (If, WS) where
parse = tokIfP >> do
@@ -360,7 +613,7 @@ breaklikeParser constr p = p >> do
instance Parse Class where
parse = liftM5 Class
(many (liftM2 (,) (tokAbstractP <|> tokFinalP) parse))
- (tokClassP >> liftM3 WSCap parse identifierParser parse)
+ (tokClassP >> wsCapParser identifierParser)
(optionMaybe $ tokExtendsP >> parse)
((tokImplementsP >> sepBy1 parse tokCommaP) <|> return [])
parse
@@ -417,15 +670,11 @@ classFuncParser pre = CStmtFuncDef pre <$> parse
classAbstrFuncParser :: (AbstrFunc -> c) -> [(String, WS)] -> Parser c
classAbstrFuncParser constr pre = constr <$> liftM5 (AbstrFunc pre)
- (tokFunctionP >> optionMaybe (try $ parse <* tokAmpP)) parse
- (argListParser parse) parse parse
-
-instance Parse (FuncArg, WS) where
- parse = do
- t <- optionMaybe
- (first Just <$> parse <|> (tokArrayP >> (,) Nothing <$> parse))
- ref <- optionMaybe (tokAmpP >> parse)
- first (FuncArg t ref) <$> parse
+ (tokFunctionP >> optionMaybe (try $ parse <* tokAmpP))
+ parse
+ (argListParser parse)
+ parse
+ parse
unsnoc :: [a] -> ([a], a)
unsnoc = first reverse . swap . uncons . reverse
@@ -439,22 +688,24 @@ classVarsParser pre = let (preInit, (s, w)) = unsnoc pre in
instance Parse Declare where
parse = tokDeclareP >> liftM2 Declare
- (liftM3 WSCap parse (tokLParenP >>
- liftM2 (,) parse (tokEqualsP >> parse)) (tokRParenP >> parse))
+ (wsCapParser $
+ tokLParenP >> liftM2 (,) parse (tokEqualsP >> parse) <* tokRParenP)
parse
instance Parse DoWhile where
- parse = liftM3 DoWhile (tokDoP >> parse) (tokWhileP >>
- liftM3 WSCap parse (tokLParenP >> parse <* tokRParenP) parse)
+ parse = liftM3 DoWhile
+ (tokDoP >> parse)
+ (tokWhileP >> wsCapParser (tokLParenP >> parse <* tokRParenP))
parse
instance (Parse (a, WS), Parse (b, WS)) => Parse (Either a b, WS) where
parse = first Right <$> parse <|> first Left <$> parse
instance Parse (For, WS) where
parse = tokForP >> do
- h <- liftM3 WSCap parse (tokLParenP >> liftM3 (,,) parse
- (tokSemiP >> parse <* tokSemiP) parse <* tokRParenP) parse
+ h <- wsCapParser $ tokLParenP >>
+ liftM3 (,,) parse (tokSemiP >> parse <* tokSemiP) parse
+ <* tokRParenP
first (For h) <$> parse
instance Parse ForPart where
@@ -468,15 +719,30 @@ forPartExpry w1 = ForPart . Right <$>
instance Parse (Foreach, WS) where
parse = tokForeachP >> do
- h <- liftM3 WSCap parse
- (tokLParenP >> liftM2 (,) parse (tokAsP >> parse) <* tokRParenP)
- parse
+ h <- wsCapParser $
+ tokLParenP >> liftM2 (,) parse (tokAsP >> parse) <* tokRParenP
first (Foreach h) <$> parse
+funcParser :: Parser Stmt
+funcParser = do
+ start <- funcStartParser
+ StmtFuncDef <$> funcContParser start <|>
+ -- We should actually implement something here like:
+ -- exprContParser :: (Expr, WS) -> Parser (Expr, WS)
+ -- since weird things like
+ -- function (){} + 4;
+ -- are grammatical even at top-level
+ -- (just generates a warning a.k.a. a PHP "notice").
+ -- Instead we use the less general stmtExprContParser,
+ -- because such weird things are crazy anyway and this is easy for now.
+ -- I believe there's actually no use to ever having a statement
+ -- start-with/be an anon func anyway. But we'll play along,
+ -- allowing a statement to be an anon func at least.
+ stmtExprContParser (toWsParser $
+ ExprAnonFunc <$> anonFuncContParser start)
+
instance Parse Func where
- parse = tokFunctionP >> liftM5 Func parse
- ((tokAmpP >> Just <$> parse) <|> return Nothing) identifierParser
- (liftM3 WSCap parse (argListParser parse) parse) parse
+ parse = funcStartParser >>= funcContParser
instance Parse Interface where
parse = tokInterfaceP >> liftM3 Interface
@@ -501,7 +767,7 @@ instance Parse IfaceStmt where
instance Parse Switch where
parse = tokSwitchP >> liftM3 Switch
- (liftM3 WSCap parse (tokLParenP >> parse <* tokRParenP) parse)
+ (wsCapParser $ tokLParenP >> parse <* tokRParenP)
(tokLBraceP >> parse)
parse <* tokRBraceP
@@ -512,7 +778,7 @@ instance Parse Case where
instance Parse (While, WS) where
parse = tokWhileP >> do
- e <- liftM3 WSCap parse (tokLParenP >> parse <* tokRParenP) parse
+ e <- wsCapParser $ tokLParenP >> parse <* tokRParenP
first (While e) <$> parse
instance Parse (a, WS) => Parse (Block a) where
@@ -532,4 +798,3 @@ instance Parse TopLevel where
instance Parse StmtEnd where
parse = (tokSemiP >> return StmtEndSemi) <|>
(tokClosePhpP >> StmtEndClose <$> parse)
-
View
232 src/Lang/Php/Ast/StmtTypes.hs
@@ -1,14 +1,183 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell #-}
+
module Lang.Php.Ast.StmtTypes where
import Text.PrettyPrint.GenericPretty
+import Lang.Php.Ast.ArgList
import Lang.Php.Ast.Common
-import Lang.Php.Ast.ExprTypes
+import Lang.Php.Ast.Lex
import qualified Data.Intercal as IC
+-- Val's are defined to only contain: "$", identifiers, "[Expr]", "[]",
+-- "(Exprs)", "${Expr}", "::", "->". The most important consideration is which
+-- ones can be assigned to (LVal's) and which ones can be assigned from
+-- (RVal's). In PHP, most but not all LVal's are also RVal's.
+
+-- Note that this grammar allows "$$a[]->a = 5;" but Zend does not. However,
+-- Zend allows "${$a}[]->a = 5;", and it's not clear what is gained by treating
+-- $a and ${..} asymmetrically here. PHP also allows "${$a}[0]->a = 5" and
+-- "$$a[0]->a = 5;". So we're regarding this as a by-product of the Zend
+-- implementation. In particular, we think they simplify their job by slurping
+-- all [Expr?]'s onto Var's and only later analyze things with regard to LVal
+-- considerations, simply fataling if something is then awry.
+--
+-- Modeling that nuance is impractical under the clear division of
+-- Var's, LVal's, and RVal's that we desire to make the AST nice for
+-- refactoring.
+
+data Val = ValLOnlyVal LOnlyVal | ValROnlyVal ROnlyVal | ValLRVal LRVal
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data LVal = LValLOnlyVal LOnlyVal | LValLRVal LRVal
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data RVal = RValROnlyVal ROnlyVal | RValLRVal LRVal
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data Var =
+ -- In php, indexing is oddly coupled very tightly with being a non-dyn var.
+ Var String [((WS, (Bool, WSCap Expr)))] | -- "$a", "$a[0]", "$a[0][0]"
+ VarDyn WS Var | -- "$$a"
+ -- note: "$$a[0]()->a" == "${$a[0]}()->a"
+ VarDynExpr WS (WSCap Expr) -- "${$a . '_'}"
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data DynConst = DynConst [(String, WS2)] Var -- "a::$a"
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data LRVal =
+ LRValVar DynConst |
+ LRValInd RVal WS (WSCap Expr) | -- "$a->a[0]"
+ LRValMemb RVal WS2 Memb | -- $a->a
+ LRValStaMemb RVal WS2 Memb -- $a::a
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data LOnlyVal =
+ LOnlyValList WS (Either WS [Either WS (WSCap LVal)]) |
+ LOnlyValAppend LVal WS2 | -- "$a[]"
+ LOnlyValInd LOnlyVal WS (WSCap Expr) | -- "$a[][0]"
+ LOnlyValMemb LOnlyVal WS2 Memb -- "$a[]->a"
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data Const = Const [(String, WS2)] String -- "a::a"
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data ROnlyVal =
+ ROnlyValConst Const |
+ -- "a()", "$a()"
+ ROnlyValFunc (Either LRVal Const) WS (Either WS [WSCap (Either Expr LVal)])
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data Memb =
+ MembStr String |
+ MembVar Var |
+ MembExpr (WSCap Expr)
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+--
+-- Expr's
+--
+
+data Expr =
+ ExprAnonFunc AnonFunc |
+ ExprArray WS (Either WS ([WSCap DubArrowMb], Maybe WS)) |
+ ExprAssign (Maybe BinOpBy) LVal WS2 Expr |
+ ExprBackticks String |
+ ExprBinOp BinOp Expr WS2 Expr |
+ -- we're lazy so just String here instead of like PhpType
+ ExprCast (WSCap String) WS Expr |
+ ExprEmpty WS (WSCap LRVal) |
+ ExprEval WS (WSCap Expr) |
+ ExprExit Bool (Maybe (WS, Either WS (WSCap Expr))) |
+ ExprHereDoc HereDoc |
+ -- FIXME: this fb extension should be separated to a superclass-like Lang?
+ ExprIndex Expr WS (WSCap Expr) |
+ ExprInclude IncOrReq OnceOrNot WS Expr |
+ -- true story: "instanceof" takes LRVal's but not non-Const ROnlyVal's..
+ ExprInstOf Expr WS2 (Either LRVal Const) |
+ ExprIsset WS [WSCap LRVal] |
+ ExprNew WS RVal (Maybe (WS, Either WS [WSCap Expr])) |
+ ExprNumLit NumLit |
+ ExprParen (WSCap Expr) |
+ ExprPostOp PostOp Expr WS |
+ ExprPreOp PreOp WS Expr |
+ -- note: "list"/"&" is actually more limited
+ -- ("list() = &$a;" is nonsyntactic)
+ ExprRef WS (Either Expr Val) |
+ ExprRVal RVal |
+ ExprStrLit StrLit |
+ ExprTernaryIf TernaryIf |
+ -- FIXME: this fb extension should be separated to a superclass-like Lang?
+ ExprXml Xml
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data Xml = Xml String
+ (IC.Intercal WS (String, Maybe (WS2, Either StrLit (WSCap Expr))))
+ (Maybe ([Either XmlLitOrExpr Xml], Bool))
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data XmlLitOrExpr = XmlLit String | XmlExpr (WSCap Expr)
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data BinOp = BAnd | BAndWd | BEQ | BGE | BGT | BID | BLE | BLT | BNE |
+ -- <> has different precedence than !=
+ BNEOld | BNI | BOr | BOrWd | BXorWd | BByable BinOpBy
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data BinOpBy = BBitAnd | BBitOr | BConcat | BDiv | BMinus | BMod | BMul |
+ BPlus | BShiftL | BShiftR | BXor
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data PreOp = PrPrint | PrAt | PrBitNot | PrClone | PrNegate | PrNot | PrPos |
+ PrSuppress | PrIncr | PrDecr
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data PostOp = PoIncr | PoDecr
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data IncOrReq = Inc | Req
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data OnceOrNot = Once | NotOnce
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data TernaryIf = TernaryIf {
+ ternaryIfCond :: Expr,
+ ternaryIfWS1 :: WS2,
+ ternaryIfThen :: Maybe Expr,
+ ternaryIfWS2 :: WS2,
+ ternaryIfElse :: Expr}
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data DubArrowMb = DubArrowMb (Maybe (Expr, WS2)) Expr
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data AnonFuncUse = AnonFuncUse {
+ -- Note that this list must be nonempty.
+ afuncUseArgs :: WSCap [WSCap FuncArg]}
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data AnonFunc = AnonFunc {
+ afuncWS :: WS,
+ afuncRef :: Maybe WS,
+ afuncArgs :: WSCap (ArgList FuncArg),
+ afuncUse :: Maybe AnonFuncUse,
+ afuncBlock :: Block Stmt}
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+data FuncArg = FuncArg {
+ funcArgType :: Maybe (Maybe Const, WS),
+ funcArgRef :: Maybe WS,
+ funcArgVar :: VarMbVal}
+ deriving (Data, Eq, Generic, Show, Typeable)
+
+--
+-- Stmt's
+--
+
type StmtList = IC.Intercal WS Stmt
data Stmt =
@@ -88,12 +257,6 @@ data Class = Class {
classBlock :: Block ClassStmt}
deriving (Data, Eq, Generic, Show, Typeable)
-data FuncArg = FuncArg {
- funcArgType :: Maybe (Maybe Const, WS),
- funcArgRef :: Maybe WS,
- funcArgVar :: VarMbVal}
- deriving (Data, Eq, Generic, Show, Typeable)
-
data VarMbVal = VarMbVal Var (Maybe (WS2, Expr))
deriving (Data, Eq, Generic, Show, Typeable)
@@ -178,56 +341,101 @@ data StmtEnd = StmtEndSemi | StmtEndClose TopLevel
type BlockOrStmt = Either Stmt (Block Stmt)
instance Out AbstrFunc
+instance Out AnonFunc
+instance Out AnonFuncUse
+instance Out BinOp
+instance Out BinOpBy
instance (Out a) => Out (Block a)
instance Out Case
instance Out Catch
instance Out Class
instance Out ClassStmt
+instance Out Const
instance Out Declare
instance Out DoWhile
+instance Out DubArrowMb
+instance Out DynConst
+instance Out Expr
instance Out For
-instance Out ForPart
instance Out Foreach
+instance Out ForPart
instance Out Func
instance Out FuncArg
instance Out If
instance Out IfaceStmt
instance Out IfBlock
+instance Out IncOrReq
instance Out Interface
+instance Out LOnlyVal
+instance Out LRVal
+instance Out LVal
+instance Out Memb
instance Out Namespace
+instance Out OnceOrNot
+instance Out PostOp
+instance Out PreOp
+instance Out ROnlyVal
+instance Out RVal
instance Out Stmt
instance Out StmtEnd
instance Out Switch
+instance Out TernaryIf
instance Out TopLevel
instance Out Use
-instance Out VarMbVal
+instance Out Val
+instance Out Var
instance (Out a) => Out (VarEqVal a)
+instance Out VarMbVal
instance Out While
+instance Out Xml
+instance Out XmlLitOrExpr
$(derive makeBinary ''AbstrFunc)
+$(derive makeBinary ''AnonFunc)
+$(derive makeBinary ''AnonFuncUse)
+$(derive makeBinary ''BinOp)
+$(derive makeBinary ''BinOpBy)
$(derive makeBinary ''Block)
$(derive makeBinary ''Case)
$(derive makeBinary ''Catch)
$(derive makeBinary ''Class)
$(derive makeBinary ''ClassStmt)
+$(derive makeBinary ''Const)
$(derive makeBinary ''Declare)
$(derive makeBinary ''DoWhile)
+$(derive makeBinary ''DubArrowMb)
+$(derive makeBinary ''DynConst)
+$(derive makeBinary ''Expr)
$(derive makeBinary ''For)
-$(derive makeBinary ''ForPart)
$(derive makeBinary ''Foreach)
+$(derive makeBinary ''ForPart)
$(derive makeBinary ''Func)
$(derive makeBinary ''FuncArg)
$(derive makeBinary ''If)
$(derive makeBinary ''IfaceStmt)
$(derive makeBinary ''IfBlock)
+$(derive makeBinary ''IncOrReq)
$(derive makeBinary ''Interface)
+$(derive makeBinary ''LOnlyVal)
+$(derive makeBinary ''LRVal)
+$(derive makeBinary ''LVal)
+$(derive makeBinary ''Memb)
$(derive makeBinary ''Namespace)
+$(derive makeBinary ''OnceOrNot)
+$(derive makeBinary ''PostOp)
+$(derive makeBinary ''PreOp)
+$(derive makeBinary ''ROnlyVal)
+$(derive makeBinary ''RVal)
$(derive makeBinary ''Stmt)
$(derive makeBinary ''StmtEnd)
$(derive makeBinary ''Switch)
+$(derive makeBinary ''TernaryIf)
$(derive makeBinary ''TopLevel)
$(derive makeBinary ''Use)
-$(derive makeBinary ''VarMbVal)
+$(derive makeBinary ''Val)
+$(derive makeBinary ''Var)
$(derive makeBinary ''VarEqVal)
+$(derive makeBinary ''VarMbVal)
$(derive makeBinary ''While)
-
+$(derive makeBinary ''Xml)
+$(derive makeBinary ''XmlLitOrExpr)
View
402 src/Lang/Php/Ast/StmtUnparse.hs
@@ -0,0 +1,402 @@
+-- {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+-- {-# LANGUAGE UndecidableInstances #-}
+
+module Lang.Php.Ast.StmtUnparse where
+
+import Control.Monad.Identity
+import Lang.Php.Ast.ArgList
+import Lang.Php.Ast.Common
+import Lang.Php.Ast.Lex
+import Lang.Php.Ast.StmtTypes
+import Text.ParserCombinators.Parsec.Expr
+import qualified Data.Intercal as IC
+
+-- Val
+
+instance Unparse Var where
+ unparse (Var s indexes) = tokDollar ++ s ++
+ concatMap (\ (ws, (isBracket, expr)) -> unparse ws ++
+ if isBracket
+ then tokLBracket ++ unparse expr ++ tokRBracket
+ else tokLBrace ++ unparse expr ++ tokRBrace
+ ) indexes
+ unparse (VarDyn ws var) = tokDollar ++ unparse ws ++ unparse var
+ unparse (VarDynExpr ws expr) = tokDollar ++ unparse ws ++ tokLBrace ++
+ unparse expr ++ tokRBrace
+
+instance Unparse Const where
+ unparse (Const statics s) = concatMap (\ (s, (ws1, ws2)) -> s ++
+ unparse ws1 ++ tokDubColon ++ unparse ws2) statics ++ s
+
+instance Unparse DynConst where
+ unparse (DynConst statics var) = concatMap (\ (s, (ws1, ws2)) -> s ++
+ unparse ws1 ++ tokDubColon ++ unparse ws2) statics ++ unparse var
+
+instance Unparse LRVal where
+ unparse (LRValVar a) = unparse a
+ unparse (LRValInd a w e) = unparse a ++ unparse w ++ tokLBracket ++
+ unparse e ++ tokRBracket
+ unparse (LRValMemb v (ws1, ws2) m) =
+ unparse v ++ unparse ws1 ++ tokArrow ++ unparse ws2 ++ unparse m
+ unparse (LRValStaMemb v (ws1, ws2) m) =
+ unparse v ++ unparse ws1 ++ tokDubColon ++ unparse ws2 ++ unparse m
+
+instance Unparse LOnlyVal where
+ unparse (LOnlyValList w args) = tokList ++ unparse w ++ tokLParen ++
+ either unparse (intercalate tokComma . map unparse) args ++ tokRParen
+ unparse (LOnlyValAppend v (ws1, ws2)) =
+ unparse v ++ unparse ws1 ++ tokLBracket ++ unparse ws2 ++ tokRBracket
+ unparse (LOnlyValInd v ws expr) =
+ unparse v ++ unparse ws ++ tokLBracket ++ unparse expr ++ tokRBracket
+ unparse (LOnlyValMemb v (ws1, ws2) m) =
+ unparse v ++ unparse ws1 ++ tokArrow ++ unparse ws2 ++ unparse m
+
+instance Unparse ROnlyVal where
+ unparse (ROnlyValConst a) = unparse a
+ unparse (ROnlyValFunc v ws (Left w)) = unparse v ++ unparse ws ++
+ tokLParen ++ unparse w ++ tokRParen
+ unparse (ROnlyValFunc v ws (Right args)) = unparse v ++ unparse ws ++
+ tokLParen ++ intercalate tokComma (map unparse args) ++ tokRParen
+
+instance Unparse Memb where
+ unparse (MembExpr e) = tokLBrace ++ unparse e ++ tokRBrace
+ unparse (MembStr s) = s
+ unparse (MembVar a) = unparse a
+
+instance Unparse Val where
+ unparse (ValLOnlyVal a) = unparse a
+ unparse (ValROnlyVal a) = unparse a
+ unparse (ValLRVal a) = unparse a
+
+instance Unparse LVal where
+ unparse (LValLOnlyVal a) = unparse a
+ unparse (LValLRVal a) = unparse a
+
+instance Unparse RVal where
+ unparse (RValROnlyVal a) = unparse a
+ unparse (RValLRVal a) = unparse a
+
+-- Expr
+
+instance Unparse Expr where
+ unparse expr = case expr of
+ ExprAnonFunc a -> unparse a
+ ExprArray w elemsOrW -> tokArray ++ unparse w ++ tokLParen ++
+ either unparse f elemsOrW ++ tokRParen where
+ f (elems, wEnd) = intercalate tokComma .
+ maybe id (flip (++) . (:[]) . unparse) wEnd $ map unparse elems
+ ExprAssign o v w e -> unparse v ++ w2With (unparse o ++ tokEquals) w ++
+ unparse e
+ ExprBackticks a -> a
+ ExprBinOp o e1 (w1, w2) e2 -> unparse e1 ++ unparse w1 ++ unparse o ++
+ unparse w2 ++ unparse e2
+ ExprCast (WSCap w1 t w2) w e -> tokLParen ++ unparse w1 ++ t ++
+ unparse w2 ++ tokRParen ++ unparse w ++ unparse e
+ ExprEmpty w e -> tokEmpty ++ unparse w ++ tokLParen ++ unparse e ++
+ tokRParen
+ ExprEval w e -> tokEval ++ unparse w ++ tokLParen ++ unparse e ++
+ tokRParen
+ ExprExit isExit a -> (if isExit then tokExit else tokDie) ++
+ maybe "" (\ (w, x) -> unparse w ++ tokLParen ++
+ either unparse unparse x ++ tokRParen) a
+ ExprHereDoc a -> unparse a
+ ExprInclude a b w e -> unparse a ++ unparse b ++ unparse w ++ unparse e
+ ExprIndex a w b ->
+ unparse a ++ unparse w ++ tokLBracket ++ unparse b ++ tokRBracket
+ ExprInstOf e w t -> unparse e ++ w2With tokInstanceof w ++ unparse t
+ ExprIsset w vs -> tokIsset ++ unparse w ++ tokLParen ++
+ intercalate tokComma (map unparse vs) ++ tokRParen
+ ExprNew w a argsMb -> tokNew ++ unparse w ++ unparse a ++ maybe ""
+ (\ (wPre, args) -> unparse wPre ++ tokLParen ++ either unparse
+ (intercalate tokComma . map unparse) args ++ tokRParen) argsMb
+ ExprNumLit a -> unparse a
+ ExprParen a -> tokLParen ++ unparse a ++ tokRParen
+ ExprPostOp o e w -> unparse e ++ unparse w ++ unparse o
+ ExprPreOp o w e -> unparse o ++ unparse w ++ unparse e
+ ExprRef w v -> tokAmp ++ unparse w ++ unparse v
+ ExprRVal a -> unparse a
+ ExprStrLit a -> unparse a
+ ExprTernaryIf a -> unparse a
+ ExprXml a -> unparse a
+
+instance Unparse BinOpBy where
+ unparse binOp = case binOp of
+ BBitAnd -> tokAmp
+ BBitOr -> tokBitOr
+ BConcat -> tokConcat
+ BDiv -> tokDiv
+ BMinus -> tokMinus
+ BMod -> tokMod
+ BMul -> tokMul
+ BPlus -> tokPlus
+ BShiftL -> tokShiftL
+ BShiftR -> tokShiftR
+ BXor -> tokXor
+
+instance Unparse BinOp where
+ unparse binOp = case binOp of
+ BAnd -> tokAnd
+ BAndWd -> tokAndWd
+ BEQ -> tokEQ
+ BGE -> tokGE
+ BGT -> tokGT
+ BID -> tokID
+ BLE -> tokLE
+ BLT -> tokLT
+ BNE -> tokNE
+ BNEOld -> tokNEOld
+ BNI -> tokNI
+ BOr -> tokOr
+ BOrWd -> tokOrWd
+ BXorWd -> tokXorWd
+ BByable o -> unparse o
+
+instance Unparse PreOp where
+ unparse preOp = case preOp of
+ PrPrint -> tokPrint
+ PrAt -> tokAt
+ PrBitNot -> tokBitNot
+ PrClone -> tokClone
+ PrNegate -> tokMinus
+ PrNot -> tokNot
+ PrPos -> tokPlus
+ PrSuppress -> tokAt
+ PrIncr -> tokIncr
+ PrDecr -> tokDecr
+
+instance Unparse PostOp where
+ unparse postOp = case postOp of
+ PoIncr -> tokIncr
+ PoDecr -> tokDecr
+
+instance Unparse IncOrReq where
+ unparse Inc = tokInclude
+ unparse Req = tokRequire
+
+instance Unparse OnceOrNot where
+ unparse Once = "_once"
+ unparse NotOnce = ""
+
+instance Unparse DubArrowMb where
+ unparse (DubArrowMb k v) = maybe "" (\ (e, (w1, w2)) -> unparse e ++
+ unparse w1 ++ tokDubArrow ++ unparse w2) k ++ unparse v
+
+instance Unparse TernaryIf where
+ unparse (TernaryIf e1 (w1, w2) e2 (w3, w4) e3) = unparse e1 ++ unparse w1 ++
+ tokQMark ++ unparse w2 ++ unparse e2 ++ unparse w3 ++ tokColon ++
+ unparse w4 ++ unparse e3
+
+instance Unparse Xml where
+ unparse (Xml tag attrs content) = tokLT ++ tag ++
+ IC.intercalUnparser unparse
+ (\ (k, vMb) -> k ++
+ maybe "" (\ (w, v) -> w2With tokEquals w ++
+ either unparse ((tokLBrace ++) . (++ tokRBrace) . unparse) v) vMb)
+ attrs ++
+ maybe tokDiv (\ (c, hasExplicitCloseTag) ->
+ tokGT ++ concatMap unparse c ++ tokLT ++ tokDiv ++
+ if hasExplicitCloseTag then tag else "") content ++
+ tokGT
+
+instance Unparse XmlLitOrExpr where
+ unparse (XmlLit a) = a
+ unparse (XmlExpr a) = tokLBrace ++ unparse a ++ tokRBrace
+
+instance Unparse VarMbVal where
+ unparse (VarMbVal var exprMb) = unparse var ++ maybe []
+ (\ (w, expr) -> w2With tokEquals w ++ unparse expr) exprMb
+
+instance Unparse FuncArg where
+ unparse (FuncArg const refWs var) = concat [
+ maybe [] (\ (c, w) -> maybe tokArray unparse c ++ unparse w) const,
+ maybe [] ((tokAmp ++) . unparse) refWs, unparse var]
+
+instance Unparse AnonFuncUse where
+ unparse (AnonFuncUse argList) = tokUse ++ unparse argList
+
+instance Unparse AnonFunc where
+ unparse (AnonFunc w1 ref (WSCap w2 args w3) use block) = concat [tokFunction,
+ unparse w1, maybe [] ((tokAmp ++) . unparse) ref, unparse w2,
+ tokLParen, unparse args, tokRParen, unparse w3, unparse use, unparse block]
+
+-- Stmt
+
+instance Unparse Stmt where
+ unparse stmt = case stmt of
+ StmtBlock a -> unparse a
+ StmtBreak iMb w end -> tokBreak ++ unparse iMb ++ unparse w ++ unparse end
+ StmtClass a -> unparse a
+ StmtContinue iMb w end -> tokContinue ++ unparse iMb ++ unparse w ++
+ unparse end
+ StmtDeclare a -> unparse a
+ StmtDoWhile a -> unparse a
+ StmtEcho a end -> tokEcho ++ intercalate tokComma (map unparse a) ++
+ unparse end
+ StmtExpr a b c -> unparse a ++ unparse b ++ unparse c
+ StmtFor a -> unparse a
+ StmtForeach a -> unparse a
+ StmtFuncDef a -> unparse a
+ StmtGlobal a end -> tokGlobal ++
+ intercalate tokComma (map unparse a) ++ unparse end
+ StmtIf a -> unparse a
+ StmtInterface a -> unparse a
+ StmtNamespace n end -> tokNamespace ++ unparse n ++ unparse end
+ StmtNothing end -> unparse end
+ StmtReturn rMb w end -> tokReturn ++ unparse rMb ++ unparse w ++
+ unparse end
+ StmtStatic a end -> tokStatic ++ intercalate tokComma (map unparse a) ++
+ unparse end
+ StmtSwitch a -> unparse a
+ StmtThrow a end -> tokThrow ++ unparse a ++ unparse end
+ StmtTry a cs -> tokTry ++ unparse a ++ unparse cs
+ StmtUnset (WSCap w1 a w2) end -> tokUnset ++ unparse w1 ++ tokLParen ++
+ intercalate tokComma (map unparse a) ++ tokRParen ++ unparse w2 ++
+ unparse end
+ StmtUse n end -> tokUse ++ unparse n ++ unparse end
+ StmtWhile a -> unparse a
+
+instance Unparse StmtEnd where
+ unparse StmtEndSemi = tokSemi
+ unparse (StmtEndClose a) = tokClosePhp ++ unparse a
+
+instance Unparse TopLevel where
+ unparse (TopLevel s echoOrTok) = s ++
+ maybe "" (either ((tokOpenPhpEcho ++) . unparse) ("<?" ++)) echoOrTok
+
+instance (Unparse a) => Unparse (Block a) where
+ unparse (Block a) = tokLBrace ++ unparse a ++ tokRBrace
+
+unparsePre :: [(String, WS)] -> String
+unparsePre = concatMap (\ (a, b) -> a ++ unparse b)
+
+instance Unparse Class where
+ unparse (Class pre (WSCap w1 name w2) extends impls block) = concat [
+ unparsePre pre, tokClass, unparse w1, name, unparse w2,
+ maybe [] ((tokExtends ++) . unparse) extends,
+ if null impls then []
+ else tokImplements ++ intercalate tokComma (map unparse impls),
+ unparse block]
+
+instance Unparse ClassStmt where
+ unparse stmt = case stmt of
+ CStmtVar pre a end -> IC.intercalUnparser id unparse pre ++
+ intercalate tokComma (map unparse a) ++ unparse end
+ CStmtConst a -> cStmtConstUnparser a
+ CStmtFuncDef pre a -> unparsePre pre ++ unparse a
+ CStmtAbstrFunc a -> unparse a
+ CStmtCategory a -> tokCategory ++ a ++ tokSemi
+ CStmtChildren a -> tokChildren ++ a ++ tokSemi
+ CStmtAttribute a -> tokAttribute ++ a ++ tokSemi
+
+cStmtConstUnparser :: (Unparse a) => [a] -> String
+cStmtConstUnparser vars = tokConst ++
+ intercalate tokComma (map unparse vars) ++ tokSemi
+
+instance Unparse AbstrFunc where
+ unparse (AbstrFunc pre ref name args ws end) = concat [unparsePre pre,
+ tokFunction, maybe "" ((++ tokAmp) . unparse) ref, unparse name, tokLParen,
+ either unparse (intercalate tokComma . map unparse) args, tokRParen,
+ unparse ws, unparse end]
+
+instance (Unparse a) => Unparse (VarEqVal a) where
+ unparse (VarEqVal var w expr) = unparse var ++ w2With tokEquals w ++
+ unparse expr
+
+-- todo: the block form too? does anyone use it? declare is terrible anyway..
+instance Unparse Declare where
+ unparse (Declare (WSCap w1 (name, expr) w2) end) = concat [tokDeclare,
+ unparse w1, tokLParen, unparse name, tokEquals, unparse expr, tokRParen,
+ unparse w2, unparse end]
+
+instance Unparse DoWhile where
+ unparse (DoWhile block (WSCap w1 (WSCap w2 expr w3) w4) end) = concat [tokDo,
+ unparse block, tokWhile, unparse w1, tokLParen, unparse w2, unparse expr,
+ unparse w3, tokRParen, unparse w4, unparse end]
+
+instance Unparse For where
+ unparse (For (WSCap w1 (inits, conds, incrs) w2) block) = concat [
+ tokFor, unparse w1, tokLParen,
+ intercalate tokSemi $ map unparse [inits, conds, incrs],
+ tokRParen, unparse w2, unparse block]
+
+instance Unparse ForPart where
+ unparse (ForPart e) = either unparse (intercalate tokComma . map unparse) e