Skip to content
This repository
Browse code

Merge branch 'master' of git://github.com/facebook/lex-pass

  • Loading branch information...
commit 9816cc258098448f74caf3e3e35599a623a27f97 2 parents c87f981 + e8e4e35
arvidj authored
1  .gitignore
... ...
@@ -0,0 +1 @@
  1
+/src/CodeGen/Transf.hs
34  lex-pass.cabal
@@ -19,9 +19,21 @@ executable lex-pass
19 19
     buildable: False
20 20
   hs-source-dirs: src
21 21
   main-is:        Main.hs
22  
-  build-depends:  FUtil, HSH >= 2, MissingH, base >= 4, binary, bytestring,
23  
-                  containers, derive, directory, filepath, mtl, parsec == 3.*,
24  
-                  process, syb
  22
+  build-depends:  base           >= 4 && < 5,
  23
+                  binary,
  24
+                  binary-generic,
  25
+                  bytestring,
  26
+                  containers,
  27
+                  directory,
  28
+                  filepath,
  29
+                  FUtil,
  30
+                  GenericPretty,
  31
+                  HSH            >= 2 && < 3,
  32
+                  MissingH,
  33
+                  mtl,
  34
+                  parsec         >= 3 && < 4,
  35
+                  process,
  36
+                  syb
25 37
   ghc-options:    -threaded
26 38
 
27 39
 executable lex-pass-test
@@ -29,7 +41,19 @@ executable lex-pass-test
29 41
     buildable: False
30 42
   hs-source-dirs: src
31 43
   main-is:        Lang/Php/Ast/Test.hs
32  
-  build-depends:  FUtil, HSH >= 2, base >= 4, binary, bytestring, containers,
33  
-                  derive, directory, filepath, mtl, parsec == 3.*, process, syb
  44
+  build-depends:  base           >= 4,
  45
+                  binary,
  46
+                  binary-generic,
  47
+                  bytestring,
  48
+                  containers,
  49
+                  directory,
  50
+                  filepath,
  51
+                  FUtil,
  52
+                  GenericPretty,
  53
+                  HSH            >= 2 && < 3,
  54
+                  mtl,
  55
+                  parsec         >= 3 && < 4,
  56
+                  process,
  57
+                  syb
34 58
   ghc-options:    -threaded
35 59
 
48  src/Common.hs
... ...
@@ -1,40 +1,12 @@
1  
-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
2  
-
3  
-module Common (
4  
-  module Text.ParserCombinators.Parsec,
5  
-  Oper, Parse(..), Unparse(..)) where
6  
-
7  
-import Control.Applicative hiding (many, (<|>))
  1
+module Common
  2
+    (
  3
+      module Control.Applicative
  4
+    , module Control.Arrow
  5
+    , module Control.Monad
  6
+    , module Text.ParserCombinators.Parsec
  7
+    ) where
  8
+
  9
+import Control.Applicative hiding ((<|>), many, optional, Const)
  10
+import Control.Arrow
8 11
 import Control.Monad
9 12
 import Text.ParserCombinators.Parsec hiding (State, parse, choice)
10  
-import Text.ParserCombinators.Parsec.Expr
11  
-
12  
--- parsec 2 vs 3 stuff
13  
-
14  
-type Oper a = Operator Char () a
15  
-
16  
-class Parse a where
17  
-  parse :: Parser a
18  
-
19  
-class Unparse a where
20  
-  unparse :: a -> String
21  
-
22  
-instance (Parse a) => Parse [a] where
23  
-  parse = many parse
24  
-
25  
-instance (Parse a, Parse b) => Parse (Either a b) where
26  
-  parse = Left <$> parse <|> Right <$> parse
27  
-
28  
-instance (Unparse a, Unparse b) => Unparse (Either a b) where
29  
-  unparse (Left a) = unparse a
30  
-  unparse (Right a) = unparse a
31  
-
32  
-instance (Unparse a, Unparse b) => Unparse (a, b) where
33  
-  unparse (a, b) = unparse a ++ unparse b
34  
-
35  
-instance (Unparse a) => Unparse [a] where
36  
-  unparse = concatMap unparse
37  
-
38  
-instance (Unparse a) => Unparse (Maybe a) where
39  
-  unparse = maybe "" unparse
40  
-
21  src/Data/Intercal.hs
... ...
@@ -1,8 +1,8 @@
1 1
 {-# LANGUAGE DeriveDataTypeable #-}
  2
+{-# LANGUAGE DeriveGeneric #-}
2 3
 
3 4
 module Data.Intercal where
4 5
 
5  
-import Common
6 6
 import Control.Arrow
7 7
 import Control.Applicative
8 8
 import Control.Monad
@@ -11,19 +11,13 @@ import Data.Data
11 11
 import Prelude hiding (concatMap, map)
12 12
 import qualified Prelude
13 13
 
  14
+import Common
  15
+import Parse
  16
+import Unparse
  17
+import Text.PrettyPrint.GenericPretty
  18
+
14 19
 data Intercal a b = Intercal a b (Intercal a b) | Interend a
15  
-  deriving (Eq, Show, Typeable, Data)
16  
-
17  
--- we're using method that should be faster-but-bigger instead of storing
18  
--- length.  this is probably the same as the derive one, just use that?
19  
-instance (Binary a, Binary b) => Binary (Intercal a b) where
20  
-  put (Intercal x y r) = put (0 :: Word8) >> put x >> put y >> put r
21  
-  put (Interend x)     = put (1 :: Word8) >> put x
22  
-  get = do
23  
-    tag <- getWord8
24  
-    case tag of
25  
-      0 -> liftM3 Intercal get get get
26  
-      1 -> liftM  Interend get
  20
+  deriving (Data, Eq, Generic, Show, Typeable)
27 21
 
28 22
 intercalParser :: Parser a -> Parser b -> Parser (Intercal a b)
29 23
 intercalParser a b = do
@@ -105,3 +99,4 @@ append :: a -> b -> Intercal b a -> Intercal b a
105 99
 append a b (Interend b0) = Intercal b0 a $ Interend b
106 100
 append a b (Intercal b0 a0 rest) = Intercal b0 a0 $ append a b rest
107 101
 
  102
+instance (Out a, Out b) => Out (Intercal a b)
27  src/Data/List/NonEmpty.hs
... ...
@@ -0,0 +1,27 @@
  1
+{-# LANGUAGE DeriveDataTypeable #-}
  2
+{-# LANGUAGE DeriveGeneric #-}
  3
+
  4
+module Data.List.NonEmpty where
  5
+
  6
+import Data.Binary
  7
+import Data.Data
  8
+import qualified Data.List as L
  9
+import Text.PrettyPrint.GenericPretty
  10
+
  11
+-- | A non-empty list
  12
+data NonEmpty a = NonEmpty
  13
+    { head :: a
  14
+    , tail :: [a]
  15
+    } deriving (Data, Eq, Generic, Show, Typeable)
  16
+
  17
+toList :: NonEmpty a -> [a]
  18
+toList (NonEmpty x xs) = x:xs
  19
+
  20
+fromList :: [a] -> Maybe (NonEmpty a)
  21
+fromList [] = Nothing
  22
+fromList (x:xs) = Just $ NonEmpty x xs
  23
+
  24
+length :: NonEmpty a -> Int
  25
+length = L.length . toList
  26
+
  27
+instance (Out a) => Out (NonEmpty a)
17  src/Lang/Php/Ast.hs
... ...
@@ -1,24 +1,24 @@
1  
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
  1
+{-# LANGUAGE DeriveDataTypeable #-}
2 2
 
3 3
 module Lang.Php.Ast (
4 4
   module Lang.Php.Ast.Common,
5  
-  module Lang.Php.Ast.Expr,
6 5
   module Lang.Php.Ast.Lex,
7 6
   module Lang.Php.Ast.Stmt,
8 7
   Ast
9 8
   ) where
10 9
 
11  
-import Common
12 10
 import Control.Applicative hiding ((<|>), many)
13 11
 import Control.Arrow
14 12
 import Control.Monad
  13
+import Data.Binary.Generic
15 14
 import Data.Char
  15
+
  16
+import Common
  17
+import qualified Data.ByteString as BS
  18
+import qualified Data.Intercal as IC
16 19
 import Lang.Php.Ast.Common
17  
-import Lang.Php.Ast.Expr
18 20
 import Lang.Php.Ast.Lex
19 21
 import Lang.Php.Ast.Stmt
20  
-import qualified Data.ByteString as BS
21  
-import qualified Data.Intercal as IC
22 22
 
23 23
 data Ast = Ast TopLevel StmtList
24 24
   deriving (Eq, Show, Typeable, Data)
@@ -27,7 +27,4 @@ instance Unparse Ast where
27 27
   unparse (Ast t s) = unparse t ++ unparse s
28 28
 
29 29
 instance Parse Ast where
30  
-  parse = liftM2 Ast parse stmtListParser
31  
-
32  
-$(derive makeBinary ''Ast)
33  
-
  30
+  parse = liftM2 Ast parse stmtListP
28  src/Lang/Php/Ast/ArgList.hs
... ...
@@ -1,11 +1,23 @@
1  
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
2  
-
3 1
 module Lang.Php.Ast.ArgList where
4 2
 
5 3
 import Data.Either.Utils
  4
+
  5
+import qualified Data.List.NonEmpty as NE
6 6
 import Lang.Php.Ast.Common
7 7
 import Lang.Php.Ast.Lex
8  
-import qualified Data.Intercal as IC
  8
+
  9
+type ArgList a = Either WS [WSCap a]
  10
+
  11
+type ReqArgList a = NE.NonEmpty (WSCap a)
  12
+
  13
+argListUnparser :: Unparse a => Unparser (ArgList a)
  14
+argListUnparser x =
  15
+  tokLParen ++
  16
+  either unparse (intercalate tokComma . map unparse) x ++
  17
+  tokRParen
  18
+
  19
+reqArgListUnparser :: Unparse a => Unparser (ReqArgList a)
  20
+reqArgListUnparser = argListUnparser . Right . NE.toList
9 21
 
10 22
 -- e.g. ($a, $b, $c) in f($a, $b, $c) or () in f()
11 23
 argListParser :: Parser (a, WS) -> Parser (Either WS [WSCap a])
@@ -25,9 +37,9 @@ mbArgListParser :: Parser (a, WS) -> Parser (Either WS [Either WS (WSCap a)])
25 37
 mbArgListParser = genArgListParser True False True True
26 38
 
27 39
 -- e.g. ($a, $b, $c) in isset($a, $b, $c)
28  
-issetListParser :: Parser (a, WS) -> Parser [WSCap a]
29  
-issetListParser = fmap (map fromRight . fromRight) .
30  
-  genArgListParser False False False True
  40
+reqArgListParser :: Parser (a, WS) -> Parser (ReqArgList a)
  41
+reqArgListParser p = fromJust . NE.fromList . map fromRight . fromRight <$>
  42
+  genArgListParser False False False True p
31 43
 
32 44
 -- todo: this can just be separate right?
33 45
 -- e.g. ($a) in exit($a) or () in exit()
@@ -38,8 +50,7 @@ exitListParser = fmap (fmap (fromRight . head)) .
38 50
 genArgListParser :: Bool -> Bool -> Bool -> Bool -> Parser (a, WS) ->
39 51
   Parser (Either WS [Either WS (WSCap a)])
40 52
 genArgListParser emptyElemsAllowed finalCommaAllowed singleWSPoss
41  
-    overOneArgAllowed p = do
42  
-  tokLParenP
  53
+    overOneArgAllowed p = tokLParenP >> do
43 54
   args <- grabArgs emptyElemsAllowed finalCommaAllowed singleWSPoss
44 55
     overOneArgAllowed p
45 56
   return $ case args of
@@ -66,4 +77,3 @@ grabArgs emptyElemsAllowed finalCommaAllowed isFirstArgAndWSPoss
66 77
       grabArgs emptyElemsAllowed finalCommaAllowed False overOneArgAllowed p
67 78
   (arg:) <$> (if canContinue then ((tokCommaP >> cont) <|>) else id)
68 79
     (tokRParenP >> return [])
69  
-
141  src/Lang/Php/Ast/Common.hs
... ...
@@ -1,123 +1,32 @@
1  
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell, TypeSynonymInstances,
2  
-             FlexibleInstances, FlexibleContexts, OverlappingInstances,
3  
-             UndecidableInstances #-}
  1
+{-# LANGUAGE FlexibleInstances #-}
  2
+{-# LANGUAGE UndecidableInstances #-}
  3
+
  4
+module Lang.Php.Ast.Common
  5
+    (
  6
+      module Data.Binary
  7
+    , module Data.Char
  8
+    , module Data.Data
  9
+    , module Data.List
  10
+    , module Data.Maybe
  11
+
  12
+    , module Common
  13
+    , module Parse
  14
+    , module Unparse
  15
+    , module Lang.Php.Ast.WS
  16
+    ) where
4 17
 
5  
-module Lang.Php.Ast.Common (
6  
-  module Common,
7  
-  module Control.Applicative,
8  
-  module Control.Arrow,
9  
-  module Control.Monad,
10  
-  module Data.Binary,
11  
-  module Data.Char,
12  
-  module Data.Data,
13  
-  module Data.DeriveTH,
14  
-  module Data.List,
15  
-  module Data.Maybe,
16  
-  module FUtil,
17  
-  WS, WS2, WSElem(..), WSCap(..), WSCap2, capify, wsNoNLParser, w2With,
18  
-  upToCharsOrEndParser) where
19  
-
20  
-import Common
21  
-import Control.Applicative hiding ((<|>), many, optional, Const)
22  
-import Control.Arrow
23  
-import Control.Monad
24 18
 import Data.Binary
  19
+import Data.Binary.Generic
25 20
 import Data.Char
26  
-import Data.Data hiding (Prefix, Infix)
27  
-import Data.DeriveTH
  21
+import Data.Data hiding (Infix, Prefix)
28 22
 import Data.List
29 23
 import Data.Maybe
30  
-import FUtil
31  
-import qualified Data.Intercal as IC
32  
-
33  
-type WS = [WSElem]
34  
-
35  
-data WSElem = WS String | LineComment Bool String | Comment String
36  
-  deriving (Show, Eq, Typeable, Data)
37  
-
38  
-type WS2 = (WS, WS)
39  
-
40  
-w2With :: (Unparse t, Unparse t1) => String -> (t, t1) -> String
41  
-w2With s (w1, w2) = unparse w1 ++ s ++ unparse w2
42  
-
43  
-instance Parse WSElem where
44  
-  parse = WS <$> many1 space <|>
45  
-    Comment <$> (tokStartCommentP >> upToCharsParser '*' '/') <|> do
46  
-      isSlash <- (tokLineCommentP >> return True) <|>
47  
-        (tokPoundP >> return False)
48  
-      (gotChars, c) <- upToCharsOrEndParser (/= '\n') '?' '>'
49  
-      -- hackily put the "?>" back; this should be rare and frowned upon
50  
-      -- and i can't believe php works this way with // vs ?>
51  
-      when gotChars $ do
52  
-        setInput =<< ("?>" ++) <$> getInput
53  
-        pos <- getPosition
54  
-        setPosition . setSourceColumn pos $ sourceColumn pos - 2
55  
-      return $ LineComment isSlash c
56  
-
57  
--- yikes, these can't be in Lex.hs currently, reorg needed?
58  
-tokStartComment = "/*"
59  
-tokStartCommentP = try $ string tokStartComment
60  
-tokLineComment = "//";
61  
-tokLineCommentP = try $ string tokLineComment
62  
-tokEndComment = "*/"
63  
-tokEndCommentP = try $ string tokEndComment
64  
-tokPound = "#"
65  
-tokPoundP = string tokPound
66  
-
67  
-upToCharsParser c1 c2 = do
68  
-  (gotChars, r) <- upToCharsOrEndParser (const True) c1 c2
69  
-  if gotChars then return r
70  
-    else fail $ "Unexpected <eof>, expecting " ++ [c1, c2] ++ "."
71  
-
72  
-upToCharsOrEndParser f c1 c2 = do
73  
-  s <- many (satisfy (\ x -> x /= c1 && f x))
74  
-  r1Mb <- optionMaybe (char c1)
75  
-  second (s ++) <$> case r1Mb of
76  
-    Nothing -> return (False, "")
77  
-    Just _ -> upToCharsOrEndParserC2 f c1 c2
78  
-
79  
-upToCharsOrEndParserC2 f c1 c2 = do
80  
-  r2Mb <- optionMaybe $ satisfy f
81  
-  case r2Mb of
82  
-    Nothing -> return (False, [c1])
83  
-    Just r2 -> if r2 == c2
84  
-      then return (True, "")
85  
-      else second (c1:) <$> if r2 == c1
86  
-        then upToCharsOrEndParserC2 f c1 c2
87  
-        else second (r2:) <$> upToCharsOrEndParser f c1 c2
88 24
 
89  
-instance Unparse WSElem where
90  
-  unparse (WS a) = a
91  
-  unparse (Comment a) = tokStartComment ++ a ++ tokEndComment
92  
-  unparse (LineComment isSlash a) =
93  
-    (if isSlash then tokLineComment else tokPound) ++ a
94  
-
95  
-wsNoNLParser :: Parser String
96  
-wsNoNLParser = many (satisfy (\ x -> isSpace x && x /= '\n'))
97  
-
98  
-data WSCap a = WSCap {
99  
-  wsCapPre :: WS,
100  
-  wsCapMain :: a,
101  
-  wsCapPost :: WS}
102  
-  deriving (Show, Eq, Typeable, Data)
103  
-
104  
-instance (Unparse a) => Unparse (WSCap a) where
105  
-  unparse (WSCap a b c) = concat [unparse a, unparse b, unparse c]
106  
-
107  
-instance Functor WSCap where
108  
-  fmap f w = w {wsCapMain = f $ wsCapMain w}
109  
-
110  
-capify :: WS -> (a, WS) -> WSCap a
111  
-capify a (b, c) = WSCap a b c
112  
-
113  
-instance (Parse (a, WS)) => Parse (WSCap a) where
114  
-  parse = liftM2 capify parse parse
115  
-
116  
-instance Parse a => Parse (a, WS) where
117  
-  parse = liftM2 (,) parse parse
118  
-
119  
-type WSCap2 a = WSCap (WSCap a)
120  
-
121  
-$(derive makeBinary ''WSElem)
122  
-$(derive makeBinary ''WSCap)
  25
+import Common
  26
+import Parse
  27
+import Unparse
  28
+import Lang.Php.Ast.WS
123 29
 
  30
+instance (Data a) => Binary a where
  31
+  get = getGeneric
  32
+  put = putGeneric
7  src/Lang/Php/Ast/Expr.hs
... ...
@@ -1,7 +0,0 @@
1  
-module Lang.Php.Ast.Expr (
2  
-  module Lang.Php.Ast.ExprParse,
3  
-  module Lang.Php.Ast.ExprTypes
4  
-  ) where
5  
-
6  
-import Lang.Php.Ast.ExprParse
7  
-import Lang.Php.Ast.ExprTypes
595  src/Lang/Php/Ast/ExprParse.hs
... ...
@@ -1,595 +0,0 @@
1  
-{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
2  
-module Lang.Php.Ast.ExprParse where
3  
-
4  
-import Control.Monad.Identity
5  
-import Lang.Php.Ast.ArgList
6  
-import Lang.Php.Ast.Common
7  
-import Lang.Php.Ast.ExprTypes
8  
-import Lang.Php.Ast.Lex
9  
-import Text.ParserCombinators.Parsec.Expr
10  
-import qualified Data.Intercal as IC
11  
-
12  
--- Val
13  
-
14  
-instance Unparse Var where
15  
-  unparse (Var s indexes) = tokDollar ++ s ++
16  
-    concatMap (\ (ws, (isBracket, expr)) -> unparse ws ++
17  
-      if isBracket
18  
-        then tokLBracket ++ unparse expr ++ tokRBracket
19  
-        else tokLBrace ++ unparse expr ++ tokRBrace
20  
-      ) indexes
21  
-  unparse (VarDyn ws var) = tokDollar ++ unparse ws ++ unparse var
22  
-  unparse (VarDynExpr ws expr) = tokDollar ++ unparse ws ++ tokLBrace ++
23  
-    unparse expr ++ tokRBrace
24  
-
25  
-instance Unparse Const where
26  
-  unparse (Const statics s) = concatMap (\ (s, (ws1, ws2)) -> s ++
27  
-    unparse ws1 ++ tokDubColon ++ unparse ws2) statics ++ s
28  
-
29  
-instance Unparse DynConst where
30  
-  unparse (DynConst statics var) = concatMap (\ (s, (ws1, ws2)) -> s ++
31  
-    unparse ws1 ++ tokDubColon ++ unparse ws2) statics ++ unparse var
32  
-
33  
-instance Unparse LRVal where
34  
-  unparse (LRValVar a) = unparse a
35  
-  unparse (LRValInd a w e) = unparse a ++ unparse w ++ tokLBracket ++
36  
-    unparse e ++ tokRBracket
37  
-  unparse (LRValMemb v (ws1, ws2) m) =
38  
-    unparse v ++ unparse ws1 ++ tokArrow ++ unparse ws2 ++ unparse m
39  
-  unparse (LRValStaMemb v (ws1, ws2) m) =
40  
-    unparse v ++ unparse ws1 ++ tokDubColon ++ unparse ws2 ++ unparse m
41  
-
42  
-instance Unparse LOnlyVal where
43  
-  unparse (LOnlyValList w args) = tokList ++ unparse w ++ tokLParen ++
44  
-    either unparse (intercalate tokComma . map unparse) args ++ tokRParen
45  
-  unparse (LOnlyValAppend v (ws1, ws2)) =
46  
-    unparse v ++ unparse ws1 ++ tokLBracket ++ unparse ws2 ++ tokRBracket
47  
-  unparse (LOnlyValInd v ws expr) =
48  
-    unparse v ++ unparse ws ++ tokLBracket ++ unparse expr ++ tokRBracket
49  
-  unparse (LOnlyValMemb v (ws1, ws2) m) =
50  
-    unparse v ++ unparse ws1 ++ tokArrow ++ unparse ws2 ++ unparse m
51  
-
52  
-instance Unparse ROnlyVal where
53  
-  unparse (ROnlyValConst a) = unparse a
54  
-  unparse (ROnlyValFunc v ws (Left w)) = unparse v ++ unparse ws ++
55  
-    tokLParen ++ unparse w ++ tokRParen
56  
-  unparse (ROnlyValFunc v ws (Right args)) = unparse v ++ unparse ws ++
57  
-    tokLParen ++ intercalate tokComma (map unparse args) ++ tokRParen
58  
-
59  
-instance Unparse Memb where
60  
-  unparse (MembExpr e) = tokLBrace ++ unparse e ++ tokRBrace
61  
-  unparse (MembStr s) = s
62  
-  unparse (MembVar a) = unparse a
63  
-
64  
-instance Unparse Val where
65  
-  unparse (ValLOnlyVal a) = unparse a
66  
-  unparse (ValROnlyVal a) = unparse a
67  
-  unparse (ValLRVal a) = unparse a
68  
-
69  
-instance Unparse LVal where
70  
-  unparse (LValLOnlyVal a) = unparse a
71  
-  unparse (LValLRVal a) = unparse a
72  
-
73  
-instance Unparse RVal where
74  
-  unparse (RValROnlyVal a) = unparse a
75  
-  unparse (RValLRVal a) = unparse a
76  
-
77  
-instance Parse (Var, WS) where
78  
-  parse = tokDollarP >> (undyn <|> dyn) where
79  
-    undyn = do
80  
-      i <- genIdentifierParser
81  
-      -- try is here unless we combine processing for [expr] vs []
82  
-      (inds, ws) <- IC.breakEnd <$> IC.intercalParser parse (try $
83  
-        (tokLBracketP >> (,) True <$> parse <* tokRBracketP) <|>
84  
-        (tokLBraceP >> (,) False <$> parse <* tokRBraceP))
85  
-      return (Var i inds, ws)
86  
-    dyn = do
87  
-      ws <- parse
88  
-      first (VarDyn ws) <$> parse <|> first (VarDynExpr ws) <$> liftM2 (,)
89  
-        (tokLBraceP >> parse <* tokRBraceP) parse
90  
-
91  
-parseABPairsUntilAOrC :: Parser a -> Parser b -> Parser c ->
92  
-  Parser ([(a, b)], Either a c)
93  
-parseABPairsUntilAOrC a b c = (,) [] . Right <$> c <|> do
94  
-  aR <- a
95  
-  (b >>= \ bR -> first ((aR, bR):) <$> parseABPairsUntilAOrC a b c) <|>
96  
-    return ([], Left aR)
97  
-
98  
-dynConstOrConstParser :: Parser (Either DynConst Const, WS)
99  
-dynConstOrConstParser = do
100  
-  (statics, cOrD) <-
101  
-    first (map (\ ((a, b), c) -> (a, (b, c)))) <$>
102  
-    parseABPairsUntilAOrC (liftM2 (,) (tokStaticP <|> identifierParser) parse)
103  
-    (tokDubColonP >> parse) parse
104  
-  return $ case cOrD of
105  
-    Left c -> first (Right . Const statics) c
106  
-    Right d -> first (Left . DynConst statics) d
107  
-
108  
-exprOrLValParser :: Parser (Either Expr LVal, WS)
109  
-exprOrLValParser = try (first Left <$> parse) <|> first Right <$> parse
110  
-
111  
-instance Parse (Val, WS) where
112  
-  parse = listVal <|> otherVal where
113  
-    listVal = tokListP >> liftM2 (,)
114  
-      (ValLOnlyVal <$> liftM2 LOnlyValList parse (mbArgListParser parse))
115  
-      parse
116  
-    otherVal = do
117  
-      (dOrC, ws) <- dynConstOrConstParser
118  
-      valExtend =<< case dOrC of
119  
-        Left d -> return (ValLRVal $ LRValVar d, ws)
120  
-        Right c -> (first ValROnlyVal <$>) $
121  
-          liftM2 (,) (ROnlyValFunc (Right c) ws <$> argListParser exprOrLValParser) parse
122  
-          <|> return (ROnlyValConst c, ws)
123  
-
124  
-firstM :: (Monad m) => (a -> m b) -> (a, c) -> m (b, c)
125  
-firstM = runKleisli . first . Kleisli
126  
-
127  
-instance Parse (LVal, WS) where
128  
-  parse = firstM f =<< parse where
129  
-    f r = case r of
130  
-      ValLOnlyVal v -> return $ LValLOnlyVal v
131  
-      ValROnlyVal _ -> fail "Expecting an LVal but found an ROnlyVal."
132  
-      ValLRVal v -> return $ LValLRVal v
133  
-
134  
-instance Parse (RVal, WS) where
135  
-  parse = firstM f =<< parse where
136  
-    f r = case r of
137  
-      ValLOnlyVal _ -> fail "Expecting an RVal but found an LOnlyVal."
138  
-      ValROnlyVal v -> return $ RValROnlyVal v
139  
-      ValLRVal v -> return $ RValLRVal v
140  
-
141  
-instance Parse (LRVal, WS) where
142  
-  parse = firstM f =<< parse where
143  
-    f r = case r of
144  
-      ValLOnlyVal _ -> fail "Expecting an LRVal but found an LOnlyVal."
145  
-      ValROnlyVal _ -> fail "Expecting an LRVal but found an ROnlyVal."
146  
-      ValLRVal v -> return v
147  
-
148  
--- val extending is like this:
149  
--- L --member,index,append--> L
150  
--- R --member--> LR
151  
--- LR --member,index--> LR
152  
--- LR --func--> R
153  
--- LR --append--> L
154  
-valExtend :: (Val, WS) -> Parser (Val, WS)
155  
-valExtend v@(state, ws) = case state of
156  
-  ValLOnlyVal a ->
157  
-    do
158  
-      ws2 <- tokArrowP >> parse
159  
-      (memb, wsEnd) <- parse
160  
-      valExtend (ValLOnlyVal $ LOnlyValMemb a (ws, ws2) memb, wsEnd)
161  
-    <|> valExtendIndApp (LValLOnlyVal a) (ValLOnlyVal . LOnlyValInd a ws) ws
162  
-    <|> return v
163  
-  ValROnlyVal a -> valExtendMemb (RValROnlyVal a) ws
164  
-    <|> do
165  
-      ws2 <- tokLBracketP >> parse
166  
-      st <- ValLRVal . LRValInd (RValROnlyVal a) ws . capify ws2 <$>
167  
-        parse <* tokRBracketP
168  
-      valExtend =<< (,) st <$> parse
169  
-    <|> return v
170  
-  ValLRVal a ->
171  
-    do
172  
-      r <- liftM2 (,) (ValROnlyVal . ROnlyValFunc (Left a) ws <$>
173  
-        argListParser exprOrLValParser) parse
174  
-      valExtend r
175  
-    <|> valExtendIndApp (LValLRVal a) (ValLRVal . LRValInd (RValLRVal a) ws) ws
176  
-    <|> valExtendMemb (RValLRVal a) ws
177  
-    <|> return v
178  
-
179  
-valExtendMemb :: RVal -> WS -> Parser (Val, WS)
180  
-valExtendMemb a ws = (tokArrowP >> do
181  
-  ws2 <- parse
182  
-  (memb, wsEnd) <- parse
183  
-  valExtend (ValLRVal $ LRValMemb a (ws, ws2) memb, wsEnd))
184  
-		<|> (tokDubColonP >> do
185  
-		  ws2 <- parse
186  
-		  (memb, wsEnd) <- parse
187  
-		  valExtend (ValLRVal $ LRValStaMemb a (ws, ws2) memb, wsEnd))
188  
-
189  
-instance Parse (Memb, WS) where
190  
-  parse =
191  
-    liftM2 (,) (
192  
-      (tokLBraceP >> MembExpr <$> parse <* tokRBraceP) <|>
193  
-      MembStr <$> genIdentifierParser) parse <|>
194  
-    first MembVar <$> parse
195  
-
196  
-valExtendIndApp :: LVal -> (WSCap Expr -> Val) -> WS -> Parser (Val, WS)
197  
-valExtendIndApp lVal mkVal ws = tokLBracketP >> do
198  
-  ws2 <- parse
199  
-  st <-
200  
-    (tokRBracketP >>
201  
-      return (ValLOnlyVal $ LOnlyValAppend lVal (ws, ws2))) <|>
202  
-    mkVal . capify ws2 <$> (parse <* tokRBracketP)
203  
-  valExtend =<< (,) st <$> parse
204  
-
205  
-varOrStringParser :: Parser (Either Var String, WS)
206  
-varOrStringParser = first Left <$> parse <|>
207  
-  liftM2 (,) (Right <$> identifierParser) parse
208  
-
209  
-instance Parse (DynConst, WS) where
210  
-  parse = do
211  
-    statics <- many . liftM2 (,) identifierParser . liftM2 (,) parse $
212  
-      tokDubColonP >> parse
213  
-    first (DynConst statics) <$> parse
214  
-
215  
-instance Parse (Const, WS) where
216  
-  parse = first (uncurry Const) . rePairLeft . first (map rePairRight) .
217  
-    IC.breakEnd <$> IC.intercalParser (liftM2 (,) identifierParser parse)
218  
-    (tokDubColonP >> parse)
219  
-
220  
-lRValOrConstParser :: Parser (Either LRVal Const, WS)
221  
-lRValOrConstParser = do
222  
-  (v, w) <- parse
223  
-  case v of
224  
-    ValLRVal a -> return (Left a, w)
225  
-    ValROnlyVal (ROnlyValConst a) -> return (Right a, w)
226  
-    _ -> fail "Expected LRVal or Const but fould a different Val type."
227  
-
228  
--- Expr
229  
-
230  
-instance Unparse Expr where
231  
-  unparse expr = case expr of
232  
-    ExprArray w elemsOrW -> tokArray ++ unparse w ++ tokLParen ++
233  
-      either unparse f elemsOrW ++ tokRParen where
234  
-      f (elems, wEnd) = intercalate tokComma .
235  
-        maybe id (flip (++) . (:[]) . unparse) wEnd $ map unparse elems
236  
-    ExprAssign o v w e -> unparse v ++ w2With (unparse o ++ tokEquals) w ++
237  
-      unparse e
238  
-    ExprBackticks a -> a
239  
-    ExprBinOp o e1 (w1, w2) e2 -> unparse e1 ++ unparse w1 ++ unparse o ++
240  
-      unparse w2 ++ unparse e2
241  
-    ExprCast (WSCap w1 t w2) w e -> tokLParen ++ unparse w1 ++ t ++
242  
-      unparse w2 ++ tokRParen ++ unparse w ++ unparse e
243  
-    ExprEmpty w e -> tokEmpty ++ unparse w ++ tokLParen ++ unparse e ++
244  
-      tokRParen
245  
-    ExprEval w e -> tokEval ++ unparse w ++ tokLParen ++ unparse e ++
246  
-      tokRParen
247  
-    ExprExit isExit a -> (if isExit then tokExit else tokDie) ++
248  
-      maybe "" (\ (w, x) -> unparse w ++ tokLParen ++
249  
-        either unparse unparse x ++ tokRParen) a
250  
-    ExprHereDoc a -> unparse a
251  
-    ExprInclude a b w e -> unparse a ++ unparse b ++ unparse w ++ unparse e
252  
-    ExprIndex a w b ->
253  
-      unparse a ++ unparse w ++ tokLBracket ++ unparse b ++ tokRBracket
254  
-    ExprInstOf e w t -> unparse e ++ w2With tokInstanceof w ++ unparse t
255  
-    ExprIsset w vs -> tokIsset ++ unparse w ++ tokLParen ++
256  
-      intercalate tokComma (map unparse vs) ++ tokRParen
257  
-    ExprNew w a argsMb -> tokNew ++ unparse w ++ unparse a ++ maybe ""
258  
-      (\ (wPre, args) -> unparse wPre ++ tokLParen ++ either unparse
259  
-        (intercalate tokComma . map unparse) args ++ tokRParen) argsMb
260  
-    ExprNumLit a -> unparse a
261  
-    ExprParen a -> tokLParen ++ unparse a ++ tokRParen
262  
-    ExprPostOp o e w -> unparse e ++ unparse w ++ unparse o
263  
-    ExprPreOp o w e -> unparse o ++ unparse w ++ unparse e
264  
-    ExprRef w v -> tokAmp ++ unparse w ++ unparse v
265  
-    ExprRVal a -> unparse a
266  
-    ExprStrLit a -> unparse a
267  
-    ExprTernaryIf a -> unparse a
268  
-    ExprXml a -> unparse a
269  
-
270  
-instance Unparse BinOpBy where
271  
-  unparse binOp = case binOp of
272  
-    BBitAnd -> tokAmp
273  
-    BBitOr -> tokBitOr
274  
-    BConcat -> tokConcat
275  
-    BDiv -> tokDiv
276  
-    BMinus -> tokMinus
277  
-    BMod -> tokMod
278  
-    BMul -> tokMul
279  
-    BPlus -> tokPlus
280  
-    BShiftL -> tokShiftL
281  
-    BShiftR -> tokShiftR
282  
-    BXor -> tokXor
283  
-
284  
-instance Unparse BinOp where
285  
-  unparse binOp = case binOp of
286  
-    BAnd -> tokAnd
287  
-    BAndWd -> tokAndWd
288  
-    BEQ -> tokEQ
289  
-    BGE -> tokGE
290  
-    BGT -> tokGT
291  
-    BID -> tokID
292  
-    BLE -> tokLE
293  
-    BLT -> tokLT
294  
-    BNE -> tokNE
295  
-    BNEOld -> tokNEOld
296  
-    BNI -> tokNI
297  
-    BOr -> tokOr
298  
-    BOrWd -> tokOrWd
299  
-    BXorWd -> tokXorWd
300  
-    BByable o -> unparse o
301  
-
302  
-instance Unparse PreOp where
303  
-  unparse preOp = case preOp of
304  
-    PrPrint -> tokPrint
305  
-    PrAt -> tokAt
306  
-    PrBitNot -> tokBitNot
307  
-    PrClone -> tokClone
308  
-    PrNegate -> tokMinus
309  
-    PrNot -> tokNot
310  
-    PrPos -> tokPlus
311  
-    PrSuppress -> tokAt
312  
-    PrIncr -> tokIncr
313  
-    PrDecr -> tokDecr
314  
-
315  
-instance Unparse PostOp where
316  
-  unparse postOp = case postOp of
317  
-    PoIncr -> tokIncr
318  
-    PoDecr -> tokDecr
319  
-
320  
-instance Unparse IncOrReq where
321  
-  unparse Inc = tokInclude
322  
-  unparse Req = tokRequire
323  
-
324  
-instance Unparse OnceOrNot where
325  
-  unparse Once = "_once"
326  
-  unparse NotOnce = ""
327  
-
328  
-instance Unparse DubArrowMb where
329  
-  unparse (DubArrowMb k v) = maybe "" (\ (e, (w1, w2)) -> unparse e ++
330  
-    unparse w1 ++ tokDubArrow ++ unparse w2) k ++ unparse v
331  
-
332  
-instance Unparse TernaryIf where
333  
-  unparse (TernaryIf e1 (w1, w2) e2 (w3, w4) e3) = unparse e1 ++ unparse w1 ++
334  
-    tokQMark ++ unparse w2 ++ unparse e2 ++ unparse w3 ++ tokColon ++
335  
-    unparse w4 ++ unparse e3
336  
-
337  
-instance Unparse Xml where
338  
-  unparse (Xml tag attrs content) = tokLT ++ tag ++
339  
-    IC.intercalUnparser unparse
340  
-      (\ (k, vMb) -> k ++
341  
-        maybe "" (\ (w, v) -> w2With tokEquals w ++
342  
-        either unparse ((tokLBrace ++) . (++ tokRBrace) . unparse) v) vMb)
343  
-      attrs ++
344  
-    maybe tokDiv (\ (c, hasExplicitCloseTag) ->
345  
-      tokGT ++ concatMap unparse c ++ tokLT ++ tokDiv ++
346  
-      if hasExplicitCloseTag then tag else "") content ++
347  
-    tokGT
348  
-
349  
-instance Unparse XmlLitOrExpr where
350  
-  unparse (XmlLit a) = a
351  
-  unparse (XmlExpr a) = tokLBrace ++ unparse a ++ tokRBrace
352  
-
353  
-instance Parse (Expr, WS) where
354  
-  parse = buildExpressionParser exprParserTable simpleExprParser
355  
-
356  
-simpleExprParser :: Parser (Expr, WS)
357  
-simpleExprParser = assignOrRValParser
358  
-  <|> do
359  
-    ws1 <- tokLParenP >> parse
360  
-    ambigCastParser ws1 <|> castOrParenParser ws1
361  
-  <|> do
362  
-    ws1 <- tokNewP >> parse
363  
-    (v, ws2) <- parse
364  
-    argsWSMb <- optionMaybe $ argListParser parse
365  
-    case argsWSMb of
366  
-      Just args -> (,) (ExprNew ws1 v $ Just (ws2, args)) <$> parse
367  
-      _ -> return (ExprNew ws1 v Nothing, ws2)
368  
-  <|> includeParser
369  
-  <|> do
370  
-    isExit <- return True <$> tokExitP <|> return False <$> tokDieP
371  
-    ws1 <- parse
372  
-    argMb <- optionMaybe $ exitListParser parse
373  
-    case argMb of
374  
-      Just arg -> (,) (ExprExit isExit $ Just (ws1, arg)) <$> parse
375  
-      _ -> return (ExprExit isExit Nothing, ws1)
376  
-  <|> do
377  
-    w <- tokAmpP >> parse
378  
-    first (ExprRef w . Right) <$> parse <|> do
379  
-      (e, wEnd) <- parse
380  
-      case e of
381  
-        ExprNew _ _ _ -> return (ExprRef w (Left e), wEnd)
382  
-        _ -> fail "Expecting a Val or ExprNew."
383  
-  <|> liftM2 (,) (
384  
-    ExprStrLit <$> parse <|>
385  
-    ExprNumLit <$> parse <|>
386  
-    ExprHereDoc <$> parse <|>
387  
-    (tokArrayP >> liftM2 ExprArray parse (arrListParser parse)) <|>
388  
-    funclike1Parser ExprEmpty tokEmptyP <|>
389  
-    funclike1Parser ExprEval tokEvalP <|>
390  
-    (tokIssetP >> liftM2 ExprIsset parse (issetListParser parse)) <|>
391  
-    ExprBackticks <$> backticksParser <|>
392  
-    ExprXml <$> parse
393  
-    ) parse
394  
-
395  
-ambigCastParser :: WS -> Parser (Expr, WS)
396  
-ambigCastParser ws1 = try $ do
397  
-  i <- identsCI ["array", "unset"]
398  
-  ws2 <- parse
399  
-  ws3 <- tokRParenP >> parse
400  
-  first (ExprCast (WSCap ws1 i ws2) ws3) <$> parse
401  
-
402  
-castOrParenParser :: WS -> Parser (Expr, WS)
403  
-castOrParenParser ws1 = do
404  
-  iMb <- optionMaybe $ identsCI ["int", "integer", "bool", "boolean",
405  
-    "float", "double", "real", "string", "binary", "object"]
406  
-  case iMb of
407  
-    Just i -> do
408  
-      ws2 <- parse
409  
-      ws3 <- tokRParenP >> parse
410  
-      first (ExprCast (WSCap ws1 i ws2) ws3) <$> parse
411  
-    _ -> liftM2 (,) (ExprParen . capify ws1 <$> parse <* tokRParenP) parse
412  
-
413  
-assignOrRValParser :: Parser (Expr, WS)
414  
-assignOrRValParser = do
415  
-  (val, w) <- parse
416  
-  case val of
417  
-    ValLOnlyVal v -> assignCont (LValLOnlyVal v) w
418  
-    ValLRVal v -> assignCont (LValLRVal v) w <|>
419  
-      return (ExprRVal $ RValLRVal v, w)
420  
-    ValROnlyVal v -> return (ExprRVal $ RValROnlyVal v, w)
421  
-
422  
-assignCont :: LVal -> WS -> Parser (Expr, WS)
423  
-assignCont l w1 = do
424  
-  o <- (tokEqualsP >> return Nothing) <|> Just <$> (
425  
-    (tokPlusByP   >> return BPlus) <|>
426  
-    (tokMinusByP  >> return BMinus) <|>
427  
-    (tokMulByP    >> return BMul) <|>
428  
-    (tokDivByP    >> return BDiv) <|>
429  
-    (tokConcatByP >> return BConcat) <|>
430  
-    (tokModByP    >> return BMod) <|>
431  
-    (tokBitAndByP >> return BBitAnd) <|>
432  
-    (tokBitOrByP  >> return BBitOr) <|>
433  
-    (tokXorByP    >> return BXor) <|>
434  
-    (tokShiftLByP >> return BShiftL) <|>
435  
-    (tokShiftRByP >> return BShiftR))
436  
-  w2 <- parse
437  
-  first (ExprAssign o l (w1, w2)) <$> parse
438  
-
439  
-includeParser :: Parser (Expr, WS)
440  
-includeParser = try $ do
441  
-  i <- map toLower <$> genIdentifierParser
442  
-  f <- if i == tokRequireOnce then return $ ExprInclude Req Once else
443  
-    if i == tokIncludeOnce then return $ ExprInclude Inc Once else
444  
-    if i == tokRequire then return $ ExprInclude Req NotOnce else
445  
-    if i == tokInclude then return $ ExprInclude Inc NotOnce else
446  
-    fail "Expecting an include/require expression."
447  
-  ws <- parse
448  
-  first (f ws) <$> parse
449  
-
450  
-instance Parse (DubArrowMb, WS) where
451  
-  parse = do
452  
-    (k, ws) <- parse
453  
-    vMb <- optionMaybe (tokDubArrowP >> liftM2 (,) parse parse)
454  
-    return $ case vMb of
455  
-      Just (ws2, (v, ws3)) -> (DubArrowMb (Just (k, (ws, ws2))) v, ws3)
456  
-      _ -> (DubArrowMb Nothing k, ws)
457  
-
458  
-funclike1Parser :: (Parse (a, WS)) => (WS -> WSCap a -> b) -> Parser c ->
459  
-  Parser b
460  
-funclike1Parser constr tokP = liftM2 constr (tokP >> parse)
461  
-  (tokLParenP >> parse <* tokRParenP)
462  
-
463  
-exprParserTable :: [[Oper (Expr, WS)]]
464  
-exprParserTable = [
465  
-  [Postfix eptIndex],
466  
-  [Prefix eptClone],
467  
-  [Prefix eptPreIncr, Prefix eptPreDecr,
468  
-   Postfix eptPostIncr, Postfix eptPostDecr],
469  
-  [Postfix eptInstOf],
470  
-  [Prefix . preRep $ eptNot <|> eptBitNot <|> eptNegate <|> eptPos <|>
471  
-    eptSuppress],
472  
-  ial [eptMul, eptDiv, eptMod],
473  
-  ial [eptPlus, eptMinus, eptConcat],
474  
-  ial [eptShiftL, eptShiftR],
475  
-  ian [eptLT, eptLE, eptGT, eptGE, eptNEOld],
476  
-  ian [eptEQ, eptNE, eptID, eptNI],
477  
-  ial [eptBitAnd],
478  
-  ial [eptXor],
479  
-  ial [eptBitOr],
480  
-  [Prefix eptPrint],
481  
-  ial [eptAnd],
482  
-  ial [eptOr],
483  
-  [Postfix eptTernaryIf],
484  
-  ial [eptAndWd],
485  
-  ial [eptXorWd],
486  
-  ial [eptOrWd]]
487  
-
488  
-preRep, postRep :: Parser (a -> a) -> Parser (a -> a)
489  
-preRep p = (p >>= \ f -> (f .) <$> preRep p) <|> return id
490  
-postRep p = (p >>= \ f -> (. f) <$> postRep p) <|> return id
491  
-
492  
-ial :: [Parser (a -> a -> a)] -> [Oper a]
493  
-ial = map $ flip Infix AssocLeft
494  
-ian = map $ flip Infix AssocNone
495  
-
496  
-eptClone = preOp PrClone tokCloneP
497  
-eptPreIncr = preOp PrIncr tokIncrP
498  
-eptPreDecr = preOp PrDecr tokDecrP
499  
-eptPostIncr = postOp PoIncr tokIncrP
500  
-eptPostDecr = postOp PoDecr tokDecrP
501  
-
502  
-preOp :: PreOp -> Parser a -> Parser ((Expr, WS) -> (Expr, WS))
503  
-preOp o p = do
504  
-  ws1 <- p >> parse
505  
-  return . first $ ExprPreOp o ws1
506  
-
507  
-postOp :: PostOp -> Parser a -> Parser ((Expr, WS) -> (Expr, WS))
508  
-postOp o p = do
509  
-  ws2 <- p >> parse
510  
-  return $ \ (e, ws1) -> (ExprPostOp o e ws1, ws2)
511  
-
512  
-binOp :: BinOp -> Parser a -> Parser ((Expr, WS) -> (Expr, WS) -> (Expr, WS))
513  
-binOp o p = do
514  
-  ws2 <- p >> parse
515  
-  return $ \ (e1, ws1) (e2, ws3) -> (ExprBinOp o e1 (ws1, ws2) e2, ws3)
516  
-
517  
-eptBitNot = preOp PrBitNot tokBitNotP
518  
-eptNegate = preOp PrNegate tokMinusP
519  
-eptPos    = preOp PrPos tokPlusP
520  
-eptSuppress = preOp PrSuppress tokAtP
521  
-
522  
-eptInstOf = do
523  
-  tokInstanceofP
524  
-  ws2 <- parse
525  
-  (t, ws3) <- lRValOrConstParser
526  
-  return $ \ (e, ws1) -> (ExprInstOf e (ws1, ws2) t, ws3)
527  
-
528  
-eptNot = preOp PrNot tokNotP
529  
-
530  
-eptMul = binOp (BByable BMul) tokMulP
531  
-eptDiv = binOp (BByable BDiv) tokDivP
532  
-eptMod = binOp (BByable BMod) tokModP
533  
-eptPlus   = binOp (BByable BPlus) tokPlusP
534  
-eptMinus  = binOp (BByable BMinus) tokMinusP
535  
-eptConcat = binOp (BByable BConcat) tokConcatP
536  
-eptShiftL = binOp (BByable BShiftL) tokShiftLP
537  
-eptShiftR = binOp (BByable BShiftR) tokShiftRP
538  
-eptLT     = binOp BLT     tokLTP
539  
-eptLE     = binOp BLE     tokLEP
540  
-eptGT     = binOp BGT     tokGTP
541  
-eptGE     = binOp BGE     tokGEP
542  
-eptNEOld  = binOp BNEOld  tokNEOldP
543  
-eptEQ     = binOp BEQ     tokEQP
544  
-eptNE     = binOp BNE     tokNEP
545  
-eptID     = binOp BID     tokIDP
546  
-eptNI     = binOp BNI     tokNIP
547  
-
548  
-eptBitAnd = binOp (BByable BBitAnd) tokAmpP
549  
-eptXor    = binOp (BByable BXor) tokXorP
550  
-eptBitOr  = binOp (BByable BBitOr) tokBitOrP
551  
-
552  
-eptPrint  = preOp PrPrint tokPrintP
553  
-
554  
-eptAnd    = binOp BAnd    tokAndP
555  
-eptOr     = binOp BOr     tokOrP
556  
-
557  
-eptTernaryIf :: Parser ((Expr, WS) -> (Expr, WS))
558  
-eptTernaryIf = do
559  
-  w2 <- tokQMarkP >> parse
560  
-  (e2, w3) <- parse
561  
-  w4 <- tokColonP >> parse
562  
-  (e3, w5) <- parse
563  
-  return $ \ (e1, w1) ->
564  
-    (ExprTernaryIf $ TernaryIf e1 (w1, w2) e2 (w3, w4) e3, w5)
565  
-
566  
-eptAndWd = binOp BAndWd tokAndWdP
567  
-eptXorWd = binOp BXorWd tokXorWdP
568  
-eptOrWd  = binOp BOrWd  tokOrWdP
569  
-
570  
-eptIndex :: Parser ((Expr, WS) -> (Expr, WS))
571  
-eptIndex = do
572  
-  e2 <- tokLBracketP >> parse
573  
-  w2 <- tokRBracketP >> parse
574  
-  return $ \ (e1, w1) -> (ExprIndex e1 w1 e2, w2)
575  
-
576  
-instance Parse Xml where
577  
-  parse = tokLTP >> do
578  
-    tag <- many1 . oneOf $
579  
-      -- i thought _ wasn't allowed but i guess when marcel's away e will play
580  
-      [':', '-', '_'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
581  
-    attrs <- IC.intercalParser parse . liftM2 (,) xmlIdentifierParser $
582  
-      Just <$> try (liftM2 (,) (liftM2 (,) parse (tokEqualsP >> parse)) $
583  
-        (tokLBraceP >> Right <$> parse <* tokRBraceP) <|>
584  
-        Left <$> parse) <|>
585  
-      return Nothing
586  
-    content <- (tokDivP >> tokGTP >> return Nothing) <|>
587  
-      Just <$> liftM2 (,)
588  
-        (tokGTP >> many (Right <$> try parse <|> Left <$> parse))
589  
-        (tokLTP >> tokDivP >> ((string tag >> return True) <|> return False))
590  
-        <* tokGTP
591  
-    return $ Xml tag attrs content
592  
-
593  
-instance Parse XmlLitOrExpr where
594  
-  parse = (tokLBraceP >> XmlExpr <$> parse <* tokRBraceP) <|>
595  
-    XmlLit <$> many1 (satisfy (`notElem` "<{"))
170  src/Lang/Php/Ast/ExprTypes.hs
<
... ...
@@ -1,170 +0,0 @@
1  
-{-# LANGUAGE DeriveDataTypeable, TemplateHaskell #-}
2  
-module Lang.Php.Ast.ExprTypes where
3  
-
4  
-import Lang.Php.Ast.Common
5  
-import Lang.Php.Ast.Lex
6  
-import qualified Data.Intercal as IC
7  
-
8  
--- Val's are defined to only contain: "$", identifiers, "[Expr]", "[]",
9  
--- "(Exprs)", "${Expr}", "::", "->".  The most important consideration is which
10  
--- ones can be assigned to (LVal's) and which ones can be assigned from
11  
--- (RVal's).  In PHP, most but not all LVal's are also RVal's.
12  
-
13  
--- Note that this grammar allows "$$a[]->a = 5;" but Zend does not.  However,
14  
--- Zend allows "${$a}[]->a = 5;", and it's not clear what is gained by treating
15  
--- $a and ${..} asymmetrically here.  PHP also allows "${$a}[0]->a = 5" and
16  
--- "$$a[0]->a = 5;".  So we're regarding this as a by-product of the Zend
17  
--- implementation.  In particular, we think they simplify their job by slurping
18  
--- all [Expr?]'s onto Var's and only later analyze things with regard to LVal
19  
--- considerations, simply fataling if something is then awry.
20  
---
21  
--- Modeling that nuance is impractical under the clear division of
22  
--- Var's, LVal's, and RVal's that we desire to make the AST nice for
23  
--- refactoring.
24  
-
25  
-data Val = ValLOnlyVal LOnlyVal | ValROnlyVal ROnlyVal | ValLRVal LRVal
26  
-  deriving (Eq, Show, Typeable, Data)
27  
-
28  
-data LVal = LValLOnlyVal LOnlyVal | LValLRVal LRVal
29  
-  deriving (Eq, Show, Typeable, Data)
30  
-
31  
-data RVal = RValROnlyVal ROnlyVal | RValLRVal LRVal
32  
-  deriving (Eq, Show, Typeable, Data)
33  
-
34  
-data Var =
35  
-  -- In php, indexing is oddly coupled very tightly with being a non-dyn var.
36  
-  Var        String [((WS, (Bool, WSCap Expr)))] | -- "$a", "$a[0]", "$a[0][0]"
37  
-  VarDyn     WS Var          | -- "$$a"
38  
-                               -- note: "$$a[0]()->a" == "${$a[0]}()->a"
39  
-  VarDynExpr WS (WSCap Expr)   -- "${$a . '_'}"
40  
-  deriving (Eq, Show, Typeable, Data)
41  
-
42  
-data DynConst = DynConst [(String, WS2)] Var -- "a::$a"
43  
-  deriving (Eq, Show, Typeable, Data)
44  
-
45  
-data LRVal =
46  
-  LRValVar     DynConst |
47  
-  LRValInd     RVal WS (WSCap Expr) | -- "$a->a[0]"
48  
-  LRValMemb    RVal WS2 Memb | -- $a->a
49  
-  LRValStaMemb RVal WS2 Memb -- $a::a
50  
-  deriving (Eq, Show, Typeable, Data)
51  
-
52  
-data LOnlyVal =
53  
-  LOnlyValList   WS (Either WS [Either WS (WSCap LVal)]) |
54  
-  LOnlyValAppend LVal WS2                 | -- "$a[]"
55  
-  LOnlyValInd    LOnlyVal WS (WSCap Expr) | -- "$a[][0]"
56  
-  LOnlyValMemb   LOnlyVal WS2 Memb          -- "$a[]->a"
57  
-  deriving (Eq, Show, Typeable, Data)
58  
-
59  
-data Const = Const [(String, WS2)] String -- "a::a"
60  
-  deriving (Eq, Show, Typeable, Data)
61  
-
62  
-data ROnlyVal =
63  
-  ROnlyValConst Const |
64  
-  -- "a()", "$a()"
65  
-  ROnlyValFunc  (Either LRVal Const) WS (Either WS [WSCap (Either Expr LVal)])
66  
-  deriving (Eq, Show, Typeable, Data)
67  
-
68  
-data Memb =
69  
-  MembStr  String |
70  
-  MembVar  Var    |
71  
-  MembExpr (WSCap Expr)
72  
-  deriving (Eq, Show, Typeable, Data)
73  
-
74  
--- Expr's
75  
-
76  
-data Expr =
77  
-  ExprArray     WS (Either WS ([WSCap DubArrowMb], Maybe WS)) |
78  
-  ExprAssign    (Maybe BinOpBy) LVal WS2 Expr |
79  
-  ExprBackticks String |
80  
-  ExprBinOp     BinOp Expr WS2 Expr |
81  
-  -- we're lazy so just String here instead of like PhpType
82  
-  ExprCast      (WSCap String) WS Expr |
83  
-  ExprEmpty     WS (WSCap LRVal) |
84  
-  ExprEval      WS (WSCap Expr) |
85  
-  ExprExit      Bool (Maybe (WS, Either WS (WSCap Expr))) |
86  
-  ExprHereDoc   HereDoc |
87  
-  -- FIXME: this fb extension should be separated to a superclass-like Lang?
88  
-  ExprIndex     Expr WS (WSCap Expr) |
89  
-  ExprInclude   IncOrReq OnceOrNot WS Expr |
90  
-  -- true story: "instanceof" takes LRVal's but not non-Const ROnlyVal's..
91  
-  ExprInstOf    Expr WS2 (Either LRVal Const) |
92  
-  ExprIsset     WS [WSCap LRVal] |
93  
-  ExprNew       WS RVal (Maybe (WS, Either WS [WSCap Expr])) |
94  
-  ExprNumLit    NumLit |
95  
-  ExprParen     (WSCap Expr) |
96  
-  ExprPostOp    PostOp Expr WS |
97  
-  ExprPreOp     PreOp WS Expr |
98  
-  -- note: "list"/"&" is actually more limited
99  
-  -- ("list() = &$a;" is nonsyntactic)
100  
-  ExprRef       WS (Either Expr Val) |
101  
-  ExprRVal      RVal |
102  
-  ExprStrLit    StrLit |
103  
-  ExprTernaryIf TernaryIf |
104  
-  -- FIXME: this fb extension should be separated to a superclass-like Lang?
105  
-  ExprXml       Xml
106  
-  deriving (Eq, Show, Typeable, Data)
107  
-
108  
-data Xml = Xml String
109  
-  (IC.Intercal WS (String, Maybe (WS2, Either StrLit (WSCap Expr))))
110  
-  (Maybe ([Either XmlLitOrExpr Xml], Bool))
111  
-  deriving (Eq, Show, Typeable, Data)
112  
-
113  
-data XmlLitOrExpr = XmlLit String | XmlExpr (WSCap Expr)
114  
-  deriving (Eq, Show, Typeable, Data)
115  
-
116  
-data BinOp = BAnd | BAndWd | BEQ | BGE | BGT | BID | BLE | BLT | BNE |
117  
-  -- <> has different precedence than !=
118  
-  BNEOld | BNI | BOr | BOrWd | BXorWd | BByable BinOpBy
119  
-  deriving (Eq, Show, Typeable, Data)
120  
-
121  
-data BinOpBy = BBitAnd | BBitOr | BConcat | BDiv | BMinus | BMod | BMul |
122  
-  BPlus | BShiftL | BShiftR | BXor
123  
-  deriving (Eq, Show, Typeable, Data)
124  
-
125