Skip to content

Commit fd444cc

Browse files
author
Mizunashi Mana
committed
Refactor codes
1 parent 27bddf1 commit fd444cc

12 files changed

+95
-45
lines changed

‎src/Language/Haskell/Exts/InternalLexer.hs

Lines changed: 22 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
{-# OPTIONS_HADDOCK hide #-}
23
-----------------------------------------------------------------------------
34
-- |
@@ -31,8 +32,11 @@ import Data.Char
3132
import Data.Ratio
3233
import Data.List (intercalate, isPrefixOf)
3334
import Control.Monad (when)
35+
-- #define DEBUG 1
36+
#ifdef DEBUG
37+
import Debug.Trace (trace)
38+
#endif
3439

35-
-- import Debug.Trace (trace)
3640

3741
data Token
3842
= VarId String
@@ -385,13 +389,22 @@ matchChar c msg = do
385389

386390
lexer :: (Loc Token -> P a) -> P a
387391
lexer = runL topLexer
392+
#ifdef DEBUG
393+
. \f token -> trace (show token) $ f token
394+
#endif
388395

389396
topLexer :: Lex a (Loc Token)
390397
topLexer = do
391398
b <- pullCtxtFlag
392-
if b then -- trace (show cf ++ ": " ++ show VRightCurly) $
393-
-- the lex context state flags that we must do an empty {} - UGLY
394-
setBOL >> getSrcLocL >>= \l -> return (Loc (mkSrcSpan l l) VRightCurly)
399+
if b then do
400+
#ifdef DEBUG
401+
trace ("By context flag: " ++ show VRightCurly) $ return ()
402+
#endif
403+
-- the lex context state flags that we must do an empty {} - UGLY
404+
sl <- getSrcLocL
405+
setBOL
406+
el <- getSrcLocL
407+
return $ Loc (mkSrcSpan sl el) VRightCurly
395408
else do
396409
bol <- checkBOL
397410
(bol', ws) <- lexWhiteSpace bol
@@ -512,7 +525,10 @@ lexNestedComment bol str = do
512525
lexBOL :: Lex a Token
513526
lexBOL = do
514527
pos <- getOffside
515-
-- trace ("Off: " ++ (show pos)) $ do
528+
l <- getSrcLocL
529+
#ifdef DEBUG
530+
trace ("Off: " ++ show (pos, l)) $ return ()
531+
#endif
516532
case pos of
517533
LT -> do
518534
-- trace "layout: inserting '}'\n" $
@@ -524,7 +540,7 @@ lexBOL = do
524540
popContextL "lexBOL"
525541
return VRightCurly
526542
EQ ->
527-
-- trace "layout: inserting ';'\n" $
543+
-- trace "layout: inserting ';'" $
528544
return SemiColon
529545
GT -> lexToken
530546

‎src/Language/Haskell/Exts/InternalParser.ly

Lines changed: 16 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -1807,7 +1807,7 @@ TODO: The points can't be added here, must be propagated!
18071807

18081808
> stmtlist :: { ([Stmt L],L,[S]) }
18091809
> : '{' stmts '}' { (fst $2, $1 <^^> $3, $1:snd $2 ++ [$3]) }
1810-
> | open stmts close { let l' = ann . last $ fst $2
1810+
> | stmtopen stmts close { let l' = ann . last $ fst $2
18111811
> in (fst $2, nIS $1 <++> l', $1:snd $2 ++ [$3]) }
18121812

18131813
> stmts :: { ([Stmt L],[S]) }
@@ -2037,11 +2037,20 @@ Implicit parameter
20372037
-----------------------------------------------------------------------------
20382038
Layout
20392039

2040-
> open :: { S } : {% pushCurrentContext >> getSrcLoc >>= \s -> return $ mkSrcSpan s s {- >>= \x -> trace (show x) (return x) -} }
2040+
> open :: { S } : {% pushCurrentContext BindLayout >> getZeroSpanByLoc
2041+
> {- >>= \x -> trace (show x) (return x) -}
2042+
> }
2043+
> stmtopen :: { S } : {% pushCurrentContext StmtLayout >> getZeroSpanByLoc
2044+
> {- >>= \x -> trace (show x) (return x) -}
2045+
> }
20412046

20422047
> close :: { S }
2043-
> : vccurly { $1 {- >>= \x -> trace (show x ++ show x ++ show x) (return x) -} } -- context popped in lexer.
2044-
> | error {% popContext >> getSrcLoc >>= \s -> return $ mkSrcSpan s s {- >>= \x -> trace (show x ++ show x) (return x) -} }
2048+
> : vccurly {% return $1
2049+
> {- >>= \x -> trace (show x ++ show x ++ show x) (return x) -}
2050+
> }
2051+
> | error {% popContext >> getZeroSpanByLoc
2052+
> {- >>= \x -> trace (show x ++ show x) (return x) -}
2053+
> }
20452054

20462055
-----------------------------------------------------------------------------
20472056
Pattern Synonyms
@@ -2206,4 +2215,7 @@ Exported as partial parsers:
22062215
> fail $ "Expected single declaration, found import declaration"
22072216
> checkSingleDecl ds
22082217

2218+
> getZeroSpanByLoc :: P SrcSpan
2219+
> getZeroSpanByLoc = getSrcLoc >>= \s -> return $ mkSrcSpan s s
2220+
22092221
> }

‎src/Language/Haskell/Exts/ParseMonad.hs

Lines changed: 44 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
{-# OPTIONS_HADDOCK hide #-}
23
-----------------------------------------------------------------------------
34
-- |
@@ -18,7 +19,7 @@ module Language.Haskell.Exts.ParseMonad(
1819
-- * Generic Parsing
1920
Parseable(..),
2021
-- * Parsing
21-
P, ParseResult(..), atSrcLoc, LexContext(..),
22+
P, ParseResult(..), atSrcLoc, LexContext(..), LayoutKind(..),
2223
ParseMode(..), defaultParseMode, fromParseResult,
2324
runParserWithMode, runParserWithModeComments, runParser,
2425
getSrcLoc, pushCurrentContext, popContext,
@@ -51,6 +52,10 @@ import Data.Semigroup (Semigroup(..))
5152
-- To avoid import warnings for Control.Applicative, Data.Monoid, and Data.Semigroup
5253
import Prelude
5354

55+
#ifdef DEBUG
56+
import Debug.Trace
57+
#endif
58+
5459
-- | Class providing function for parsing at many different types.
5560
--
5661
-- Note that for convenience of implementation, the default methods have
@@ -115,22 +120,27 @@ instance ( Monoid m , Semigroup m) => Monoid (ParseResult m) where
115120
data ParseStatus a = Ok ParseState a | Failed SrcLoc String
116121
deriving Show
117122

118-
data LexContext = NoLayout | Layout Int
123+
data LayoutKind
124+
= BindLayout
125+
| StmtLayout
126+
deriving (Eq, Ord, Show)
127+
128+
data LexContext = NoLayout | Layout LayoutKind Int
119129
deriving (Eq,Ord,Show)
120130

121131
data ExtContext = CodeCtxt | HarpCtxt | TagCtxt | ChildCtxt
122132
| CloseTagCtxt | CodeTagCtxt
123133
deriving (Eq,Ord,Show)
124134

125135
type CtxtFlag = (Bool,Bool)
126-
-- (True,_) = We're in a do context.
127-
-- (_, True)= Next token must be a virtual closing brace.
136+
-- (True, _) = We're in a do context.
137+
-- (_, True) = Next token must be a virtual closing brace.
128138

129139
type ParseState = ([LexContext],[[KnownExtension]],[ExtContext],CtxtFlag,[Comment])
130140

131141
indentOfParseState :: ParseState -> Int
132-
indentOfParseState (Layout n:_,_,_,_,_) = n
133-
indentOfParseState _ = 0
142+
indentOfParseState (Layout _ n:_,_,_,_,_) = n
143+
indentOfParseState _ = 0
134144

135145
-- | Static parameters governing a parse.
136146
-- Note that the various parse functions in "Language.Haskell.Exts.Parser"
@@ -278,30 +288,35 @@ getModuleName = P $ \_i _x _y _l _ch s m ->
278288
-- (So if the source loc is not to the right of the current indent, an
279289
-- empty list {} will be inserted.)
280290

281-
pushCurrentContext :: P ()
282-
pushCurrentContext = do
291+
pushCurrentContext :: LayoutKind -> P ()
292+
pushCurrentContext layoutKind = do
283293
lc <- getSrcLoc
284294
indent <- currentIndent
285295
dob <- pullDoStatus
286296
let loc = srcColumn lc
287297
when (dob && loc < indent
288298
|| not dob && loc <= indent) pushCtxtFlag
289-
pushContext (Layout loc)
299+
pushContext (Layout layoutKind loc)
290300

291301
currentIndent :: P Int
292302
currentIndent = P $ \_r _x _y _ _ stk _mode -> Ok stk (indentOfParseState stk)
293303

294304
pushContext :: LexContext -> P ()
295305
pushContext ctxt =
296-
--trace ("pushing lexical scope: " ++ show ctxt ++"\n") $
306+
#ifdef DEBUG
307+
trace ("pushing lexical scope: " ++ show ctxt) $
308+
#endif
297309
P $ \_i _x _y _l _ (s, exts, e, p, c) _m -> Ok (ctxt:s, exts, e, p, c) ()
298310

299311
popContext :: P ()
300312
popContext = P $ \_i _x _y loc _ stk _m ->
301-
case stk of
302-
(_:s, exts, e, p, c) -> --trace ("popping lexical scope, context now "++show s ++ "\n") $
303-
Ok (s, exts, e, p, c) ()
304-
([],_,_,_,_) -> Failed loc "Unexpected }" -- error "Internal error: empty context in popContext"
313+
case stk of
314+
(_:s, exts, e, p, c) ->
315+
#ifdef DEBUG
316+
trace ("popping lexical scope, context now " ++ show s) $
317+
#endif
318+
Ok (s, exts, e, p, c) ()
319+
([],_,_,_,_) -> Failed loc "Unexpected }"
305320

306321
{-
307322
-- HaRP/Hsx
@@ -323,9 +338,13 @@ getExtensions = P $ \_i _x _y _l _ s m ->
323338

324339
pushCtxtFlag :: P ()
325340
pushCtxtFlag =
326-
P $ \_i _x _y _l _ (s, exts, e, (d,c), cs) _m -> case c of
327-
False -> Ok (s, exts, e, (d,True), cs) ()
328-
_ -> error "Internal error: context flag already pushed"
341+
P $ \_i _x _y _l _ (s, exts, e, (d,c), cs) _m ->
342+
#ifdef DEBUG
343+
trace "pushing context switch" $
344+
#endif
345+
case c of
346+
False -> Ok (s, exts, e, (d,True), cs) ()
347+
_ -> error "Internal error: context flag already pushed"
329348

330349
pullDoStatus :: P Bool
331350
pullDoStatus = P $ \_i _x _y _l _ (s, exts, e, (d,c), cs) _m -> Ok (s,exts,e,(False,c),cs) d
@@ -364,6 +383,9 @@ instance Fail.MonadFail (Lex r) where
364383
getInput :: Lex r String
365384
getInput = Lex $ \cont -> P $ \r -> runP (cont r) r
366385

386+
parserL :: P a -> Lex r a
387+
parserL p = Lex (p >>=)
388+
367389
-- | Discard some input characters (these must not include tabs or newlines).
368390

369391
discard :: Int -> Lex r ()
@@ -480,16 +502,16 @@ setSrcLineL y = Lex $ \cont -> P $ \i x _ ->
480502
runP (cont ()) i x y
481503

482504
pushContextL :: LexContext -> Lex a ()
483-
pushContextL ctxt = Lex $ \cont -> P $ \r x y loc ch (stk, exts, e, pst, cs) ->
484-
runP (cont ()) r x y loc ch (ctxt:stk, exts, e, pst, cs)
505+
pushContextL = parserL . pushContext
485506

486507
popContextL :: String -> Lex a ()
487-
popContextL _ = Lex $ \cont -> P $ \r x y loc ch stk m -> case stk of
488-
(_:ctxt, exts, e, pst, cs) -> runP (cont ()) r x y loc ch (ctxt, exts, e, pst, cs) m
489-
([], _, _, _, _) -> Failed loc "Unexpected }"
508+
popContextL _ = parserL popContext
490509

491510
pullCtxtFlag :: Lex a Bool
492511
pullCtxtFlag = Lex $ \cont -> P $ \r x y loc ch (ct, exts, e, (d,c), cs) ->
512+
#ifdef DEBUG
513+
trace "pulling context switch" $
514+
#endif
493515
runP (cont c) r x y loc ch (ct, exts, e, (d,False), cs)
494516

495517

‎tests/examples/BracketInstanceHead.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ ParseOk
2323
, SrcSpan "tests/examples/BracketInstanceHead.hs" 1 37 1 42
2424
, SrcSpan "tests/examples/BracketInstanceHead.hs" 2 1 2 1
2525
, SrcSpan "tests/examples/BracketInstanceHead.hs" 2 1 2 1
26-
, SrcSpan "tests/examples/BracketInstanceHead.hs" 2 0 2 0
26+
, SrcSpan "tests/examples/BracketInstanceHead.hs" 2 1 2 0
2727
]
2828
}
2929
Nothing

‎tests/examples/ConstraintKinds.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -80,7 +80,7 @@ ParseOk
8080
, SrcSpan "tests/examples/ConstraintKinds.hs" 4 13 4 18
8181
, SrcSpan "tests/examples/ConstraintKinds.hs" 6 1 6 1
8282
, SrcSpan "tests/examples/ConstraintKinds.hs" 6 1 6 1
83-
, SrcSpan "tests/examples/ConstraintKinds.hs" 6 0 6 0
83+
, SrcSpan "tests/examples/ConstraintKinds.hs" 6 1 6 0
8484
]
8585
}
8686
Nothing

‎tests/examples/DataKinds2.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -204,7 +204,7 @@ ParseOk
204204
, SrcSpan "tests/examples/DataKinds2.hs" 9 27 9 32
205205
, SrcSpan "tests/examples/DataKinds2.hs" 10 1 10 1
206206
, SrcSpan "tests/examples/DataKinds2.hs" 10 1 10 1
207-
, SrcSpan "tests/examples/DataKinds2.hs" 10 0 10 0
207+
, SrcSpan "tests/examples/DataKinds2.hs" 10 1 10 0
208208
]
209209
}
210210
Nothing

‎tests/examples/EmptyInstance.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -23,7 +23,7 @@ ParseOk
2323
, SrcSpan "tests/examples/EmptyInstance.hs" 1 27 1 32
2424
, SrcSpan "tests/examples/EmptyInstance.hs" 3 1 3 1
2525
, SrcSpan "tests/examples/EmptyInstance.hs" 3 1 3 1
26-
, SrcSpan "tests/examples/EmptyInstance.hs" 3 0 3 0
26+
, SrcSpan "tests/examples/EmptyInstance.hs" 3 1 3 0
2727
]
2828
}
2929
Nothing

‎tests/examples/EmptyWhere.hs.parser.golden

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -51,11 +51,11 @@ ParseOk
5151
(Just
5252
(BDecls
5353
SrcSpanInfo
54-
{ srcInfoSpan = SrcSpan "tests/examples/EmptyWhere.hs" 2 0 2 1
54+
{ srcInfoSpan = SrcSpan "tests/examples/EmptyWhere.hs" 2 1 2 1
5555
, srcInfoPoints =
5656
[ SrcSpan "tests/examples/EmptyWhere.hs" 2 1 2 1
5757
, SrcSpan "tests/examples/EmptyWhere.hs" 2 1 2 1
58-
, SrcSpan "tests/examples/EmptyWhere.hs" 2 0 2 0
58+
, SrcSpan "tests/examples/EmptyWhere.hs" 2 1 2 0
5959
]
6060
}
6161
[]))

‎tests/examples/ForallInInstance.hs.parser.golden

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -59,7 +59,7 @@ ParseOk
5959
, SrcSpan "tests/examples/ForallInInstance.hs" 4 45 4 50
6060
, SrcSpan "tests/examples/ForallInInstance.hs" 5 1 5 1
6161
, SrcSpan "tests/examples/ForallInInstance.hs" 5 1 5 1
62-
, SrcSpan "tests/examples/ForallInInstance.hs" 5 0 5 0
62+
, SrcSpan "tests/examples/ForallInInstance.hs" 5 1 5 0
6363
]
6464
}
6565
Nothing

‎tests/examples/TrailingWhere.hs.parser.golden

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -99,11 +99,11 @@ ParseOk
9999
(Just
100100
(BDecls
101101
SrcSpanInfo
102-
{ srcInfoSpan = SrcSpan "tests/examples/TrailingWhere.hs" 5 0 5 5
102+
{ srcInfoSpan = SrcSpan "tests/examples/TrailingWhere.hs" 5 5 5 5
103103
, srcInfoPoints =
104104
[ SrcSpan "tests/examples/TrailingWhere.hs" 5 5 5 5
105105
, SrcSpan "tests/examples/TrailingWhere.hs" 5 5 5 5
106-
, SrcSpan "tests/examples/TrailingWhere.hs" 5 0 5 0
106+
, SrcSpan "tests/examples/TrailingWhere.hs" 5 5 5 0
107107
]
108108
}
109109
[]))

0 commit comments

Comments
 (0)