Skip to content
This repository was archived by the owner on Sep 20, 2023. It is now read-only.

Commit eb6b852

Browse files
skogsbaerskogsbaer
committed
support for shallow parsing
1 parent a22c4a3 commit eb6b852

4 files changed

Lines changed: 79 additions & 30 deletions

File tree

‎Language/Java/Parser.hs‎

Lines changed: 46 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22

33

44
module Language.Java.Parser (
5-
parser,
5+
parser, parserWithMode, ParserMode(..),
66

77
compilationUnit, packageDecl, importDecl, typeDecl,
88

@@ -43,10 +43,9 @@ import Language.Java.Pretty (pretty)
4343
import Text.Parsec hiding ( Empty )
4444
import Text.Parsec.Pos
4545

46-
import Prelude hiding ( exp, catch, (>>), (>>=) )
46+
import Prelude hiding ( exp, (>>), (>>=) )
4747
import qualified Prelude as P ( (>>), (>>=) )
48-
import Data.Maybe ( isJust, catMaybes, maybeToList )
49-
import Control.Monad ( ap )
48+
import Data.Maybe ( isJust, catMaybes )
5049

5150
#if __GLASGOW_HASKELL__ < 707
5251
import Control.Applicative ( (<$>), (<$), (<*) )
@@ -59,7 +58,20 @@ import Control.Applicative ( (<$>), (<$), (<*), (<*>) )
5958
import GHC.IO (unsafePerformIO)
6059
#endif
6160

62-
type P = Parsec [L Token] ()
61+
data ParserState
62+
= ParserState
63+
{ ps_mode :: ParserMode }
64+
deriving (Eq, Show)
65+
66+
data ParserMode =
67+
ParseFull -- the default
68+
| ParseShallow -- do not parse methods bodies
69+
deriving (Eq, Show)
70+
71+
defaultParserState :: ParserState
72+
defaultParserState = ParserState ParseFull
73+
74+
type P = Parsec [L Token] ParserState
6375

6476
getNextTok :: P (Maybe (L Token))
6577
getNextTok = do
@@ -79,20 +91,27 @@ logToFile msg =
7991
-- A trick to allow >> and >>=, normally infixr 1, to be
8092
-- used inside branches of <|>, which is declared as infixl 1.
8193
-- There are no clashes with other operators of precedence 2.
94+
(>>) :: P a -> P b -> P b
8295
(>>) = (P.>>)
96+
97+
(>>=) :: P a -> (a -> P b) -> P b
8398
(>>=) = (P.>>=)
99+
84100
infixr 2 >>, >>=
85101
-- Note also when reading that <$> is infixl 4 and thus has
86102
-- lower precedence than all the others (>>, >>=, and <|>).
87103

88104
----------------------------------------------------------------------------
89105
-- Top-level parsing
90106

91-
parseCompilationUnit :: String -> Either ParseError CompilationUnit
92-
parseCompilationUnit inp =
93-
runParser compilationUnit () "" (lexer inp)
107+
parser :: P a -> FilePath -> String -> Either ParseError a
108+
parser = parserWithState defaultParserState
109+
110+
parserWithMode :: ParserMode -> P a -> FilePath -> String -> Either ParseError a
111+
parserWithMode mode = parserWithState (ParserState mode)
94112

95-
parser p = runParser p () "" . lexer
113+
parserWithState :: ParserState -> P a -> FilePath -> String -> Either ParseError a
114+
parserWithState state p srcName src = runParser p state srcName (lexer src)
96115

97116
--class Parse a where
98117
-- parse :: String -> a
@@ -461,7 +480,24 @@ arrayInit = braces $ do
461480
-- Statements
462481

463482
block :: P Block
464-
block = braces $ Block <$> list blockStmt
483+
block = do
484+
state <- getState
485+
case ps_mode state of
486+
ParseFull -> braces $ Block <$> list blockStmt
487+
ParseShallow -> Block <$> parseNestedCurly (-1)
488+
489+
-- | Parses anything between properly balance curly brackets.
490+
-- level must initially be -1
491+
parseNestedCurly :: Int -> P [a]
492+
parseNestedCurly level = do
493+
newLevel <-
494+
javaToken $ \t ->
495+
case t of
496+
OpenCurly -> Just (level + 1)
497+
_ | level < 0 -> Nothing -- need to start with {
498+
CloseCurly -> Just (level - 1)
499+
_ -> Just level
500+
if newLevel < 0 then return [] else parseNestedCurly newLevel
465501

466502
blockStmt :: P BlockStmt
467503
blockStmt =
@@ -1352,10 +1388,3 @@ colon = tok Op_Colon
13521388
semiColon = tok SemiColon
13531389
period = tok Period
13541390

1355-
------------------------------------------------------------
1356-
1357-
test = "public class Foo { }"
1358-
testFile file = do
1359-
i <- readFile file
1360-
let r = parseCompilationUnit i
1361-
putStrLn$ either (("Parsing error:\n"++) . show) (show . pretty) r

‎tests/Tests.hs‎

Lines changed: 25 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -44,27 +44,39 @@ testJavaDirectory = "tests" </> "java"
4444
isJavaFile :: FilePath -> Bool
4545
isJavaFile f = ".java" `isSuffixOf` f
4646

47-
toTestCase expected jFile = testCase (takeBaseName jFile) doTest
48-
where doTest = do r <- E.try parseOne
49-
case r of
50-
Left (e :: E.SomeException) -> assertBool ("failure exception: " ++ show e) (not expected)
51-
Right (Left perr) -> assertBool ("failure parse error: " ++ show perr) (not expected)
52-
Right (Right p) -> assertBool ("success: " ++ show p) expected
53-
parseOne = parser compilationUnit <$> readFile jFile
47+
toTestCase :: ParserMode -> Bool -> FilePath -> TestTree
48+
toTestCase mode expected jFile = testCase (takeBaseName jFile) doTest
49+
where
50+
doTest = do
51+
r <- E.try parseOne
52+
case r of
53+
Left (e :: E.SomeException) -> assertBool ("failure exception: " ++ show e) (not expected)
54+
Right (Left perr) -> assertBool ("failure parse error: " ++ show perr) (not expected)
55+
Right (Right p) -> assertBool ("success: " ++ show p) expected
56+
parseOne = parserWithMode mode compilationUnit jFile <$> readFile jFile
5457

58+
getAllJavaPaths :: FilePath -> IO [FilePath]
5559
getAllJavaPaths path = map (path </>) . filter isJavaFile <$> getDirectoryContents path
5660

61+
main :: IO ()
5762
main = do
5863
exists <- doesDirectoryExist testJavaDirectory
5964
when (not exists) $ error "cannot find tests files java directory"
60-
65+
6166
allGoodJavas <- getAllJavaPaths (testJavaDirectory </> "good")
6267
allBadJavas <- getAllJavaPaths (testJavaDirectory </> "bad")
68+
let -- the bad tests that work with shallow parsing
69+
shallowGoodJavas = ["tests/java/bad/DiamondIncorrectPlacement.java"]
70+
shallowBadJavas = filter (\p -> not (p `elem` shallowGoodJavas)) allBadJavas
6371

6472
defaultMain $ testGroup "java"
65-
[ testGroup "parsing unit good" (map (toTestCase True) allGoodJavas)
66-
, testGroup "parsing unit bad" (map (toTestCase False) allBadJavas)
67-
, testProperty "parsing.generating==id" (\g -> case parser compilationUnit (show $ pretty g) of
68-
Right g' -> g == g'
69-
Left perr -> error (show (pretty g) ++ show perr))
73+
[ testGroup "parsing unit good" (map (toTestCase ParseFull True) allGoodJavas)
74+
, testGroup "parsing shallow unit good"
75+
(map (toTestCase ParseShallow True) (allGoodJavas ++ shallowGoodJavas))
76+
, testGroup "parsing unit bad" (map (toTestCase ParseFull False) allBadJavas)
77+
, testGroup "parsing shallow unit bad" (map (toTestCase ParseShallow False) shallowBadJavas)
78+
, testProperty "parsing.generating==id"
79+
(\g -> case parser compilationUnit "<input>" (show $ pretty g) of
80+
Right g' -> g == g'
81+
Left perr -> error (show (pretty g) ++ show perr))
7082
]

‎tests/java/bad/BadNesting.java‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
public class BadNesting {
2+
void foo() {
3+
if (true) {
4+
}
5+
}

‎tests/java/good/sealed.java‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
record Circle() implements Shape {}
2+
record Rectangle(int sealed, double permits) implements Shape {} // sealed and permits are no keywords here
3+
sealed interface Shape permits Circle, Rectangle {} // but here

0 commit comments

Comments
 (0)