@@ -1,809 +0,0 @@
1−-- | Functions for working with streams of tokens.
2−
3−module Text.Parsing.Parser.Token
4− ( token
5− , when
6− , match
7− , LanguageDef
8− , GenLanguageDef(LanguageDef)
9− , unGenLanguageDef
10− , TokenParser
11− , GenTokenParser
12− , makeTokenParser
13− -- should these be exported? Maybe they should go in a different module?
14− , digit
15− , hexDigit
16− , octDigit
17− , upper
18− , space
19− , letter
20− , alphaNum
21− )
22− where
23−
24−import Prelude hiding (when,between)
25−
26−import Control.Lazy (fix)
27−import Control.Monad.State (gets, modify_)
28−import Control.MonadPlus (guard, (<|>))
29−import Data.Array as Array
30−import Data.Char (fromCharCode, toCharCode)
31−import Data.Char.Unicode (digitToInt, isAlpha, isAlphaNum, isDigit, isHexDigit, isOctDigit, isSpace, isUpper)
32−import Data.Char.Unicode as Unicode
33−import Data.Either (Either(..))
34−import Data.Foldable (foldl, foldr)
35−import Data.Identity (Identity)
36−import Data.Int (toNumber)
37−import Data.List (List(..))
38−import Data.List as List
39−import Data.Maybe (Maybe(..), maybe)
40−import Data.String (null, toLower)
41−import Data.String.CodeUnits as SCU
42−import Data.Tuple (Tuple(..))
43−import Math (pow)
44−import Text.Parsing.Parser (ParseState(..), ParserT, fail)
45−import Text.Parsing.Parser.Combinators (skipMany1, try, tryRethrow, skipMany, notFollowedBy, option, choice, between, sepBy1, sepBy, (<?>), (<??>))
46−import Text.Parsing.Parser.Pos (Position)
47−import Text.Parsing.Parser.String (satisfy, oneOf, noneOf, string, char)
48−
49−-- | Create a parser which Returns the first token in the stream.
50−token :: forall m a. Monad m => (a -> Position) -> ParserT (List a) m a
51−token tokpos = do
52− input <- gets \(ParseState input _ _) -> input
53− case List.uncons input of
54− Nothing -> fail "Unexpected EOF"
55− Just { head, tail } -> do
56− modify_ \(ParseState _ position _) ->
57− ParseState tail (tokpos head) true
58− pure head
59−
60−-- | Create a parser which matches any token satisfying the predicate.
61−when :: forall m a. Monad m => (a -> Position) -> (a -> Boolean) -> ParserT (List a) m a
62−when tokpos f = tryRethrow do
63− a <- token tokpos
64− guard $ f a
65− pure a
66−
67−-- | Match the specified token at the head of the stream.
68−match :: forall a m. Monad m => Eq a => (a -> Position) -> a -> ParserT (List a) m a
69−match tokpos tok = when tokpos (_ == tok)
70−
71−type LanguageDef = GenLanguageDef String Identity
72−
73−-- | The `GenLanguageDef` type is a record that contains all parameterizable
74−-- | features of the "Text.Parsec.Token" module. The module `Text.Parsec.Language`
75−-- | contains some default definitions.
76−newtype GenLanguageDef s m
77− = LanguageDef {
78− -- | Describes the start of a block comment. Use the empty string if the
79− -- | language doesn't support block comments. For example `/*`.
80− commentStart :: String,
81− -- | Describes the end of a block comment. Use the empty string if the
82− -- | language doesn't support block comments. For example `*/`.
83− commentEnd :: String,
84− -- | Describes the start of a line comment. Use the empty string if the
85− -- | language doesn't support line comments. For example `//`.
86− commentLine :: String,
87− -- | Set to `true` if the language supports nested block comments.
88− nestedComments :: Boolean,
89− -- | This parser should accept any start characters of identifiers. For
90− -- | example `letter <|> char '_'`.
91− identStart :: ParserT s m Char,
92− -- | This parser should accept any legal tail characters of identifiers.
93− -- | For example `alphaNum <|> char '_'`.
94− identLetter :: ParserT s m Char,
95− -- | This parser should accept any start characters of operators. For
96− -- | example `oneOf [':', '+', '=']`.
97− opStart :: ParserT s m Char,
98− -- | This parser should accept any legal tail characters of operators.
99− -- | Note that this parser should even be defined if the language doesn't
100− -- | support user-defined operators, or otherwise the `reservedOp`
101− -- | parser won't work correctly.
102− opLetter :: ParserT s m Char,
103− -- | The list of reserved identifiers.
104− reservedNames :: Array String,
105− -- | The list of reserved operators.
106− reservedOpNames:: Array String,
107− -- | Set to `true` if the language is case sensitive.
108− caseSensitive :: Boolean
109− }
110−
111−unGenLanguageDef :: forall s m . GenLanguageDef s m -> { caseSensitive :: Boolean
112− , reservedOpNames :: Array String
113− , reservedNames :: Array String
114− , opLetter :: ParserT s m Char
115− , opStart :: ParserT s m Char
116− , identLetter :: ParserT s m Char
117− , identStart :: ParserT s m Char
118− , nestedComments :: Boolean
119− , commentLine :: String
120− , commentEnd :: String
121− , commentStart :: String
122− }
123−unGenLanguageDef (LanguageDef langDef) = langDef
124−
125−-----------------------------------------------------------
126−-- A first class module: TokenParser
127−-----------------------------------------------------------
128−
129−type TokenParser = GenTokenParser String Identity
130−
131−-- | The type of the record that holds lexical parsers that work on
132−-- | `s` streams over a monad `m`.
133−type GenTokenParser s m
134− = {
135− -- | This lexeme parser parses a legal identifier. Returns the identifier
136− -- | string. This parser will fail on identifiers that are reserved
137− -- | words. Legal identifier (start) characters and reserved words are
138− -- | defined in the `LanguageDef` that is passed to
139− -- | `makeTokenParser`. An `identifier` is treated as
140− -- | a single token using `try`.
141− identifier :: ParserT s m String,
142− -- | The lexeme parser `reserved name` parses `symbol
143− -- | name`, but it also checks that the `name` is not a prefix of a
144− -- | valid identifier. A `reserved` word is treated as a single token
145− -- | using `try`.
146− reserved :: String -> ParserT s m Unit,
147− -- | This lexeme parser parses a legal operator. Returns the name of the
148− -- | operator. This parser will fail on any operators that are reserved
149− -- | operators. Legal operator (start) characters and reserved operators
150− -- | are defined in the `LanguageDef` that is passed to
151− -- | `makeTokenParser`. An `operator` is treated as a
152− -- | single token using `try`.
153− operator :: ParserT s m String,
154− -- |The lexeme parser `reservedOp name` parses `symbol
155− -- | name`, but it also checks that the `name` is not a prefix of a
156− -- | valid operator. A `reservedOp` is treated as a single token using
157− -- | `try`.
158− reservedOp :: String -> ParserT s m Unit,
159− -- | This lexeme parser parses a single literal character. Returns the
160− -- | literal character value. This parsers deals correctly with escape
161− -- | sequences. The literal character is parsed according to the grammar
162− -- | rules defined in the Haskell report (which matches most programming
163− -- | languages quite closely).
164− charLiteral :: ParserT s m Char,
165− -- | This lexeme parser parses a literal string. Returns the literal
166− -- | string value. This parsers deals correctly with escape sequences and
167− -- | gaps. The literal string is parsed according to the grammar rules
168− -- | defined in the Haskell report (which matches most programming
169− -- | languages quite closely).
170− stringLiteral :: ParserT s m String,
171− -- | This lexeme parser parses a natural number (a positive whole
172− -- | number). Returns the value of the number. The number can be
173− -- | specified in `decimal`, `hexadecimal` or
174− -- | `octal`. The number is parsed according to the grammar
175− -- | rules in the Haskell report.
176− natural :: ParserT s m Int,
177− -- | This lexeme parser parses an integer (a whole number). This parser
178− -- | is like `natural` except that it can be prefixed with
179− -- | sign (i.e. `-` or `+`). Returns the value of the number. The
180− -- | number can be specified in `decimal`, `hexadecimal`
181− -- | or `octal`. The number is parsed according
182− -- | to the grammar rules in the Haskell report.
183− integer :: ParserT s m Int,
184− -- | This lexeme parser parses a floating point value. Returns the value
185− -- | of the number. The number is parsed according to the grammar rules
186− -- | defined in the Haskell report.
187− float :: ParserT s m Number,
188− -- | This lexeme parser parses either `natural` or a `float`.
189− -- | Returns the value of the number. This parsers deals with
190− -- | any overlap in the grammar rules for naturals and floats. The number
191− -- | is parsed according to the grammar rules defined in the Haskell report.
192− naturalOrFloat :: ParserT s m (Either Int Number),
193− -- | Parses a positive whole number in the decimal system. Returns the
194− -- | value of the number.
195− decimal :: ParserT s m Int,
196− -- | Parses a positive whole number in the hexadecimal system. The number
197− -- | should be prefixed with `0x` or `0X`. Returns the value of the
198− -- | number.
199− hexadecimal :: ParserT s m Int,
200− -- | Parses a positive whole number in the octal system. The number
201− -- | should be prefixed with `0o` or `0O`. Returns the value of the
202− -- | number.
203− octal :: ParserT s m Int,
204− -- | Lexeme parser `symbol s` parses `string` `s` and skips
205− -- | trailing white space.
206− symbol :: String -> ParserT s m String,
207− -- | `lexeme p` first applies parser `p` and than the `whiteSpace`
208− -- | parser, returning the value of `p`. Every lexical
209− -- | token (lexeme) is defined using `lexeme`, this way every parse
210− -- | starts at a point without white space. Parsers that use `lexeme` are
211− -- | called *lexeme* parsers in this document.
212− -- |
213− -- | The only point where the `whiteSpace` parser should be
214− -- | called explicitly is the start of the main parser in order to skip
215− -- | any leading white space.
216− -- |
217− -- | ```purescript
218− -- | mainParser = do
219− -- | whiteSpace
220− -- | ds <- many (lexeme digit)
221− -- | eof
222− -- | pure (sum ds)
223− -- | ```
224− lexeme :: forall a. ParserT s m a -> ParserT s m a,
225− -- | Parses any white space. White space consists of *zero* or more
226− -- | occurrences of a `space`, a line comment or a block (multi
227− -- | line) comment. Block comments may be nested. How comments are
228− -- | started and ended is defined in the `LanguageDef`
229− -- | that is passed to `makeTokenParser`.
230− whiteSpace :: ParserT s m Unit,
231− -- | Lexeme parser `parens p` parses `p` enclosed in parenthesis,
232− -- | returning the value of `p`.
233− parens :: forall a. ParserT s m a -> ParserT s m a,
234− -- | Lexeme parser `braces p` parses `p` enclosed in braces (`{` and
235− -- | `}`), returning the value of `p`.
236− braces :: forall a. ParserT s m a -> ParserT s m a,
237− -- | Lexeme parser `angles p` parses `p` enclosed in angle brackets (`<`
238− -- | and `>`), returning the value of `p`.
239− angles :: forall a. ParserT s m a -> ParserT s m a,
240− -- | Lexeme parser `brackets p` parses `p` enclosed in brackets (`[`
241− -- | and `]`), returning the value of `p`.
242− brackets :: forall a. ParserT s m a -> ParserT s m a,
243− -- | Lexeme parser `semi` parses the character `;` and skips any
244− -- | trailing white space. Returns the string `;`.
245− semi :: ParserT s m String,
246− -- | Lexeme parser `comma` parses the character `,` and skips any
247− -- | trailing white space. Returns the string `,`.
248− comma :: ParserT s m String,
249− -- | Lexeme parser `colon` parses the character `:` and skips any
250− -- | trailing white space. Returns the string `:`.
251− colon :: ParserT s m String,
252− -- | Lexeme parser `dot` parses the character `.` and skips any
253− -- | trailing white space. Returns the string `.`.
254− dot :: ParserT s m String,
255− -- | Lexeme parser `semiSep p` parses *zero* or more occurrences of `p`
256− -- | separated by `semi`. Returns a list of values pureed by
257− -- | `p`.
258− semiSep :: forall a . ParserT s m a -> ParserT s m (List a),
259− -- | Lexeme parser `semiSep1 p` parses *one* or more occurrences of `p`
260− -- | separated by `semi`. Returns a list of values pureed by `p`.
261− semiSep1 :: forall a . ParserT s m a -> ParserT s m (List a),
262− -- | Lexeme parser `commaSep p` parses *zero* or more occurrences of
263− -- | `p` separated by `comma`. Returns a list of values pureed
264− -- | by `p`.
265− commaSep :: forall a . ParserT s m a -> ParserT s m (List a),
266− -- | Lexeme parser `commaSep1 p` parses *one* or more occurrences of
267− -- | `p` separated by `comma`. Returns a list of values pureed
268− -- | by `p`.
269− commaSep1 :: forall a . ParserT s m a -> ParserT s m (List a)
270− }
271−
272−-----------------------------------------------------------
273−-- Given a LanguageDef, create a token parser.
274−-----------------------------------------------------------
275−
276−-- | The expression `makeTokenParser language` creates a `GenTokenParser`
277−-- | record that contains lexical parsers that are
278−-- | defined using the definitions in the `language` record.
279−-- |
280−-- | The use of this function is quite stylized - one imports the
281−-- | appropiate language definition and selects the lexical parsers that
282−-- | are needed from the resulting `GenTokenParser`.
283−-- |
284−-- | ```purescript
285−-- | module Main where
286−-- |
287−-- | import Text.Parsing.Parser.Language (haskellDef)
288−-- | import Text.Parsing.Parser.Token (makeTokenParser)
289−-- |
290−-- | -- The parser
291−-- | expr = parens expr
292−-- | <|> identifier
293−-- | <|> ...
294−-- |
295−-- |
296−-- | -- The lexer
297−-- | tokenParser = makeTokenParser haskellDef
298−-- | parens = tokenParser.parens
299−-- | braces = tokenParser.braces
300−-- | identifier = tokenParser.identifier
301−-- | reserved = tokenParser.reserved
302−-- | ...
303−-- | ```
304−makeTokenParser :: forall m . Monad m => GenLanguageDef String m -> GenTokenParser String m
305−makeTokenParser (LanguageDef languageDef)
306− = { identifier: identifier
307− , reserved: reserved
308− , operator: operator
309− , reservedOp: reservedOp
310−
311− , charLiteral: charLiteral
312− , stringLiteral: stringLiteral
313− , natural: natural
314− , integer: integer
315− , float: float
316− , naturalOrFloat: naturalOrFloat
317− , decimal: decimal
318− , hexadecimal: hexadecimal
319− , octal: octal
320−
321− , symbol: symbol
322− , lexeme: lexeme
323− , whiteSpace: whiteSpace' (LanguageDef languageDef)
324−
325− , parens: parens
326− , braces: braces
327− , angles: angles
328− , brackets: brackets
329− , semi: semi
330− , comma: comma
331− , colon: colon
332− , dot: dot
333− , semiSep: semiSep
334− , semiSep1: semiSep1
335− , commaSep: commaSep
336− , commaSep1: commaSep1
337− }
338− where
339− -----------------------------------------------------------
340− -- Bracketing
341− -----------------------------------------------------------
342− parens :: forall a . ParserT String m a -> ParserT String m a
343− parens p = between (symbol "(") (symbol ")") p
344−
345− braces :: forall a . ParserT String m a -> ParserT String m a
346− braces p = between (symbol "{") (symbol "}") p
347−
348− angles :: forall a . ParserT String m a -> ParserT String m a
349− angles p = between (symbol "<") (symbol ">") p
350−
351− brackets :: forall a . ParserT String m a -> ParserT String m a
352− brackets p = between (symbol "[") (symbol "]") p
353−
354− semi :: ParserT String m String
355− semi = symbol ";"
356−
357− comma :: ParserT String m String
358− comma = symbol ","
359−
360− dot :: ParserT String m String
361− dot = symbol "."
362−
363− colon :: ParserT String m String
364− colon = symbol ":"
365−
366− commaSep :: forall a . ParserT String m a -> ParserT String m (List a)
367− commaSep p = sepBy p comma
368−
369− semiSep :: forall a . ParserT String m a -> ParserT String m (List a)
370− semiSep p = sepBy p semi
371−
372− commaSep1 :: forall a . ParserT String m a -> ParserT String m (List a)
373− commaSep1 p = sepBy1 p comma
374−
375− semiSep1 :: forall a . ParserT String m a -> ParserT String m (List a)
376− semiSep1 p = sepBy1 p semi
377−
378− -----------------------------------------------------------
379− -- Chars & Strings
380− -----------------------------------------------------------
381− charLiteral :: ParserT String m Char
382− charLiteral = lexeme go <?> "character"
383− where
384− go :: ParserT String m Char
385− go = between (char '\'') (char '\'' <?> "end of character") characterChar
386−
387− characterChar :: ParserT String m Char
388− characterChar = charLetter <|> charEscape <?> "literal character"
389−
390− charEscape :: ParserT String m Char
391− charEscape = char '\\' *> escapeCode
392−
393− charLetter :: ParserT String m Char
394− charLetter = satisfy \c -> (c /= '\'') && (c /= '\\') && (c > '\x1A')
395−
396− stringLiteral :: ParserT String m String
397− stringLiteral = lexeme (go <?> "literal string")
398− where
399− go :: ParserT String m String
400− go = do
401− maybeChars <- between (char '"') (char '"' <?> "end of string") (List.many stringChar)
402− pure $ SCU.fromCharArray $ List.toUnfoldable $ foldr folder Nil maybeChars
403−
404− folder :: Maybe Char -> List Char -> List Char
405− folder Nothing chars = chars
406− folder (Just c) chars = Cons c chars
407−
408−
409− stringChar :: ParserT String m (Maybe Char)
410− stringChar = (Just <$> stringLetter)
411− <|> stringEscape
412− <?> "string character"
413−
414− stringLetter :: ParserT String m Char
415− stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\x1A'))
416−
417− stringEscape :: ParserT String m (Maybe Char)
418− stringEscape = do
419− _ <- char '\\'
420− (escapeGap $> Nothing) <|> (escapeEmpty $> Nothing) <|> (Just <$> escapeCode)
421−
422− escapeEmpty :: ParserT String m Char
423− escapeEmpty = char '&'
424−
425− escapeGap :: ParserT String m Char
426− escapeGap = Array.some space *> char '\\' <?> "end of string gap"
427−
428− -- -- escape codes
429− escapeCode :: ParserT String m Char
430− escapeCode = charEsc <|> charNum <|> charAscii <|> charControl
431− <?> "escape code"
432−
433− charControl :: ParserT String m Char
434− charControl = do
435− _ <- char '^'
436− code <- upper
437− case fromCharCode (toCharCode code - toCharCode 'A' + 1) of
438− Just c -> pure c
439− Nothing -> fail "invalid character code (should not happen)"
440−
441− charNum :: ParserT String m Char
442− charNum = do
443− code <- decimal
444− <|> ( char 'o' *> number 8 octDigit )
445− <|> ( char 'x' *> number 16 hexDigit )
446− if code > 0x10FFFF
447− then fail "invalid escape sequence"
448− else case fromCharCode code of
449− Just c -> pure c
450− Nothing -> fail "invalid character code (should not happen)"
451−
452− charEsc :: ParserT String m Char
453− charEsc = choice (map parseEsc escMap)
454− where
455− parseEsc :: Tuple Char Char -> ParserT String m Char
456− parseEsc (Tuple c code) = char c $> code
457−
458− charAscii :: ParserT String m Char
459− charAscii = choice (map parseAscii asciiMap)
460− where
461− parseAscii :: Tuple String Char -> ParserT String m Char
462− parseAscii (Tuple asc code) = try $ string asc $> code
463−
464− -- escape code tables
465− escMap :: Array (Tuple Char Char)
466− escMap = Array.zip [ 'a', 'b', 'f', 'n', 'r', 't', 'v', '\\', '\"', '\'' ]
467− [ '\x7', '\x8', '\xC', '\n', '\r', '\t', '\xB', '\\', '\"', '\'' ]
468−
469− asciiMap :: Array (Tuple String Char)
470− asciiMap = Array.zip (ascii3codes <> ascii2codes) (ascii3 <> ascii2)
471−
472− ascii2codes :: Array String
473− ascii2codes = [ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI", "EM", "FS", "GS", "RS", "US", "SP" ]
474−
475− ascii3codes :: Array String
476− ascii3codes = [ "NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL"
477− , "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB"
478− , "CAN", "SUB", "ESC", "DEL"
479− ]
480−
481− ascii2 :: Array Char
482− ascii2 = [ '\x8', '\x9', '\xA', '\xB', '\xC', '\xD', '\xE', '\xF'
483− , '\x19', '\x1C', '\x1D', '\x1E', '\x1F', '\x20'
484− ]
485−
486− ascii3 :: Array Char
487− ascii3 = [ '\x0', '\x1', '\x2', '\x3', '\x4', '\x5', '\x6'
488− , '\x7', '\x10', '\x11', '\x12', '\x13', '\x14', '\x15'
489− , '\x16', '\x17', '\x18', '\x1A', '\x1B', '\x7F'
490− ]
491−
492− -----------------------------------------------------------
493− -- Numbers
494− -----------------------------------------------------------
495−
496− naturalOrFloat :: ParserT String m (Either Int Number)
497− naturalOrFloat = lexeme (natFloat) <?> "number"
498−
499− float :: ParserT String m Number
500− float = lexeme floating <?> "float"
501−
502− integer :: ParserT String m Int
503− integer = lexeme int <?> "integer"
504−
505− natural :: ParserT String m Int
506− natural = lexeme nat <?> "natural"
507−
508− -- floats
509− floating :: ParserT String m Number
510− floating = decimal >>= fractExponent
511−
512− natFloat :: ParserT String m (Either Int Number)
513− natFloat = char '0' *> zeroNumFloat
514− <|> decimalFloat
515−
516− zeroNumFloat :: ParserT String m (Either Int Number)
517− zeroNumFloat = Left <$> (hexadecimal <|> octal)
518− <|> decimalFloat
519− <|> fractFloat 0
520− <|> pure (Left 0)
521−
522− decimalFloat :: ParserT String m (Either Int Number)
523− decimalFloat = do
524− n <- decimal
525− option (Left n) (fractFloat n)
526−
527− fractFloat :: forall a . Int -> ParserT String m (Either a Number)
528− fractFloat n = Right <$> fractExponent n
529−
530− fractExponent :: Int -> ParserT String m Number
531− fractExponent n = fractExponent' <|> justExponent
532− where
533− fractExponent' :: ParserT String m Number
534− fractExponent' = do
535− fract <- fraction
536− expo <- option 1.0 exponent'
537− pure $ (toNumber n + fract) * expo
538−
539− justExponent :: ParserT String m Number
540− justExponent = do
541− expo <- exponent'
542− pure $ (toNumber n * expo)
543−
544− fraction :: ParserT String m Number
545− fraction = "fraction" <??> do
546− _ <- char '.'
547− digits <- Array.some digit <?> "fraction"
548− maybe (fail "not digit") pure $ foldr op (Just 0.0) digits
549− where
550− op :: Char -> Maybe Number -> Maybe Number
551− op _ Nothing = Nothing
552− op d (Just f) = do
553− int' <- digitToInt d
554− pure $ ( f + toNumber int' ) / 10.0
555−
556− exponent' :: ParserT String m Number
557− exponent' = "exponent" <??> do
558− _ <- oneOf ['e', 'E']
559− f <- sign
560− e <- decimal <?> "exponent"
561− pure $ power (f e)
562− where
563− power :: Int -> Number
564− power e | e < 0 = 1.0 / power (-e)
565− | otherwise = 10.0 `pow` toNumber e
566−
567− -- integers and naturals
568− int :: ParserT String m Int
569− int = do
570− f <- lexeme sign
571− n <- nat
572− pure $ f n
573−
574− sign :: forall a . (Ring a) => ParserT String m (a -> a)
575− sign = (char '-' $> negate)
576− <|> (char '+' $> identity)
577− <|> pure identity
578−
579− nat :: ParserT String m Int
580− nat = zeroNumber <|> decimal
581−
582− zeroNumber :: ParserT String m Int
583− zeroNumber = char '0' *>
584− ( hexadecimal <|> octal <|> decimal <|> pure 0 ) <?> ""
585−
586− decimal :: ParserT String m Int
587− decimal = number 10 digit
588−
589− hexadecimal :: ParserT String m Int
590− hexadecimal = oneOf ['x', 'X'] *> number 16 hexDigit
591−
592− octal :: ParserT String m Int
593− octal = oneOf ['o', 'O'] *> number 8 octDigit
594−
595− number :: Int -> ParserT String m Char -> ParserT String m Int
596− number base baseDigit = do
597− digits <- Array.some baseDigit
598− maybe (fail "not digits") pure $ foldl folder (Just 0) digits
599− where
600− folder :: Maybe Int -> Char -> Maybe Int
601− folder Nothing _ = Nothing
602− folder (Just x) d = ((base * x) + _) <$> digitToInt d
603−
604− -----------------------------------------------------------
605− -- Operators & reserved ops
606− -----------------------------------------------------------
607−
608− reservedOp :: String -> ParserT String m Unit
609− reservedOp name = lexeme $ try go
610− where
611− go :: ParserT String m Unit
612− go = do
613− _ <- string name
614− notFollowedBy languageDef.opLetter <?> "end of " <> name
615−
616− operator :: ParserT String m String
617− operator = lexeme $ try go
618− where
619− go :: ParserT String m String
620− go = do
621− name <- oper
622− if (isReservedOp name)
623− then fail ("reserved operator " <> name)
624− else pure name
625−
626− oper :: ParserT String m String
627− oper = go <?> "operator"
628− where
629− go :: ParserT String m String
630− go = do
631− c <- languageDef.opStart
632− cs <- Array.many languageDef.opLetter
633− pure $ SCU.singleton c <> SCU.fromCharArray cs
634−
635− isReservedOp :: String -> Boolean
636− isReservedOp name = isReserved (Array.sort languageDef.reservedOpNames) name
637−
638−
639− -----------------------------------------------------------
640− -- Identifiers & Reserved words
641− -----------------------------------------------------------
642−
643− reserved :: String -> ParserT String m Unit
644− reserved name = lexeme $ try go
645− where
646− go :: ParserT String m Unit
647− go = caseString name *> (notFollowedBy languageDef.identLetter <?> "end of " <> name)
648−
649− caseString :: String -> ParserT String m String
650− caseString name | languageDef.caseSensitive = string name $> name
651− | otherwise = walk name $> name
652− where
653− walk :: String -> ParserT String m Unit
654− walk name' = case SCU.uncons name' of
655− Nothing -> pure unit
656− Just { head: c, tail: cs } -> (caseChar c <?> msg) *> walk cs
657−
658− caseChar :: Char -> ParserT String m Char
659− caseChar c | isAlpha c = char (Unicode.toLower c) <|> char (Unicode.toUpper c)
660− | otherwise = char c
661−
662− msg :: String
663− msg = show name
664−
665−
666− identifier :: ParserT String m String
667− identifier = lexeme $ try go
668− where
669− go :: ParserT String m String
670− go = do
671− name <- ident
672− if (isReservedName (LanguageDef languageDef) name)
673− then fail ("reserved word " <> show name)
674− else pure name
675−
676−
677− ident :: ParserT String m String
678− ident = go <?> "identifier"
679− where
680− go :: ParserT String m String
681− go = do
682− c <- languageDef.identStart
683− cs <- Array.many languageDef.identLetter
684− pure $ SCU.singleton c <> SCU.fromCharArray cs
685−
686−
687− -----------------------------------------------------------
688− -- White space & symbols
689− -----------------------------------------------------------
690− symbol :: String -> ParserT String m String
691− symbol name = lexeme (string name) $> name
692−
693− lexeme :: forall a . ParserT String m a -> ParserT String m a
694− lexeme p = p <* whiteSpace' (LanguageDef languageDef)
695−
696−
697−-- ================================================================================ --
698−-- The following functions should really be in the where-clause of makeTokenParser, --
699−-- but they can't go there because they are mutually recursive. --
700−-- ================================================================================ --
701−
702−-----------------------------------------------------------
703−-- Identifiers & Reserved words
704−-----------------------------------------------------------
705−
706−isReservedName :: forall m . Monad m => GenLanguageDef String m -> String -> Boolean
707−isReservedName langDef@(LanguageDef languageDef) name =
708− isReserved (theReservedNames langDef) caseName
709− where
710− caseName | languageDef.caseSensitive = name
711− | otherwise = toLower name
712−
713−isReserved :: Array String -> String -> Boolean
714−isReserved names name =
715− case Array.uncons names of
716− Nothing -> false
717− Just { head: r, tail: rs } -> case (compare r name) of
718− LT -> isReserved rs name
719− EQ -> true
720− GT -> false
721−
722−theReservedNames :: forall m . Monad m => GenLanguageDef String m -> Array String
723−theReservedNames (LanguageDef languageDef)
724− | languageDef.caseSensitive = Array.sort languageDef.reservedNames
725− | otherwise = Array.sort $ map toLower languageDef.reservedNames
726−
727−-----------------------------------------------------------
728−-- White space & symbols
729−-----------------------------------------------------------
730−
731−whiteSpace' :: forall m . Monad m => GenLanguageDef String m -> ParserT String m Unit
732−whiteSpace' langDef@(LanguageDef languageDef)
733− | null languageDef.commentLine && null languageDef.commentStart =
734− skipMany (simpleSpace <?> "")
735− | null languageDef.commentLine =
736− skipMany (simpleSpace <|> multiLineComment langDef <?> "")
737− | null languageDef.commentStart =
738− skipMany (simpleSpace <|> oneLineComment langDef <?> "")
739− | otherwise =
740− skipMany (simpleSpace <|> oneLineComment langDef <|> multiLineComment langDef <?> "")
741−
742−simpleSpace :: forall m . Monad m => ParserT String m Unit
743−simpleSpace = skipMany1 (satisfy isSpace)
744−
745−oneLineComment :: forall m . Monad m => GenLanguageDef String m -> ParserT String m Unit
746−oneLineComment (LanguageDef languageDef) =
747− try (string languageDef.commentLine) *> skipMany (satisfy (_ /= '\n'))
748−
749−multiLineComment :: forall m . Monad m => GenLanguageDef String m -> ParserT String m Unit
750−multiLineComment langDef@(LanguageDef languageDef) =
751− try (string languageDef.commentStart) *> inComment langDef
752−
753−inComment :: forall m . Monad m => GenLanguageDef String m -> ParserT String m Unit
754−inComment langDef@(LanguageDef languageDef) =
755− if languageDef.nestedComments then inCommentMulti langDef else inCommentSingle langDef
756−
757−inCommentMulti :: forall m . Monad m => GenLanguageDef String m -> ParserT String m Unit
758−inCommentMulti langDef@(LanguageDef languageDef) =
759− fix \p -> ( void $ try (string languageDef.commentEnd) )
760− <|> ( multiLineComment langDef *> p )
761− <|> ( skipMany1 (noneOf startEnd) *> p )
762− <|> ( oneOf startEnd *> p )
763− <?> "end of comment"
764− where
765− startEnd :: Array Char
766− startEnd = SCU.toCharArray languageDef.commentEnd <> SCU.toCharArray languageDef.commentStart
767−
768−inCommentSingle :: forall m . Monad m => GenLanguageDef String m -> ParserT String m Unit
769−inCommentSingle (LanguageDef languageDef) =
770− fix \p -> ( void $ try (string languageDef.commentEnd) )
771− <|> ( skipMany1 (noneOf startEnd) *> p )
772− <|> ( oneOf startEnd *> p )
773− <?> "end of comment"
774− where
775− startEnd :: Array Char
776− startEnd = SCU.toCharArray languageDef.commentEnd <> SCU.toCharArray languageDef.commentStart
777−
778−-------------------------------------------------------------------------
779−-- Helper functions that should maybe go in Text.Parsing.Parser.String --
780−-------------------------------------------------------------------------
781−
782−-- | Parse a digit. Matches any char that satisfies `Data.Char.Unicode.isDigit`.
783−digit :: forall m . Monad m => ParserT String m Char
784−digit = satisfy isDigit <?> "digit"
785−
786−-- | Parse a hex digit. Matches any char that satisfies `Data.Char.Unicode.isHexDigit`.
787−hexDigit :: forall m . Monad m => ParserT String m Char
788−hexDigit = satisfy isHexDigit <?> "hex digit"
789−
790−-- | Parse an octal digit. Matches any char that satisfies `Data.Char.Unicode.isOctDigit`.
791−octDigit :: forall m . Monad m => ParserT String m Char
792−octDigit = satisfy isOctDigit <?> "oct digit"
793−
794−-- | Parse an uppercase letter. Matches any char that satisfies `Data.Char.Unicode.isUpper`.
795−upper :: forall m . Monad m => ParserT String m Char
796−upper = satisfy isUpper <?> "uppercase letter"
797−
798−-- | Parse a space character. Matches any char that satisfies `Data.Char.Unicode.isSpace`.
799−space :: forall m . Monad m => ParserT String m Char
800−space = satisfy isSpace <?> "space"
801−
802−-- | Parse an alphabetical character. Matches any char that satisfies `Data.Char.Unicode.isAlpha`.
803−letter :: forall m . Monad m => ParserT String m Char
804−letter = satisfy isAlpha <?> "letter"
805−
806−-- | Parse an alphabetical or numerical character.
807−-- | Matches any char that satisfies `Data.Char.Unicode.isAlphaNum`.
808−alphaNum :: forall m . Monad m => ParserT String m Char
809−alphaNum = satisfy isAlphaNum <?> "letter or digit"