ajhc-0.8.0.1: src/FrontEnd/Lexer.hs
-- #hide
-----------------------------------------------------------------------------
-- |
-- Module : Language.Haskell.Lexer
-- Copyright : (c) The GHC Team, 1997-2000
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- Lexer for Haskell.
--
-----------------------------------------------------------------------------
-- ToDo: Introduce different tokens for decimal, octal and hexadecimal (?)
-- ToDo: FloatTok should have three parts (integer part, fraction, exponent) (?)
-- ToDo: Use a lexical analyser generator (lx?)
module FrontEnd.Lexer (Token(..), lexer) where
import Control.Monad
import Data.Char hiding(isSymbol)
import Data.Ratio
import qualified Data.Char
import qualified Data.Map as Map
import qualified Data.Set as Set
import FrontEnd.ParseMonad
import FrontEnd.SrcLoc
import FrontEnd.Warning
import Name.Name
import Options
import PackedString
import Util.SetLike
import qualified FlagOpts as FO
data Token
= VarId !Name
| QVarId !Name
| ConId !Name
| QConId !Name
| VarSym !Name
| ConSym !Name
| QVarSym !Name
| QConSym !Name
| IntTok !Integer
| UIntTok !Integer
| FloatTok !Rational
| Character !Char
| UCharacter !Char
| StringTok String
| UStringTok String
| PragmaOptions [String]
| PragmaInline String
| PragmaExp String
| PragmaRules !Bool
| PragmaSpecialize !Bool
| PragmaStart String
| PragmaEnd
-- Symbols
| LeftParen
| RightParen
| LeftUParen
| RightUParen
| SemiColon
| LeftCurly
| RightCurly
| VRightCurly -- a virtual close brace
| LeftSquare
| RightSquare
| Comma
| Underscore
| BackQuote
-- Reserved operators
| DotDot
| Colon
| DoubleColon
| Equals
| Backslash
| Bar
| LeftArrow
| RightArrow
| At
| Tilde
| DoubleArrow
| Minus
| Quest
| QuestQuest
| StarBang
| Exclamation
| BangExclamation
| Star
| Hash
| Dot
-- Reserved Ids
| KW_As
| KW_Case
| KW_Class
| KW_Alias
| KW_Data
| KW_Default
| KW_Deriving
| KW_Do
| KW_Else
| KW_Hiding
| KW_If
| KW_Import
| KW_In
| KW_Infix
| KW_InfixL
| KW_InfixR
| KW_Instance
| KW_Let
| KW_Module
| KW_NewType
| KW_Of
| KW_Then
| KW_Type
| KW_Where
| KW_Qualified
| KW_Foreign
| KW_Forall
| KW_Exists
| KW_Kind
| KW_Family
| KW_Closed
| EOF
reserved_ops :: Map.Map Name Token
reserved_ops = procMap [
( "..", DotDot ),
-- ( ":", Colon ),
( "::", DoubleColon ),
( "=", Equals ),
( "\\", Backslash ),
( "|", Bar ),
( "<-", LeftArrow ),
( "->", RightArrow ),
( "@", At ),
( "~", Tilde ),
( "=>", DoubleArrow ),
( [chr 0x2192], RightArrow ), -- →
( [chr 0x2190], LeftArrow ), -- ←
( [chr 0x2237], DoubleColon ), -- ∷
( [chr 0x2025], DotDot ), -- ‥
( [chr 0x21d2], DoubleArrow ) -- ⇒
]
special_varops :: Map.Map Name Token
special_varops = procMap [
( "-", Minus ), --ToDo: shouldn't be here
( "?", Quest ), --ditto
( "??", QuestQuest ),--ditto
( "*!", StarBang ),--ditto
( "!", Exclamation ), --ditto
( ".", Dot ), --ditto
( "*", Star ), --ditto
( "\x2605", Star ), --ditto
( "#", Hash ) --ditto
]
procMap :: [(String,Token)] -> Map.Map Name Token
procMap xs = fromList $ map f xs where
f (x,y) = (toUnqualName x,y)
reserved_ids :: Map.Map Name Token
reserved_ids = procMap [
( "_", Underscore ),
( "case", KW_Case ),
( "class", KW_Class ),
( "alias", KW_Alias ),
( "data", KW_Data ),
( "default", KW_Default ),
( "deriving", KW_Deriving ),
( "do", KW_Do ),
( "else", KW_Else ),
( "if", KW_If ),
( "import", KW_Import ),
( "in", KW_In ),
( "infix", KW_Infix ),
( "infixl", KW_InfixL ),
( "infixr", KW_InfixR ),
( "instance", KW_Instance ),
( "let", KW_Let ),
( "module", KW_Module ),
( "newtype", KW_NewType ),
( "of", KW_Of ),
( "then", KW_Then ),
( "type", KW_Type ),
( "\x2200", KW_Forall ),
( ['∃'], KW_Exists ),
( "where", KW_Where )
]
special_varids :: Map.Map Name Token
special_varids = procMap [
( "as", KW_As ),
( "closed", KW_Closed ),
( "qualified", KW_Qualified ),
( "hiding", KW_Hiding ),
( "forall", KW_Forall )
]
-- these become keywords when the cooresponding extensions are enabled.
optional_ids = procOpt [
( "kind", KW_Kind, FO.UserKinds ),
( "foreign", KW_Foreign, FO.Ffi ),
( "family", KW_Family, FO.TypeFamilies ),
( "forall", KW_Forall, FO.Forall ),
( "exists", KW_Exists, FO.Exists),
( "!" , BangExclamation, FO.BangPatterns )
]
procOpt xs = Map.fromList [ (toUnqualName w,(o,k)) | (w,k,o) <- xs ]
isIdent :: Char -> Bool
isIdent c = isAlpha c || isDigit c || c == '\'' || c == '_'
isSymbol :: Char -> Bool
isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~" || (not (isAscii c) && Data.Char.isSymbol c)
matchChar :: Char -> String -> Lex a ()
matchChar c msg = do
s <- getInput
if null s || head s /= c then fail msg else discard 1
-- The top-level lexer.
-- We need to know whether we are at the beginning of the line to decide
-- whether to insert layout tokens.
lexer :: (Token -> P a) -> P a
lexer = runL topLexer
topLexer :: Lex a Token
topLexer = do
b <- pullCtxtFlag
if b
then setBOL >> return VRightCurly -- the lex context state flags that we must do an empty {} - UGLY
else do
bol <- checkBOL
bol <- lexWhiteSpace bol
startToken
if bol then lexBOL else lexToken
lexWhiteSpace :: Bool -> Lex a Bool
lexWhiteSpace bol = do
let linePragma = do
lexWhile (`elem` " \r\t")
v <- lexDecimal
lexWhile (`elem` " \r\t")
s <- getInput
fn <- case s of
'"':_ -> do
discard 1
StringTok s <- lexString
return (Just s)
_ -> return Nothing
-- discard any "flags" at end of line ...
lexWhile (`elem` " \r\t")
lexWhile (isDigit)
setFilePos (fromInteger v - 1) 1 fn
lexWhiteSpace False
s <- getInput
case s of
'{':'-':'#':s
| pname `Map.member` pragmas -> return bol
| otherwise -> do
when (pname `Set.notMember` pragmas_ignored) $
addWarn (UnknownPragma $ packString pname) $ "The pragma '" ++ pname ++ "' is unknown"
discard 2
bol <- lexNestedComment bol
lexWhiteSpace bol
where pname = takeWhile isIdent (dropWhile isSpace s)
'{':'-':_ -> do
discard 2
bol <- lexNestedComment bol
lexWhiteSpace bol
'-':'-':rest | all (== '-') (takeWhile isSymbol rest) -> do
lexWhile (== '-')
lexWhile (/= '\n')
s' <- getInput
case s' of
-- [] -> fail "Unterminated end-of-line comment"
_ -> lexWhiteSpace False
'\n':'#':' ':ns -> discard 2 >> linePragma
'\n':'#':'l':'i':'n':'e':' ':ns -> discard 6 >> linePragma
'\n':_ -> do
lexNewline
lexWhiteSpace True
'\t':_ -> do
lexTab
lexWhiteSpace bol
c:_ | isSpace c -> do
discard 1
lexWhiteSpace bol
_ -> return bol
setFilePos :: Int -> Int -> Maybe String -> Lex a ()
setFilePos line column ms = do
sl <- getSrcLoc
let sl' = sl { srcLocLine = line, srcLocColumn = column }
case ms of
Just fn -> setSrcLoc sl' { srcLocFileName = packString fn }
Nothing -> setSrcLoc sl'
lexNestedComment :: Bool -> Lex a Bool
lexNestedComment bol = do
s <- getInput
case s of
'-':'}':_ -> discard 2 >> return bol
'{':'-':_ -> do
discard 2
bol <- lexNestedComment bol -- rest of the subcomment
lexNestedComment bol -- rest of this comment
'\t':_ -> lexTab >> lexNestedComment bol
'\n':_ -> lexNewline >> lexNestedComment True
_:_ -> discard 1 >> lexNestedComment bol
[] -> fail "Unterminated nested comment"
lexRawPragma :: String -> Lex a Token
lexRawPragma w = rp [] where
rp c = do
s <- getInput
case s of
'#':'-':'}':_ | w == "OPTIONS" -> discard 3 >> return (PragmaOptions (words $ reverse c))
-- '#':'-':'}':_ -> discard 3 >> return (PragmaRaw w (reverse c))
'#':'-':'}':_ -> fail "Unknown raw pragma"
'\t':_ -> lexTab >> rp ('\t':c)
'\n':_ -> lexNewline >> rp ('\n':c)
x:_ -> discard 1 >> rp (x:c)
[] -> fail "Unterminated raw pragma"
-- When we are lexing the first token of a line, check whether we need to
-- insert virtual semicolons or close braces due to layout.
lexBOL :: Lex a Token
lexBOL = do
pos <- getOffside
case pos of
LT -> do
-- trace "layout: inserting '}'\n" $
-- Set col to 0, indicating that we're still at the
-- beginning of the line, in case we need a semi-colon too.
-- Also pop the context here, so that we don't insert
-- another close brace before the parser can pop it.
setBOL
popContextL "lexBOL"
return VRightCurly
EQ ->
-- trace "layout: inserting ';'\n" $
return SemiColon
GT ->
lexToken
lexToken :: Lex a Token
lexToken = do
s <- getInput
ParseMode { parseUnboxedValues = uval, parseUnboxedTuples = utup, parseOpt = opt } <- lexParseMode
let opt_ids = Map.mapMaybe f optional_ids where
f (fo,k) = if fo `Set.member` optFOptsSet opt
then Just k else Nothing
case s of
[] -> return EOF
'(':'#':_ | utup -> do
discard 2
return LeftUParen
'#':')':_ | utup -> do
discard 2
return RightUParen
'{':'-':'#':s' -> do
discard 3
lexWhile isSpace
w <- lexWhile isIdent
case normPragma w of
Right t -> return t
Left w' -> lexRawPragma w'
'#':'-':'}':_ -> do
discard 3
return PragmaEnd
'0':c:d:_ | toLower c == 'o' && isOctDigit d -> do
discard 2
n <- lexOctal
return (IntTok n)
| toLower c == 'x' && isHexDigit d -> do
discard 2
n <- lexHexadecimal
rest <- getInput
case rest of
'#':_ | uval -> discard 1 >> return (UIntTok n)
_ -> return (IntTok n)
c:_ | isDigit c -> lexDecimalOrFloat
| isUpper c -> lexConIdOrQual ""
| isLower c || c == '_' || generalCategory c == OtherLetter -> do
(toUnqualName -> ident) <- lexWhile isIdent
case Map.lookup ident (opt_ids `Map.union` reserved_ids `Map.union` special_varids) of
Just KW_Do -> setFlagDo >> return KW_Do
Just keyword -> return keyword
Nothing -> return $ VarId ident
| isSymbol c -> do
sym <- lexWhile isSymbol
let nsym = toUnqualName sym
return $ case Map.lookup nsym (opt_ids `Map.union` reserved_ops `Map.union` special_varops) of
Just t -> t
Nothing -> case c of
':' -> ConSym nsym
_ -> VarSym nsym
| otherwise -> do
discard 1
case c of
-- First the special symbols
'(' -> return LeftParen
')' -> return RightParen
',' -> return Comma
';' -> return SemiColon
'[' -> return LeftSquare
']' -> return RightSquare
'`' -> return BackQuote
'{' -> do
pushContextL NoLayout
return LeftCurly
'}' -> do
popContextL "lexToken"
return RightCurly
'\'' -> do
c2 <- lexChar
matchChar '\'' "Improperly terminated character constant"
rest <- getInput
case rest of
--'#':_ | uval -> discard 1 >> return (UIntTok $ fromIntegral $ ord c2)
'#':_ | uval -> discard 1 >> return (UCharacter c2)
_ -> return (Character c2)
'"' -> lexString
_ -> fail ("Illegal character \'" ++ show c ++ "\'\n")
lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat = do
ParseMode { parseUnboxedValues = uval } <- lexParseMode
let ld ds' = do
ds <- lexWhile isDigit
rest <- getInput
case rest of
('_':_) -> discard 1 >> ld (ds' ++ ds)
rest -> return (ds' ++ ds,rest)
(ds,rest) <- ld []
case rest of
('.':d:_) | isDigit d -> do
discard 1
frac <- lexWhile isDigit
let num = parseInteger 10 (ds ++ frac)
decimals = toInteger (length frac)
exponent <- do
rest2 <- getInput
case rest2 of
e:pm:d:_ | e `elem` "eE", (pm `elem` "+-" && isDigit d) || isDigit pm -> lexExponent
-- 'e':_ -> lexExponent
-- 'E':_ -> lexExponent
_ -> return 0
return (FloatTok ((num%1) * 10^^(exponent - decimals)))
e:_ | toLower e == 'e' -> do
exponent <- lexExponent
return (FloatTok ((parseInteger 10 ds%1) * 10^^exponent))
'#':_ | uval -> discard 1 >> return (UIntTok (parseInteger 10 ds))
_ -> return (IntTok (parseInteger 10 ds))
where
lexExponent :: Lex a Integer
lexExponent = do
discard 1 -- 'e' or 'E'
r <- getInput
case r of
'+':d:_ | isDigit d -> do
discard 1
lexDecimal
'-':d:_ | isDigit d -> do
discard 1
n <- lexDecimal
return (negate n)
d:_ | isDigit d -> lexDecimal
_ -> fail "Float with missing exponent"
lexConIdOrQual :: String -> Lex a Token
lexConIdOrQual qual = do
con <- lexWhile isIdent
let conid | null qual = ConId (toUnqualName con)
| otherwise = QConId (toName UnknownType (qual,con))
qual' | null qual = con
| otherwise = qual ++ '.':con
just_a_conid <- alternative (return conid)
rest <- getInput
case rest of
'.':c:_
| isLower c || c == '_' -> do -- qualified varid?
discard 1
ident <- lexWhile isIdent
case Map.lookup (toUnqualName ident) reserved_ids of
-- cannot qualify a reserved word
Just _ -> just_a_conid
Nothing -> return (QVarId $ toName UnknownType (qual', ident))
| isUpper c -> do -- qualified conid?
discard 1
lexConIdOrQual qual'
| isSymbol c -> do -- qualified symbol?
discard 1
sym <- lexWhile isSymbol
let nsym = toUnqualName sym
case Map.lookup nsym reserved_ops of
-- cannot qualify a reserved operator
Just _ -> just_a_conid
Nothing -> return $ case c of
':' -> QConSym $ toName UnknownType (qual', sym)
_ -> QVarSym $ toName UnknownType (qual', sym)
_ -> return conid -- not a qualified thing
lexChar :: Lex a Char
lexChar = do
r <- getInput
case r of
'\\':_ -> lexEscape
c:_ -> discard 1 >> return c
[] -> fail "Incomplete character constant"
lexString :: Lex a Token
lexString = do
ParseMode { parseUnboxedValues = uval } <- lexParseMode
let loop s = do
r <- getInput
case r of
'\\':'&':_ -> do
discard 2
loop s
'\\':c:_ | isSpace c -> do
discard 1
lexWhiteChars
matchChar '\\' "Illegal character in string gap"
loop s
| otherwise -> do
ce <- lexEscape
loop (ce:s)
'"':'#':_ | uval -> do
discard 2
return (UStringTok (reverse s))
'"':_ -> do
discard 1
return (StringTok (reverse s))
c:_ -> do
discard 1
loop (c:s)
[] -> fail "Improperly terminated string"
lexWhiteChars :: Lex a ()
lexWhiteChars = do
s <- getInput
case s of
'\n':_ -> do
lexNewline
lexWhiteChars
'\t':_ -> do
lexTab
lexWhiteChars
c:_ | isSpace c -> do
discard 1
lexWhiteChars
_ -> return ()
loop ""
lexEscape :: Lex a Char
lexEscape = do
discard 1
r <- getInput
case r of
-- Production charesc from section B.2 (Note: \& is handled by caller)
'a':_ -> discard 1 >> return '\a'
'b':_ -> discard 1 >> return '\b'
'f':_ -> discard 1 >> return '\f'
'n':_ -> discard 1 >> return '\n'
'r':_ -> discard 1 >> return '\r'
't':_ -> discard 1 >> return '\t'
'v':_ -> discard 1 >> return '\v'
'\\':_ -> discard 1 >> return '\\'
'"':_ -> discard 1 >> return '\"'
'\'':_ -> discard 1 >> return '\''
-- Production ascii from section B.2
'^':c:_ -> discard 2 >> cntrl c
'N':'U':'L':_ -> discard 3 >> return '\NUL'
'S':'O':'H':_ -> discard 3 >> return '\SOH'
'S':'T':'X':_ -> discard 3 >> return '\STX'
'E':'T':'X':_ -> discard 3 >> return '\ETX'
'E':'O':'T':_ -> discard 3 >> return '\EOT'
'E':'N':'Q':_ -> discard 3 >> return '\ENQ'
'A':'C':'K':_ -> discard 3 >> return '\ACK'
'B':'E':'L':_ -> discard 3 >> return '\BEL'
'B':'S':_ -> discard 2 >> return '\BS'
'H':'T':_ -> discard 2 >> return '\HT'
'L':'F':_ -> discard 2 >> return '\LF'
'V':'T':_ -> discard 2 >> return '\VT'
'F':'F':_ -> discard 2 >> return '\FF'
'C':'R':_ -> discard 2 >> return '\CR'
'S':'O':_ -> discard 2 >> return '\SO'
'S':'I':_ -> discard 2 >> return '\SI'
'D':'L':'E':_ -> discard 3 >> return '\DLE'
'D':'C':'1':_ -> discard 3 >> return '\DC1'
'D':'C':'2':_ -> discard 3 >> return '\DC2'
'D':'C':'3':_ -> discard 3 >> return '\DC3'
'D':'C':'4':_ -> discard 3 >> return '\DC4'
'N':'A':'K':_ -> discard 3 >> return '\NAK'
'S':'Y':'N':_ -> discard 3 >> return '\SYN'
'E':'T':'B':_ -> discard 3 >> return '\ETB'
'C':'A':'N':_ -> discard 3 >> return '\CAN'
'E':'M':_ -> discard 2 >> return '\EM'
'S':'U':'B':_ -> discard 3 >> return '\SUB'
'E':'S':'C':_ -> discard 3 >> return '\ESC'
'F':'S':_ -> discard 2 >> return '\FS'
'G':'S':_ -> discard 2 >> return '\GS'
'R':'S':_ -> discard 2 >> return '\RS'
'U':'S':_ -> discard 2 >> return '\US'
'S':'P':_ -> discard 2 >> return '\SP'
'D':'E':'L':_ -> discard 3 >> return '\DEL'
-- Escaped numbers
'o':c:_ | isOctDigit c -> do
discard 1
n <- lexOctal
checkChar n
'x':c:_ | isHexDigit c -> do
discard 1
n <- lexHexadecimal
checkChar n
c:_ | isDigit c -> do
n <- lexDecimal
checkChar n
_ -> fail "Illegal escape sequence"
where
checkChar n | n <= 0x01FFFF = return (chr (fromInteger n))
checkChar _ = fail "Character constant out of range"
-- Production cntrl from section B.2
cntrl :: Char -> Lex a Char
cntrl c | c >= '@' && c <= '_' = return (chr (ord c - ord '@'))
cntrl _ = fail "Illegal control character"
-- assumes at least one octal digit
lexOctal :: Lex a Integer
lexOctal = do
ds <- lexWhile isOctDigit
return (parseInteger 8 ds)
-- assumes at least one hexadecimal digit
lexHexadecimal :: Lex a Integer
lexHexadecimal = do
ds <- lexWhile isHexDigit
return (parseInteger 16 ds)
-- assumes at least one decimal digit
lexDecimal :: Lex a Integer
lexDecimal = do
ds <- lexWhile isDigit
return (parseInteger 10 ds)
-- Stolen from Hugs's Prelude
parseInteger :: Integer -> String -> Integer
parseInteger radix ds =
foldl1 (\n d -> n * radix + d) (map (toInteger . digitToInt) ds)
-- pragmas for which we just want the raw contents of
pragmas_raw = [["OPTIONS", "JHC_OPTIONS", "OPTIONS_JHC" ]]
-- pragmas which just have a simple string based start rule.
pragmas_std = [
["NOETA"],
["SUPERINLINE"],
["MULTISPECIALIZE", "MULTISPECIALISE"],
["SRCLOC_ANNOTATE"]
]
pragmas_exp = [
["CTYPE"]
]
-- pragmas with a special starting token
pragmas_parsed = [
(["INLINE"],PragmaInline "INLINE"),
(["NOINLINE","NOTINLINE"],PragmaInline "NOINLINE"),
(["RULES","RULE","RULES_JHC","RULE_JHC"],PragmaRules False),
(["CATALYST","CATALYSTS"],PragmaRules True),
(["SPECIALIZE", "SPECIALISE"],PragmaSpecialize False),
(["SUPERSPECIALIZE", "SUPERSPECIALISE"],PragmaSpecialize True)
]
pragmas = Map.fromList $ [ (y,Left x) | xs@(x:_) <- pragmas_raw, y <- xs] ++
[ (y,Right w) | (xs@(~(x:_)),w) <- pragmas_all , y <- xs] where
pragmas_all = pragmas_parsed ++
[ (xs,PragmaStart x) | xs@(~(x:_)) <- pragmas_std ] ++
[ (xs,PragmaExp x) | xs@(~(x:_)) <- pragmas_exp ]
pragmas_ignored = Set.fromList ["LANGUAGE", "OPTIONS_GHC", "UNPACK"]
normPragma :: String -> Either String Token
normPragma s | ~(Just v) <- Map.lookup s pragmas = v
toUnqualName n = toName UnknownType (Nothing :: Maybe Module,n)