-- The Timber compiler <timber-lang.org>
--
-- Copyright 2008-2009 Johan Nordlander <nordland@csee.ltu.se>
-- All rights reserved.
-- 
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions
-- are met:
-- 
-- 1. Redistributions of source code must retain the above copyright
--    notice, this list of conditions and the following disclaimer.
-- 
-- 2. Redistributions in binary form must reproduce the above copyright
--    notice, this list of conditions and the following disclaimer in the
--    documentation and/or other materials provided with the distribution.
-- 
-- 3. Neither the names of the copyright holder and any identified
--    contributors, nor the names of their affiliations, may be used to 
--    endorse or promote products derived from this software without 
--    specific prior written permission.
-- 
-- THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
-- OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-- DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
-- ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-- POSSIBILITY OF SUCH DAMAGE.

{-
**************************************************************************
** This file is based on sources distributed as the haskell-src package **
**************************************************************************
The Glasgow Haskell Compiler License

Copyright 2004, The University Court of the University of Glasgow. 
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

- Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
 
- Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.
 
- Neither name of the University nor the names of its contributors may be
used to endorse or promote products derived from this software without
specific prior written permission. 

THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
DAMAGE.
-}

module Lexer (Token(..), lexer, readInteger, readNumber, readRational) where


import ParseMonad
import Data.Char
import Data.Ratio
import Token
import Common


{-

The source location, (y,x), is the coordinates of the previous token.
col is the current column in the source file.  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 (y,x) col ->
    if col == 0 then tab y x   True  input  col
                else tab y col False input  col -- throw away old x
    where
    -- move past whitespace and comments
    tab y x bol []          col = (unPM $ cont EOF) [] (y,x) col
    tab y x bol ('\t':s)    col = tab y (nextTab x) bol s col
    tab y x bol ('\n':s)    col = newLine s y col
    tab y x bol ('-':'-':s) col = newLine (drop 1 (dropWhile (/= '\n') s))
                                      y col
    tab y x bol ('{':'-':s) col = nestedComment tab y x bol s col
    tab y x bol (c:s)       col
                 | isSpace c = tab y (x + 1) bol s col
                 | otherwise =
                     if bol then
                         (unPM $ lexBOL cont)   (c:s) (y,x) x
                     else
                         (unPM $ lexToken cont) (c:s) (y,x) x

    newLine s y col = tab (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@(y,x) col ctx ->
    if need_close_curly x ctx then 
        -- tr' ("layout: inserting '}' at " ++ show loc ++ "\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
        -- tr' ("layout: inserting ';' at " ++ show loc ++ "\n") $
        (unPM $ cont SemiColon) s loc col ctx
    else
        (unPM $ lexToken cont)  s loc col ctx
    where
        need_close_curly x []    = False
        need_close_curly x (Layout n:Layout m:_)
          | n <= m               = True
        need_close_curly x (i:_) = case i of
                                   NoLayout -> False
                                   Layout n -> x < n
                                   RecLayout n -> False

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


lexToken :: (Token -> PM a) -> PM a
lexToken cont =
    PM lexToken'
    where
    lexToken' (c:s) loc@(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
        '}' -> \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)

        '_' | null s || not (isIdent (head s)) -> special Wildcard
        
        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 -> lexVarId "" c s

          | isUpper c -> lexQualName "" c s

          | isSymbol c -> lexSymbol "" c s

          | 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)
 
      join "" n = n
      join q n  = q ++ '.' : n

      len "" n = length n
      len q n  = length q + length n + 1

      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)
      
      lexVarId q c s = let (vidtail, rest) = span isIdent s
                           vid             = c:vidtail
                           l_vid           = len q vid
              in
                  case lookup vid reserved_ids of
                  Just keyword -> case q of
                                    "" -> forward l_vid keyword rest
                                    _ -> (unPM $ parseError "illegal qualified name") s loc x
                  Nothing      -> forward l_vid (VarId (q,vid)) rest

      lexQualName q c s = let (contail, rest) = span isIdent s
                              con             = join q (c:contail)
                              l_con           = length con
                          in case rest of
                               '.': c' : rest'
                                  | isUpper c' -> lexQualName con c' rest'
                                  | isLower c' -> lexVarId con c' rest'
                                  | isSymbol c' -> lexSymbol con c' rest'
                                  | otherwise -> (unPM $ parseError "illegal qualified name") s loc x
                               _ -> forward l_con (ConId (q,c:contail)) rest
                  
      lexSymbol q c s = let (symtail, rest) = span isSymbol s
                            sym             = c:symtail
                            l_sym = len q sym
                        in case lookup sym reserved_ops of
                                Just t  -> case q of
                                    "" -> forward l_sym t rest
                                    _ -> (unPM $ parseError "illegal qualified name") s loc x
                                Nothing -> case c of
                                 ':' -> forward l_sym (ConSym (q,sym)) rest
                                 _   -> forward l_sym (VarSym (q,sym)) rest
   
      
    lexToken' _  _ _ =
        internalError0 "Lexer.lexToken: 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@(y,_) 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)
        []   -> internalError0 "Lexer.lexChar: 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@(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
                []     -> internalError0 "Lexer.stringGap: empty list."


escapeChar :: String -> PM (Char, String, Int)
escapeChar s = case s of
   '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)

   '^':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.

   -- 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 character
   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 n < (toInteger $ fromEnum (minBound :: Char)) ||
                n > (toInteger $ fromEnum (maxBound :: Char)) then
                 parseError "illegal character literal (number out of range)."
             else
                 return (chr $ fromInteger n, s, l_n)
            

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 y x bol s  col =
    case s of
    '-':'}':s -> cont y (x + 2) bol s  col
    '{':'-':s -> nestedComment (nestedComment cont) y (x + 2) bol s  col
    '\t':s    -> nestedComment cont y (nextTab x) bol s  col
    '\n':s    -> nestedComment cont (y + 1) 1 True s  col
    c:s       -> nestedComment cont y (x + 1) bol s  col
    []        -> compileError "Open comment at end of file"



readInteger :: String -> Integer
readInteger ('0':'o':ds) = readInteger2  8 isOctDigit ds
readInteger ('0':'O':ds) = readInteger2  8 isOctDigit ds
readInteger ('0':'x':ds) = readInteger2 16 isHexDigit ds
readInteger ('0':'X':ds) = readInteger2 16 isHexDigit ds
readInteger          ds  = readInteger2 10 isDigit    ds

readNumber :: Integer -> String -> Integer
readNumber radix ds = readInteger2 radix (const True) ds

readInteger2 :: Integer -> (Char -> Bool) -> String -> Integer
readInteger2 radix isDig ds 
  = foldl1 (\n d -> n * radix + d) (map (fromIntegral . digitToInt) 
                                    (takeWhile isDig ds))

readRational :: String -> Rational
readRational xs
    = (readInteger (i ++ m))%1 * 10^^((case e of
                                       ""       -> 0
                                       ('+':e2) -> read e2
                                       _        -> read e) - length m)
      where (i, r1) = span isDigit xs
            (m, r2) = span isDigit (dropWhile (== '.') r1)
            e       = dropWhile (== 'e') r2

