{-# LANGUAGE LambdaCase #-}

module BNFC.Backend.Java.RegToJLex (printRegJLex, escapeChar) where

import Data.Char           (ord, showLitChar)

import BNFC.Abs            (Identifier(..), Reg(..))
import BNFC.Options        (JavaLexerParser(..))
import BNFC.Backend.Common (flexEps)

-- | Print a regular expression for the Java lexers.

printRegJLex :: JavaLexerParser -> Reg -> String
printRegJLex :: JavaLexerParser -> Reg -> String
printRegJLex JavaLexerParser
lexer Reg
reg = JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
0 Reg
reg String
""

class Print a where
  prt     :: JavaLexerParser -> Int -> a -> ShowS
  prtList :: JavaLexerParser -> [a] -> ShowS
  prtList JavaLexerParser
lexer [a]
xs String
s = (a -> ShowS) -> String -> [a] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (JavaLexerParser -> Int -> a -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
0) String
s [a]
xs
  -- OR: prtList lexer = foldr (.) id . map (prt lexer 0)

instance Print a => Print [a] where
  prt :: JavaLexerParser -> Int -> [a] -> ShowS
prt JavaLexerParser
lexer Int
_ = JavaLexerParser -> [a] -> ShowS
forall a. Print a => JavaLexerParser -> [a] -> ShowS
prtList JavaLexerParser
lexer

instance Print Char where
  prt :: JavaLexerParser -> Int -> Char -> ShowS
prt JavaLexerParser
lexer Int
_ Char
c = String -> ShowS
showString (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ JavaLexerParser -> Char -> String
escapeChar JavaLexerParser
lexer Char
c

escapeChar :: JavaLexerParser -> Char -> String
escapeChar :: JavaLexerParser -> Char -> String
escapeChar JavaLexerParser
_ Char
'^' = String
"\\x5E" -- special case, since \^ is a control character escape
escapeChar JavaLexerParser
JFlexCup Char
x | Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
jflexReserved = Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char
x]
escapeChar JavaLexerParser
_ Char
x
  | Char
x Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
jlexReserved = Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: [Char
x]
  | Char -> Int
ord Char
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
255          = [Char
x]
  | Bool
otherwise             = Char -> ShowS
showLitChar Char
x String
""

-- Characters that must be escaped in JLex regular expressions
jlexReserved :: [Char]
jlexReserved :: String
jlexReserved = [Char
'?',Char
'*',Char
'+',Char
'|',Char
'(',Char
')',Char
'^',Char
'$',Char
'.',Char
'[',Char
']',Char
'{',Char
'}',Char
'"',Char
'\\']

jflexReserved :: [Char]
jflexReserved :: String
jflexReserved = Char
'~'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'!'Char -> ShowS
forall a. a -> [a] -> [a]
:Char
'/'Char -> ShowS
forall a. a -> [a] -> [a]
:[]  -- plus the @jlexReserved@, but they are tested separately

instance Print Identifier where
  prt :: JavaLexerParser -> Int -> Identifier -> ShowS
prt JavaLexerParser
_ Int
_ (Identifier ((Int, Int)
_, String
x)) = String -> ShowS
showString String
x

instance Print Reg where
  prt :: JavaLexerParser -> Int -> Reg -> ShowS
prt JavaLexerParser
lexer Int
i = \case
    RSeq Reg
reg1 Reg
reg2          -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
2 Reg
reg1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
3 Reg
reg2
    RAlt Reg
reg1 Reg
reg2          -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
1 Reg
reg1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'|' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
2 Reg
reg2

    -- JLex does not support set difference in general
    RMinus Reg
reg0 Reg
REps        -> JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
i Reg
reg0 -- REps is identity for set difference
    RMinus Reg
RAny reg :: Reg
reg@RChar{} -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"[^" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
0 Reg
reg ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"]"
    RMinus Reg
RAny (RAlts String
str) -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"[^" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JavaLexerParser -> Int -> String -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
0 String
str ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"]"
    -- FIXME: maybe we could add cases for char - RDigit, RLetter etc.
    RMinus Reg
_ Reg
_              -> String -> ShowS
forall a. HasCallStack => String -> a
error (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$ String
"J[F]Lex does not support general set difference"

    RStar Reg
reg               -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
3 Reg
reg ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'*'
    RPlus Reg
reg               -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
3 Reg
reg ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'+'
    ROpt Reg
reg                -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ JavaLexerParser -> Int -> Reg -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
3 Reg
reg ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'?'
    Reg
REps                    -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
flexEps
    RChar Char
c                 -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ JavaLexerParser -> Int -> Char -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
0 Char
c
    RAlts String
str               -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Char -> ShowS
showChar Char
'[' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JavaLexerParser -> Int -> String -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
0 String
str ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
']'
    RSeqs String
str               -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ JavaLexerParser -> Int -> String -> ShowS
forall a. Print a => JavaLexerParser -> Int -> a -> ShowS
prt JavaLexerParser
lexer Int
0 String
str
    Reg
RDigit                  -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"{DIGIT}"
    Reg
RLetter                 -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"{LETTER}"
    Reg
RUpper                  -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"{CAPITAL}"
    Reg
RLower                  -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"{SMALL}"
    Reg
RAny                    -> Bool -> ShowS -> ShowS
showParen (Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Char -> ShowS
showChar Char
'.'