-- $Id: Lexer.hs,v 1.11 2001/11/08 22:09:28 hallgren Exp $

{-

ToDo: Parsing floats is a *real* hack...
ToDo: FloatTok should have three parts (integer part, fraction, exponent)
ToDo: Use a lexical analyser generator (lx?)

Known bug: It seems that _x is a valid identifier name; our lexer, on the
other hand, produces two lexemes, the wildcard followed by x. Argh!!!!
e.p. FIXED e.p.

-}

module Lexer (Token(..), lexer, isSymbol) where


import ParseMonad
import LexUtil
import SrcLoc
import Char
import Ratio
--import IOExts(trace)
import Token


{-

The source location, (f, y, x), is the coordinates of the previous token.
col is the current column in the source file f.  If col is 0, we are
somewhere at the beginning of the line before the first token.

Setting col to 0 is used in two places: just after emitting a virtual
close brace due to layout, so that next time through we check whether
we also need to emit a semi-colon, and at the beginning of the file,
to kick off the lexer.

-}
lexer :: (Token -> PM a) -> PM a
lexer cont =
    PM $ \input (SrcLoc f y x) col ->
    if col == 0 then tab f y x   True  input  col
                else tab f y col False input  col -- throw away old x
    where
    -- move past whitespace and comments
    tab f y x bol []          col = (unPM $ cont EOF) [] (SrcLoc f y x) col
    tab f y x bol ('\t':s)    col = tab f y (nextTab x) bol s col
    tab f y x bol ('\n':s)    col = newLine f s y col
    tab f y x bol ('-':'-':s) col = newLine f (drop 1 (dropWhile (/= '\n') s))
				      y col
    tab f y x bol ('{':'-':s) col = nestedComment tab f y x bol s col
    tab f y x bol (c:s)       col
		 | isSpace c = tab f y (x + 1) bol s col
	         | otherwise =
		     if bol then
		         (unPM $ lexBOL cont)   (c:s) (SrcLoc f y x) x
		     else
		         (unPM $ lexToken cont) (c:s) (SrcLoc f y x) x

    newLine f s y col = tab f (y + 1) 1 True s col


nextTab x = x + (tab_length - (x - 1) `mod` tab_length)

{-

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 :: (Token -> PM a) -> PM a
lexBOL cont =
    PM $ \ s loc@(SrcLoc f y x) col (state@ctx) ->
    if need_close_curly x ctx then 
        -- 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.
        (unPM $ cont VRightCurly) s loc 0 (tail ctx)
    else if need_semi_colon x ctx then
        -- trace "layout: inserting ';'\n" $
	(unPM $ cont SemiColon) s loc col state
    else
        (unPM $ lexToken cont)  s loc col state
    where
        need_close_curly x []    = False
	need_close_curly x (i:_) = case i of
				   NoLayout -> False
				   Layout n -> x < n

        need_semi_colon x []     = False
	need_semi_colon x (i:_)  = case i of
				   NoLayout -> False
				   Layout n -> x == n


lexToken :: (Token -> PM a) -> PM a
lexToken cont =
    PM lexToken'
    where
    lexToken' (c:s) loc@(SrcLoc f y x') x =
        -- trace ("lexer: y = " ++ show y ++ " x = " ++ show x ++ "\n") $ 
	case c of
	-- First the special symbols
        '(' -> special LeftParen
        ')' -> special RightParen
        ',' -> special Comma
        ';' -> special SemiColon
        '[' -> special LeftSquare
        ']' -> special RightSquare
        '`' -> special BackQuote
        '{' -> special LeftCurly . (NoLayout:) -- push context on '{'
        '}' -> \state ->
               case state of
               _:ctxt ->
	           special RightCurly ctxt -- pop context on '}'
               []       ->
		   (unPM $ parseError "parse error (possibly incorrect indentation)")
                   s loc x []

        '\'' -> (unPM $ lexChar cont)   s loc (x + 1)
        '\"' -> (unPM $ lexString cont) s loc (x + 1)


        c | isDigit c ->
	      case lexInt (c:s) of
	      Decimal (n, rest) ->
		  case rest of
		  ('.':c2:rest2) | isDigit c2 ->
				     case lexFloatRest (c2:rest2) of
				     Nothing -> (unPM $
						 parseError "illegal float.")
						s loc x
				     Just (n2,rest3) ->
					 let f = n ++ ('.':n2) in
				         forward (length f) (FloatTok f) rest3
		  _ -> forward (length n) (IntTok n) rest
	      Octal       (n,rest) -> forward (length n) (IntTok n) rest
	      Hexadecimal (n,rest) -> forward (length n) (IntTok n) rest

          | isLower_ c ->
	      let (vidtail, rest) = span isIdent s
		  vid             = c:vidtail
		  l_vid           = 1 + length vidtail
	      in
		  case lookup vid reserved_ids of
		  Just keyword -> forward l_vid keyword rest
		  Nothing      -> forward l_vid (VarId vid) rest

          | isUpper c ->
	      let (contail, rest) = span isIdent s
		  l_con           = 1 + length contail
		  con             = c:contail
	      in
		  case lookup con reserved_ids of
		  Just keyword -> forward l_con keyword rest
		  Nothing      -> lexQual l_con con rest
                                      (forward l_con (ConId con) rest)
		  
          | isSymbol c ->
	      let (symtail, rest) = span isSymbol s
		  sym             = c : symtail
		  l_sym           = 1 + length symtail
	      in
	          case lookup sym reserved_ops of
		  Just t  -> forward l_sym t rest
		  Nothing -> case c of
			     ':' -> forward l_sym (ConSym sym) rest
                             '.' | l_sym == 1 -> special Period
                                 | otherwise  ->
                                    forward l_sym (VarSym sym) rest
			     _   -> forward l_sym (VarSym sym) rest

          | otherwise ->
	      (unPM $
	       parseError ("illegal character \'" ++
			   showLitChar c "" ++ "\'\n"))
	      s loc x
		  
      where
      special t = forward 1 t s
      forward n t s = (unPM $ cont t) s loc (x + n)
 
      lexFloatRest r = case span isDigit r of
		       (r2, 'e':r3) -> lexFloatExp (r2 ++ "e") r3
		       (r2, 'E':r3) -> lexFloatExp (r2 ++ "e") r3
		       f@(r2,   r3) -> Just f
 
      lexFloatExp r1 ('-':r2) = lexFloatExp2 (r1 ++ "-") r2
      lexFloatExp r1 ('+':r2) = lexFloatExp2 (r1 ++ "+") r2
      lexFloatExp r1      r2  = lexFloatExp2 r1          r2

      lexFloatExp2 r1 r2 = case span isDigit r2 of
			   ("", _ ) -> Nothing
			   (ds, r3) -> Just (r1++ds,r3)

      lexQual l_mod mod s lexConId =
          case s of
          '.':c:rest
           | isLower c ->	-- qualified varid?
	       let (vidtail, rest1) = span isIdent rest
		   vid              = c:vidtail
		   l_vid            = 1 + length vidtail
	       in
	       case lookup vid reserved_ids of -- cannot qualify reserved word
	       Just keyword -> lexConId
	       Nothing      -> forward (l_mod + l_vid + 1) -- + 1 for the '.'
				       (QVarId (mod, vid)) rest1

           | isUpper c ->	-- qualified conid?
	       let (con1, rest1) = span isIdent rest
		   qcon          = c : con1
		   l_con1        = 1 + length con1
	       in
		   forward (l_mod + l_con1 + 1) -- + 1 for the '.'
			   (QConId (mod, qcon)) rest1

           | isSymbol c ->	-- qualified symbol?
               let (symtail, rest1) = span isSymbol rest    
		   sym              = c : symtail
		   l_sym            = 1 + length symtail
               in
	       case lookup sym reserved_ops of
	       -- cannot qualify a reserved operator
	       Just _  -> lexConId
	       Nothing ->
		   case c of
	           ':' -> forward (l_mod + l_sym + 1) -- + 1 for the '.'
			          (QConSym (mod, sym)) rest1
		   _   -> forward (l_mod + l_sym + 1) -- + 1 for the '.'
			          (QVarSym (mod, sym)) rest1

           -- special case for M.[]; allows whitespace between '[' and ']'
	   -- (provided layout is not violated)
           | c == '[' ->
	       case snd $ span isSpace rest of
	       (']':_) -> forward l_mod (QModId mod) s
               _       -> lexConId

           -- special case for M.(), M.(,,,), etc.; allows whitespace between
	   -- '(' and ')', and '(' and ',' (provided layout is not violated)
           | c == '(' ->
	       case snd $ span isSpace rest of
	       (')':_) -> forward l_mod (QModId mod) s
               (',':_) -> forward l_mod (QModId mod) s
	       _       -> lexConId

	  _ -> lexConId -- not a qualified object
			      
    lexToken' _  _ _ =
	error "Lexer.lexToken: Internal error: empty input stream."


lexInt ('0':o:d:r) | toLower o == 'o' && isOctDigit d
    = let (ds, rs) = span isOctDigit r
      in
           Octal       ('0':'o':d:ds, rs)
lexInt ('0':x:d:r) | toLower x == 'x' && isHexDigit d
    = let (ds, rs) = span isHexDigit r
      in 
           Hexadecimal ('0':'x':d:ds, rs)
lexInt r = Decimal     (span isDigit r)


lexChar :: (Token -> PM a) -> PM a
lexChar cont = PM lexChar'
    where
    lexChar' s loc x =
	case s of
	'\\':s ->
	    let (e, s2, i) =
		  runPM (escapeChar s) "" loc x []
	    in
                charEnd e s2 loc (x + i)
	c:s  -> charEnd c s  loc (x + 1)
	[]   -> error "Lexer.lexChar: Internal error: empty list."

    charEnd c ('\'':s)   =
	\loc x -> (unPM $ cont (Character c)) s loc (x + 1)
    charEnd c s         =
	(unPM $ parseError "improperly terminated character constant.") s 


lexString :: (Token -> PM a) -> PM a
lexString cont = PM lexString'
    where
    lexString' s loc@(SrcLoc f y _) x = loop "" s x y
	where
	loop e s x y =
	    case s of
            '\\':'&':s  -> loop e s (x+2) y
	    '\\':c:s | isSpace c -> stringGap e s (x + 2) y
		     | otherwise ->
			 let (e', sr, i) =
			       runPM (escapeChar (c:s)) ""  loc x []
                         in  loop (e':e) sr (x+i) y
            '\"':s{-"-} -> (unPM $ cont (StringTok (reverse e))) s  loc (x + 1)
	    c:s	      -> loop (c:e) s (x + 1) y
	    []          -> (unPM $ parseError "improperly terminated string.")
			            s  loc x

	stringGap e s x y =
	    case s of
		'\n':s -> stringGap e s 1 (y + 1)
	        '\\':s -> loop e s (x + 1) y
	        c:s' | isSpace c -> stringGap e s' (x + 1) y
	             | otherwise ->
			 (unPM $ parseError "illegal character in string gap.")
			 s  loc x
	        []     -> error "Lexer.stringGap: Internal error: empty list."


escapeChar :: String -> PM (Char, String, Int)
escapeChar s = case s of
    -- Production charesc from section B.2 (Note: \& is handled by caller)
   'a':s 	 -> return ('\a', s, 2)
   'b':s 	 -> return ('\b', s, 2)
   'f':s 	 -> return ('\f', s, 2)
   'n':s 	 -> return ('\n', s, 2)
   'r':s 	 -> return ('\r', s, 2)
   't':s 	 -> return ('\t', s, 2)
   'v':s 	 -> return ('\v', s, 2)
   '\\':s        -> return ('\\', s, 2)
   '"':s         -> return ('\"', s, 2)
   '\'':s        -> return ('\'', s, 2)

    -- Production ascii from section B.2
   '^':x@(c:s)   -> cntrl x
   'N':'U':'L':s -> return ('\NUL', s, 4)
   'S':'O':'H':s -> return ('\SOH', s, 4)
   'S':'T':'X':s -> return ('\STX', s, 4)
   'E':'T':'X':s -> return ('\ETX', s, 4)
   'E':'O':'T':s -> return ('\EOT', s, 4)
   'E':'N':'Q':s -> return ('\ENQ', s, 4)
   'A':'C':'K':s -> return ('\ACK', s, 4)
   'B':'E':'L':s -> return ('\BEL', s, 4)
   'B':'S':s     -> return ('\BS',  s, 3)
   'H':'T':s  	 -> return ('\HT',  s, 3)
   'L':'F':s 	 -> return ('\LF',  s, 3)
   'V':'T':s 	 -> return ('\VT',  s, 3)
   'F':'F':s 	 -> return ('\FF',  s, 3)
   'C':'R':s 	 -> return ('\CR',  s, 3)
   'S':'O':s 	 -> return ('\SO',  s, 3)
   'S':'I':s 	 -> return ('\SI',  s, 3)
   'D':'L':'E':s -> return ('\DLE', s, 4)
   'D':'C':'1':s -> return ('\DC1', s, 4)
   'D':'C':'2':s -> return ('\DC2', s, 4)
   'D':'C':'3':s -> return ('\DC3', s, 4)
   'D':'C':'4':s -> return ('\DC4', s, 4)
   'N':'A':'K':s -> return ('\NAK', s, 4)
   'S':'Y':'N':s -> return ('\SYN', s, 4)
   'E':'T':'B':s -> return ('\ETB', s, 4)
   'C':'A':'N':s -> return ('\CAN', s, 4)
   'E':'M':s     -> return ('\EM',  s, 3)
   'S':'U':'B':s -> return ('\SUB', s, 4)
   'E':'S':'C':s -> return ('\ESC', s, 4)
   'F':'S':s     -> return ('\FS',  s, 3)
   'G':'S':s     -> return ('\GS',  s, 3)
   'R':'S':s     -> return ('\RS',  s, 3)
   'U':'S':s     -> return ('\US',  s, 3)
   'S':'P':s     -> return ('\SP',  s, 3)
   'D':'E':'L':s -> return ('\DEL', s, 4)


   -- Depending upon the compiler/interpreter's Char type, these yield either
   -- just 8-bit ISO-8859-1 or 2^16 UniCode.  The report says it should be the
   -- latter.

   -- Octal representation of a character
   'o':s           -> let (ds, s') = span isOctDigit s
			  n        = readNumber 8 ds
                      in 
		          numberToChar n s' (length ds + 1)

   -- Hexadecimal representation of a character
   'x':s           -> let (ds, s') = span isHexDigit s
			  n        = readNumber 16 ds
                      in
		          numberToChar n s' (length ds + 1)
 
   -- Base 10 representation of a charactef
   d:s | isDigit d -> let (ds, s') = span isDigit s
			  n        = readNumber 10 (d:ds)
                      in 
		          numberToChar n s' (length ds + 1)

   _               -> parseError "illegal escape sequence."

   where numberToChar n s l_n =
	     if toInteger (fromEnum (minBound :: Char))<=n &&
		n <= toInteger (fromEnum (maxBound :: Char))
	     then return (chr $ fromInteger n, s, l_n)
	     else parseError $ "illegal character literal (number "++
			       show n++" out of range)."
            
{-

Production cntrl from section B.2

-}
cntrl :: String -> PM (Char, String, Int)
cntrl (c   :s) | isUpper c = return (chr (ord c - ord 'A'), s, 2)
cntrl ('@' :s)             = return ('\^@', s, 2)
cntrl ('[' :s)             = return ('\^[', s, 2)
cntrl ('\\':s)             = return ('\^\', s, 2)
cntrl (']' :s)             = return ('\^]', s, 2)
cntrl ('^' :s)             = return ('\^^', s, 2)
cntrl ('_' :s)             = return ('\^_', s, 2)
cntrl _                    = parseError "illegal control character"


nestedComment cont f y x bol s  col =
    case s of
    '-':'}':s -> cont f y (x + 2) bol s  col
    '{':'-':s -> nestedComment (nestedComment cont) f y (x + 2) bol s  col
    '\t':s    -> nestedComment cont f y (nextTab x) bol s  col
    '\n':s    -> nestedComment cont f (y + 1) 1 True s  col
    c:s       -> nestedComment cont f y (x + 1) bol s  col
    []        -> error "Lexer.nestedComment: Internal error: empty list."


{-
getTokens 0       = return []
getTokens (n + 1) = lexer (\t -> do { l <- getTokens n
			            ; return (t:l)
				    }
			  )

tokens f s =
    (unPM $ getTokens (length s)) s (SrcLoc f 0 0) 0
        (error "Lexer.tokens: problem with initial infix environment.", [])

-}

{-
instance Printable Token where
    ppi (VarId v)        = text v
    ppi (QVarId (m, v))  = text m <> '.' <> text v
    ppi (ConId c)        = text c
    ppi (QConId (m, c))  = text m <> '.' <> text c
    ppi (VarSym v)       = text v
    ppi (ConSym c)       = text c
    ppi (QVarSym (m, v)) = text m <> '.' <> text v
    ppi (QConSym (m, c)) = text m <> '.' <> text c
    ppi (QModId m)       = text m
    ppi (IntTok i)       = text i
    ppi (FloatTok f)     = text f
    ppi (Character ch)   = char ch
    ppi (StringTok s)    = text s

    ppi LeftParen    = lparen
    ppi RightParen   = rparen
    ppi SemiColon    = semi
    ppi LeftCurly    = lcurly
    ppi RightCurly   = rcurly
    ppi VRightCurly  = text "virtual" <+> rcurly
    ppi LeftSquare   = lbrack
    ppi RightSquare  = rbrack
    ppi Comma        = comma
    ppi Underscore   = char '_'
    ppi BackQuote    = backQuote
    ppi Period       = char '.'

    ppi DotDot       = text ".."
    ppi DoubleColon  = text "::"
    ppi Equals       = text "=="
    ppi Backslash    = char '\\'
    ppi Bar          = char '|'
    ppi LeftArrow    = text "<-"
    ppi RightArrow   = text "->"
    ppi At           = char'@'
    ppi Tilde        = char '~'
    ppi DoubleArrow  = text "=>"
    ppi Minus        = char '-'
    ppi Exclamation  = char '!'

    ppi KW_As        = text "as"
    ppi KW_Case      = text "case"     
    ppi KW_Class     = text "class"    
    ppi KW_Data      = text "data"     
    ppi KW_Default   = text "default"  
    ppi KW_Deriving  = text "deriving" 
    ppi KW_Do        = text "do"       
    ppi KW_Else      = text "else"     
    ppi KW_If        = text "if"       
    ppi KW_Import    = text "import"   
    ppi KW_In        = text "in"       
    ppi KW_Infix     = text "infix"    
    ppi KW_InfixL    = text "infixl"   
    ppi KW_InfixR    = text "infixr"   
    ppi KW_Instance  = text "instance" 
    ppi KW_Let       = text "let"      
    ppi KW_Module    = text "module"   
    ppi KW_NewType   = text "newtype"  
    ppi KW_Of        = text "of"       
    ppi KW_Then      = text "then"     
    ppi KW_Type      = text "type"     
    ppi KW_Where     = text "where"    
    ppi KW_Qualified = text "qualified"
    ppi KW_Hiding    = text "hiding"
    ppi KW_Primitive = text "primitive"

    ppi KW_Property  = text "property"
    ppi KW_QAll      = text "All"
    ppi KW_QExists   = text "Ex"
    ppi KW_QAllDef   = text "AllDef"

    ppi EOF = text "EOF"
-}