----------------------------------------------------------------------------- -- | -- 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