msyds/rlp
1
0
Fork 0
Code Issues 4 Pull Requests Actions Packages Projects Releases 2 Wiki Activity

location (row,col) -> span (row,col,len)

Browse Source
This commit is contained in:
crumbtoo
2023-11-22 15:38:15 -07:00
parent 26c135cccb
commit ae39579c97
3 changed files with 48 additions and 48 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
src/Compiler/RLPC.hs
View File

@@ -42,7 +42,7 @@ evalRLPC o m = coerce $ evalRLPCT o m
data RLPCOptions = RLPCOptions
data SrcError e = SrcError
{ _errLocation :: (Int, Int)
{ _errSpan :: (Int, Int, Int)
, _errSeverity :: Severity
, _errDiagnostic :: e
}

44
src/Core/Lex.x
View File

@@ -135,11 +135,11 @@ $white_no_nl+ { skip }
}
{
data Located a = Located AlexPosn a
data Located a = Located Int Int Int a
deriving Show
constTok :: t -> AlexInput -> Int -> Alex (Located t)
constTok t (p,_,_,_) _ = pure $ Located p t
constTok t (AlexPn _ y x,_,_,_) l = pure $ Located x y l t
data CoreToken = TokenLet
| TokenLetrec
@@ -210,16 +210,16 @@ lexStream :: Alex [Located CoreToken]
lexStream = do
l <- alexMonadScan
case l of
Located _ TokenEOF -> pure [l]
_ -> (l:) <$> lexStream
Located _ _ _ TokenEOF -> pure [l]
_ -> (l:) <$> lexStream
-- | The main lexer driver.
lexCore :: String -> RLPC ParseError [Located CoreToken]
lexCore s = case m of
Left e -> addFatal err
where err = SrcError
{ _errLocation = (0,0) -- TODO: location
, _errSeverity = Error
{ _errSpan = (0,0,0) -- TODO: location
, _errSeverity = Error
, _errDiagnostic = ParErrLexical e
}
Right ts -> pure ts
@@ -230,14 +230,14 @@ lexCore s = case m of
-- debugging
lexCore' :: String -> RLPC ParseError [CoreToken]
lexCore' s = fmap f <$> lexCore s
where f (Located _ t) = t
where f (Located _ _ _ t) = t
data ParseError = ParErrLexical String
| ParErrParse
deriving Show
lexWith :: (String -> CoreToken) -> Lexer
lexWith f (p,_,_,s) l = pure $ Located p (f $ take l s)
lexWith f (AlexPn _ y x,_,_,s) l = pure $ Located x y l (f $ take l s)
lexToken :: Alex (Located CoreToken)
lexToken = alexMonadScan
@@ -248,23 +248,23 @@ getSrcCol = Alex $ \ st ->
in Right (st, col)
lbrace :: Lexer
lbrace (p,_,_,_) _ = do
lbrace (AlexPn _ y x,_,_,_) l = do
pushContext NoLayout
pure $ Located p TokenLBrace
pure $ Located x y l TokenLBrace
rbrace :: Lexer
rbrace (p,_,_,_) _ = do
rbrace (AlexPn _ y x,_,_,_) l = do
popContext
pure $ Located p TokenRBrace
pure $ Located x y l TokenRBrace
insRBraceV :: AlexPosn -> Alex (Located CoreToken)
insRBraceV p = do
insRBraceV (AlexPn _ y x) = do
popContext
pure $ Located p TokenRBraceV
pure $ Located x y 0 TokenRBraceV
insSemi :: AlexPosn -> Alex (Located CoreToken)
insSemi p = do
pure $ Located p TokenSemicolon
insSemi (AlexPn _ y x) = do
pure $ Located x y 0 TokenSemicolon
modifyUst :: (AlexUserState -> AlexUserState) -> Alex ()
modifyUst f = do
@@ -279,10 +279,10 @@ newLayoutContext (p,_,_,_) _ = do
undefined
noBrace :: Lexer
noBrace (p,_,_,_) l = do
noBrace (AlexPn _ y x,_,_,_) l = do
col <- getSrcCol
pushContext (Layout col)
pure $ Located p TokenLBraceV
pure $ Located x y l TokenLBraceV
getOffside :: Alex Ordering
getOffside = do
@@ -301,15 +301,15 @@ doBol (p,c,_,s) _ = do
_ -> lexToken
letin :: Lexer
letin (p,_,_,_) l = do
letin (AlexPn _ y x,_,_,_) l = do
popContext
pure $ Located p TokenIn
pure $ Located x y l TokenIn
topLevelOff :: Lexer
topLevelOff = noBrace
alexEOF :: Alex (Located CoreToken)
alexEOF = Alex $ \ st@(AlexState { alex_pos = p }) ->
Right (st, Located p TokenEOF)
alexEOF = Alex $ \ st@(AlexState { alex_pos = AlexPn _ y x }) ->
Right (st, Located x y 0 TokenEOF)
}

50
src/Core/Parse.y
View File

@@ -26,28 +26,28 @@ import Compiler.RLPC
%monad { RLPC ParseError }
%token
let { Located _ TokenLet }
letrec { Located _ TokenLetrec }
module { Located _ TokenModule }
where { Located _ TokenWhere }
',' { Located _ TokenComma }
in { Located _ TokenIn }
litint { Located _ (TokenLitInt $$) }
varname { Located _ (TokenVarName $$) }
varsym { Located _ (TokenVarSym $$) }
conname { Located _ (TokenConName $$) }
consym { Located _ (TokenConSym $$) }
'λ' { Located _ TokenLambda }
'->' { Located _ TokenArrow }
'=' { Located _ TokenEquals }
'(' { Located _ TokenLParen }
')' { Located _ TokenRParen }
'{' { Located _ TokenLBrace }
'}' { Located _ TokenRBrace }
vl { Located _ TokenLBraceV }
vr { Located _ TokenRBraceV }
';' { Located _ TokenSemicolon }
eof { Located _ TokenEOF }
let { Located _ _ _ TokenLet }
letrec { Located _ _ _ TokenLetrec }
module { Located _ _ _ TokenModule }
where { Located _ _ _ TokenWhere }
',' { Located _ _ _ TokenComma }
in { Located _ _ _ TokenIn }
litint { Located _ _ _ (TokenLitInt $$) }
varname { Located _ _ _ (TokenVarName $$) }
varsym { Located _ _ _ (TokenVarSym $$) }
conname { Located _ _ _ (TokenConName $$) }
consym { Located _ _ _ (TokenConSym $$) }
'λ' { Located _ _ _ TokenLambda }
'->' { Located _ _ _ TokenArrow }
'=' { Located _ _ _ TokenEquals }
'(' { Located _ _ _ TokenLParen }
')' { Located _ _ _ TokenRParen }
'{' { Located _ _ _ TokenLBrace }
'}' { Located _ _ _ TokenRBrace }
vl { Located _ _ _ TokenLBraceV }
vr { Located _ _ _ TokenRBraceV }
';' { Located _ _ _ TokenSemicolon }
eof { Located _ _ _ TokenEOF }
%%
@@ -138,10 +138,10 @@ Con : '(' consym ')' { $2 }
{
parseError :: [Located CoreToken] -> RLPC ParseError a
parseError (Located (AlexPn _ x y) _ : _) = addFatal err
parseError (Located x y l _ : _) = addFatal err
where err = SrcError
{ _errLocation = (x, y)
, _errSeverity = Error
{ _errSpan = (x, y, l)
, _errSeverity = Error
, _errDiagnostic = ParErrParse
}