diff options
Diffstat (limited to 'src/LambdaCube/Compiler/Lexer.hs')
-rw-r--r-- | src/LambdaCube/Compiler/Lexer.hs | 20 |
1 files changed, 20 insertions, 0 deletions
diff --git a/src/LambdaCube/Compiler/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs index 29b88930..3281fdb0 100644 --- a/src/LambdaCube/Compiler/Lexer.hs +++ b/src/LambdaCube/Compiler/Lexer.hs | |||
@@ -8,6 +8,7 @@ | |||
8 | {-# LANGUAGE NoMonomorphismRestriction #-} | 8 | {-# LANGUAGE NoMonomorphismRestriction #-} |
9 | {-# LANGUAGE TypeFamilies #-} | 9 | {-# LANGUAGE TypeFamilies #-} |
10 | {-# LANGUAGE RankNTypes #-} | 10 | {-# LANGUAGE RankNTypes #-} |
11 | {-# LANGUAGE CPP #-} | ||
11 | module LambdaCube.Compiler.Lexer | 12 | module LambdaCube.Compiler.Lexer |
12 | ( module LambdaCube.Compiler.Lexer | 13 | ( module LambdaCube.Compiler.Lexer |
13 | , module ParseUtils | 14 | , module ParseUtils |
@@ -43,7 +44,11 @@ toSPos :: SourcePos -> SPos | |||
43 | toSPos p = SPos (fromIntegral $ unPos $ sourceLine p) (fromIntegral $ unPos $ sourceColumn p) | 44 | toSPos p = SPos (fromIntegral $ unPos $ sourceLine p) (fromIntegral $ unPos $ sourceColumn p) |
44 | 45 | ||
45 | getSPos :: Parse r w SPos | 46 | getSPos :: Parse r w SPos |
47 | #if MIN_VERSION_megaparsec(7,0,0) | ||
48 | getSPos = toSPos <$> getSourcePos | ||
49 | #else | ||
46 | getSPos = toSPos <$> getPosition | 50 | getSPos = toSPos <$> getPosition |
51 | #endif | ||
47 | 52 | ||
48 | -------------------------------------------------------------------------------- literals | 53 | -------------------------------------------------------------------------------- literals |
49 | 54 | ||
@@ -121,10 +126,25 @@ parseState fi di = (ParseEnv fi di ExpNS (SPos 0 0), either (error "impossible") | |||
121 | --type Parse r w = ReaderT (ParseEnv r) (WriterT [w] (StateT SPos (Parsec String))) | 126 | --type Parse r w = ReaderT (ParseEnv r) (WriterT [w] (StateT SPos (Parsec String))) |
122 | type Parse r w = RWST (ParseEnv r) [w] SPos (Parsec (ErrorFancy Void) String) | 127 | type Parse r w = RWST (ParseEnv r) [w] SPos (Parsec (ErrorFancy Void) String) |
123 | 128 | ||
129 | #if MIN_VERSION_megaparsec(7,0,0) | ||
130 | newtype ParseError = ParseErr (P.ParseErrorBundle (String) (ErrorFancy Void)) | ||
131 | instance ShowErrorComponent (ErrorFancy Void) where | ||
132 | showErrorComponent (ErrorFail s) = s | ||
133 | -- fail has been used in parser monad | ||
134 | showErrorComponent (ErrorIndentation ordering row col) = "Indentation error " ++ show (ordering,row,col) | ||
135 | -- Incorrect indentation error: desired ordering between reference level and actual level, reference indentation level, actual indentation level | ||
136 | showErrorComponent _ = "CustomError" | ||
137 | -- ErrorCustom e -- Custom error data, can be conveniently disabled by indexing ErrorFancy by Void | ||
138 | #else | ||
124 | newtype ParseError = ParseErr (P.ParseError (Token String) (ErrorFancy Void)) | 139 | newtype ParseError = ParseErr (P.ParseError (Token String) (ErrorFancy Void)) |
140 | #endif | ||
125 | 141 | ||
126 | instance Show ParseError where | 142 | instance Show ParseError where |
143 | #if MIN_VERSION_megaparsec(7,0,0) | ||
144 | show (ParseErr e) = errorBundlePretty e | ||
145 | #else | ||
127 | show (ParseErr e) = parseErrorPretty e | 146 | show (ParseErr e) = parseErrorPretty e |
147 | #endif | ||
128 | 148 | ||
129 | runParse :: Parse r w a -> ParseState r -> Either ParseError (a, [w]) | 149 | runParse :: Parse r w a -> ParseState r -> Either ParseError (a, [w]) |
130 | runParse p (env, st) = left ParseErr . snd . flip runParser' st $ evalRWST p env (error "spos") | 150 | runParse p (env, st) = left ParseErr . snd . flip runParser' st $ evalRWST p env (error "spos") |