Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Fixes #1; colon notation for "if" control structures.

Added some things to help with testing.
I've used GenericPretty to display AST tree structures in debugging.
Unfortunately it requires "deriving Generic" and GHC.Generics.
We're already "deriving (Data, Typeable)" which seems to be similar
but not as GHC-only so probably better?  Have to look into.
Also GenericPretty makes things too wide.  I played around with an
alternative src/Test/PrettyPrint.hs but gave up on it for now..

Also tested by running dump-as-id on wordpress, which now works until
there's a "foreach .. :".  So I guess that's next.
  • Loading branch information...
commit 32c0f0f37dbdee94aae7a798f6f00afef62a1c6e 1 parent eb89cc4
@dancor dancor authored
View
34 lex-pass.cabal
@@ -19,9 +19,21 @@ executable lex-pass
buildable: False
hs-source-dirs: src
main-is: Main.hs
- build-depends: FUtil, HSH >= 2, MissingH, base >= 4, binary, bytestring,
- containers, derive, directory, filepath, mtl, parsec == 3.*,
- process, syb
+ build-depends: FUtil,
+ GenericPretty,
+ HSH >= 2,
+ MissingH,
+ base >= 4,
+ binary,
+ bytestring,
+ containers,
+ derive,
+ directory,
+ filepath,
+ mtl,
+ parsec == 3.*,
+ process,
+ syb
ghc-options: -threaded
executable lex-pass-test
@@ -29,7 +41,19 @@ executable lex-pass-test
buildable: False
hs-source-dirs: src
main-is: Lang/Php/Ast/Test.hs
- build-depends: FUtil, HSH >= 2, base >= 4, binary, bytestring, containers,
- derive, directory, filepath, mtl, parsec == 3.*, process, syb
+ build-depends: FUtil,
+ GenericPretty,
+ HSH >= 2,
+ base >= 4,
+ binary,
+ bytestring,
+ containers,
+ derive,
+ directory,
+ filepath,
+ mtl,
+ parsec == 3.*,
+ process,
+ syb
ghc-options: -threaded
View
8 src/Data/Intercal.hs
@@ -1,8 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
module Data.Intercal where
-import Common
import Control.Arrow
import Control.Applicative
import Control.Monad
@@ -11,8 +11,11 @@ import Data.Data
import Prelude hiding (concatMap, map)
import qualified Prelude
+import Common
+import Text.PrettyPrint.GenericPretty
+
data Intercal a b = Intercal a b (Intercal a b) | Interend a
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
-- we're using method that should be faster-but-bigger instead of storing
-- length. this is probably the same as the derive one, just use that?
@@ -105,3 +108,4 @@ append :: a -> b -> Intercal b a -> Intercal b a
append a b (Interend b0) = Intercal b0 a $ Interend b
append a b (Intercal b0 a0 rest) = Intercal b0 a0 $ append a b rest
+instance (Out a, Out b) => Out (Intercal a b)
View
22 src/Lang/Php/Ast/Common.hs
@@ -1,6 +1,11 @@
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeSynonymInstances,
- FlexibleInstances, FlexibleContexts, OverlappingInstances,
- UndecidableInstances #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
module Lang.Php.Ast.Common (
module Common,
@@ -17,7 +22,6 @@ module Lang.Php.Ast.Common (
WS, WS2, WSElem(..), WSCap(..), WSCap2, capify, wsNoNLParser, w2With,
upToCharsOrEndParser) where
-import Common
import Control.Applicative hiding ((<|>), many, optional, Const)
import Control.Arrow
import Control.Monad
@@ -28,12 +32,15 @@ import Data.DeriveTH
import Data.List
import Data.Maybe
import FUtil
+import Text.PrettyPrint.GenericPretty
+
+import Common
import qualified Data.Intercal as IC
type WS = [WSElem]
data WSElem = WS String | LineComment Bool String | Comment String
- deriving (Show, Eq, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
type WS2 = (WS, WS)
@@ -99,7 +106,7 @@ data WSCap a = WSCap {
wsCapPre :: WS,
wsCapMain :: a,
wsCapPost :: WS}
- deriving (Show, Eq, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
instance (Unparse a) => Unparse (WSCap a) where
unparse (WSCap a b c) = concat [unparse a, unparse b, unparse c]
@@ -118,6 +125,9 @@ instance Parse a => Parse (a, WS) where
type WSCap2 a = WSCap (WSCap a)
+instance Out WSElem
+instance (Out a) => Out (WSCap a)
+
$(derive makeBinary ''WSElem)
$(derive makeBinary ''WSCap)
View
70 src/Lang/Php/Ast/ExprTypes.hs
@@ -1,6 +1,10 @@
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
+{-# 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
@@ -23,13 +27,13 @@ import qualified Data.Intercal as IC
-- refactoring.
data Val = ValLOnlyVal LOnlyVal | ValROnlyVal ROnlyVal | ValLRVal LRVal
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data LVal = LValLOnlyVal LOnlyVal | LValLRVal LRVal
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data RVal = RValROnlyVal ROnlyVal | RValLRVal LRVal
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Var =
-- In php, indexing is oddly coupled very tightly with being a non-dyn var.
@@ -37,39 +41,39 @@ data Var =
VarDyn WS Var | -- "$$a"
-- note: "$$a[0]()->a" == "${$a[0]}()->a"
VarDynExpr WS (WSCap Expr) -- "${$a . '_'}"
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data DynConst = DynConst [(String, WS2)] Var -- "a::$a"
- deriving (Eq, Show, Typeable, Data)
+ 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 (Eq, Show, Typeable, Data)
+ 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 (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Const = Const [(String, WS2)] String -- "a::a"
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data ROnlyVal =
ROnlyValConst Const |
-- "a()", "$a()"
ROnlyValFunc (Either LRVal Const) WS (Either WS [WSCap (Either Expr LVal)])
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Memb =
MembStr String |
MembVar Var |
MembExpr (WSCap Expr)
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
-- Expr's
@@ -103,37 +107,37 @@ data Expr =
ExprTernaryIf TernaryIf |
-- FIXME: this fb extension should be separated to a superclass-like Lang?
ExprXml Xml
- deriving (Eq, Show, Typeable, Data)
+ 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 (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data XmlLitOrExpr = XmlLit String | XmlExpr (WSCap Expr)
- deriving (Eq, Show, Typeable, Data)
+ 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 (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data BinOpBy = BBitAnd | BBitOr | BConcat | BDiv | BMinus | BMod | BMul |
BPlus | BShiftL | BShiftR | BXor
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data PreOp = PrPrint | PrAt | PrBitNot | PrClone | PrNegate | PrNot | PrPos |
PrSuppress | PrIncr | PrDecr
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data PostOp = PoIncr | PoDecr
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data IncOrReq = Inc | Req
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data OnceOrNot = Once | NotOnce
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data TernaryIf = TernaryIf {
ternaryIfCond :: Expr,
@@ -141,10 +145,32 @@ data TernaryIf = TernaryIf {
ternaryIfThen :: Expr,
ternaryIfWS2 :: WS2,
ternaryIfElse :: Expr}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data DubArrowMb = DubArrowMb (Maybe (Expr, WS2)) Expr
- deriving (Eq, Show, Typeable, Data)
+ 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)
View
16 src/Lang/Php/Ast/Lex.hs
@@ -1,12 +1,16 @@
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
module Lang.Php.Ast.Lex where
+import Text.PrettyPrint.GenericPretty
+
import Lang.Php.Ast.Common
import qualified Data.Set as Set
data StrLit = StrLit String
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
instance Parse StrLit where
parse = StrLit <$> (
@@ -43,7 +47,7 @@ backticksParser :: Parser String
backticksParser = liftM2 (:) (char '`') (strLitRestParserCurly '`' False)
data NumLit = NumLit String
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
instance Parse NumLit where
-- could be tighter
@@ -58,7 +62,7 @@ instance Unparse NumLit where
unparse (NumLit a) = a
data HereDoc = HereDoc String
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
instance Parse HereDoc where
parse = HereDoc <$> do
@@ -437,6 +441,10 @@ tokChildrenP = identCI tokChildren
tokAttribute = "attribute"
tokAttributeP = identCI tokAttribute
+instance Out HereDoc
+instance Out NumLit
+instance Out StrLit
+
$(derive makeBinary ''HereDoc)
$(derive makeBinary ''NumLit)
$(derive makeBinary ''StrLit)
View
29 src/Lang/Php/Ast/StmtParse.hs
@@ -243,6 +243,12 @@ instance Parse (If, WS) where
(isColon, ifBlockAndW) <- ifBlockP
ifRestP isColon $ IC.Interend ifBlockAndW
+-- | Parse the first conditional and block of an "if" control structure.
+-- Returns:
+-- - True iff the control structure uses the alternative colon-based
+-- syntax
+-- - the conditional and block
+-- - any immediately trailing whitespace
ifBlockP :: Parser (Bool, (IfBlock, WS))
ifBlockP = do
cond <- ifCondP
@@ -260,16 +266,20 @@ instance Parse (IfBlock, WS) where
cond <- ifCondP
first (IfBlock cond) <$> parse
+-- | Parse the entire remainder of an "if" control structure given
+-- is-it-colon-syntax and the first conditional-and-block.
ifRestP :: Bool -> IC.Intercal (IfBlock, WS) (Maybe WS) -> Parser (If, WS)
ifRestP isColon soFar =
elseifContP isColon soFar <|>
elseContP isColon soFar <|>
do
- w' <- if isColon then tokEndifP >> (parse :: Parser WS) else return []
+ w' <- if isColon then tokEndifP >> parse else return []
return (If isColon soFar' Nothing, w ++ w')
where
(soFar', w) = ifReconstr soFar
+-- | Parse a conditional-and-block ensuring that its colon-syntax-or-not
+-- matches the rest of the "if" control structure.
ifBlockPCheck :: Bool -> Parser (IfBlock, WS)
ifBlockPCheck isColon = do
(isColon', ifBlockAndW) <- ifBlockP
@@ -277,34 +287,43 @@ ifBlockPCheck isColon = do
fail "You can't mix colon notation in one if block."
return ifBlockAndW
+-- | Parse the rest of an "if" control structure where the next token is
+-- "elseif".
elseifContP :: Bool -> IC.Intercal (IfBlock, WS) (Maybe WS) -> Parser (If, WS)
elseifContP isColon soFar = tokElseifP >> do
ifBlockAndW <- ifBlockPCheck isColon
ifRestP isColon $ (\ x -> IC.append Nothing x soFar) ifBlockAndW
+-- | Parse the rest of an "if" control structure where the next token is
+-- "else".
elseContP :: Bool -> IC.Intercal (IfBlock, WS) (Maybe WS) -> Parser (If, WS)
elseContP isColon soFar = tokElseP >> do
w <- parse
elseIfContP isColon soFar w <|> elseEndP isColon soFar w
+-- | Parse the rest of an "if" control structure where we've just seen
+-- "else"+WS and will now see "if".
elseIfContP :: Bool -> IC.Intercal (IfBlock, WS) (Maybe WS) -> WS ->
Parser (If, WS)
elseIfContP isColon soFar w = tokIfP >> do
ifBlockAndW <- ifBlockPCheck isColon
ifRestP isColon $ (\ x -> IC.append (Just w) x soFar) ifBlockAndW
+-- | Parse the rest of an "if" control structure where we've just seen
+-- "else"+WS and now there is only the final block.
elseEndP :: Bool -> IC.Intercal (IfBlock, WS) (Maybe WS) -> WS ->
Parser (If, WS)
elseEndP True soFar w2 = do
let (soFar', w1) = ifReconstr soFar
- _ <- tokColonP
- block <- Right . Block <$> stmtListP
- return (If True soFar' $ Just ((w1, w2), block), [])
+ block <- tokColonP >> Right . Block <$> stmtListP
+ w3 <- tokEndifP >> parse
+ return (If True soFar' $ Just ((w1, w2), block), w3)
elseEndP False soFar w2 = do
let (soFar', w1) = ifReconstr soFar
(block, wEnd) <- parse
return (If False soFar' $ Just ((w1, w2), block), wEnd)
+-- | Regroup a parsed "if" control structure to group WS together.
ifReconstr :: IC.Intercal (IfBlock, WS) (Maybe WS) ->
(IC.Intercal IfBlock (WS, Maybe WS), WS)
ifReconstr a = (IC.unbreakEnd (map rePairRight main) ifBlockLast, w) where
@@ -497,7 +516,7 @@ instance Parse (While, WS) where
first (While e) <$> parse
instance Parse (a, WS) => Parse (Block a) where
- parse = tokLBraceP >> Block <$> liftM2 IC.unbreakStart parse parse <*
+ parse = tokLBraceP >> Block <$> liftM2 IC.unbreakStart parse parse <*
tokRBraceP
instance Parse TopLevel where
View
86 src/Lang/Php/Ast/StmtTypes.hs
@@ -1,7 +1,10 @@
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
-
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TemplateHaskell #-}
module Lang.Php.Ast.StmtTypes where
+import Text.PrettyPrint.GenericPretty
+
import Lang.Php.Ast.Common
import Lang.Php.Ast.ExprTypes
import qualified Data.Intercal as IC
@@ -36,18 +39,18 @@ data Stmt =
StmtUnset (WSCap [WSCap LRVal]) StmtEnd |
StmtUse (WSCap Use) StmtEnd |
StmtWhile While
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
-- a block has {}'s, so one-liner's are not considered blocks
-- and a (Block Stmt) is not the same as a StmtList tho it has the same ast
data Block a = Block (IC.Intercal WS a)
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Namespace = Namespace String
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Use = Use String
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Func = Func {
funcWS :: WS,
@@ -55,18 +58,18 @@ data Func = Func {
funcName :: String,
funcArgs :: WSCap (Either WS [WSCap FuncArg]),
funcBlock :: Block Stmt}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Interface = Interface {
ifaceName :: WSCap Const,
ifaceExtends :: [WSCap Const],
ifaceBlock :: Block IfaceStmt}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data IfaceStmt =
IfaceConst [WSCap (VarEqVal Const)] |
IfaceFunc AbstrFunc
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data AbstrFunc = AbstrFunc {
abstrFuncPre :: [(String, WS)],
@@ -75,7 +78,7 @@ data AbstrFunc = AbstrFunc {
abstrFuncArgs :: Either WS [WSCap FuncArg],
abstrFuncWS :: WS,
abstrFuncStmtEnd :: StmtEnd}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Class = Class {
classPre :: [(String, WS)],
@@ -83,19 +86,19 @@ data Class = Class {
classExtends :: Maybe (WSCap Const),
classImplements :: [WSCap Const],
classBlock :: Block ClassStmt}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data FuncArg = FuncArg {
funcArgType :: Maybe (Maybe Const, WS),
funcArgRef :: Maybe WS,
funcArgVar :: VarMbVal}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data VarMbVal = VarMbVal Var (Maybe (WS2, Expr))
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data VarEqVal a = VarEqVal a WS2 Expr
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data ClassStmt =
-- this list must have at least one element.. should i make a type for that?
@@ -106,74 +109,101 @@ data ClassStmt =
CStmtCategory String |
CStmtChildren String |
CStmtAttribute String
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data DoWhile = DoWhile {
doWhileBlock :: WSCap BlockOrStmt,
doWhileExpr :: WSCap2 Expr,
doWhileStmtEnd :: StmtEnd}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Declare = Declare {
declareHeader :: WSCap (WSCap Const, WSCap Expr),
declareStmtEnd :: StmtEnd}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data For = For {
forHeader :: WSCap (ForPart, ForPart, ForPart),
forBlock :: BlockOrStmt}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data ForPart = ForPart (Either WS [WSCap Expr])
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Foreach = Foreach {
foreachHeader :: WSCap (WSCap Expr, WSCap DubArrowMb),
foreachBlock :: BlockOrStmt}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data If = If {
-- And when ifAltColonSyntax is True, all the BlockOrStmts must be Blocks.
ifAltColonSyntax :: Bool,
ifAndIfelses :: IC.Intercal IfBlock (WS, Maybe WS),
ifElse :: Maybe (WS2, BlockOrStmt)}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data IfBlock = IfBlock {
ifBlockExpr :: WSCap2 Expr,
ifBlockBlock :: BlockOrStmt}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Switch = Switch {
switchExpr :: WSCap2 Expr,
switchWS :: WS,
switchCases :: [Case]}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Case = Case {
caseExpr :: Either WS (WSCap Expr),
caseStmtList :: StmtList}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data Catch = Catch {
catchHeader :: WSCap (WSCap Const, Expr),
catchWS :: WS,
catchBlock :: Block Stmt}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data While = While {
whileExpr :: WSCap2 Expr,
whileBlock :: BlockOrStmt}
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data TopLevel = TopLevel String (Maybe (Either (WSCap Expr, StmtEnd) String))
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
data StmtEnd = StmtEndSemi | StmtEndClose TopLevel
- deriving (Eq, Show, Typeable, Data)
+ deriving (Data, Eq, Generic, Show, Typeable)
type BlockOrStmt = Either Stmt (Block Stmt)
+instance Out AbstrFunc
+instance (Out a) => Out (Block a)
+instance Out Case
+instance Out Catch
+instance Out Class
+instance Out ClassStmt
+instance Out Declare
+instance Out DoWhile
+instance Out For
+instance Out ForPart
+instance Out Foreach
+instance Out Func
+instance Out FuncArg
+instance Out If
+instance Out IfaceStmt
+instance Out IfBlock
+instance Out Interface
+instance Out Namespace
+instance Out Stmt
+instance Out StmtEnd
+instance Out Switch
+instance Out TopLevel
+instance Out Use
+instance Out VarMbVal
+instance (Out a) => Out (VarEqVal a)
+instance Out While
+
$(derive makeBinary ''AbstrFunc)
$(derive makeBinary ''Block)
$(derive makeBinary ''Case)
View
60 src/Test/Hm.hs
@@ -0,0 +1,60 @@
+import Control.Applicative hiding (Const)
+import Data.Tree
+--import PrettyPrint
+--import Text.ParserCombinators.Parsec
+import Text.PrettyPrint.GenericPretty
+
+import Lang.Php.Ast.Common
+import Lang.Php.Ast.StmtTypes
+import Lang.Php.Ast.StmtParse
+
+import Lang.Php.Ast.ExprTypes
+import Lang.Php.Ast.Lex
+import Data.Intercal
+
+{-
+class ToTree a where
+ toTree :: a -> Tree String
+
+instance ToTree If where
+ toTree (If a b c) =
+-}
+
+myIfBlock = IfBlock
+ {ifBlockExpr = WSCap {wsCapPre = [],
+ wsCapMain = WSCap {wsCapPre = [],
+ wsCapMain = ExprRVal (RValROnlyVal (ROnlyValConst (Const []
+ "true"))),
+ wsCapPost = []},
+ wsCapPost = []},
+ ifBlockBlock = Right $ Block (Intercal [WS "\n"]
+ (StmtExpr (ExprAssign Nothing
+ (LValLRVal (LRValVar (DynConst []
+ (Var "a"
+ []))))
+ ([],
+ [])
+ (ExprNumLit (NumLit "4")))
+ []
+ StmtEndSemi)
+ (Interend [WS "\n"]))}
+
+run =
+ runParser ((parse :: Parser (If, WS)) <* eof) () "lol" $
+ intercalate "\n" ["if(true):","$a=4;","endif"]
+
+main = do
+ either print pp run
+
+{-
+*Lang.Php.Ast.StmtParse> runParser ((parse :: Parser (If, WS)) <* eof) () "lol" $ intercalate "\n" ["if(true):","$a=4;","endif"]
+ Right (If {ifAltColonSyntax = True, ifAndIfelses = Interend (IfBlock {ifBlockExpr = WSCap {wsCapPre = [], wsCapMain = WSCap {wsCapPre = [], wsCapMain = ExprRVal (RValROnlyVal (ROnlyValConst (Const [] "true"))), wsCapPost = []}, wsCapPost = []}, ifBlockBlock = Right (Block (Intercal [WS "\n"] (StmtExpr (ExprAssign Nothing (LValLRVal (LRValVar (DynConst [] (Var "a" [])))) ([],[]) (ExprNumLit (NumLit "4"))) [] StmtEndSemi) (Interend [WS "\n"])))}), ifElse = Nothing},[])
+*Lang.Php.Ast.StmtParse> runParser (ifRestP True (IC.Interend (IfBlock {ifBlockExpr = WSCap {wsCapPre = [], wsCapMain = WSCap {wsCapPre = [], wsCapMain = ExprRVal (RValROnlyVal (ROnlyValConst (Const [] "true"))), wsCapPost = []}, wsCapPost = []}, ifBlockBlock = Right (Block (Intercal [WS "\n"] (StmtExpr (ExprAssign Nothing (LValLRVal (LRValVar (DynConst [] (Var "a" [])))) ([],[]) (ExprNumLit (NumLit "4"))) [] StmtEndSemi) (Interend [WS "\n"])))}), ifElse = Nothing}, []))) <* eof) () "lol" $ intercalate "\n" ["if(true):","$a=4;","endif"]
+
+<interactive>:26:435: parse error on input `='
+*Lang.Php.Ast.StmtParse> runParser (ifRestP True (IC.Interend (IfBlock {ifBlockExpr = WSCap {wsCapPre = [], wsCapMain = WSCap {wsCapPre = [], wsCapMain = ExprRVal (RValROnlyVal (ROnlyValConst (Const [] "true"))), wsCapPost = []}, wsCapPost = []}, ifBlockBlock = Right (Block (Intercal [WS "\n"] (StmtExpr (ExprAssign Nothing (LValLRVal (LRValVar (DynConst [] (Var "a" [])))) ([],[]) (ExprNumLit (NumLit "4"))) [] StmtEndSemi) (Interend [WS "\n"])))}), ifElse = Nothing}, [])) <* eof) () "lol" $ intercalate "\n" ["if(true):","$a=4;","endif"]
+
+<interactive>:27:435: parse error on input `='
+*Lang.Php.Ast.StmtParse>
+Leaving GHCi.
+-}
View
50 src/Test/PrettyPrint.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module PrettyPrint where
+
+import Control.Applicative
+import Data.Generics
+import Data.List.Split
+import Data.Tree
+
+{-
+data Bar = Bar Int deriving (Data, Typeable)
+
+data Baz = Baz Int deriving (Data, Typeable)
+
+data FooD = Foo {
+ foo1 :: Bar,
+ foo2 :: Baz} deriving (Data, Typeable)
+
+data Foo2D = Foo2 Bar Baz deriving (Data, Typeable)
+
+lol = Foo (Bar 4) (Baz 5)
+
+lol2 = Foo2 (Bar 4) (Baz 5)
+-}
+
+pp4 :: Data a => a -> Tree (String, [String])
+pp4 var = Node (show c, fields) $ gmapQ pp4 var
+ where
+ c = toConstr var
+ fields = if isAlgType $ dataTypeOf var then constrFields c else []
+
+pp3 :: Data a => a -> Tree String
+pp3 = treeMergeSndToNextFst (\ fieldNames constrReps ->
+ zipWith (++) (map (++ "=") fieldNames ++ repeat "") constrReps) . pp4
+
+pp2 :: Data a => a -> String
+pp2 = unlines . map head . chunksOf 2 . lines . drawTree . pp3
+
+pp :: Data a => a -> IO ()
+pp = putStr . pp2
+
+treeMergeSndToNextFst :: (b -> [a] -> [a]) -> Tree (a, b) -> Tree a
+treeMergeSndToNextFst f (Node (a, b) kids) =
+ Node a $ zipWith Node kidAs' forests
+ where
+ kidAs' = f b kidAs
+ (kidAs, forests) = unzip $ map (treeToPair . treeMergeSndToNextFst f) kids
+
+treeToPair :: Tree a -> (a, Forest a)
+treeToPair (Node a kids) = (a, kids)
Please sign in to comment.
Something went wrong with that request. Please try again.