{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}

{-
    BNF Converter: C flex generator
    Copyright (C) 2004  Author:  Michael Pellauer
    Copyright (C) 2020  Andreas Abel

    Description   : This module generates the Flex file. It is
                    similar to JLex but with a few peculiarities.

    Author        : Michael Pellauer
    Created       : 5 August, 2003
-}

module BNFC.Backend.C.CFtoFlexC
  ( cf2flex
  , ParserMode(..), parserName, parserPackage, cParser, stlParser, parserHExt
  , preludeForBuffer  -- C code defining a buffer for lexing string literals.
  , cMacros           -- Lexer definitions.
  , commentStates     -- Stream of names for lexer states for comments.
  , lexComments       -- Lexing rules for comments.
  , lexStrings        -- Lexing rules for string literals.
  , lexChars          -- Lexing rules for character literals.
  ) where

import Prelude hiding                ( (<>) )
import Data.Bifunctor                ( first )
import Data.Char                     ( isAlphaNum, isAscii )
import Data.List                     ( isInfixOf )
import Data.Maybe                    ( fromMaybe, maybeToList )
import qualified Data.Map as Map
import System.FilePath               ( (<.>) )

import BNFC.CF
import BNFC.Backend.C.Common         ( posixC )
import BNFC.Backend.C.RegToFlex
import BNFC.Backend.Common.NamedVariables
import BNFC.Options                  ( InPackage )
import BNFC.PrettyPrint
import BNFC.Utils                    ( cstring, symbolToName, unless, when )

data ParserMode
  = CParser Bool String    -- ^ @C@ (@False@) or @C++ no STL@ (@True@) mode, with @name@ to use as prefix.
  | CppParser InPackage String    -- ^ @C++@ mode, with optional package name

parserName :: ParserMode -> String
parserName :: ParserMode -> String
parserName = \case
  CParser   Bool
_ String
n -> String
n
  CppParser InPackage
p String
n -> String -> InPackage -> String
forall a. a -> Maybe a -> a
fromMaybe String
n InPackage
p

parserPackage :: ParserMode -> InPackage
parserPackage :: ParserMode -> InPackage
parserPackage = \case
  CParser   Bool
_ String
_ -> InPackage
forall a. Maybe a
Nothing
  CppParser InPackage
p String
_ -> InPackage
p

cParser :: ParserMode -> Bool
cParser :: ParserMode -> Bool
cParser = \case
  CParser   Bool
b String
_ -> Bool -> Bool
not Bool
b
  CppParser InPackage
_ String
_ -> Bool
False

stlParser :: ParserMode -> Bool
stlParser :: ParserMode -> Bool
stlParser = \case
  CParser   Bool
_ String
_ -> Bool
False
  CppParser InPackage
_ String
_ -> Bool
True

parserHExt :: ParserMode -> String
parserHExt :: ParserMode -> String
parserHExt = \case
  CParser   Bool
b String
_ -> if Bool
b then String
"H" else String
"h"
  CppParser InPackage
_ String
_ -> String
"H"

-- | Entrypoint.
cf2flex :: ParserMode -> CF -> (String, SymMap) -- The environment is reused by the parser.
cf2flex :: ParserMode -> CF -> (String, SymMap)
cf2flex ParserMode
mode CF
cf = (, SymMap
env) (String -> (String, SymMap)) -> String -> (String, SymMap)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ Bool -> ParserMode -> String
prelude Bool
stringLiterals ParserMode
mode
    , CF -> String
cMacros CF
cf
    , KeywordEnv -> String
lexSymbols KeywordEnv
env1
    , InPackage -> CF -> SymMap -> String
restOfFlex (ParserMode -> InPackage
parserPackage ParserMode
mode) CF
cf SymMap
env
    , String
footer -- mode
    ]
  where
    env :: SymMap
env  = [(SymKey, String)] -> SymMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(SymKey, String)]
env2
    env0 :: KeywordEnv
env0 = [String] -> [Int] -> KeywordEnv
makeSymEnv (CF -> [String]
forall function. CFG function -> [String]
cfgSymbols CF
cf) [Int
0 :: Int ..]
    env1 :: KeywordEnv
env1 = KeywordEnv
env0 KeywordEnv -> KeywordEnv -> KeywordEnv
forall a. [a] -> [a] -> [a]
++ [String] -> [Int] -> KeywordEnv
makeKwEnv (CF -> [String]
forall function. CFG function -> [String]
reservedWords CF
cf) [KeywordEnv -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length KeywordEnv
env0 ..]
    env2 :: [(SymKey, String)]
env2 = ((String, String) -> (SymKey, String))
-> KeywordEnv -> [(SymKey, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> SymKey) -> (String, String) -> (SymKey, String)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> SymKey
Keyword) KeywordEnv
env1 [(SymKey, String)] -> [(SymKey, String)] -> [(SymKey, String)]
forall a. [a] -> [a] -> [a]
++ (String -> (SymKey, String)) -> [String] -> [(SymKey, String)]
forall a b. (a -> b) -> [a] -> [b]
map (\ String
x -> (String -> SymKey
Tokentype String
x, String
"T_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x)) (CF -> [String]
forall function. CFG function -> [String]
tokenNames CF
cf)
    makeSymEnv :: [String] -> [Int] -> KeywordEnv
makeSymEnv     = (String -> Int -> (String, String))
-> [String] -> [Int] -> KeywordEnv
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((String -> Int -> (String, String))
 -> [String] -> [Int] -> KeywordEnv)
-> (String -> Int -> (String, String))
-> [String]
-> [Int]
-> KeywordEnv
forall a b. (a -> b) -> a -> b
$ \ String
s Int
n -> (String
s, Char
'_' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> InPackage -> String
forall a. a -> Maybe a -> a
fromMaybe (String
"SYMB_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n) (String -> InPackage
symbolToName String
s))
    makeKwEnv :: [String] -> [Int] -> KeywordEnv
makeKwEnv      = (String -> Int -> (String, String))
-> [String] -> [Int] -> KeywordEnv
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((String -> Int -> (String, String))
 -> [String] -> [Int] -> KeywordEnv)
-> (String -> Int -> (String, String))
-> [String]
-> [Int]
-> KeywordEnv
forall a b. (a -> b) -> a -> b
$ \ String
s Int
n -> (String
s, String
"_KW_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
c) String
s then String
s else Int -> String
forall a. Show a => a -> String
show Int
n)
    stringLiterals :: Bool
stringLiterals = CF -> Cat -> Bool
forall f. CFG f -> Cat -> Bool
isUsedCat CF
cf (String -> Cat
TokenCat String
catString)

prelude :: Bool -> ParserMode -> String
prelude :: Bool -> ParserMode -> String
prelude Bool
stringLiterals ParserMode
mode = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"/* Lexer definition for use with FLex */"
    , String
""
    -- noinput and nounput are most often unused
    -- https://stackoverflow.com/questions/39075510/option-noinput-nounput-what-are-they-for
    , String
"%option noyywrap noinput nounput"
    , String
"%option reentrant bison-bridge bison-locations"
    , String
""
    ]
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when Bool
stringLiterals
    [ String
"/* Additional data for the lexer: a buffer for lexing string literals. */"
    , String
"%option extra-type=\"Buffer\""
    , String
""
    ]
  , InPackage -> [String]
forall a. Maybe a -> [a]
maybeToList (InPackage -> [String]) -> InPackage -> [String]
forall a b. (a -> b) -> a -> b
$ (String
"%option prefix=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" ) (String -> String) -> InPackage -> InPackage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserMode -> InPackage
parserPackage ParserMode
mode
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when (ParserMode -> Bool
cParser ParserMode
mode) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    -- The following #define needs to be at the top before the automatic #include <stdlib.h>
    [ [ String
"%top{" ]
    , [String]
posixC
    , [ String
"}" ]
    ]
  , [ String
"%{"
    , String
"#include \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
"Absyn" String -> String -> String
<.> String
h) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
    , String
"#include \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
"Bison" String -> String -> String
<.> String
h) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
    , String
""
    ]
  , [ String
"#define initialize_lexer " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParserMode -> String
parserName ParserMode
mode String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_initialize_lexer"
    , String
""
    ]
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
when Bool
stringLiterals ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
preludeForBuffer (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ String
"Buffer" String -> String -> String
<.> String
h
    -- https://www.gnu.org/software/bison/manual/html_node/Token-Locations.html
    -- Flex is responsible for keeping tracking of the yylloc for Bison.
    -- Flex also doesn't do this automatically so we need this function
    -- https://stackoverflow.com/a/22125500/425756
  , [ String
"static void update_loc(YYLTYPE* loc, char* text)"
    , String
"{"
    , String
"  loc->first_line = loc->last_line;"
    , String
"  loc->first_column = loc->last_column;"
    , String
"  int i = 0;"  -- put this here as @for (int i...)@ is only allowed in C99
    , String
"  for (; text[i] != '\\0'; ++i) {"
    , String
"      if (text[i] == '\\n') {"        -- Checking for \n is good enough to also support \r\n (but not \r)
    , String
"          ++loc->last_line;"
    , String
"          loc->last_column = 0; "
    , String
"      } else {"
    , String
"          ++loc->last_column; "
    , String
"      }"
    , String
"  }"
    , String
"}"
    , String
"#define YY_USER_ACTION update_loc(yylloc, yytext);"
    , String
""
    , String
"%}"
    ]
  ]
  where
  h :: String
h = ParserMode -> String
parserHExt ParserMode
mode

-- | Part of the lexer prelude needed when string literals are to be lexed.
--   Defines an interface to the Buffer.
preludeForBuffer :: String -> [String]
preludeForBuffer :: String -> [String]
preludeForBuffer String
bufferH =
    [ String
"/* BEGIN extensible string buffer */"
    , String
""
    , String
"#include \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bufferH String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
    , String
""
    , String
"/* The initial size of the buffer to lex string literals. */"
    , String
"#define LITERAL_BUFFER_INITIAL_SIZE 1024"
    , String
""
    , String
"/* The pointer to the literal buffer. */"
    , String
"#define literal_buffer yyextra"
    , String
""
    , String
"/* Initialize the literal buffer. */"
    , String
"#define LITERAL_BUFFER_CREATE() literal_buffer = newBuffer(LITERAL_BUFFER_INITIAL_SIZE)"
    , String
""
    , String
"/* Append characters at the end of the buffer. */"
    , String
"#define LITERAL_BUFFER_APPEND(s) bufferAppendString(literal_buffer, s)"
    , String
""
    , String
"/* Append a character at the end of the buffer. */"
    , String
"#define LITERAL_BUFFER_APPEND_CHAR(c) bufferAppendChar(literal_buffer, c)"
    , String
""
    , String
"/* Release the buffer, returning a pointer to its content. */"
    , String
"#define LITERAL_BUFFER_HARVEST() releaseBuffer(literal_buffer)"
    , String
""
    , String
"/* In exceptional cases, e.g. when reaching EOF, we have to free the buffer. */"
    , String
"#define LITERAL_BUFFER_FREE() freeBuffer(literal_buffer)"
    , String
""
    , String
"/* END extensible string buffer */"
    , String
""
    ]

-- For now all categories are included.
-- Optimally only the ones that are used should be generated.
cMacros :: CF ->  String
cMacros :: CF -> String
cMacros CF
cf = [String] -> String
unlines
  [ String
"LETTER [a-zA-Z]"
  , String
"CAPITAL [A-Z]"
  , String
"SMALL [a-z]"
  , String
"DIGIT [0-9]"
  , String
"IDENT [a-zA-Z0-9'_]"
  , [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ [ String
"%START CHAR CHARESC CHAREND STRING ESCAPED" ]
      , Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take (CF -> Int
numberOfBlockCommentForms CF
cf) [String]
commentStates
      ]
  , String
""
  , String
"%%  /* Rules. */"
  ]

lexSymbols :: KeywordEnv -> String
lexSymbols :: KeywordEnv -> String
lexSymbols KeywordEnv
ss = ((String, String) -> String) -> KeywordEnv -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, String) -> String
transSym KeywordEnv
ss
  where
    transSym :: (String, String) -> String
transSym (String
s,String
r) =
      String
"<INITIAL>\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"      \t return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
r String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";\n"
        where
         s' :: String
s' = String -> String
escapeChars String
s

restOfFlex :: InPackage -> CF -> SymMap -> String
restOfFlex :: InPackage -> CF -> SymMap -> String
restOfFlex InPackage
_inPackage CF
cf SymMap
env = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ (KeywordEnv, [String]) -> Doc
lexComments ((KeywordEnv, [String]) -> Doc) -> (KeywordEnv, [String]) -> Doc
forall a b. (a -> b) -> a -> b
$ CF -> (KeywordEnv, [String])
comments CF
cf
    , String
""
    ]
  , [String]
userDefTokens
  , String -> [String] -> [String]
forall a. String -> [a] -> [a]
ifC String
catString  ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> [String]
lexStrings String
"yylval" String
"_STRING_" String
"_ERROR_"
  , String -> [String] -> [String]
forall a. String -> [a] -> [a]
ifC String
catChar    ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
lexChars   String
"yylval" String
"_CHAR_"
  , String -> [String] -> [String]
forall a. String -> [a] -> [a]
ifC String
catDouble  [ String
"<INITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)?      \t yylval->_double = atof(yytext); return _DOUBLE_;" ]
  , String -> [String] -> [String]
forall a. String -> [a] -> [a]
ifC String
catInteger [ String
"<INITIAL>{DIGIT}+      \t yylval->_int = atoi(yytext); return _INTEGER_;" ]
  , String -> [String] -> [String]
forall a. String -> [a] -> [a]
ifC String
catIdent   [ String
"<INITIAL>{LETTER}{IDENT}*      \t yylval->_string = strdup(yytext); return _IDENT_;" ]
  , [ String
"<INITIAL>[ \\t\\r\\n\\f]      \t /* ignore white space. */;"
    , String
"<INITIAL>.      \t return _ERROR_;"
    , String
""
    , String
"%%  /* Initialization code. */"
    ]
  ]
  where
  ifC :: String -> [a] -> [a]
ifC String
cat [a]
s = if CF -> Cat -> Bool
forall f. CFG f -> Cat -> Bool
isUsedCat CF
cf (String -> Cat
TokenCat String
cat) then [a]
s else []
  userDefTokens :: [String]
userDefTokens =
    [ String
"<INITIAL>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
printRegFlex Reg
exp String -> String -> String
forall a. [a] -> [a] -> [a]
++
       String
"    \t yylval->_string = strdup(yytext); return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
sName String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    | (String
name, Reg
exp) <- CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf
    ]
    where sName :: String -> String
sName String
n = String -> InPackage -> String
forall a. a -> Maybe a -> a
fromMaybe String
n (InPackage -> String) -> InPackage -> String
forall a b. (a -> b) -> a -> b
$ SymKey -> SymMap -> InPackage
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> SymKey
Tokentype String
n) SymMap
env

footer :: String
footer :: String
footer = [String] -> String
unlines
    [ String
"yyscan_t initialize_lexer(FILE *inp)"
    , String
"{"
    , String
"  yyscan_t scanner;"
    , String
"  if (yylex_init_extra(NULL, &scanner)) return 0;"
    , String
"  if (inp) yyrestart(inp, scanner);"
    , String
"  return scanner;"
    , String
"}"
    ]

-- | Lexing of strings, converting escaped characters.
lexStrings :: String -> String -> String -> [String]
lexStrings :: String -> String -> String -> [String]
lexStrings String
yylval String
stringToken String
errorToken =
    [ String
"<INITIAL>\"\\\"\"        \t LITERAL_BUFFER_CREATE(); BEGIN STRING;"
    , String
"<STRING>\\\\             \t BEGIN ESCAPED;"
    , String
"<STRING>\\\"             \t " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
yylval String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->_string = LITERAL_BUFFER_HARVEST(); BEGIN INITIAL; return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
stringToken String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"<STRING>.              \t LITERAL_BUFFER_APPEND_CHAR(yytext[0]);"
    , String
"<ESCAPED>f             \t LITERAL_BUFFER_APPEND_CHAR('\\f'); BEGIN STRING;"
    , String
"<ESCAPED>n             \t LITERAL_BUFFER_APPEND_CHAR('\\n'); BEGIN STRING;"
    , String
"<ESCAPED>r             \t LITERAL_BUFFER_APPEND_CHAR('\\r'); BEGIN STRING;"
    , String
"<ESCAPED>t             \t LITERAL_BUFFER_APPEND_CHAR('\\t'); BEGIN STRING;"
    , String
"<ESCAPED>\\\"            \t LITERAL_BUFFER_APPEND_CHAR('\"');  BEGIN STRING;"
    , String
"<ESCAPED>\\\\            \t LITERAL_BUFFER_APPEND_CHAR('\\\\'); BEGIN STRING;"
    , String
"<ESCAPED>.             \t LITERAL_BUFFER_APPEND(yytext);    BEGIN STRING;"
    , String
"<STRING,ESCAPED><<EOF>>\t LITERAL_BUFFER_FREE(); return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
errorToken String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    ]

-- | Lexing of characters, converting escaped characters.
lexChars :: String -> String -> [String]
lexChars :: String -> String -> [String]
lexChars String
yylval String
charToken =
    [ String
"<INITIAL>\"'\" \tBEGIN CHAR;"
    , String
"<CHAR>\\\\      \t BEGIN CHARESC;"
    , String
"<CHAR>[^']      \t BEGIN CHAREND; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
yylval String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->_char = yytext[0]; return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
charToken String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"<CHARESC>f      \t BEGIN CHAREND; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
yylval String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->_char = '\\f';     return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
charToken String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"<CHARESC>n      \t BEGIN CHAREND; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
yylval String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->_char = '\\n';     return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
charToken String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"<CHARESC>r      \t BEGIN CHAREND; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
yylval String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->_char = '\\r';     return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
charToken String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"<CHARESC>t      \t BEGIN CHAREND; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
yylval String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->_char = '\\t';     return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
charToken String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"<CHARESC>.      \t BEGIN CHAREND; " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
yylval String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"->_char = yytext[0]; return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
charToken String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"<CHAREND>\"'\"      \t BEGIN INITIAL;"
    ]

-- ---------------------------------------------------------------------------
-- Comments

-- | Create flex rules for single-line and multi-lines comments.
-- The first argument is an optional namespace (for C++); the second
-- argument is the set of comment delimiters as returned by BNFC.CF.comments.
--
-- This function is only compiling the results of applying either
-- lexSingleComment or lexMultiComment on each comment delimiter or pair of
-- delimiters.
--
-- >>> lexComments ([("{-","-}")],["--"])
-- <INITIAL>"--"[^\n]* /* skip */; /* BNFC: comment "--" */
-- <INITIAL>"{-" BEGIN COMMENT; /* BNFC: block comment "{-" "-}" */
-- <COMMENT>"-}" BEGIN INITIAL;
-- <COMMENT>.    /* skip */;
-- <COMMENT>[\n] /* skip */;
lexComments :: ([(String, String)], [String]) -> Doc
lexComments :: (KeywordEnv, [String]) -> Doc
lexComments (KeywordEnv
m,[String]
s) = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [[Doc]] -> [Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
lexSingleComment [String]
s
  , ((String, String) -> String -> Doc)
-> KeywordEnv -> [String] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (String, String) -> String -> Doc
lexMultiComment KeywordEnv
m [String]
commentStates
  ]

-- | If we have several block comments, we need different COMMENT lexing states.
commentStates :: [String]
commentStates :: [String]
commentStates = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"COMMENT" String -> String -> String
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show [Int
1::Int ..]

-- | Create a lexer rule for single-line comments.
-- The first argument is -- an optional c++ namespace
-- The second argument is the delimiter that marks the beginning of the
-- comment.
--
-- >>> lexSingleComment "--"
-- <INITIAL>"--"[^\n]* /* skip */; /* BNFC: comment "--" */
--
-- >>> lexSingleComment "\""
-- <INITIAL>"\""[^\n]* /* skip */; /* BNFC: comment "\"" */
lexSingleComment :: String -> Doc
lexSingleComment :: String -> Doc
lexSingleComment String
c =
    Doc
"<INITIAL>" Doc -> Doc -> Doc
<> String -> Doc
cstring String
c Doc -> Doc -> Doc
<> Doc
"[^\\n]*"
    Doc -> Doc -> Doc
<+> Doc
"/* skip */;"
    Doc -> Doc -> Doc
<+> Bool -> Doc -> Doc
forall m. Monoid m => Bool -> m -> m
unless (String -> Bool
containsCCommentMarker String
c) (Doc
"/* BNFC: comment" Doc -> Doc -> Doc
<+> String -> Doc
cstring String
c Doc -> Doc -> Doc
<+> Doc
"*/")

containsCCommentMarker :: String -> Bool
containsCCommentMarker :: String -> Bool
containsCCommentMarker String
s = String
"/*" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s Bool -> Bool -> Bool
|| String
"*/" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s

-- | Create a lexer rule for multi-lines comments.
-- The first argument is -- an optional c++ namespace
-- The second arguments is the pair of delimiter for the multi-lines comment:
-- start deleminiter and end delimiter.
-- 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 ("{-", "-}") "COMMENT"
-- <INITIAL>"{-" BEGIN COMMENT; /* BNFC: block comment "{-" "-}" */
-- <COMMENT>"-}" BEGIN INITIAL;
-- <COMMENT>.    /* skip */;
-- <COMMENT>[\n] /* skip */;
--
-- >>> lexMultiComment ("\"'", "'\"") "COMMENT"
-- <INITIAL>"\"'" BEGIN COMMENT; /* BNFC: block comment "\"'" "'\"" */
-- <COMMENT>"'\"" BEGIN INITIAL;
-- <COMMENT>.    /* skip */;
-- <COMMENT>[\n] /* skip */;
lexMultiComment :: (String, String) -> String -> Doc
lexMultiComment :: (String, String) -> String -> Doc
lexMultiComment (String
b,String
e) String
comment = [Doc] -> Doc
vcat
    [ Doc
"<INITIAL>" Doc -> Doc -> Doc
<> String -> Doc
cstring String
b Doc -> Doc -> Doc
<+> Doc
"BEGIN" Doc -> Doc -> Doc
<+> String -> Doc
text String
comment Doc -> Doc -> Doc
<> Doc
";"
      Doc -> Doc -> Doc
<+> Bool -> Doc -> Doc
forall m. Monoid m => Bool -> m -> m
unless (String -> Bool
containsCCommentMarker String
b Bool -> Bool -> Bool
|| String -> Bool
containsCCommentMarker String
e)
          (Doc
"/* BNFC: block comment" Doc -> Doc -> Doc
<+> String -> Doc
cstring String
b Doc -> Doc -> Doc
<+> String -> Doc
cstring String
e Doc -> Doc -> Doc
<+> Doc
"*/")
    , Doc
commentTag Doc -> Doc -> Doc
<> String -> Doc
cstring String
e Doc -> Doc -> Doc
<+> Doc
"BEGIN INITIAL;"
    , Doc
commentTag Doc -> Doc -> Doc
<> Doc
".    /* skip */;"
    , Doc
commentTag Doc -> Doc -> Doc
<> Doc
"[\\n] /* skip */;"
    ]
  where
  commentTag :: Doc
commentTag = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
comment String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

-- | Helper function that escapes characters in strings.
escapeChars :: String -> String
escapeChars :: String -> String
escapeChars [] = []
escapeChars (Char
'\\':String
xs) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: (Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: (String -> String
escapeChars String
xs))
escapeChars (Char
'\"':String
xs) = Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: (Char
'\"' Char -> String -> String
forall a. a -> [a] -> [a]
: (String -> String
escapeChars String
xs))
escapeChars (Char
x:String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: (String -> String
escapeChars String
xs)