Text/ParserCombinators/Parsec/Token.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  Text.ParserCombinators.Parsec.Token
   4 -- Copyright   :  (c) Daan Leijen 1999-2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  daan@cs.uu.nl
   8 -- Stability   :  provisional
   9 -- Portability :  non-portable (uses existentially quantified data constructors)
  10 --
  11 -- A helper module to parse lexical elements (tokens).
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module Text.ParserCombinators.Parsec.Token
  16                   ( LanguageDef (..)
  17                   , TokenParser (..)
  18                   , makeTokenParser
  19                   ) where
  20
  21 import Data.Char (isAlpha,toLower,toUpper,isSpace,digitToInt)
  22 import Data.List (nub,sort)
  23 import Text.ParserCombinators.Parsec
  24
  25
  26 -----------------------------------------------------------
  27 -- Language Definition
  28 -----------------------------------------------------------
  29 data LanguageDef st
  30     = LanguageDef
  31     { commentStart   :: String
  32     , commentEnd     :: String
  33     , commentLine    :: String
  34     , nestedComments :: Bool
  35     , identStart     :: CharParser st Char
  36     , identLetter    :: CharParser st Char
  37     , opStart        :: CharParser st Char
  38     , opLetter       :: CharParser st Char
  39     , reservedNames  :: [String]
  40     , reservedOpNames:: [String]
  41     , caseSensitive  :: Bool
  42     }
  43
  44 -----------------------------------------------------------
  45 -- A first class module: TokenParser
  46 -----------------------------------------------------------
  47 data TokenParser st
  48     = TokenParser{ identifier       :: CharParser st String
  49                  , reserved         :: String -> CharParser st ()
  50                  , operator         :: CharParser st String
  51                  , reservedOp       :: String -> CharParser st ()
  52
  53                  , charLiteral      :: CharParser st Char
  54                  , stringLiteral    :: CharParser st String
  55                  , natural          :: CharParser st Integer
  56                  , integer          :: CharParser st Integer
  57                  , float            :: CharParser st Double
  58                  , naturalOrFloat   :: CharParser st (Either Integer Double)
  59                  , decimal          :: CharParser st Integer
  60                  , hexadecimal      :: CharParser st Integer
  61                  , octal            :: CharParser st Integer
  62
  63                  , symbol           :: String -> CharParser st String
  64                  , lexeme           :: forall a. CharParser st a -> CharParser st a
  65                  , whiteSpace       :: CharParser st ()
  66
  67                  , parens           :: forall a. CharParser st a -> CharParser st a
  68                  , braces           :: forall a. CharParser st a -> CharParser st a
  69                  , angles           :: forall a. CharParser st a -> CharParser st a
  70                  , brackets         :: forall a. CharParser st a -> CharParser st a
  71                  -- "squares" is deprecated
  72                  , squares          :: forall a. CharParser st a -> CharParser st a
  73
  74                  , semi             :: CharParser st String
  75                  , comma            :: CharParser st String
  76                  , colon            :: CharParser st String
  77                  , dot              :: CharParser st String
  78                  , semiSep          :: forall a . CharParser st a -> CharParser st [a]
  79                  , semiSep1         :: forall a . CharParser st a -> CharParser st [a]
  80                  , commaSep         :: forall a . CharParser st a -> CharParser st [a]
  81                  , commaSep1        :: forall a . CharParser st a -> CharParser st [a]
  82                  }
  83
  84 -----------------------------------------------------------
  85 -- Given a LanguageDef, create a token parser.
  86 -----------------------------------------------------------
  87 makeTokenParser :: LanguageDef st -> TokenParser st
  88 makeTokenParser languageDef
  89     = TokenParser{ identifier = identifier
  90                  , reserved = reserved
  91                  , operator = operator
  92                  , reservedOp = reservedOp
  93
  94                  , charLiteral = charLiteral
  95                  , stringLiteral = stringLiteral
  96                  , natural = natural
  97                  , integer = integer
  98                  , float = float
  99                  , naturalOrFloat = naturalOrFloat
 100                  , decimal = decimal
 101                  , hexadecimal = hexadecimal
 102                  , octal = octal
 103
 104                  , symbol = symbol
 105                  , lexeme = lexeme
 106                  , whiteSpace = whiteSpace
 107
 108                  , parens = parens
 109                  , braces = braces
 110                  , angles = angles
 111                  , brackets = brackets
 112                  , squares = brackets
 113                  , semi = semi
 114                  , comma = comma
 115                  , colon = colon
 116                  , dot = dot
 117                  , semiSep = semiSep
 118                  , semiSep1 = semiSep1
 119                  , commaSep = commaSep
 120                  , commaSep1 = commaSep1
 121                  }
 122     where
 123
 124     -----------------------------------------------------------
 125     -- Bracketing
 126     -----------------------------------------------------------
 127     parens p        = between (symbol "(") (symbol ")") p
 128     braces p        = between (symbol "{") (symbol "}") p
 129     angles p        = between (symbol "<") (symbol ">") p
 130     brackets p      = between (symbol "[") (symbol "]") p
 131
 132     semi            = symbol ";"
 133     comma           = symbol ","
 134     dot             = symbol "."
 135     colon           = symbol ":"
 136
 137     commaSep p      = sepBy p comma
 138     semiSep p       = sepBy p semi
 139
 140     commaSep1 p     = sepBy1 p comma
 141     semiSep1 p      = sepBy1 p semi
 142
 143
 144     -----------------------------------------------------------
 145     -- Chars & Strings
 146     -----------------------------------------------------------
 147     -- charLiteral :: CharParser st Char
 148     charLiteral     = lexeme (between (char '\'')
 149                                       (char '\'' <?> "end of character")
 150                                       characterChar )
 151                     <?> "character"
 152
 153     characterChar   = charLetter <|> charEscape
 154                     <?> "literal character"
 155
 156     charEscape      = do{ char '\\'; escapeCode }
 157     charLetter      = satisfy (\c -> (c /= '\'') && (c /= '\\') && (c > '\026'))
 158
 159
 160
 161     -- stringLiteral :: CharParser st String
 162     stringLiteral   = lexeme (
 163                       do{ str <- between (char '"')
 164                                          (char '"' <?> "end of string")
 165                                          (many stringChar)
 166                         ; return (foldr (maybe id (:)) "" str)
 167                         }
 168                       <?> "literal string")
 169
 170     -- stringChar :: CharParser st (Maybe Char)
 171     stringChar      =   do{ c <- stringLetter; return (Just c) }
 172                     <|> stringEscape
 173                     <?> "string character"
 174
 175     stringLetter    = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026'))
 176
 177     stringEscape    = do{ char '\\'
 178                         ;     do{ escapeGap  ; return Nothing }
 179                           <|> do{ escapeEmpty; return Nothing }
 180                           <|> do{ esc <- escapeCode; return (Just esc) }
 181                         }
 182
 183     escapeEmpty     = char '&'
 184     escapeGap       = do{ many1 space
 185                         ; char '\\' <?> "end of string gap"
 186                         }
 187
 188
 189
 190     -- escape codes
 191     escapeCode      = charEsc <|> charNum <|> charAscii <|> charControl
 192                     <?> "escape code"
 193
 194     -- charControl :: CharParser st Char
 195     charControl     = do{ char '^'
 196                         ; code <- upper
 197                         ; return (toEnum (fromEnum code - fromEnum 'A'))
 198                         }
 199
 200     -- charNum :: CharParser st Char
 201     charNum         = do{ code <- decimal
 202                                   <|> do{ char 'o'; number 8 octDigit }
 203                                   <|> do{ char 'x'; number 16 hexDigit }
 204                         ; return (toEnum (fromInteger code))
 205                         }
 206
 207     charEsc         = choice (map parseEsc escMap)
 208                     where
 209                       parseEsc (c,code)     = do{ char c; return code }
 210
 211     charAscii       = choice (map parseAscii asciiMap)
 212                     where
 213                       parseAscii (asc,code) = try (do{ string asc; return code })
 214
 215
 216     -- escape code tables
 217     escMap          = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'")
 218     asciiMap        = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2)
 219
 220     ascii2codes     = ["BS","HT","LF","VT","FF","CR","SO","SI","EM",
 221                        "FS","GS","RS","US","SP"]
 222     ascii3codes     = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL",
 223                        "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB",
 224                        "CAN","SUB","ESC","DEL"]
 225
 226     ascii2          = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI',
 227                        '\EM','\FS','\GS','\RS','\US','\SP']
 228     ascii3          = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK',
 229                        '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK',
 230                        '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL']
 231
 232
 233     -----------------------------------------------------------
 234     -- Numbers
 235     -----------------------------------------------------------
 236     -- naturalOrFloat :: CharParser st (Either Integer Double)
 237     naturalOrFloat  = lexeme (natFloat) <?> "number"
 238
 239     float           = lexeme floating   <?> "float"
 240     integer         = lexeme int        <?> "integer"
 241     natural         = lexeme nat        <?> "natural"
 242
 243
 244     -- floats
 245     floating        = do{ n <- decimal
 246                         ; fractExponent n
 247                         }
 248
 249
 250     natFloat        = do{ char '0'
 251                         ; zeroNumFloat
 252                         }
 253                       <|> decimalFloat
 254
 255     zeroNumFloat    =  do{ n <- hexadecimal <|> octal
 256                          ; return (Left n)
 257                          }
 258                     <|> decimalFloat
 259                     <|> fractFloat 0
 260                     <|> return (Left 0)
 261
 262     decimalFloat    = do{ n <- decimal
 263                         ; option (Left n)
 264                                  (fractFloat n)
 265                         }
 266
 267     fractFloat n    = do{ f <- fractExponent n
 268                         ; return (Right f)
 269                         }
 270
 271     fractExponent n = do{ fract <- fraction
 272                         ; expo  <- option 1.0 exponent'
 273                         ; return ((fromInteger n + fract)*expo)
 274                         }
 275                     <|>
 276                       do{ expo <- exponent'
 277                         ; return ((fromInteger n)*expo)
 278                         }
 279
 280     fraction        = do{ char '.'
 281                         ; digits <- many1 digit <?> "fraction"
 282                         ; return (foldr op 0.0 digits)
 283                         }
 284                       <?> "fraction"
 285                     where
 286                       op d f    = (f + fromIntegral (digitToInt d))/10.0
 287
 288     exponent'       = do{ oneOf "eE"
 289                         ; f <- sign
 290                         ; e <- decimal <?> "exponent"
 291                         ; return (power (f e))
 292                         }
 293                       <?> "exponent"
 294                     where
 295                        power e  | e < 0      = 1.0/power(-e)
 296                                 | otherwise  = fromInteger (10^e)
 297
 298
 299     -- integers and naturals
 300     int             = do{ f <- lexeme sign
 301                         ; n <- nat
 302                         ; return (f n)
 303                         }
 304
 305     -- sign            :: CharParser st (Integer -> Integer)
 306     sign            =   (char '-' >> return negate)
 307                     <|> (char '+' >> return id)
 308                     <|> return id
 309
 310     nat             = zeroNumber <|> decimal
 311
 312     zeroNumber      = do{ char '0'
 313                         ; hexadecimal <|> octal <|> decimal <|> return 0
 314                         }
 315                       <?> ""
 316
 317     decimal         = number 10 digit
 318     hexadecimal     = do{ oneOf "xX"; number 16 hexDigit }
 319     octal           = do{ oneOf "oO"; number 8 octDigit  }
 320
 321     -- number :: Integer -> CharParser st Char -> CharParser st Integer
 322     number base baseDigit
 323         = do{ digits <- many1 baseDigit
 324             ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits
 325             ; seq n (return n)
 326             }
 327
 328     -----------------------------------------------------------
 329     -- Operators & reserved ops
 330     -----------------------------------------------------------
 331     reservedOp name =
 332         lexeme $ try $
 333         do{ string name
 334           ; notFollowedBy (opLetter languageDef) <?> ("end of " ++ show name)
 335           }
 336
 337     operator =
 338         lexeme $ try $
 339         do{ name <- oper
 340           ; if (isReservedOp name)
 341              then unexpected ("reserved operator " ++ show name)
 342              else return name
 343           }
 344
 345     oper =
 346         do{ c <- (opStart languageDef)
 347           ; cs <- many (opLetter languageDef)
 348           ; return (c:cs)
 349           }
 350         <?> "operator"
 351
 352     isReservedOp name =
 353         isReserved (sort (reservedOpNames languageDef)) name
 354
 355
 356     -----------------------------------------------------------
 357     -- Identifiers & Reserved words
 358     -----------------------------------------------------------
 359     reserved name =
 360         lexeme $ try $
 361         do{ caseString name
 362           ; notFollowedBy (identLetter languageDef) <?> ("end of " ++ show name)
 363           }
 364
 365     caseString name
 366         | caseSensitive languageDef  = string name
 367         | otherwise               = do{ walk name; return name }
 368         where
 369           walk []     = return ()
 370           walk (c:cs) = do{ caseChar c <?> msg; walk cs }
 371
 372           caseChar c  | isAlpha c  = char (toLower c) <|> char (toUpper c)
 373                       | otherwise  = char c
 374
 375           msg         = show name
 376
 377
 378     identifier =
 379         lexeme $ try $
 380         do{ name <- ident
 381           ; if (isReservedName name)
 382              then unexpected ("reserved word " ++ show name)
 383              else return name
 384           }
 385
 386
 387     ident
 388         = do{ c <- identStart languageDef
 389             ; cs <- many (identLetter languageDef)
 390             ; return (c:cs)
 391             }
 392         <?> "identifier"
 393
 394     isReservedName name
 395         = isReserved theReservedNames caseName
 396         where
 397           caseName      | caseSensitive languageDef  = name
 398                         | otherwise               = map toLower name
 399
 400
 401     isReserved names name
 402         = scan names
 403         where
 404           scan []       = False
 405           scan (r:rs)   = case (compare r name) of
 406                             LT  -> scan rs
 407                             EQ  -> True
 408                             GT  -> False
 409
 410     theReservedNames
 411         | caseSensitive languageDef  = sortedNames
 412         | otherwise               = map (map toLower) sortedNames
 413         where
 414           sortedNames   = sort (reservedNames languageDef)
 415
 416
 417
 418     -----------------------------------------------------------
 419     -- White space & symbols
 420     -----------------------------------------------------------
 421     symbol name
 422         = lexeme (string name)
 423
 424     lexeme p
 425         = do{ x <- p; whiteSpace; return x  }
 426
 427
 428     --whiteSpace
 429     whiteSpace
 430         | noLine && noMulti  = skipMany (simpleSpace <?> "")
 431         | noLine             = skipMany (simpleSpace <|> multiLineComment <?> "")
 432         | noMulti            = skipMany (simpleSpace <|> oneLineComment <?> "")
 433         | otherwise          = skipMany (simpleSpace <|> oneLineComment <|> multiLineComment <?> "")
 434         where
 435           noLine  = null (commentLine languageDef)
 436           noMulti = null (commentStart languageDef)
 437
 438
 439     simpleSpace =
 440         skipMany1 (satisfy isSpace)
 441
 442     oneLineComment =
 443         do{ try (string (commentLine languageDef))
 444           ; skipMany (satisfy (/= '\n'))
 445           ; return ()
 446           }
 447
 448     multiLineComment =
 449         do { try (string (commentStart languageDef))
 450            ; inComment
 451            }
 452
 453     inComment
 454         | nestedComments languageDef  = inCommentMulti
 455         | otherwise                = inCommentSingle
 456
 457     inCommentMulti
 458         =   do{ try (string (commentEnd languageDef)) ; return () }
 459         <|> do{ multiLineComment                     ; inCommentMulti }
 460         <|> do{ skipMany1 (noneOf startEnd)          ; inCommentMulti }
 461         <|> do{ oneOf startEnd                       ; inCommentMulti }
 462         <?> "end of comment"
 463         where
 464           startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)
 465
 466     inCommentSingle
 467         =   do{ try (string (commentEnd languageDef)); return () }
 468         <|> do{ skipMany1 (noneOf startEnd)         ; inCommentSingle }
 469         <|> do{ oneOf startEnd                      ; inCommentSingle }
 470         <?> "end of comment"
 471         where
 472           startEnd   = nub (commentEnd languageDef ++ commentStart languageDef)
 473