{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TupleSections #-}

{-
    BNF Converter: 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
    Modified      : 22 August, 2006 by Aarne Ranta
-}

module BNFC.Backend.CPP.NoSTL.CFtoFlex (cf2flex) where

import Prelude hiding ((<>))
import Data.Bifunctor (first)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map

import BNFC.CF
import BNFC.Backend.C.CFtoFlexC (preludeForBuffer, cMacros, commentStates, lexChars, lexStrings)
import BNFC.Backend.C.RegToFlex
import BNFC.Backend.Common.NamedVariables
import BNFC.Backend.CPP.STL.STLUtils
import BNFC.PrettyPrint
import BNFC.Utils (cstring, when)

--The environment must be returned for the parser to use.
cf2flex :: Maybe String -> String -> CF -> (String, SymMap)
cf2flex :: Maybe String -> String -> CF -> (String, SymMap)
cf2flex Maybe String
inPackage String
_name CF
cf = (, SymMap
env) (String -> (String, SymMap)) -> String -> (String, SymMap)
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
    [ Bool -> Maybe String -> String
prelude Bool
stringLiterals Maybe String
inPackage
    , CF -> String
cMacros CF
cf
    , SymEnv -> String
lexSymbols SymEnv
env0
    , Maybe String -> CF -> SymMap -> String
restOfFlex Maybe String
inPackage CF
cf SymMap
env
    ]
  where
    env :: SymMap
env  = [(SymKey, String)] -> SymMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(SymKey, String)]
env1
    env0 :: SymEnv
env0 = [String] -> [Int] -> SymEnv
forall a. [a] -> [Int] -> [(a, String)]
makeSymEnv (CF -> [String]
forall function. CFG function -> [String]
cfgSymbols CF
cf [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ CF -> [String]
forall function. CFG function -> [String]
reservedWords CF
cf) [Int
0 :: Int ..]
    env1 :: [(SymKey, String)]
env1 = ((String, String) -> (SymKey, String))
-> SymEnv -> [(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) SymEnv
env0 [(SymKey, String)] -> [(SymKey, String)] -> [(SymKey, String)]
forall a. [a] -> [a] -> [a]
++ [SymKey] -> [Int] -> [(SymKey, String)]
forall a. [a] -> [Int] -> [(a, String)]
makeSymEnv ((String -> SymKey) -> [String] -> [SymKey]
forall a b. (a -> b) -> [a] -> [b]
map String -> SymKey
Tokentype ([String] -> [SymKey]) -> [String] -> [SymKey]
forall a b. (a -> b) -> a -> b
$ CF -> [String]
forall function. CFG function -> [String]
tokenNames CF
cf) [SymEnv -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length SymEnv
env0 ..]
    makeSymEnv :: [a] -> [Int] -> [(a, String)]
makeSymEnv = (a -> Int -> (a, String)) -> [a] -> [Int] -> [(a, String)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((a -> Int -> (a, String)) -> [a] -> [Int] -> [(a, String)])
-> (a -> Int -> (a, String)) -> [a] -> [Int] -> [(a, String)]
forall a b. (a -> b) -> a -> b
$ \ a
s Int
n -> (a
s, String
"_SYMB_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ 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 -> Maybe String -> String
prelude :: Bool -> Maybe String -> String
prelude Bool
stringLiterals Maybe String
inPackage = [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
"/* This FLex file was machine-generated by the BNF converter */" ]
  , [String] -> (String -> [String]) -> Maybe String -> [String]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\ String
ns -> [ String
"%option prefix=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy\"" ]) Maybe String
inPackage
  , [ String
"%{"
    , String
"#include <string.h>"
    , String
"#include \"Parser.H\""
    , String
"extern int " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
nsString Maybe String
inPackage String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_mylinenumber ;" --- hack to get line number. AR 2006
    , 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
"Buffer.H"
  , [ String
"%}" ]
  ]

lexSymbols :: SymEnv -> String
lexSymbols :: SymEnv -> String
lexSymbols SymEnv
ss = ((String, String) -> String) -> SymEnv -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, String) -> String
transSym SymEnv
ss
  where
    transSym :: (String, String) -> String
transSym (String
s,String
r) =
      String
"<YYINITIAL>\"" 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 :: Maybe String -> CF -> SymMap -> String
restOfFlex :: Maybe String -> CF -> SymMap -> String
restOfFlex Maybe String
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
$ Maybe String -> (SymEnv, [String]) -> Doc
lexComments Maybe String
inPackage (CF -> (SymEnv, [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
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yylval") (Maybe String -> String -> String
nsDefine Maybe String
inPackage String
"_STRING_") (Maybe String -> String -> String
nsDefine Maybe String
inPackage 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
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yylval") (Maybe String -> String -> String
nsDefine Maybe String
inPackage String
"_CHAR_")
  , String -> [String] -> [String]
forall a. String -> [a] -> [a]
ifC String
catDouble  [ String
"<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)?      \t " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yylval._double = atof(yytext); return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String -> String
nsDefine Maybe String
inPackage String
"_DOUBLE_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" ]
  , String -> [String] -> [String]
forall a. String -> [a] -> [a]
ifC String
catInteger [ String
"<YYINITIAL>{DIGIT}+      \t " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yylval._int = atoi(yytext); return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String -> String
nsDefine Maybe String
inPackage String
"_INTEGER_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" ]
  , String -> [String] -> [String]
forall a. String -> [a] -> [a]
ifC String
catIdent   [ String
"<YYINITIAL>{LETTER}{IDENT}*      \t " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yylval._string = strdup(yytext); return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String -> String
nsDefine Maybe String
inPackage String
"_IDENT_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" ]
  , [ String
"\\n  ++" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"yy_mylinenumber ;"
    , String
"<YYINITIAL>[ \\t\\r\\n\\f]      \t /* ignore white space. */;"
    , String
"<YYINITIAL>.      \t return " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String -> String
nsDefine Maybe String
inPackage String
"_ERROR_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";"
    , String
"%%"
    ]
  , [String]
footer
  ]
  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 []
   ns :: String
ns = Maybe String -> String
nsString Maybe String
inPackage
   userDefTokens :: [String]
userDefTokens =
     [ String
"<YYINITIAL>" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Reg -> String
printRegFlex Reg
exp String -> String -> String
forall a. [a] -> [a] -> [a]
++
         String
"     \t " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"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 -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
n (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ SymKey -> SymMap -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (String -> SymKey
Tokentype String
n) SymMap
env
   footer :: [String]
footer =
     [ String
"void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ns String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"initialize_lexer(FILE *inp) { yyrestart(inp); BEGIN YYINITIAL; }"
     , String
"int yywrap(void) { return 1; }"
     ]


-- ---------------------------------------------------------------------------
-- 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 (Just "myns.") ([("{-","-}")],["--"])
-- <YYINITIAL>"--"[^\n]* ; // BNFC: comment "--";
-- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: block comment "{-" "-}";
-- <COMMENT>"-}" BEGIN YYINITIAL;
-- <COMMENT>.    /* skip */;
-- <COMMENT>[\n] ++myns.yy_mylinenumber;
lexComments :: Maybe String -> ([(String, String)], [String]) -> Doc
lexComments :: Maybe String -> (SymEnv, [String]) -> Doc
lexComments Maybe String
ns (SymEnv
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    (Maybe String -> String -> Doc
lexSingleComment Maybe String
ns) [String]
s
  , ((String, String) -> String -> Doc) -> SymEnv -> [String] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Maybe String -> (String, String) -> String -> Doc
lexMultiComment Maybe String
ns) SymEnv
m [String]
commentStates
  ]

-- | 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 (Just "mypackage.") "--"
-- <YYINITIAL>"--"[^\n]* ; // BNFC: comment "--";
--
-- >>> lexSingleComment Nothing "--"
-- <YYINITIAL>"--"[^\n]* ; // BNFC: comment "--";
--
-- >>> lexSingleComment Nothing "\""
-- <YYINITIAL>"\""[^\n]* ; // BNFC: comment "\"";
lexSingleComment :: Maybe String -> String -> Doc
lexSingleComment :: Maybe String -> String -> Doc
lexSingleComment Maybe String
_ String
c =
    Doc
"<YYINITIAL>" Doc -> Doc -> Doc
<> String -> Doc
cstring String
c Doc -> Doc -> Doc
<> Doc
"[^\\n]*"
    Doc -> Doc -> Doc
<+> Doc
";"
    Doc -> Doc -> Doc
<+> Doc
"// BNFC: comment" Doc -> Doc -> Doc
<+> String -> Doc
cstring String
c Doc -> Doc -> Doc
<> Doc
";"

-- -- | 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 (Just "mypackage.") "--"
-- -- <YYINITIAL>"--"[^\n]*\n ++mypackage.yy_mylinenumber; // BNFC: comment "--";
-- --
-- -- >>> lexSingleComment Nothing "--"
-- -- <YYINITIAL>"--"[^\n]*\n ++yy_mylinenumber; // BNFC: comment "--";
-- --
-- -- >>> lexSingleComment Nothing "\""
-- -- <YYINITIAL>"\""[^\n]*\n ++yy_mylinenumber; // BNFC: comment "\"";
-- lexSingleComment :: Maybe String -> String -> Doc
-- lexSingleComment ns c =
--     "<YYINITIAL>" <> cstring c <> "[^\\n]*\\n"
--     <+> "++"<> text (fromMaybe "" ns)<>"yy_mylinenumber;"
--     <+> "// BNFC: comment" <+> cstring c <> ";"

-- | 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 Nothing ("{-", "-}") "COMMENT"
-- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: block comment "{-" "-}";
-- <COMMENT>"-}" BEGIN YYINITIAL;
-- <COMMENT>.    /* skip */;
-- <COMMENT>[\n] ++yy_mylinenumber;
--
-- >>> lexMultiComment (Just "foo.") ("{-", "-}") "COMMENT"
-- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: block comment "{-" "-}";
-- <COMMENT>"-}" BEGIN YYINITIAL;
-- <COMMENT>.    /* skip */;
-- <COMMENT>[\n] ++foo.yy_mylinenumber;
--
-- >>> lexMultiComment Nothing ("\"'", "'\"") "COMMENT"
-- <YYINITIAL>"\"'" BEGIN COMMENT; // BNFC: block comment "\"'" "'\"";
-- <COMMENT>"'\"" BEGIN YYINITIAL;
-- <COMMENT>.    /* skip */;
-- <COMMENT>[\n] ++yy_mylinenumber;
lexMultiComment :: Maybe String -> (String, String) -> String -> Doc
lexMultiComment :: Maybe String -> (String, String) -> String -> Doc
lexMultiComment Maybe String
ns (String
b,String
e) String
comment = [Doc] -> Doc
vcat
    [ Doc
"<YYINITIAL>" 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
<+> 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 YYINITIAL;"
    , Doc
commentTag Doc -> Doc -> Doc
<> Doc
".    /* skip */;"
    , Doc
commentTag Doc -> Doc -> Doc
<> Doc
"[\\n] ++" Doc -> Doc -> Doc
<> String -> Doc
text (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
ns) Doc -> Doc -> Doc
<> Doc
"yy_mylinenumber;"
    ]
  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)