-- #hide
-----------------------------------------------------------------------------
-- |
-- Module      :  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 Lexer (Token(..), lexer) where

import Language.Haskell.ParseMonad

import Data.Char	(isAlpha, isLower, isUpper, toLower,
			 isDigit, isHexDigit, isOctDigit, isSpace,
			 ord, chr, digitToInt)
import Data.Ratio

data Token
        = VarId String
        | QVarId (String,String)
	| ConId String
        | QConId (String,String)
        | VarSym String
        | ConSym String
        | QVarSym (String,String)
        | QConSym (String,String)
	| IntTok Integer
	| FloatTok Rational
	| Character Char
        | StringTok String

-- Symbols

	| LeftParen
	| RightParen
	| 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
	| Exclamation
	| LeftArrowTail		-- added for arrows
	| RightArrowTail	-- added for arrows
	| LeftArrowDTail	-- added for arrows
	| RightArrowDTail	-- added for arrows
	| LeftBanana		-- added for arrows
	| RightBanana		-- added for arrows

-- Reserved Ids

	| KW_Case
	| KW_Class
	| KW_Data
	| KW_Default
	| KW_Deriving
	| KW_Do
	| KW_Else
	| KW_Foreign
	| 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

-- Special Ids

	| KW_As
	| KW_Export
	| KW_Hiding
	| KW_Qualified
	| KW_Safe
	| KW_Unsafe
	| KW_Proc		-- added for arrows
	| KW_Rec		-- added for arrows
	| KW_Form		-- added for arrows
	| KW_Cmd		-- added for arrows

        | EOF
        deriving (Eq,Show)

reserved_ops :: [(String,Token)]
reserved_ops = [
 ( "..", DotDot ),
 ( ":",  Colon ),
 ( "::", DoubleColon ),
 ( "=",  Equals ),
 ( "\\", Backslash ),
 ( "|",  Bar ),
 ( "<-", LeftArrow ),
 ( "->", RightArrow ),
 ( "@",  At ),
 ( "~",  Tilde ),
 ( "=>", DoubleArrow ),
 ( "-<", LeftArrowTail ),	-- added for arrows
 ( ">-", RightArrowTail ),	-- added for arrows
 ( "-<<", LeftArrowDTail ),	-- added for arrows
 ( ">>-", RightArrowDTail ),	-- added for arrows
 ( "\\<", Backslash )		-- added for arrows
 ]

special_varops :: [(String,Token)]
special_varops = [
 ( "-",  Minus ),			--ToDo: shouldn't be here
 ( "!",  Exclamation )		--ditto
 ]

reserved_ids :: [(String,Token)]
reserved_ids = [
 ( "_",         Underscore ),
 ( "case",      KW_Case ),
 ( "class",     KW_Class ),
 ( "cmd",	KW_Cmd ),	-- added for arrows
 ( "data",      KW_Data ),
 ( "default",   KW_Default ),
 ( "deriving",  KW_Deriving ),
 ( "do",        KW_Do ),
 ( "else",      KW_Else ),
 ( "foreign",	KW_Foreign ),
 ( "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 ),
 ( "proc",	KW_Proc ),	-- added for arrows
 ( "rec",	KW_Rec ),	-- added for arrows
 ( "then", 	KW_Then ),
 ( "type", 	KW_Type ),
 ( "where", 	KW_Where )
 ]

special_varids :: [(String,Token)]
special_varids = [
 ( "as", 	KW_As ),
 ( "export", 	KW_Export ),
 ( "hiding", 	KW_Hiding ),
 ( "qualified", KW_Qualified ),
 ( "safe",	KW_Safe ),
 ( "unsafe", 	KW_Unsafe )
 ]

isIdent, isSymbol :: Char -> Bool
isIdent  c = isAlpha c || isDigit c || c == '\'' || c == '_'
isSymbol c = elem 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 $ do
	bol <- checkBOL
	bol <- lexWhiteSpace bol
	startToken
	if bol then lexBOL else lexToken

lexWhiteSpace :: Bool -> Lex a Bool
lexWhiteSpace bol = do
	s <- getInput
	case s of
	    '{':'-':_ -> 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"
		    _ -> do
			lexNewline
			lexWhiteSpace True
	    '\n':_ -> do
		lexNewline
		lexWhiteSpace True
	    '\t':_ -> do
		lexTab
		lexWhiteSpace bol
	    c:_ | isSpace c -> do
		discard 1
		lexWhiteSpace bol
	    _ -> return bol

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"

-- 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
    case s of
        [] -> return EOF

	'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
			return (IntTok n)

	'(':'|':c:_ | not (isSymbol c) -> do
	    discard 2
	    return LeftBanana

	'|':')':_ -> do
	    discard 2
	    return RightBanana

	c:_ | isDigit c -> lexDecimalOrFloat

	    | isUpper c -> lexConIdOrQual ""

	    | isLower c || c == '_' -> do
		ident <- lexWhile isIdent
		return $ case lookup ident (reserved_ids ++ special_varids) of
			Just keyword -> keyword
			Nothing -> VarId ident

	    | isSymbol c -> do
		sym <- lexWhile isSymbol
		return $ case lookup sym (reserved_ops ++ special_varops) of
			Just t  -> t
			Nothing -> case c of
			    ':' -> ConSym sym
			    _   -> VarSym sym

	    | 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"
			    return (Character c2)

		    '"' ->  lexString

		    _ ->    fail ("Illegal character \'" ++ show c ++ "\'\n")

lexDecimalOrFloat :: Lex a Token
lexDecimalOrFloat = do
	ds <- lexWhile isDigit
	rest <- getInput
	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':_ -> 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))
	    _ -> 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 con
		  | otherwise = QConId (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 lookup ident reserved_ids of
		   -- cannot qualify a reserved word
		   Just _  -> just_a_conid
		   Nothing -> return (QVarId (qual', ident))

	     | isUpper c -> do		-- qualified conid?
		discard 1
		lexConIdOrQual qual'

	     | isSymbol c -> do	-- qualified symbol?
		discard 1
		sym <- lexWhile isSymbol
		case lookup sym reserved_ops of
		    -- cannot qualify a reserved operator
		    Just _  -> just_a_conid
		    Nothing -> return $ case c of
			':' -> QConSym (qual', sym)
			_   -> QVarSym (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 = loop ""
    where
	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)
		    '"':_ -> 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 ()

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 <= 0x10FFFF = 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)