diff options
-rw-r--r-- | lambdacube-compiler.cabal | 2 | ||||
-rw-r--r-- | src/LambdaCube/Compiler/Infer.hs | 1 | ||||
-rw-r--r-- | src/LambdaCube/Compiler/Lexer.hs | 640 | ||||
-rw-r--r-- | src/LambdaCube/Compiler/Parser.hs | 345 |
4 files changed, 675 insertions, 313 deletions
diff --git a/lambdacube-compiler.cabal b/lambdacube-compiler.cabal index 7fcb617e..21411016 100644 --- a/lambdacube-compiler.cabal +++ b/lambdacube-compiler.cabal | |||
@@ -39,8 +39,8 @@ source-repository head | |||
39 | library | 39 | library |
40 | exposed-modules: | 40 | exposed-modules: |
41 | -- Compiler | 41 | -- Compiler |
42 | LambdaCube.Compiler.Token | ||
43 | LambdaCube.Compiler.Pretty | 42 | LambdaCube.Compiler.Pretty |
43 | LambdaCube.Compiler.Lexer | ||
44 | LambdaCube.Compiler.Parser | 44 | LambdaCube.Compiler.Parser |
45 | LambdaCube.Compiler.Infer | 45 | LambdaCube.Compiler.Infer |
46 | LambdaCube.Compiler.CoreToIR | 46 | LambdaCube.Compiler.CoreToIR |
diff --git a/src/LambdaCube/Compiler/Infer.hs b/src/LambdaCube/Compiler/Infer.hs index aa79354b..f7f5e809 100644 --- a/src/LambdaCube/Compiler/Infer.hs +++ b/src/LambdaCube/Compiler/Infer.hs | |||
@@ -37,6 +37,7 @@ import Control.Arrow hiding ((<+>)) | |||
37 | import Control.DeepSeq | 37 | import Control.DeepSeq |
38 | 38 | ||
39 | import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens) | 39 | import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens) |
40 | import LambdaCube.Compiler.Lexer | ||
40 | import LambdaCube.Compiler.Parser | 41 | import LambdaCube.Compiler.Parser |
41 | 42 | ||
42 | -------------------------------------------------------------------------------- compiled expression representation | 43 | -------------------------------------------------------------------------------- compiled expression representation |
diff --git a/src/LambdaCube/Compiler/Lexer.hs b/src/LambdaCube/Compiler/Lexer.hs new file mode 100644 index 00000000..dd61c5e0 --- /dev/null +++ b/src/LambdaCube/Compiler/Lexer.hs | |||
@@ -0,0 +1,640 @@ | |||
1 | -- contains Haskell source code copied from Text.Parsec.Token, see below | ||
2 | {-# LANGUAGE LambdaCase #-} | ||
3 | {-# LANGUAGE ViewPatterns #-} | ||
4 | {-# LANGUAGE PatternSynonyms #-} | ||
5 | {-# LANGUAGE FlexibleContexts #-} | ||
6 | {-# LANGUAGE FlexibleInstances #-} | ||
7 | {-# LANGUAGE NoMonomorphismRestriction #-} | ||
8 | {-# LANGUAGE OverloadedStrings #-} | ||
9 | {-# LANGUAGE ScopedTypeVariables #-} | ||
10 | {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance NFData SourcePos | ||
11 | {-# OPTIONS -fno-warn-unused-do-bind -fno-warn-name-shadowing #-} | ||
12 | module LambdaCube.Compiler.Lexer where | ||
13 | |||
14 | import Data.Monoid | ||
15 | import Data.Maybe | ||
16 | import Data.List | ||
17 | import Data.Char | ||
18 | import Data.Set (Set) | ||
19 | import qualified Data.Set as Set | ||
20 | import qualified Data.Map as Map | ||
21 | |||
22 | import Control.Monad.Except | ||
23 | import Control.Monad.Reader | ||
24 | import Control.Monad.Writer | ||
25 | import Control.Arrow hiding ((<+>)) | ||
26 | import Control.Applicative | ||
27 | import Control.DeepSeq | ||
28 | |||
29 | import Text.Parsec hiding (label, Empty, State, (<|>), many) | ||
30 | import qualified Text.Parsec as Pa | ||
31 | import qualified Text.Parsec.Token as Pa | ||
32 | import Text.ParserCombinators.Parsec.Language (GenLanguageDef (..)) | ||
33 | import qualified Text.ParserCombinators.Parsec.Language as Pa | ||
34 | import Text.Parsec.Indentation hiding (Any) | ||
35 | import qualified Text.Parsec.Indentation as Pa | ||
36 | import Text.Parsec.Indentation.Char | ||
37 | |||
38 | import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens) | ||
39 | |||
40 | -------------------------------------------------------------------------------- parser utils | ||
41 | |||
42 | -- see http://blog.ezyang.com/2014/05/parsec-try-a-or-b-considered-harmful/comment-page-1/#comment-6602 | ||
43 | try_ s m = Pa.try m <?> s | ||
44 | |||
45 | -- n, m >= 1, n < m | ||
46 | manyNM n m p = do | ||
47 | xs <- many1 p | ||
48 | let lxs = length xs | ||
49 | unless (n <= lxs && lxs <= m) . fail $ unwords ["manyNM", show n, show m, "found", show lxs, "occurences."] | ||
50 | return xs | ||
51 | |||
52 | -------------------------------------------------------------------------------- parser type | ||
53 | |||
54 | type P = ParsecT (IndentStream (CharIndentStream String)) SourcePos InnerP | ||
55 | type InnerP = WriterT [PostponedCheck] (Reader (DesugarInfo, Namespace)) | ||
56 | |||
57 | type PostponedCheck = Maybe String | ||
58 | |||
59 | type DesugarInfo = (FixityMap, ConsMap) | ||
60 | |||
61 | type ConsMap = Map.Map SName{-constructor name-} | ||
62 | (Either ((SName{-type name-}, Int{-num of indices-}), [(SName, Int)]{-constructors with arities-}) | ||
63 | Int{-arity-}) | ||
64 | |||
65 | dsInfo :: P DesugarInfo | ||
66 | dsInfo = asks fst | ||
67 | |||
68 | namespace :: P Namespace | ||
69 | namespace = asks snd | ||
70 | |||
71 | -------------------------------------------------------------------------------- lexing | ||
72 | |||
73 | {-# INLINE languageDef #-} | ||
74 | languageDef :: GenLanguageDef (IndentStream (CharIndentStream String)) SourcePos InnerP | ||
75 | languageDef = Pa.LanguageDef | ||
76 | { Pa.commentStart = Pa.commentStart Pa.haskellDef | ||
77 | , Pa.commentEnd = Pa.commentEnd Pa.haskellDef | ||
78 | , Pa.commentLine = Pa.commentLine Pa.haskellDef | ||
79 | , Pa.nestedComments = Pa.nestedComments Pa.haskellDef | ||
80 | , Pa.identStart = indentStreamParser $ charIndentStreamParser $ letter <|> char '_' -- '_' is included also | ||
81 | , Pa.identLetter = indentStreamParser $ charIndentStreamParser $ alphaNum <|> oneOf "_'#" | ||
82 | , Pa.opStart = indentStreamParser $ charIndentStreamParser $ oneOf ":!#$%&*+./<=>?@\\^|-~" | ||
83 | , Pa.opLetter = indentStreamParser $ charIndentStreamParser $ oneOf ":!#$%&*+./<=>?@\\^|-~" | ||
84 | , Pa.reservedOpNames = Pa.reservedOpNames Pa.haskellDef | ||
85 | , Pa.reservedNames = Pa.reservedNames Pa.haskellDef | ||
86 | , Pa.caseSensitive = Pa.caseSensitive Pa.haskellDef | ||
87 | } | ||
88 | |||
89 | lexeme p = p <* (getPosition >>= setState >> whiteSpace) | ||
90 | |||
91 | -------------------------------------------------------------------------------- names | ||
92 | |||
93 | type SName = String | ||
94 | |||
95 | caseName (c:cs) = toLower c: cs ++ "Case" | ||
96 | |||
97 | pattern MatchName cs <- (getMatchName -> Just cs) where MatchName = matchName | ||
98 | |||
99 | matchName cs = "match" ++ cs | ||
100 | getMatchName ('m':'a':'t':'c':'h':cs) = Just cs | ||
101 | getMatchName _ = Nothing | ||
102 | |||
103 | |||
104 | -------------------------------------------------------------------------------- source infos | ||
105 | |||
106 | instance NFData SourcePos where | ||
107 | rnf x = x `seq` () | ||
108 | |||
109 | data Range = Range SourcePos SourcePos | ||
110 | deriving (Eq, Ord) | ||
111 | |||
112 | instance NFData Range where | ||
113 | rnf (Range a b) = rnf a `seq` rnf b `seq` () | ||
114 | |||
115 | instance PShow Range where | ||
116 | pShowPrec _ (Range b e) | sourceName b == sourceName e = text (sourceName b) <+> f b <> "-" <> f e | ||
117 | where | ||
118 | f x = pShow (sourceLine x) <> ":" <> pShow (sourceColumn x) | ||
119 | |||
120 | joinRange :: Range -> Range -> Range | ||
121 | joinRange (Range b e) (Range b' e') = Range (min b b') (max e e') | ||
122 | |||
123 | data SI | ||
124 | = NoSI (Set String) -- no source info, attached debug info | ||
125 | | RangeSI Range | ||
126 | |||
127 | instance Show SI where show _ = "SI" | ||
128 | instance Eq SI where _ == _ = True | ||
129 | instance Ord SI where _ `compare` _ = EQ | ||
130 | |||
131 | instance Monoid SI where | ||
132 | mempty = NoSI Set.empty | ||
133 | mappend (RangeSI r1) (RangeSI r2) = RangeSI (joinRange r1 r2) | ||
134 | mappend (NoSI ds1) (NoSI ds2) = NoSI (ds1 `Set.union` ds2) | ||
135 | mappend r@RangeSI{} _ = r | ||
136 | mappend _ r@RangeSI{} = r | ||
137 | |||
138 | instance PShow SI where | ||
139 | pShowPrec _ (NoSI ds) = hsep $ map pShow $ Set.toList ds | ||
140 | pShowPrec _ (RangeSI r) = pShow r | ||
141 | |||
142 | showSI_ _ (NoSI ds) = unwords $ Set.toList ds | ||
143 | showSI_ source (RangeSI (Range s e)) = show str | ||
144 | where | ||
145 | startLine = sourceLine s - 1 | ||
146 | endline = sourceLine e - if sourceColumn e == 1 then 1 else 0 | ||
147 | len = endline - startLine | ||
148 | str = vcat $ text (show s <> ":"){- <+> "-" <+> text (show e)-}: | ||
149 | map text (take len $ drop startLine $ lines source) | ||
150 | ++ [text $ replicate (sourceColumn s - 1) ' ' ++ replicate (sourceColumn e - sourceColumn s) '^' | len == 1] | ||
151 | |||
152 | -- TODO: remove | ||
153 | validSI RangeSI{} = True | ||
154 | validSI _ = False | ||
155 | |||
156 | debugSI a = NoSI (Set.singleton a) | ||
157 | |||
158 | si@(RangeSI r) `validate` xs | all validSI xs && r `notElem` [r | RangeSI r <- xs] = si | ||
159 | _ `validate` _ = mempty | ||
160 | |||
161 | class SourceInfo si where | ||
162 | sourceInfo :: si -> SI | ||
163 | |||
164 | instance SourceInfo SI where | ||
165 | sourceInfo = id | ||
166 | |||
167 | instance SourceInfo si => SourceInfo [si] where | ||
168 | sourceInfo = foldMap sourceInfo | ||
169 | |||
170 | class SetSourceInfo a where | ||
171 | setSI :: SI -> a -> a | ||
172 | |||
173 | appRange :: P (SI -> a) -> P a | ||
174 | appRange p = (\p1 a p2 -> a $ RangeSI $ Range p1 p2) <$> getPosition <*> p <*> getState | ||
175 | |||
176 | withRange :: (SI -> a -> b) -> P a -> P b | ||
177 | withRange f p = appRange $ flip f <$> p | ||
178 | |||
179 | infix 9 `withRange` | ||
180 | |||
181 | type SIName = (SI, SName) | ||
182 | |||
183 | parseSIName :: P String -> P SIName | ||
184 | parseSIName = withRange (,) | ||
185 | |||
186 | -------------------------------------------------------------------------------- namespace handling | ||
187 | |||
188 | data Level = TypeLevel | ExpLevel | ||
189 | deriving (Eq, Show) | ||
190 | |||
191 | data Namespace = Namespace | ||
192 | { namespaceLevel :: Maybe Level | ||
193 | , constructorNamespace :: Bool -- True means that the case of the first letter of identifiers matters | ||
194 | } | ||
195 | deriving (Show) | ||
196 | |||
197 | tick :: Namespace -> SName -> SName | ||
198 | tick = (\case TypeLevel -> switchTick; _ -> id) . fromMaybe ExpLevel . namespaceLevel | ||
199 | |||
200 | switchTick ('\'': n) = n | ||
201 | switchTick n = '\'': n | ||
202 | |||
203 | modifyLevel f = local $ second $ \(Namespace l p) -> Namespace (f <$> l) p | ||
204 | |||
205 | typeNS, expNS, switchNS :: P a -> P a | ||
206 | typeNS = modifyLevel $ const TypeLevel | ||
207 | expNS = modifyLevel $ const ExpLevel | ||
208 | switchNS = modifyLevel $ \case ExpLevel -> TypeLevel; TypeLevel -> ExpLevel | ||
209 | |||
210 | -------------------------------------------------------------------------------- identifiers | ||
211 | |||
212 | check msg p m = try_ msg $ mfilter p m | ||
213 | |||
214 | firstCaseChar ('\'': c: _) = c | ||
215 | firstCaseChar (c: _) = c | ||
216 | |||
217 | upperCase, lowerCase, symbols, colonSymbols :: P SName | ||
218 | --upperCase NonTypeNamespace = mzero -- todo | ||
219 | upperCase = namespace >>= \ns -> (if constructorNamespace ns then check "uppercase ident" (isUpper . firstCaseChar) else id) $ tick ns <$> (identifier <|> try_ "tick ident" (('\'':) <$ char '\'' <*> identifier)) | ||
220 | lowerCase = namespace >>= \ns -> (if constructorNamespace ns then check "lowercase ident" (isLower . firstCaseChar) else id) identifier | ||
221 | <|> try_ "underscore ident" (('_':) <$ char '_' <*> identifier) | ||
222 | symbols = check "symbols" ((/=':') . head) operator | ||
223 | colonSymbols = "Cons" <$ reservedOp ":" <|> check "symbols" ((==':') . head) operator | ||
224 | |||
225 | moduleName = {-qualified_ todo-} expNS upperCase | ||
226 | patVar = lowerCase <|> "" <$ reserved "_" | ||
227 | --qIdent = {-qualified_ todo-} (lowerCase <|> upperCase) | ||
228 | backquotedIdent = try_ "backquoted ident" $ lexeme $ char '`' *> ((:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum)) <* char '`' | ||
229 | operatorT = symbols <|> colonSymbols <|> backquotedIdent | ||
230 | varId = lowerCase <|> parens operatorT | ||
231 | |||
232 | {- | ||
233 | qualified_ id = do | ||
234 | q <- try_ "qualification" $ upperCase' <* dot | ||
235 | (N t qs n i) <- qualified_ id | ||
236 | return $ N t (q:qs) n i | ||
237 | <|> | ||
238 | id | ||
239 | where | ||
240 | upperCase' = (:) <$> satisfy isUpper <*> many (satisfy isAlphaNum) | ||
241 | -} | ||
242 | |||
243 | -------------------------------------------------------------------------------- fixity handling | ||
244 | |||
245 | data FixityDef = Infix | InfixL | InfixR deriving (Show) | ||
246 | type Fixity = (FixityDef, Int) | ||
247 | type MFixity = Maybe Fixity | ||
248 | type FixityMap = Map.Map SName Fixity | ||
249 | |||
250 | calcPrec | ||
251 | :: (Show e, Show f) | ||
252 | => (f -> e -> e -> e) | ||
253 | -> (f -> Fixity) | ||
254 | -> e | ||
255 | -> [(f, e)] | ||
256 | -> e | ||
257 | calcPrec app getFixity e = compileOps [((Infix, -1), undefined, e)] | ||
258 | where | ||
259 | compileOps [(_, _, e)] [] = e | ||
260 | compileOps acc [] = compileOps (shrink acc) [] | ||
261 | compileOps acc@((p, g, e1): ee) es_@((op, e'): es) = case compareFixity (pr, op) (p, g) of | ||
262 | Right GT -> compileOps ((pr, op, e'): acc) es | ||
263 | Right LT -> compileOps (shrink acc) es_ | ||
264 | Left err -> error err | ||
265 | where | ||
266 | pr = getFixity op | ||
267 | |||
268 | shrink ((_, op, e): (pr, op', e'): es) = (pr, op', app op e' e): es | ||
269 | |||
270 | compareFixity ((dir, i), op) ((dir', i'), op') | ||
271 | | i > i' = Right GT | ||
272 | | i < i' = Right LT | ||
273 | | otherwise = case (dir, dir') of | ||
274 | (InfixL, InfixL) -> Right LT | ||
275 | (InfixR, InfixR) -> Right GT | ||
276 | _ -> Left $ "fixity error:" ++ show (op, op') | ||
277 | |||
278 | parseFixityDecl :: P [(SIName, Fixity)] | ||
279 | parseFixityDecl = do | ||
280 | dir <- Infix <$ reserved "infix" | ||
281 | <|> InfixL <$ reserved "infixl" | ||
282 | <|> InfixR <$ reserved "infixr" | ||
283 | localIndentation Gt $ do | ||
284 | i <- fromIntegral <$> natural | ||
285 | ns <- commaSep1 (parseSIName operatorT) | ||
286 | return $ (,) <$> ns <*> pure (dir, i) | ||
287 | |||
288 | getFixity :: DesugarInfo -> SName -> Fixity | ||
289 | getFixity (fm, _) n = fromMaybe (InfixL, 9) $ Map.lookup n fm | ||
290 | |||
291 | ------------------------------------------------------------------------------------------------- | ||
292 | |||
293 | |||
294 | |||
295 | |||
296 | |||
297 | ---------------------------------------------------------------------- | ||
298 | ---------------------------------------------------------------------- | ||
299 | -- copied from | ||
300 | -- | ||
301 | -- Module : Text.Parsec.Token | ||
302 | -- Copyright : (c) Daan Leijen 1999-2001, (c) Paolo Martini 2007 | ||
303 | -- License : BSD-style | ||
304 | |||
305 | ----------------------------------------------------------- | ||
306 | -- Bracketing | ||
307 | ----------------------------------------------------------- | ||
308 | parens p = between (symbol "(") (symbol ")") p | ||
309 | braces p = between (symbol "{") (symbol "}") p | ||
310 | angles p = between (symbol "<") (symbol ">") p | ||
311 | brackets p = between (symbol "[") (symbol "]") p | ||
312 | |||
313 | semi = symbol ";" | ||
314 | comma = symbol "," | ||
315 | dot = symbol "." | ||
316 | colon = symbol ":" | ||
317 | |||
318 | commaSep p = sepBy p comma | ||
319 | semiSep p = sepBy p semi | ||
320 | |||
321 | commaSep1 p = sepBy1 p comma | ||
322 | semiSep1 p = sepBy1 p semi | ||
323 | |||
324 | |||
325 | ----------------------------------------------------------- | ||
326 | -- Chars & Strings | ||
327 | ----------------------------------------------------------- | ||
328 | charLiteral = lexeme (between (char '\'') | ||
329 | (char '\'' <?> "end of character") | ||
330 | characterChar ) | ||
331 | <?> "character" | ||
332 | |||
333 | characterChar = charLetter <|> charEscape | ||
334 | <?> "literal character" | ||
335 | |||
336 | charEscape = do{ char '\\'; escapeCode } | ||
337 | charLetter = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026')) | ||
338 | |||
339 | |||
340 | |||
341 | stringLiteral = lexeme ( | ||
342 | do{ str <- between (char '"') | ||
343 | (localTokenMode (const Pa.Any) (char '"' <?> "end of string")) | ||
344 | (localTokenMode (const Pa.Any) (many stringChar)) | ||
345 | ; return (foldr (maybe id (:)) "" str) | ||
346 | } | ||
347 | <?> "literal string") | ||
348 | |||
349 | stringChar = do{ c <- stringLetter; return (Just c) } | ||
350 | <|> stringEscape | ||
351 | <?> "string character" | ||
352 | |||
353 | stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) | ||
354 | |||
355 | stringEscape = do{ char '\\' | ||
356 | ; do{ escapeGap ; return Nothing } | ||
357 | <|> do{ escapeEmpty; return Nothing } | ||
358 | <|> do{ esc <- escapeCode; return (Just esc) } | ||
359 | } | ||
360 | |||
361 | escapeEmpty = char '&' | ||
362 | escapeGap = do{ many1 space | ||
363 | ; char '\\' <?> "end of string gap" | ||
364 | } | ||
365 | |||
366 | |||
367 | |||
368 | -- escape codes | ||
369 | escapeCode = charEsc <|> charNum <|> charAscii <|> charControl | ||
370 | <?> "escape code" | ||
371 | |||
372 | charControl = do{ char '^' | ||
373 | ; code <- upper | ||
374 | ; return (toEnum (fromEnum code - fromEnum 'A')) | ||
375 | } | ||
376 | |||
377 | charNum = do{ code <- decimal | ||
378 | <|> do{ char 'o'; number 8 octDigit } | ||
379 | <|> do{ char 'x'; number 16 hexDigit } | ||
380 | ; return (toEnum (fromInteger code)) | ||
381 | } | ||
382 | |||
383 | charEsc = choice (map parseEsc escMap) | ||
384 | where | ||
385 | parseEsc (c,code) = do{ char c; return code } | ||
386 | |||
387 | charAscii = choice (map parseAscii asciiMap) | ||
388 | where | ||
389 | parseAscii (asc,code) = try (do{ string asc; return code }) | ||
390 | |||
391 | |||
392 | -- escape code tables | ||
393 | escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") | ||
394 | asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) | ||
395 | |||
396 | ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", | ||
397 | "FS","GS","RS","US","SP"] | ||
398 | ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", | ||
399 | "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", | ||
400 | "CAN","SUB","ESC","DEL"] | ||
401 | |||
402 | ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', | ||
403 | '\EM','\FS','\GS','\RS','\US','\SP'] | ||
404 | ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', | ||
405 | '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', | ||
406 | '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] | ||
407 | |||
408 | |||
409 | ----------------------------------------------------------- | ||
410 | -- Numbers | ||
411 | ----------------------------------------------------------- | ||
412 | naturalOrFloat = lexeme (natFloat) <?> "number" | ||
413 | |||
414 | float = lexeme floating <?> "float" | ||
415 | integer = lexeme int <?> "integer" | ||
416 | natural = lexeme nat <?> "natural" | ||
417 | |||
418 | |||
419 | -- floats | ||
420 | floating = do{ n <- decimal | ||
421 | ; fractExponent n | ||
422 | } | ||
423 | |||
424 | |||
425 | natFloat = do{ char '0' | ||
426 | ; zeroNumFloat | ||
427 | } | ||
428 | <|> decimalFloat | ||
429 | |||
430 | zeroNumFloat = do{ n <- hexadecimal <|> octal | ||
431 | ; return (Left n) | ||
432 | } | ||
433 | <|> decimalFloat | ||
434 | <|> fractFloat 0 | ||
435 | <|> return (Left 0) | ||
436 | |||
437 | decimalFloat = do{ n <- decimal | ||
438 | ; option (Left n) | ||
439 | (fractFloat n) | ||
440 | } | ||
441 | |||
442 | fractFloat n = do{ f <- fractExponent n | ||
443 | ; return (Right f) | ||
444 | } | ||
445 | |||
446 | fractExponent n = do{ fract <- fraction | ||
447 | ; expo <- option 1.0 exponent' | ||
448 | ; return ((fromInteger n + fract)*expo) | ||
449 | } | ||
450 | <|> | ||
451 | do{ expo <- exponent' | ||
452 | ; return ((fromInteger n)*expo) | ||
453 | } | ||
454 | |||
455 | fraction = do{ char '.' | ||
456 | ; digits <- many1 digit <?> "fraction" | ||
457 | ; return (foldr op 0.0 digits) | ||
458 | } | ||
459 | <?> "fraction" | ||
460 | where | ||
461 | op d f = (f + fromIntegral (digitToInt d))/10.0 | ||
462 | |||
463 | exponent' = do{ oneOf "eE" | ||
464 | ; f <- sign | ||
465 | ; e <- decimal <?> "exponent" | ||
466 | ; return (power (f e)) | ||
467 | } | ||
468 | <?> "exponent" | ||
469 | where | ||
470 | power e | e < 0 = 1.0/power(-e) | ||
471 | | otherwise = fromInteger (10^e) | ||
472 | |||
473 | |||
474 | -- integers and naturals | ||
475 | int = do{ f <- lexeme sign | ||
476 | ; n <- nat | ||
477 | ; return (f n) | ||
478 | } | ||
479 | |||
480 | sign = (char '-' >> return negate) | ||
481 | <|> (char '+' >> return id) | ||
482 | <|> return id | ||
483 | |||
484 | nat = zeroNumber <|> decimal | ||
485 | |||
486 | zeroNumber = do{ char '0' | ||
487 | ; hexadecimal <|> octal <|> decimal <|> return 0 | ||
488 | } | ||
489 | <?> "" | ||
490 | |||
491 | decimal = number 10 digit | ||
492 | hexadecimal = do{ oneOf "xX"; number 16 hexDigit } | ||
493 | octal = do{ oneOf "oO"; number 8 octDigit } | ||
494 | |||
495 | number base baseDigit | ||
496 | = do{ digits <- many1 baseDigit | ||
497 | ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits | ||
498 | ; seq n (return n) | ||
499 | } | ||
500 | |||
501 | ----------------------------------------------------------- | ||
502 | -- Operators & reserved ops | ||
503 | ----------------------------------------------------------- | ||
504 | reservedOp name = | ||
505 | lexeme $ try $ | ||
506 | do{ string name | ||
507 | ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name) | ||
508 | } | ||
509 | |||
510 | operator = | ||
511 | lexeme $ try $ | ||
512 | do{ name <- oper | ||
513 | ; if (isReservedOp name) | ||
514 | then unexpected ("reserved operator " ++ show name) | ||
515 | else return name | ||
516 | } | ||
517 | |||
518 | oper = | ||
519 | do{ c <- (opStart languageDef) | ||
520 | ; cs <- many (opLetter languageDef) | ||
521 | ; return (c:cs) | ||
522 | } | ||
523 | <?> "operator" | ||
524 | |||
525 | isReservedOp name = | ||
526 | isReserved (sort (reservedOpNames languageDef)) name | ||
527 | |||
528 | |||
529 | ----------------------------------------------------------- | ||
530 | -- Identifiers & Reserved words | ||
531 | ----------------------------------------------------------- | ||
532 | reserved name = | ||
533 | lexeme $ try $ | ||
534 | do{ caseString name | ||
535 | ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name) | ||
536 | } | ||
537 | |||
538 | caseString name | ||
539 | | caseSensitive languageDef = string name | ||
540 | | otherwise = do{ walk name; return name } | ||
541 | where | ||
542 | walk [] = return () | ||
543 | walk (c:cs) = do{ caseChar c <?> msg; walk cs } | ||
544 | |||
545 | caseChar c | isAlpha c = char (toLower c) <|> char (toUpper c) | ||
546 | | otherwise = char c | ||
547 | |||
548 | msg = show name | ||
549 | |||
550 | |||
551 | identifier = | ||
552 | lexeme $ try $ | ||
553 | do{ name <- ident | ||
554 | ; if (isReservedName name) | ||
555 | then unexpected ("reserved word " ++ show name) | ||
556 | else return name | ||
557 | } | ||
558 | |||
559 | |||
560 | ident | ||
561 | = do{ c <- identStart languageDef | ||
562 | ; cs <- many (identLetter languageDef) | ||
563 | ; return (c:cs) | ||
564 | } | ||
565 | <?> "identifier" | ||
566 | |||
567 | isReservedName name | ||
568 | = isReserved theReservedNames caseName | ||
569 | where | ||
570 | caseName | caseSensitive languageDef = name | ||
571 | | otherwise = map toLower name | ||
572 | |||
573 | |||
574 | isReserved names name | ||
575 | = scan names | ||
576 | where | ||
577 | scan [] = False | ||
578 | scan (r:rs) = case (compare r name) of | ||
579 | LT -> scan rs | ||
580 | EQ -> True | ||
581 | GT -> False | ||
582 | |||
583 | theReservedNames | ||
584 | | caseSensitive languageDef = sort reserved | ||
585 | | otherwise = sort . map (map toLower) $ reserved | ||
586 | where | ||
587 | reserved = reservedNames languageDef | ||
588 | |||
589 | |||
590 | |||
591 | ----------------------------------------------------------- | ||
592 | -- White space & symbols | ||
593 | ----------------------------------------------------------- | ||
594 | symbol name | ||
595 | = lexeme (string name) | ||
596 | |||
597 | whiteSpace = ignoreAbsoluteIndentation (localTokenMode (const Pa.Any) whiteSpace') | ||
598 | whiteSpace' | ||
599 | | noLine && noMulti = skipMany (simpleSpace <?> "") | ||
600 | | noLine = skipMany (simpleSpace <|> multiLineComment <?> "") | ||
601 | | noMulti = skipMany (simpleSpace <|> oneLineComment <?> "") | ||
602 | | otherwise = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "") | ||
603 | where | ||
604 | noLine = null (commentLine languageDef) | ||
605 | noMulti = null (commentStart languageDef) | ||
606 | |||
607 | simpleSpace = | ||
608 | skipMany1 (satisfy isSpace) | ||
609 | |||
610 | oneLineComment = | ||
611 | do{ try (string (commentLine languageDef)) | ||
612 | ; skipMany (satisfy (/= '\n')) | ||
613 | ; return () | ||
614 | } | ||
615 | |||
616 | multiLineComment = | ||
617 | do { try (string (commentStart languageDef)) | ||
618 | ; inComment | ||
619 | } | ||
620 | |||
621 | inComment | ||
622 | | nestedComments languageDef = inCommentMulti | ||
623 | | otherwise = inCommentSingle | ||
624 | |||
625 | inCommentMulti | ||
626 | = do{ try (string (commentEnd languageDef)) ; return () } | ||
627 | <|> do{ multiLineComment ; inCommentMulti } | ||
628 | <|> do{ skipMany1 (noneOf startEnd) ; inCommentMulti } | ||
629 | <|> do{ oneOf startEnd ; inCommentMulti } | ||
630 | <?> "end of comment" | ||
631 | where | ||
632 | startEnd = nub (commentEnd languageDef ++ commentStart languageDef) | ||
633 | |||
634 | inCommentSingle | ||
635 | = do{ try (string (commentEnd languageDef)); return () } | ||
636 | <|> do{ skipMany1 (noneOf startEnd) ; inCommentSingle } | ||
637 | <|> do{ oneOf startEnd ; inCommentSingle } | ||
638 | <?> "end of comment" | ||
639 | where | ||
640 | startEnd = nub (commentEnd languageDef ++ commentStart languageDef) | ||
diff --git a/src/LambdaCube/Compiler/Parser.hs b/src/LambdaCube/Compiler/Parser.hs index 2d7eb49f..31012fdd 100644 --- a/src/LambdaCube/Compiler/Parser.hs +++ b/src/LambdaCube/Compiler/Parser.hs | |||
@@ -7,8 +7,6 @@ | |||
7 | {-# LANGUAGE OverloadedStrings #-} | 7 | {-# LANGUAGE OverloadedStrings #-} |
8 | {-# LANGUAGE DeriveFunctor #-} | 8 | {-# LANGUAGE DeriveFunctor #-} |
9 | {-# LANGUAGE ScopedTypeVariables #-} | 9 | {-# LANGUAGE ScopedTypeVariables #-} |
10 | {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance NFData SourcePos | ||
11 | -- {-# OPTIONS_GHC -O0 #-} | ||
12 | module LambdaCube.Compiler.Parser | 10 | module LambdaCube.Compiler.Parser |
13 | {- todo ( definitions | 11 | {- todo ( definitions |
14 | , extensions | 12 | , extensions |
@@ -28,8 +26,6 @@ import Data.Maybe | |||
28 | import Data.List | 26 | import Data.List |
29 | import Data.Char | 27 | import Data.Char |
30 | import Data.String | 28 | import Data.String |
31 | import Data.Set (Set) | ||
32 | import qualified Data.Set as Set | ||
33 | import qualified Data.Map as Map | 29 | import qualified Data.Map as Map |
34 | 30 | ||
35 | import Control.Monad.Except | 31 | import Control.Monad.Except |
@@ -38,19 +34,16 @@ import Control.Monad.Writer | |||
38 | import Control.Monad.State | 34 | import Control.Monad.State |
39 | import Control.Arrow hiding ((<+>)) | 35 | import Control.Arrow hiding ((<+>)) |
40 | import Control.Applicative | 36 | import Control.Applicative |
41 | import Control.DeepSeq | ||
42 | 37 | ||
43 | import Text.Parsec hiding (label, Empty, State, (<|>), many, try) | 38 | import Text.Parsec hiding (label, Empty, State, (<|>), many, try) |
44 | import qualified Text.Parsec as Pa | 39 | import qualified Text.Parsec as Pa |
45 | import qualified Text.Parsec.Token as Pa | ||
46 | import qualified Text.ParserCombinators.Parsec.Language as Pa | ||
47 | import Text.Parsec.Pos | 40 | import Text.Parsec.Pos |
48 | import Text.Parsec.Indentation hiding (Any) | 41 | import Text.Parsec.Indentation hiding (Any) |
49 | import Text.Parsec.Indentation.Char | 42 | import Text.Parsec.Indentation.Char |
50 | 43 | ||
51 | import qualified LambdaCube.Compiler.Pretty as P | 44 | import qualified LambdaCube.Compiler.Pretty as P |
52 | import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens) | 45 | import LambdaCube.Compiler.Pretty hiding (Doc, braces, parens) |
53 | import LambdaCube.Compiler.Token | 46 | import LambdaCube.Compiler.Lexer |
54 | 47 | ||
55 | -------------------------------------------------------------------------------- utils | 48 | -------------------------------------------------------------------------------- utils |
56 | 49 | ||
@@ -78,309 +71,7 @@ traceD x = if debug then trace_ x else id | |||
78 | 71 | ||
79 | debug = False--True--tr | 72 | debug = False--True--tr |
80 | 73 | ||
81 | -------------------------------------------------------------------------------- parser utils | 74 | try = try_ |
82 | |||
83 | -- see http://blog.ezyang.com/2014/05/parsec-try-a-or-b-considered-harmful/comment-page-1/#comment-6602 | ||
84 | try s m = Pa.try m <?> s | ||
85 | |||
86 | -- n, m >= 1, n < m | ||
87 | manyNM n m p = do | ||
88 | xs <- many1 p | ||
89 | let lxs = length xs | ||
90 | unless (n <= lxs && lxs <= m) . fail $ unwords ["manyNM", show n, show m, "found", show lxs, "occurences."] | ||
91 | return xs | ||
92 | |||
93 | -------------------------------------------------------------------------------- parser type | ||
94 | |||
95 | type P = ParsecT (IndentStream (CharIndentStream String)) SourcePos InnerP | ||
96 | type InnerP = WriterT [PostponedCheck] (Reader (DesugarInfo, Namespace)) | ||
97 | |||
98 | type PostponedCheck = Maybe String | ||
99 | |||
100 | type DesugarInfo = (FixityMap, ConsMap) | ||
101 | |||
102 | type ConsMap = Map.Map SName{-constructor name-} | ||
103 | (Either ((SName{-type name-}, Int{-num of indices-}), [(SName, Int)]{-constructors with arities-}) | ||
104 | Int{-arity-}) | ||
105 | |||
106 | dsInfo :: P DesugarInfo | ||
107 | dsInfo = asks fst | ||
108 | |||
109 | namespace :: P Namespace | ||
110 | namespace = asks snd | ||
111 | |||
112 | -------------------------------------------------------------------------------- lexing | ||
113 | |||
114 | {-# NOINLINE lexer #-} | ||
115 | lexer :: Pa.GenTokenParser (IndentStream (CharIndentStream String)) SourcePos InnerP | ||
116 | lexer = makeTokenParser lexeme $ makeIndentLanguageDef style | ||
117 | where | ||
118 | style = Pa.LanguageDef | ||
119 | { Pa.commentStart = Pa.commentStart Pa.haskellDef | ||
120 | , Pa.commentEnd = Pa.commentEnd Pa.haskellDef | ||
121 | , Pa.commentLine = Pa.commentLine Pa.haskellDef | ||
122 | , Pa.nestedComments = Pa.nestedComments Pa.haskellDef | ||
123 | , Pa.identStart = letter <|> char '_' -- '_' is included also | ||
124 | , Pa.identLetter = alphaNum <|> oneOf "_'#" | ||
125 | , Pa.opStart = Pa.opLetter style | ||
126 | , Pa.opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" | ||
127 | , Pa.reservedOpNames = Pa.reservedOpNames Pa.haskellDef | ||
128 | , Pa.reservedNames = Pa.reservedNames Pa.haskellDef | ||
129 | , Pa.caseSensitive = Pa.caseSensitive Pa.haskellDef | ||
130 | } | ||
131 | |||
132 | lexeme p = p <* (getPosition >>= setState >> whiteSpace) | ||
133 | |||
134 | parens = Pa.parens lexer | ||
135 | braces = Pa.braces lexer | ||
136 | brackets = Pa.brackets lexer | ||
137 | commaSep = Pa.commaSep lexer | ||
138 | commaSep1 = Pa.commaSep1 lexer | ||
139 | --dot = Pa.dot lexer | ||
140 | --comma = Pa.comma lexer | ||
141 | colon = Pa.colon lexer | ||
142 | natural = Pa.natural lexer | ||
143 | --integer = Pa.integer lexer | ||
144 | float = Pa.float lexer | ||
145 | charLiteral = Pa.charLiteral lexer | ||
146 | stringLiteral = Pa.stringLiteral lexer | ||
147 | whiteSpace = Pa.whiteSpace lexer | ||
148 | operator = Pa.operator lexer | ||
149 | reserved = Pa.reserved lexer | ||
150 | reservedOp = Pa.reservedOp lexer | ||
151 | identifier = Pa.identifier lexer | ||
152 | |||
153 | |||
154 | -------------------------------------------------------------------------------- names | ||
155 | |||
156 | type SName = String | ||
157 | |||
158 | caseName (c:cs) = toLower c: cs ++ "Case" | ||
159 | |||
160 | pattern MatchName cs <- (getMatchName -> Just cs) where MatchName = matchName | ||
161 | |||
162 | matchName cs = "match" ++ cs | ||
163 | getMatchName ('m':'a':'t':'c':'h':cs) = Just cs | ||
164 | getMatchName _ = Nothing | ||
165 | |||
166 | |||
167 | -------------------------------------------------------------------------------- source infos | ||
168 | |||
169 | instance NFData SourcePos where | ||
170 | rnf x = x `seq` () | ||
171 | |||
172 | data Range = Range SourcePos SourcePos | ||
173 | deriving (Eq, Ord) | ||
174 | |||
175 | instance NFData Range where | ||
176 | rnf (Range a b) = rnf a `seq` rnf b `seq` () | ||
177 | |||
178 | instance PShow Range where | ||
179 | pShowPrec _ (Range b e) | sourceName b == sourceName e = text (sourceName b) <+> f b <> "-" <> f e | ||
180 | where | ||
181 | f x = pShow (sourceLine x) <> ":" <> pShow (sourceColumn x) | ||
182 | |||
183 | joinRange :: Range -> Range -> Range | ||
184 | joinRange (Range b e) (Range b' e') = Range (min b b') (max e e') | ||
185 | |||
186 | data SI | ||
187 | = NoSI (Set String) -- no source info, attached debug info | ||
188 | | RangeSI Range | ||
189 | |||
190 | instance Show SI where show _ = "SI" | ||
191 | instance Eq SI where _ == _ = True | ||
192 | instance Ord SI where _ `compare` _ = EQ | ||
193 | |||
194 | instance Monoid SI where | ||
195 | mempty = NoSI Set.empty | ||
196 | mappend (RangeSI r1) (RangeSI r2) = RangeSI (joinRange r1 r2) | ||
197 | mappend (NoSI ds1) (NoSI ds2) = NoSI (ds1 `Set.union` ds2) | ||
198 | mappend r@RangeSI{} _ = r | ||
199 | mappend _ r@RangeSI{} = r | ||
200 | |||
201 | instance PShow SI where | ||
202 | pShowPrec _ (NoSI ds) = hsep $ map pShow $ Set.toList ds | ||
203 | pShowPrec _ (RangeSI r) = pShow r | ||
204 | |||
205 | showSI_ _ (NoSI ds) = unwords $ Set.toList ds | ||
206 | showSI_ source (RangeSI (Range s e)) = show str | ||
207 | where | ||
208 | startLine = sourceLine s - 1 | ||
209 | endline = sourceLine e - if sourceColumn e == 1 then 1 else 0 | ||
210 | len = endline - startLine | ||
211 | str = vcat $ text (show s <> ":"){- <+> "-" <+> text (show e)-}: | ||
212 | map text (take len $ drop startLine $ lines source) | ||
213 | ++ [text $ replicate (sourceColumn s - 1) ' ' ++ replicate (sourceColumn e - sourceColumn s) '^' | len == 1] | ||
214 | |||
215 | -- TODO: remove | ||
216 | validSI RangeSI{} = True | ||
217 | validSI _ = False | ||
218 | |||
219 | debugSI a = NoSI (Set.singleton a) | ||
220 | |||
221 | si@(RangeSI r) `validate` xs | all validSI xs && r `notElem` [r | RangeSI r <- xs] = si | ||
222 | _ `validate` _ = mempty | ||
223 | |||
224 | class SourceInfo si where | ||
225 | sourceInfo :: si -> SI | ||
226 | |||
227 | instance SourceInfo SI where | ||
228 | sourceInfo = id | ||
229 | |||
230 | instance SourceInfo si => SourceInfo [si] where | ||
231 | sourceInfo = foldMap sourceInfo | ||
232 | |||
233 | instance SourceInfo ParPat where | ||
234 | sourceInfo (ParPat ps) = sourceInfo ps | ||
235 | |||
236 | instance SourceInfo Pat where | ||
237 | sourceInfo = \case | ||
238 | PVar (si,_) -> si | ||
239 | PCon (si,_) ps -> si <> sourceInfo ps | ||
240 | ViewPat e ps -> sourceInfo e <> sourceInfo ps | ||
241 | PatType ps e -> sourceInfo ps <> sourceInfo e | ||
242 | |||
243 | instance SourceInfo (SExp' a) where | ||
244 | sourceInfo = \case | ||
245 | SGlobal (si, _) -> si | ||
246 | SBind si _ _ e1 e2 -> si | ||
247 | SApp si _ e1 e2 -> si | ||
248 | SLet _ e1 e2 -> sourceInfo e1 <> sourceInfo e2 | ||
249 | SVar (si, _) _ -> si | ||
250 | STyped si _ -> si | ||
251 | SLit si _ -> si | ||
252 | |||
253 | class SetSourceInfo a where | ||
254 | setSI :: SI -> a -> a | ||
255 | |||
256 | instance SetSourceInfo (SExp' a) where | ||
257 | setSI si = \case | ||
258 | SBind _ a b c d -> SBind si a b c d | ||
259 | SApp _ a b c -> SApp si a b c | ||
260 | SLet le a b -> SLet le a b | ||
261 | SVar (_, n) i -> SVar (si, n) i | ||
262 | STyped _ t -> STyped si t | ||
263 | SGlobal (_, n) -> SGlobal (si, n) | ||
264 | SLit _ l -> SLit si l | ||
265 | |||
266 | appRange :: P (SI -> a) -> P a | ||
267 | appRange p = (\p1 a p2 -> a $ RangeSI $ Range p1 p2) <$> getPosition <*> p <*> getState | ||
268 | |||
269 | withRange :: (SI -> a -> b) -> P a -> P b | ||
270 | withRange f p = appRange $ flip f <$> p | ||
271 | |||
272 | infix 9 `withRange` | ||
273 | |||
274 | type SIName = (SI, SName) | ||
275 | |||
276 | parseSIName :: P String -> P SIName | ||
277 | parseSIName = withRange (,) | ||
278 | |||
279 | -------------------------------------------------------------------------------- namespace handling | ||
280 | |||
281 | data Level = TypeLevel | ExpLevel | ||
282 | deriving (Eq, Show) | ||
283 | |||
284 | data Namespace = Namespace | ||
285 | { namespaceLevel :: Maybe Level | ||
286 | , constructorNamespace :: Bool -- True means that the case of the first letter of identifiers matters | ||
287 | } | ||
288 | deriving (Show) | ||
289 | |||
290 | tick :: Namespace -> SName -> SName | ||
291 | tick = (\case TypeLevel -> switchTick; _ -> id) . fromMaybe ExpLevel . namespaceLevel | ||
292 | |||
293 | switchTick ('\'': n) = n | ||
294 | switchTick n = '\'': n | ||
295 | |||
296 | modifyLevel f = local $ second $ \(Namespace l p) -> Namespace (f <$> l) p | ||
297 | |||
298 | typeNS, expNS, switchNS :: P a -> P a | ||
299 | typeNS = modifyLevel $ const TypeLevel | ||
300 | expNS = modifyLevel $ const ExpLevel | ||
301 | switchNS = modifyLevel $ \case ExpLevel -> TypeLevel; TypeLevel -> ExpLevel | ||
302 | |||
303 | -------------------------------------------------------------------------------- identifiers | ||
304 | |||
305 | check msg p m = try msg $ mfilter p m | ||
306 | |||
307 | firstCaseChar ('\'': c: _) = c | ||
308 | firstCaseChar (c: _) = c | ||
309 | |||
310 | upperCase, lowerCase, symbols, colonSymbols :: P SName | ||
311 | --upperCase NonTypeNamespace = mzero -- todo | ||
312 | upperCase = namespace >>= \ns -> (if constructorNamespace ns then check "uppercase ident" (isUpper . firstCaseChar) else id) $ tick ns <$> (identifier <|> try "tick ident" (('\'':) <$ char '\'' <*> identifier)) | ||
313 | lowerCase = namespace >>= \ns -> (if constructorNamespace ns then check "lowercase ident" (isLower . firstCaseChar) else id) identifier | ||
314 | <|> try "underscore ident" (('_':) <$ char '_' <*> identifier) | ||
315 | symbols = check "symbols" ((/=':') . head) operator | ||
316 | colonSymbols = "Cons" <$ reservedOp ":" <|> check "symbols" ((==':') . head) operator | ||
317 | |||
318 | moduleName = {-qualified_ todo-} expNS upperCase | ||
319 | patVar = lowerCase <|> "" <$ reserved "_" | ||
320 | --qIdent = {-qualified_ todo-} (lowerCase <|> upperCase) | ||
321 | backquotedIdent = try "backquoted ident" $ lexeme $ char '`' *> ((:) <$> satisfy isAlpha <*> many (satisfy isAlphaNum)) <* char '`' | ||
322 | operatorT = symbols <|> colonSymbols <|> backquotedIdent | ||
323 | varId = lowerCase <|> parens operatorT | ||
324 | |||
325 | {- | ||
326 | qualified_ id = do | ||
327 | q <- try "qualification" $ upperCase' <* dot | ||
328 | (N t qs n i) <- qualified_ id | ||
329 | return $ N t (q:qs) n i | ||
330 | <|> | ||
331 | id | ||
332 | where | ||
333 | upperCase' = (:) <$> satisfy isUpper <*> many (satisfy isAlphaNum) | ||
334 | -} | ||
335 | |||
336 | -------------------------------------------------------------------------------- fixity handling | ||
337 | |||
338 | data FixityDef = Infix | InfixL | InfixR deriving (Show) | ||
339 | type Fixity = (FixityDef, Int) | ||
340 | type MFixity = Maybe Fixity | ||
341 | type FixityMap = Map.Map SName Fixity | ||
342 | |||
343 | calcPrec | ||
344 | :: (Show e, Show f) | ||
345 | => (f -> e -> e -> e) | ||
346 | -> (f -> Fixity) | ||
347 | -> e | ||
348 | -> [(f, e)] | ||
349 | -> e | ||
350 | calcPrec app getFixity e = compileOps [((Infix, -1), undefined, e)] | ||
351 | where | ||
352 | compileOps [(_, _, e)] [] = e | ||
353 | compileOps acc [] = compileOps (shrink acc) [] | ||
354 | compileOps acc@((p, g, e1): ee) es_@((op, e'): es) = case compareFixity (pr, op) (p, g) of | ||
355 | Right GT -> compileOps ((pr, op, e'): acc) es | ||
356 | Right LT -> compileOps (shrink acc) es_ | ||
357 | Left err -> error err | ||
358 | where | ||
359 | pr = getFixity op | ||
360 | |||
361 | shrink ((_, op, e): (pr, op', e'): es) = (pr, op', app op e' e): es | ||
362 | |||
363 | compareFixity ((dir, i), op) ((dir', i'), op') | ||
364 | | i > i' = Right GT | ||
365 | | i < i' = Right LT | ||
366 | | otherwise = case (dir, dir') of | ||
367 | (InfixL, InfixL) -> Right LT | ||
368 | (InfixR, InfixR) -> Right GT | ||
369 | _ -> Left $ "fixity error:" ++ show (op, op') | ||
370 | |||
371 | parseFixityDecl :: P [Stmt] | ||
372 | parseFixityDecl = do | ||
373 | dir <- Infix <$ reserved "infix" | ||
374 | <|> InfixL <$ reserved "infixl" | ||
375 | <|> InfixR <$ reserved "infixr" | ||
376 | localIndentation Gt $ do | ||
377 | i <- fromIntegral <$> natural | ||
378 | ns <- commaSep1 (parseSIName operatorT) | ||
379 | return $ PrecDef <$> ns <*> pure (dir, i) | ||
380 | |||
381 | getFixity :: DesugarInfo -> SName -> Fixity | ||
382 | getFixity (fm, _) n = fromMaybe (InfixL, 9) $ Map.lookup n fm | ||
383 | |||
384 | 75 | ||
385 | -------------------------------------------------------------------------------- literals | 76 | -------------------------------------------------------------------------------- literals |
386 | 77 | ||
@@ -489,6 +180,26 @@ downToS n m = map (SVar (debugSI "20", ".ds")) [n+m-1, n+m-2..n] | |||
489 | 180 | ||
490 | xSLabelEnd = id --SLabelEnd | 181 | xSLabelEnd = id --SLabelEnd |
491 | 182 | ||
183 | instance SourceInfo (SExp' a) where | ||
184 | sourceInfo = \case | ||
185 | SGlobal (si, _) -> si | ||
186 | SBind si _ _ e1 e2 -> si | ||
187 | SApp si _ e1 e2 -> si | ||
188 | SLet _ e1 e2 -> sourceInfo e1 <> sourceInfo e2 | ||
189 | SVar (si, _) _ -> si | ||
190 | STyped si _ -> si | ||
191 | SLit si _ -> si | ||
192 | |||
193 | instance SetSourceInfo (SExp' a) where | ||
194 | setSI si = \case | ||
195 | SBind _ a b c d -> SBind si a b c d | ||
196 | SApp _ a b c -> SApp si a b c | ||
197 | SLet le a b -> SLet le a b | ||
198 | SVar (_, n) i -> SVar (si, n) i | ||
199 | STyped _ t -> STyped si t | ||
200 | SGlobal (_, n) -> SGlobal (si, n) | ||
201 | SLit _ l -> SLit si l | ||
202 | |||
492 | -------------------------------------------------------------------------------- low-level toolbox | 203 | -------------------------------------------------------------------------------- low-level toolbox |
493 | 204 | ||
494 | foldS g f i = \case | 205 | foldS g f i = \case |
@@ -767,6 +478,16 @@ getPVars_ = \case | |||
767 | getPPVars_ = \case | 478 | getPPVars_ = \case |
768 | ParPat pp -> foldMap getPVars_ pp | 479 | ParPat pp -> foldMap getPVars_ pp |
769 | 480 | ||
481 | instance SourceInfo ParPat where | ||
482 | sourceInfo (ParPat ps) = sourceInfo ps | ||
483 | |||
484 | instance SourceInfo Pat where | ||
485 | sourceInfo = \case | ||
486 | PVar (si,_) -> si | ||
487 | PCon (si,_) ps -> si <> sourceInfo ps | ||
488 | ViewPat e ps -> sourceInfo e <> sourceInfo ps | ||
489 | PatType ps e -> sourceInfo ps <> sourceInfo e | ||
490 | |||
770 | -------------------------------------------------------------------------------- pattern parsing | 491 | -------------------------------------------------------------------------------- pattern parsing |
771 | 492 | ||
772 | parsePat :: Prec -> P Pat | 493 | parsePat :: Prec -> P Pat |
@@ -1029,7 +750,7 @@ parseDef = | |||
1029 | [{-TypeAnn x $ addParamsS ts $ SType-}{-todo-}] | 750 | [{-TypeAnn x $ addParamsS ts $ SType-}{-todo-}] |
1030 | [FunAlt x (zip ts $ map PVar $ reverse nps) $ Right rhs] | 751 | [FunAlt x (zip ts $ map PVar $ reverse nps) $ Right rhs] |
1031 | <|> do try "typed ident" $ (\(vs, t) -> TypeAnn <$> vs <*> pure t) <$> typedIds Nothing | 752 | <|> do try "typed ident" $ (\(vs, t) -> TypeAnn <$> vs <*> pure t) <$> typedIds Nothing |
1032 | <|> parseFixityDecl | 753 | <|> map (uncurry PrecDef) <$> parseFixityDecl |
1033 | <|> pure <$> funAltDef varId | 754 | <|> pure <$> funAltDef varId |
1034 | <|> pure <$> valueDef | 755 | <|> pure <$> valueDef |
1035 | where | 756 | where |