Author: Pascal "Pixel" Rigaux

Perl5Parser/Lines.hs

@@ -6,6 +6,7 @@ import Perl5Parser.Types
 import Perl5Parser.ParserHelper
 import Perl5Parser.Term
 import Perl5Parser.Expr
+import Perl5Parser.Prototype
 import qualified Perl5Parser.Token
 import qualified Perl5Parser.Token.Number
 
@@ -40,29 +41,42 @@ format = newNode"format"$ seQ
                            spaces_comments_token
          ]
 
-sub_declaration	= newNode"Statement::Sub"$ seQ
-          [ try$ seQ [ symbol_ "sub", toNodes$ Perl5Parser.Token.p_Ident_sure ] -- ^ try needed for anonymous_sub
-          , prototype
-          , subattrlist
-          , block <|> op ";"
-          ]
+sub_declaration	= newNode"Statement::Sub" p
+    where p = do (ident, l1) <- try sub_xxx -- ^ try needed for anonymous_sub
+                 (proto, l2) <- option_prototype
+                 case proto of
+                   Nothing -> return ()
+                   Just proto -> set_prototype ident proto
+                 l3 <- subattrlist
+                 l4 <- block <|> op ";"
+                 return (l1 ++ l2 ++ l3 ++ l4)
+          sub_xxx = do l1 <- symbol_ "sub"
+                       (fq, i) <- Perl5Parser.Token.p_Ident_sure_raw
+                       l2 <- spaces_comments_token
+                       return ((fq, i), l1 ++ [Tokens (Ident fq i : l2)])
+
 
 scheduled_declaration = newNode"Statement::Scheduled"$ seQ
           [ choice $ map local_ident [ "BEGIN", "CHECK", "INIT", "END", "AUTOLOAD" ] -- ^ cf AutoLoader.pm for such an AUTOLOAD example
-          , prototype
+          , fmap snd option_prototype
           , subattrlist
           , block <|> op ";"
           ]
 
 anonymous_sub = newNode"anonymous_sub"$ seQ 
                 [ notFollowedBy_ (string "=>") (symbol_ "sub")
-                , prototype
+                , fmap snd option_prototype
                 , subattrlist
                 , block
                 ]
 
-prototype = option [] (toNodes $ pcons prototype_ spaces_comments_token)
-    where prototype_ = fmap Prototype $ seQ [ charl '(' , anyTill (charl ')') ]
+option_prototype = option (Nothing, []) prototype
+prototype :: Perl5Parser (Maybe String, [Node])
+prototype = do char '('
+               proto <- many (satisfy (/= ')'))
+               char ')'
+               l <- spaces_comments_token
+               return (Just proto, [Tokens (Prototype proto : l)])
 
 subattrlist = option [] (toNodes Perl5Parser.Token.p_Attributes)
 package = newNode"package"$ pcons (symbol_node "package") (toNodes Perl5Parser.Token.p_Ident)

Perl5Parser/Prototype.hs

@@ -1,6 +1,7 @@
 module Perl5Parser.Prototype
     ( parse_prototype
     , get_prototype
+    , set_prototype
     , builtin_prototypes
     , filetest_functions
     ) where
@@ -18,6 +19,16 @@ get_prototype (LocalIdent, f) = do state <- getState
 get_prototype (fq, f) = do state <- getState
                            return$ Map.lookup (fq_canonical fq, f) (per_pkg_prototypes (prototypes state))
 
+updatePrototypes :: (Prototypes -> Prototypes) -> Perl5Parser ()
+updatePrototypes f = updateState (\state -> state { prototypes = f (prototypes state) })
+
+set_prototype :: (IdentT, String) -> String -> Perl5Parser ()
+set_prototype (LocalIdent, f) proto = updatePrototypes update
+    where update protos = protos { local_prototypes = Map.insert f proto (local_prototypes protos) }
+set_prototype (fq, f) proto = updatePrototypes update
+    where update protos = protos { per_pkg_prototypes = Map.insert (fq_canonical fq, f) proto (per_pkg_prototypes protos) }
+
+
 
 parse_prototype :: String -> Maybe (Int, Int)
 parse_prototype = parse parser () ""

Perl5Parser/Serialize.hs

@@ -48,7 +48,7 @@ instance Serialize TokenT where
     verbatim (Word s) = s
     verbatim (SpaceComment l) = verbatim l
     verbatim (PictureFormat s) = s
-    verbatim (Prototype s) = s
+    verbatim (Prototype s) = "(" ++ s ++ ")"
     verbatim (Ident fq i) = to_s_IdentT fq ++ i
     verbatim (Symbol s) = s
     verbatim (Operator s) = s

Perl5Parser/Token.hs

@@ -3,7 +3,7 @@ module Perl5Parser.Token
     , p_Pod
     , p_Label
     , p_Attributes
-    , p_Ident, p_Ident_sure, p_Ident_raw, p_Filetest_raw
+    , p_Ident, p_Ident_sure, p_Ident_raw, p_Ident_sure_raw, p_Filetest_raw
     ) where
 
 import Perl5Parser.Common
@@ -44,13 +44,13 @@ p_Ident = pcons (fmap (\(pkg, i) -> Ident pkg i) p_Ident_raw) spaces_comments_to
 
 -- | same as p_Ident with also 'b (::b)
 p_Ident_sure :: Perl5Parser [TokenT]
-p_Ident_sure = pcons (fmap (\(pkg, i) -> Ident pkg i) p_Ident_raw_sure) spaces_comments_token
+p_Ident_sure = pcons (fmap (\(pkg, i) -> Ident pkg i) p_Ident_sure_raw) spaces_comments_token
 
 p_Ident_raw :: Perl5Parser (IdentT, String)
 p_Ident_raw = fmap to_Ident (p_Ident_raw_sep1 "" <|> p_Ident_raw_word word_raw)
 
-p_Ident_raw_sure :: Perl5Parser (IdentT, String)
-p_Ident_raw_sure = fmap to_Ident (p_Ident_raw_seps "" <|> p_Ident_raw_word word_raw)
+p_Ident_sure_raw :: Perl5Parser (IdentT, String)
+p_Ident_sure_raw = fmap to_Ident (p_Ident_raw_seps "" <|> p_Ident_raw_word word_raw)
 
 p_Ident_raw_word p = do w <- p
                         p_Ident_raw_sep1 w <|> p_Ident_raw_sep2 w <|> return ([], w)

test.hs

@@ -123,9 +123,14 @@ ok_exprs = [
            , ("/\\//", "/\\//")
            , ("$s =~ s {1}   {2}", "$s =~ s {1}   {2}")
            , ("s:^f::", "s:^f::")
+           -- various
+           , ("foo: 1", "foo: 1")
            , ("`foo`", "`foo`")
            , ("our $z = 1", "(our $z )= 1")
            , ("our $z : unique = 1", "(our $z : unique )= 1")
+           , ("f + 2, 3; sub f () {}  f + 2, 3", "f ((+ 2), 3); sub f () {}  ((f )+ 2), 3")
+           , ("f + 2, 3; sub f ($) {}  f + 2, 3", "f ((+ 2), 3); sub f ($) {}  (f (+ 2)), 3")
+           , ("sub ff($\\@%) {}", "sub ff($\\@%) {}")
            -- weird function calls or keyword disambiguation
            , ("map {1}&a", "map {(1)}((&a))")
            , ("eval {1}&a", "(eval {(1)})&a")