content: --  Copyright (C) 2006-2008 Angelos Charalambidis <a.charalambidis@di.uoa.gr>
  --
  --  This program is free software; you can redistribute it and/or modify
  --  it under the terms of the GNU General Public License as published by
  --  the Free Software Foundation; either version 2, or (at your option)
  --  any later version.
  --
  --  This program is distributed in the hope that it will be useful,
  --  but WITHOUT ANY WARRANTY; without even the implied warranty of
  --  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  --  GNU General Public License for more details.
  --
  --  You should have received a copy of the GNU General Public License
  --  along with this program; see the file COPYING.  If not, write to
  --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  --  Boston, MA 02110-1301, USA.
  
  module Lexer (lexer)
  where
  
  import Loc (Loc(..), Located, located, getLocSpan, spanEnd)
  import ParseUtils (ParserT, ParserInput, Token(..), getInput, setInput, setTok, parseErrorWithLoc)
  import Data.Char (isSpace, isUpper, isLower, isDigit, isAlpha)
  import Pretty (sep,text,quotes,char)
  
  
  lexer :: Monad m => (Located Token -> ParserT m a) -> ParserT m a
  lexer cont = lexToken >>= \tok -> setTok tok >> cont tok
  
  lexError :: Monad m => String -> Loc -> ParserT m a
  lexError []  l = parseErrorWithLoc l $ text "Unexpected end of input"
  lexError inp l = parseErrorWithLoc l msg
     where msg = sep [text "Unexpected character", quotes (char (head inp))]
  
  lexToken :: Monad m => ParserT m (Located Token)
  
  lexToken = do
      inp <- getInput
      ls  <- getLocSpan
      lexToken' inp (spanEnd ls)
  
  lexToken' :: Monad m => ParserInput -> Loc -> ParserT m (Located Token)
  lexToken' inp l = do
      case scanTok inp l of
          TokEnd -> do
              return $ located l TKEOF
          TokError l2 inp2 -> do
              lexError inp2 l2
          TokSkip l2 inp2 -> do
              lexToken' inp2 l2
          Tok t len inp2 -> do
              let l2 = l{locOffset=(locOffset l)+len}
              setInput inp2
              return $ located (l,l2) t
  
  data ScanResult =
      Tok Token Int String
    | TokEnd
    | TokSkip  Loc String
    | TokError Loc String
  
  type ScanAction = String -> Loc -> ScanResult
  
  scanTok :: ScanAction
  scanTok [] loc               = TokEnd
  scanTok inp@('\n':cs) loc    = scanSkip inp loc
  scanTok inp@('%':cs) loc     = scanSkipLine inp loc
  scanTok ('(':cs) loc         = Tok TKoparen 1 cs
  scanTok (')':cs) loc         = Tok TKcparen 1 cs
  scanTok ('[':cs) loc         = Tok TKobrak  1 cs
  scanTok (']':cs) loc         = Tok TKcbrak  1 cs
  scanTok ('{':cs) loc         = Tok TKocurly 1 cs
  scanTok ('}':cs) loc         = Tok TKccurly 1 cs
  scanTok ('|':cs) loc         = Tok TKvert   1 cs
  scanTok ('/':cs) loc         = Tok TKslash  1 cs
  scanTok ('\\':cs) loc        = Tok TKbslash 1 cs
  scanTok (',':cs) loc         = Tok TKcomma  1 cs
  scanTok ('.':cs) loc         = Tok TKdot    1 cs
  scanTok ('_':cs) loc         = Tok TKwild   1 cs
  scanTok ('!':cs) loc         = Tok (TKid "!") 1 cs
  scanTok (';':cs) loc         = Tok TKsemi   1 cs
  scanTok ('\'':cs) loc        = Tok TKsq     1 cs
  scanTok ('=':cs) loc         = Tok TKeq     1 cs
  scanTok (':':'-':cs) loc     = Tok TKgets   2 cs
  scanTok (':':':':cs) loc     = Tok TKcolcol 2 cs
  scanTok ('-':'>':cs) loc     = Tok TKarrow  2 cs
  scanTok inp@(c:cs) l
      | isSpace c              = scanSkip inp l
      | isUpper c              = scanName TKid inp l
      | isLower c || isDigit c = scanName TKid inp l
  scanTok inp loc              = TokError loc inp
  
  
  scanName :: (String -> Token) -> ScanAction
  scanName cstr cs l   = Tok (cstr name) (length name) rest
     where (name,rest) = span isNameChar cs
           isNameChar c = isAlpha c || isDigit c || (c == '_')
  
  scanSkip :: ScanAction
  scanSkip inp lo =
      let scanSkip_aux o l (c:cs) lo
                   | c == '\n'              = scanSkip_aux 1 (l+1) cs lo
                   | isSpace c              = scanSkip_aux (o+1) l cs lo
                   | otherwise              = TokSkip lo{locOffset=o, locLine=l} (c:cs)
          scanSkip_aux o l [] lo            = TokEnd
      in scanSkip_aux (locOffset lo) (locLine lo) inp lo
  
  scanSkipLine :: ScanAction
  scanSkipLine inp lo = scanSkip inp2 lo{locOffset=1, locLine=(locLine lo) + 1}
      where (com, ('\n':inp2)) = span (/='\n') inp
  
  