{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

{-
    BNF Converter: Java Antlr4 Lexer generator
    Copyright (C) 2015  Author:  Gabriele Paganelli

    Description   : This module generates the Antlr4 input file.
                    Based on CFtoJLex15.hs

    Author        : Gabriele Paganelli (gapag@distruzione.org)
    Created       : 15 Oct, 2015

-}

module BNFC.Backend.Java.CFtoAntlr4Lexer ( cf2AntlrLex ) where

import Prelude hiding ((<>))

import Text.PrettyPrint
import BNFC.CF
import BNFC.Backend.Java.RegToAntlrLexer
import BNFC.Backend.Common.NamedVariables

-- | Creates a lexer grammar.
-- Since antlr token identifiers must start with an uppercase symbol,
-- I prepend "Surrogate_id_SYMB_" to the identifier.
-- This introduces risks of clashes if somebody uses the same identifier for
-- user defined tokens. This is not handled.
-- returns the environment because the parser uses it.
cf2AntlrLex :: String -> CF -> (Doc, KeywordEnv)
cf2AntlrLex lang cf = (,env) $ vcat
    [ prelude lang
    , cMacros
    -- unnamed symbols (those in quotes, not in token definitions)
    , lexSymbols env
    , restOfLexerGrammar cf
    ]
  where
    env = zip (cfgSymbols cf ++ reservedWords cf) $ map (("Surrogate_id_SYMB_" ++) . show) [0 :: Int ..]


-- | File prelude
prelude :: String -> Doc
prelude lang = vcat
    [ "// Lexer definition for use with Antlr4"
    , "lexer grammar" <+> text lang <> "Lexer;"
    ]

--For now all categories are included.
--Optimally only the ones that are used should be generated.
cMacros :: Doc
cMacros = vcat
    [ "// Predefined regular expressions in BNFC"
    , frg "LETTER  : CAPITAL | SMALL"
    , frg "CAPITAL : [A-Z\\u00C0-\\u00D6\\u00D8-\\u00DE]"
    , frg "SMALL   : [a-z\\u00DF-\\u00F6\\u00F8-\\u00FF]"
    , frg "DIGIT   : [0-9]"
    ]
  where frg a = "fragment" <+> a <+> ";"

escapeChars :: String -> String
escapeChars = concatMap escapeCharInSingleQuotes

-- |
-- >>> lexSymbols [("foo","bar")]
-- bar : 'foo' ;
-- >>> lexSymbols [("\\","bar")]
-- bar : '\\' ;
-- >>> lexSymbols [("/","bar")]
-- bar : '/' ;
-- >>> lexSymbols [("~","bar")]
-- bar : '~' ;
lexSymbols :: KeywordEnv -> Doc
lexSymbols ss = vcat $  map transSym ss
  where
    transSym (s,r) = text r <>  " : '" <> text (escapeChars s) <> "' ;"

-- | Writes rules for user defined tokens, and, if used, the predefined BNFC tokens.
restOfLexerGrammar :: CF -> Doc
restOfLexerGrammar cf = vcat
    [ lexComments (comments cf)
    , ""
    , userDefTokens
    , ifString strdec
    , ifChar chardec
    , ifC catDouble [
        "// Double predefined token type",
        "DOUBLE : DIGIT+ '.' DIGIT+ ('e' '-'? DIGIT+)?;"
        ]
    , ifC catInteger [
        "//Integer predefined token type",
        "INTEGER : DIGIT+;"
        ]
    , ifC catIdent [
        "// Identifier token type" ,
        "fragment" ,
        "IDENTIFIER_FIRST : LETTER | '_';",
        "IDENT : IDENTIFIER_FIRST (IDENTIFIER_FIRST | DIGIT)*;"
        ]
    , "// Whitespace"
    , "WS : (' ' | '\\r' | '\\t' | '\\n' | '\\f')+ ->  skip;"
    , "// Escapable sequences"
    , "fragment"
    , "Escapable : ('\"' | '\\\\' | 'n' | 't' | 'r' | 'f');"
    , "ErrorToken : . ;"
    , ifString stringmodes
    , ifChar charmodes
    ]
  where
    ifC cat s     = if isUsedCat cf (TokenCat cat) then vcat s else ""
    ifString      = ifC catString
    ifChar        = ifC catChar
    strdec        = [ "// String token type"
                    , "STRING : '\"' -> more, mode(STRINGMODE);"
                    ]
    chardec       = ["CHAR : '\\''   -> more, mode(CHARMODE);"]
    userDefTokens = vcat
        [ text name <> " : " <> text (printRegJLex exp) <> ";"
        | (name, exp) <- tokenPragmas cf ]
    stringmodes   = [ "mode STRESCAPE;"
        , "STRESCAPED : Escapable  -> more, popMode ;"
        , "mode STRINGMODE;"
        , "STRINGESC : '\\\\' -> more , pushMode(STRESCAPE);"
        , "STRINGEND : '\"' ->  type(STRING), mode(DEFAULT_MODE);"
        , "STRINGTEXT : ~[\"\\\\] -> more;"
        ]
    charmodes     = [ "mode CHARMODE;"
        , "CHARANY     :  ~['\\\\] -> more, mode(CHAREND);"
        , "CHARESC     :  '\\\\'  -> more, pushMode(CHAREND),pushMode(ESCAPE);"
        , "mode ESCAPE;"
        , "ESCAPED : (Escapable | '\\'')  -> more, popMode ;"
        , "mode CHAREND;"
        , "CHARENDC     :  '\\''  -> type(CHAR), mode(DEFAULT_MODE);"
        ]

lexComments :: ([(String, String)], [String]) -> Doc
lexComments ([],[]) = ""
lexComments (m,s) = vcat
    (prod "COMMENT_antlr_builtin" lexSingleComment s ++
         prod "MULTICOMMENT_antlr_builtin" lexMultiComment m )

  where
    prod bg lc ty = [bg, ": ("] ++ punctuate "|" (map lc ty) ++ skiplex
    skiplex       = [") -> skip;"]

-- | Create lexer rule for single-line comments.
--
-- >>> lexSingleComment "--"
-- '--' ~[\r\n]* (('\r'? '\n')|EOF)
--
-- >>> lexSingleComment "\""
-- '"' ~[\r\n]* (('\r'? '\n')|EOF)
lexSingleComment :: String -> Doc
lexSingleComment c =
    "'" <>text (escapeChars c) <>  "' ~[\\r\\n]* (('\\r'? '\\n')|EOF)"

-- | Create lexer rule for multi-lines comments.
--
-- There might be a possible bug here if a language includes 2 multi-line
-- comments. They could possibly start a comment with one character and end it
-- with another. However this seems rare.
--
-- >>> lexMultiComment ("{-", "-}")
-- '{-' (.)*? '-}'
--
-- >>> lexMultiComment ("\"'", "'\"")
-- '"\'' (.)*? '\'"'
lexMultiComment :: (String, String) -> Doc
lexMultiComment (b,e) =
         "'" <> text (escapeChars b)
        <>"' (.)*? '"<> text (escapeChars e)
        <> "'"
