-----------------------------------------------------------------------------
-- |
-- Module      :  Tokenise
-- Copyright   :  2004 Malcolm Wallace
-- Licence     :  LGPL
--
-- Maintainer  :  Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
-- Stability   :  experimental
-- Portability :  All
--
-- The purpose of this module is to lex a source file (language
-- unspecified) into tokens such that cpp can recognise a replaceable
-- symbol or macro-use, and do the right thing.
-----------------------------------------------------------------------------

module Language.Preprocessor.Cpphs.Tokenise
  ( linesCpp
  , reslash
  , tokenise
  , WordStyle(..)
  , deWordStyle
  , parseMacroCall
  ) where

import Data.Char
import Language.Preprocessor.Cpphs.HashDefine
import Language.Preprocessor.Cpphs.Position

-- | A Mode value describes whether to tokenise a la Haskell, or a la Cpp.
--   The main difference is that in Cpp mode we should recognise line
--   continuation characters.
data Mode = Haskell | Cpp

-- | linesCpp is, broadly speaking, Prelude.lines, except that
--   on a line beginning with a \#, line continuation characters are
--   recognised.  In a line continuation, the newline character is
--   preserved, but the backslash is not.
linesCpp :: String -> [String]
linesCpp  []                 = []
linesCpp (x:xs) | x=='#'     = tok Cpp     ['#'] xs
                | otherwise  = tok Haskell [] (x:xs)
  where
    tok Cpp   acc ('\\':'\n':ys)   = tok Cpp ('\n':acc) ys
    tok _     acc ('\n':'#':ys)    = reverse acc: tok Cpp ['#'] ys
    tok _     acc ('\n':ys)        = reverse acc: tok Haskell [] ys
    tok _     acc []               = reverse acc: []
    tok mode  acc (y:ys)           = tok mode (y:acc) ys

-- | Put back the line-continuation characters.
reslash :: String -> String
reslash ('\n':xs) = '\\':'\n':reslash xs
reslash (x:xs)    = x: reslash xs
reslash   []      = []

----
-- | Submodes are required to deal correctly with nesting of lexical
--   structures.
data SubMode = Any | Pred (Char->Bool) (Posn->String->WordStyle)
             | String Char | LineComment | NestComment Int
             | CComment | CLineComment

-- | Each token is classified as one of Ident, Other, or Cmd:
--   * Ident is a word that could potentially match a macro name.
--   * Cmd is a complete cpp directive (\#define etc).
--   * Other is anything else.
data WordStyle = Ident Posn String | Other String | Cmd (Maybe HashDefine)
  deriving (Eq,Show)
other :: Posn -> String -> WordStyle
other _ s = Other s

deWordStyle :: WordStyle -> String
deWordStyle (Ident _ i) = i
deWordStyle (Other i)   = i
deWordStyle (Cmd _)     = "\n"

-- | tokenise is, broadly-speaking, Prelude.words, except that:
--    * the input is already divided into lines
--    * each word-like "token" is categorised as one of {Ident,Other,Cmd}
--    * \#define's are parsed and returned out-of-band using the Cmd variant
--    * All whitespace is preserved intact as tokens.
--    * C-comments are converted to white-space (depending on first param)
--    * Parens and commas are tokens in their own right.
--    * Any cpp line continuations are respected.
--   No errors can be raised.
--   The inverse of tokenise is (concatMap deWordStyle).
tokenise :: Bool -> Bool -> Bool -> Bool -> [(Posn,String)] -> [WordStyle]
tokenise _        _             _    _     [] = []
tokenise stripEol stripComments ansi lang ((pos,str):pos_strs) =
    (if lang then haskell else plaintext) Any [] pos pos_strs str
 where
    -- rules to lex Haskell
  haskell :: SubMode -> String -> Posn -> [(Posn,String)]
             -> String -> [WordStyle]
  haskell Any acc p ls ('\n':'#':xs)      = emit acc $  -- emit "\n" $
                                            cpp Any haskell [] [] p ls xs
    -- warning: non-maximal munch on comment
  haskell Any acc p ls ('-':'-':xs)       = emit acc $
                                            haskell LineComment "--" p ls xs
  haskell Any acc p ls ('{':'-':xs)       = emit acc $
                                            haskell (NestComment 0) "-{" p ls xs
  haskell Any acc p ls ('/':'*':xs)
                          | stripComments = emit acc $
                                            haskell CComment "  " p ls xs
  haskell Any acc p ls ('/':'/':xs)
                          | stripEol      = emit acc $
                                            haskell CLineComment "  " p ls xs
  haskell Any acc p ls ('"':xs)           = emit acc $
                                            haskell (String '"') ['"'] p ls xs
  haskell Any acc p ls ('\'':'\'':xs)     = emit acc $ -- TH type quote
                                            haskell Any "''" p ls xs
  haskell Any acc p ls ('\'':xs@('\\':_)) = emit acc $ -- escaped char literal
                                            haskell (String '\'') "'" p ls xs
  haskell Any acc p ls ('\'':x:'\'':xs)   = emit acc $ -- character literal
                                            emit ['\'', x, '\''] $
                                            haskell Any [] p ls xs
  haskell Any acc p ls ('\'':xs)          = emit acc $ -- TH name quote
                                            haskell Any "'" p ls xs
  haskell Any acc p ls (x:xs) | single x  = emit acc $ emit [x] $
                                            haskell Any [] p ls xs
  haskell Any acc p ls (x:xs) | space x   = emit acc $
                                            haskell (Pred space other) [x]
                                                                        p ls xs
  haskell Any acc p ls (x:xs) | symbol x  = emit acc $
                                            haskell (Pred symbol other) [x]
                                                                        p ls xs
 -- haskell Any [] p ls (x:xs) | ident0 x  = id $
  haskell Any acc p ls (x:xs) | ident0 x  = emit acc $
                                            haskell (Pred ident1 Ident) [x]
                                                                        p ls xs
  haskell Any acc p ls (x:xs)             = haskell Any (x:acc) p ls xs

  haskell pre@(Pred pred ws) acc p ls (x:xs)
                        | pred x    = haskell pre (x:acc) p ls xs
  haskell (Pred _ ws) acc p ls xs   = ws p (reverse acc):
                                      haskell Any [] p ls xs
  haskell (String c) acc p ls ('\\':x:xs)
                        | x=='\\'   = haskell (String c) ('\\':'\\':acc) p ls xs
                        | x==c      = haskell (String c) (c:'\\':acc) p ls xs
  haskell (String c) acc p ls (x:xs)
                        | x==c      = emit (c:acc) $ haskell Any [] p ls xs
                        | otherwise = haskell (String c) (x:acc) p ls xs
  haskell LineComment acc p ls xs@('\n':_) = emit acc $ haskell Any [] p ls xs
  haskell LineComment acc p ls (x:xs)      = haskell LineComment (x:acc) p ls xs
  haskell (NestComment n) acc p ls ('{':'-':xs)
                                    = haskell (NestComment (n+1))
                                                            ("-{"++acc) p ls xs
  haskell (NestComment 0) acc p ls ('-':'}':xs)
                                    = emit ("}-"++acc) $ haskell Any [] p ls xs
  haskell (NestComment n) acc p ls ('-':'}':xs)
                                    = haskell (NestComment (n-1))
                                                            ("}-"++acc) p ls xs
  haskell (NestComment n) acc p ls (x:xs) = haskell (NestComment n) (x:acc)
                                                                        p ls xs
  haskell CComment acc p ls ('*':'/':xs)  = emit ("  "++acc) $
                                            haskell Any [] p ls xs
  haskell CComment acc p ls (x:xs)        = haskell CComment (white x:acc) p ls xs
  haskell CLineComment acc p ls xs@('\n':_)= emit acc $ haskell Any [] p ls xs
  haskell CLineComment acc p ls (_:xs)    = haskell CLineComment (' ':acc)
                                                                       p ls xs
  haskell mode acc _ ((p,l):ls) []        = haskell mode acc p ls ('\n':l)
  haskell _    acc _ [] []                = emit acc $ []

  -- rules to lex Cpp
  cpp :: SubMode -> (SubMode -> String -> Posn -> [(Posn,String)]
                     -> String -> [WordStyle])
         -> String -> [String] -> Posn -> [(Posn,String)]
         -> String -> [WordStyle]
  cpp mode next word line pos remaining input =
    lexcpp mode word line remaining input
   where
    lexcpp Any w l ls ('/':'*':xs)   = lexcpp (NestComment 0) "" (w*/*l) ls xs
    lexcpp Any w l ls ('/':'/':xs)   = lexcpp LineComment "  " (w*/*l) ls xs
    lexcpp Any w l ((p,l'):ls) ('\\':[])  = cpp Any next [] ("\n":w*/*l) p ls l'
    lexcpp Any w l ls ('\\':'\n':xs) = lexcpp Any [] ("\n":w*/*l) ls xs
    lexcpp Any w l ls xs@('\n':_)    = Cmd (parseHashDefine ansi
                                                           (reverse (w*/*l))):
                                       next Any [] pos ls xs
 -- lexcpp Any w l ls ('"':xs)     = lexcpp (String '"') ['"'] (w*/*l) ls xs
 -- lexcpp Any w l ls ('\'':xs)    = lexcpp (String '\'') "'"  (w*/*l) ls xs
    lexcpp Any w l ls ('"':xs)       = lexcpp Any [] ("\"":(w*/*l)) ls xs
    lexcpp Any w l ls ('\'':xs)      = lexcpp Any [] ("'": (w*/*l)) ls xs
    lexcpp Any [] l ls (x:xs)
                    | ident0 x  = lexcpp (Pred ident1 Ident) [x] l ls xs
 -- lexcpp Any w l ls (x:xs) | ident0 x  = lexcpp (Pred ident1 Ident) [x] (w*/*l) ls xs
    lexcpp Any w l ls (x:xs)
                    | single x  = lexcpp Any [] ([x]:w*/*l) ls xs
                    | space x   = lexcpp (Pred space other) [x] (w*/*l) ls xs
                    | symbol x  = lexcpp (Pred symbol other) [x] (w*/*l) ls xs
                    | otherwise = lexcpp Any (x:w) l ls xs
    lexcpp pre@(Pred pred _) w l ls (x:xs)
                    | pred x    = lexcpp pre (x:w) l ls xs
    lexcpp (Pred _ _) w l ls xs = lexcpp Any [] (w*/*l) ls xs
    lexcpp (String c) w l ls ('\\':x:xs)
                    | x=='\\'   = lexcpp (String c) ('\\':'\\':w) l ls xs
                    | x==c      = lexcpp (String c) (c:'\\':w) l ls xs
    lexcpp (String c) w l ls (x:xs)
                    | x==c      = lexcpp Any [] ((c:w)*/*l) ls xs
                    | otherwise = lexcpp (String c) (x:w) l ls xs
    lexcpp LineComment w l ((p,l'):ls) ('\\':[])
                             = cpp LineComment next [] (('\n':w)*/*l) pos ls l'
    lexcpp LineComment w l ls ('\\':'\n':xs)
                                = lexcpp LineComment [] (('\n':w)*/*l) ls xs
    lexcpp LineComment w l ls xs@('\n':_) = lexcpp Any w l ls xs
    lexcpp LineComment w l ls (_:xs)      = lexcpp LineComment (' ':w) l ls xs
    lexcpp (NestComment _) w l ls ('*':'/':xs)
                                          = lexcpp Any [] (w*/*l) ls xs
    lexcpp (NestComment n) w l ls (x:xs)  = lexcpp (NestComment n) (white x:w) l
                                                                        ls xs
    lexcpp mode w l ((p,l'):ls) []        = cpp mode next w l p ls ('\n':l')
    lexcpp _    _ _ []          []        = []

    -- rules to lex non-Haskell, non-cpp text
  plaintext :: SubMode -> String -> Posn -> [(Posn,String)]
            -> String -> [WordStyle]
  plaintext Any acc p ls ('\n':'#':xs)  = emit acc $  -- emit "\n" $
                                          cpp Any plaintext [] [] p ls xs
  plaintext Any acc p ls ('/':'*':xs)
                           | stripComments = emit acc $
                                             plaintext CComment "  " p ls xs
  plaintext Any acc p ls ('/':'/':xs)
                                | stripEol = emit acc $
                                             plaintext CLineComment "  " p ls xs
  plaintext Any acc p ls (x:xs) | single x = emit acc $ emit [x] $
                                             plaintext Any [] p ls xs
  plaintext Any acc p ls (x:xs) | space x  = emit acc $
                                             plaintext (Pred space other) [x]
                                                                        p ls xs
  plaintext Any acc p ls (x:xs) | ident0 x = emit acc $
                                             plaintext (Pred ident1 Ident) [x]
                                                                        p ls xs
  plaintext Any acc p ls (x:xs)            = plaintext Any (x:acc) p ls xs
  plaintext pre@(Pred pred ws) acc p ls (x:xs)
                                | pred x   = plaintext pre (x:acc) p ls xs
  plaintext (Pred _ ws) acc p ls xs        = ws p (reverse acc):
                                             plaintext Any [] p ls xs
  plaintext CComment acc p ls ('*':'/':xs) = emit ("  "++acc) $
                                             plaintext Any [] p ls xs
  plaintext CComment acc p ls (x:xs)       = plaintext CComment (white x:acc) p ls xs
  plaintext CLineComment acc p ls xs@('\n':_)
                                        = emit acc $ plaintext Any [] p ls xs
  plaintext CLineComment acc p ls (_:xs)= plaintext CLineComment (' ':acc)
                                                                       p ls xs
  plaintext mode acc _ ((p,l):ls) []    = plaintext mode acc p ls ('\n':l)
  plaintext _    acc _ [] []            = emit acc $ []

  -- predicates for lexing Haskell.
  ident0 x = isAlpha x    || x `elem` "_`"
  ident1 x = isAlphaNum x || x `elem` "'_`"
  symbol x = x `elem` ":!#$%&*+./<=>?@\\^|-~"
  single x = x `elem` "(),[];{}"
  space  x = x `elem` " \t"
  -- conversion of comment text to whitespace
  white '\n' = '\n'
  white '\r' = '\r'
  white _    = ' '
  -- emit a token (if there is one) from the accumulator
  emit ""  = id
  emit xs  = (Other (reverse xs):)
  -- add a reversed word to the accumulator
  "" */* l = l
  w */* l  = reverse w : l
  -- help out broken Haskell compilers which need balanced numbers of C
  -- comments in order to do import chasing :-)  ----->   */*


-- | Parse a possible macro call, returning argument list and remaining input
parseMacroCall :: Posn -> [WordStyle] -> Maybe ([[WordStyle]],[WordStyle])
parseMacroCall p = call . skip
  where
    skip (Other x:xs) | all isSpace x = skip xs
    skip xss                          = xss
    call (Other "(":xs)   = (args (0::Int) [] [] . skip) xs
    call _                = Nothing
    args 0 w acc (   Other ")" :xs)  = Just (reverse (addone w acc), xs)
    args 0 w acc (   Other "," :xs)  = args 0     []   (addone w acc) (skip xs)
    args n w acc (x@(Other "("):xs)  = args (n+1) (x:w)         acc    xs
    args n w acc (x@(Other ")"):xs)  = args (n-1) (x:w)         acc    xs
    args n w acc (   Ident _ v :xs)  = args n     (Ident p v:w) acc    xs
    args n w acc (x@(Other _)  :xs)  = args n     (x:w)         acc    xs
    args _ _ _   _                   = Nothing
    addone w acc = reverse (skip w): acc