{-# LANGUAGE LambdaCase #-}
module BNFC.Backend.Java.CFtoAntlr4Parser ( cf2AntlrParse ) where
import Data.Foldable ( toList )
import Data.List ( intercalate )
import Data.Maybe
import BNFC.CF
import BNFC.Options ( RecordPositions(..) )
import BNFC.Utils ( (+++), (+.+), applyWhen )
import BNFC.Backend.Java.Utils
import BNFC.Backend.Common.NamedVariables
data PDef = PDef
{ PDef -> Maybe Fun
_pdNT :: Maybe String
, PDef -> Cat
_pdCat :: Cat
, PDef -> [(Fun, Fun, Maybe Fun)]
_pdAlts :: [(Pattern, Action, Maybe Fun)]
}
type Rules = [PDef]
type Pattern = String
type Action = String
type MetaVar = (String, Cat)
cf2AntlrParse :: String -> String -> CF -> RecordPositions -> KeywordEnv -> String
cf2AntlrParse :: Fun -> Fun -> CF -> RecordPositions -> KeywordEnv -> Fun
cf2AntlrParse Fun
packageBase Fun
packageAbsyn CF
cf RecordPositions
_ KeywordEnv
env = [Fun] -> Fun
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ Fun
header
, Fun
tokens
, Fun
""
, Fun -> Rules -> Fun
prRules Fun
packageAbsyn forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Cat -> PDef
entrypoint forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> List1 Cat
allEntryPoints CF
cf
, Fun -> Rules -> Fun
prRules Fun
packageAbsyn forall a b. (a -> b) -> a -> b
$ Fun -> CF -> KeywordEnv -> Rules
rulesForAntlr4 Fun
packageAbsyn CF
cf KeywordEnv
env
]
]
where
header :: String
header :: Fun
header = [Fun] -> Fun
unlines
[ Fun
"// Parser definition for use with ANTLRv4"
, Fun
"parser grammar" Fun -> Fun -> Fun
+++ Fun
identifier forall a. [a] -> [a] -> [a]
++ Fun
"Parser;"
]
tokens :: String
tokens :: Fun
tokens = [Fun] -> Fun
unlines
[ Fun
"options {"
, Fun
" tokenVocab = "forall a. [a] -> [a] -> [a]
++Fun
identifierforall a. [a] -> [a] -> [a]
++Fun
"Lexer;"
, Fun
"}"
]
identifier :: Fun
identifier = Fun -> Fun
getLastInPackage Fun
packageBase
entrypoint :: Cat -> PDef
entrypoint :: Cat -> PDef
entrypoint Cat
cat =
Maybe Fun -> Cat -> [(Fun, Fun, Maybe Fun)] -> PDef
PDef (forall a. a -> Maybe a
Just Fun
nt) Cat
cat [(Fun
pat, Fun
act, forall {a}. Maybe a
fun)]
where
nt :: Fun
nt = Fun -> Fun
firstLowerCase forall a b. (a -> b) -> a -> b
$ Fun -> Fun
startSymbol forall a b. (a -> b) -> a -> b
$ Cat -> Fun
identCat Cat
cat
pat :: Fun
pat = Fun
"x=" forall a. [a] -> [a] -> [a]
++ Cat -> Fun
catToNT Cat
cat Fun -> Fun -> Fun
+++ Fun
"EOF"
act :: Fun
act = Fun
"$result = $x.result;"
fun :: Maybe a
fun = forall {a}. Maybe a
Nothing
rulesForAntlr4 :: String -> CF -> KeywordEnv -> Rules
rulesForAntlr4 :: Fun -> CF -> KeywordEnv -> Rules
rulesForAntlr4 Fun
packageAbsyn CF
cf KeywordEnv
env = forall a b. (a -> b) -> [a] -> [b]
map (Cat, [Rule]) -> PDef
mkOne [(Cat, [Rule])]
getrules
where
getrules :: [(Cat, [Rule])]
getrules = CF -> [(Cat, [Rule])]
ruleGroups CF
cf
mkOne :: (Cat, [Rule]) -> PDef
mkOne (Cat
cat,[Rule]
rules) = Fun -> CF -> KeywordEnv -> [Rule] -> Cat -> PDef
constructRule Fun
packageAbsyn CF
cf KeywordEnv
env [Rule]
rules Cat
cat
constructRule :: String -> CF -> KeywordEnv -> [Rule] -> NonTerminal -> PDef
constructRule :: Fun -> CF -> KeywordEnv -> [Rule] -> Cat -> PDef
constructRule Fun
packageAbsyn CF
cf KeywordEnv
env [Rule]
rules Cat
nt =
Maybe Fun -> Cat -> [(Fun, Fun, Maybe Fun)] -> PDef
PDef forall {a}. Maybe a
Nothing Cat
nt forall a b. (a -> b) -> a -> b
$
[ ( Fun
p
, forall f. IsFun f => Fun -> Cat -> f -> [MetaVar] -> Bool -> Fun
generateAction Fun
packageAbsyn Cat
nt (forall function. Rul function -> function
funRule Rule
r) [MetaVar]
m Bool
b
, forall {a}. Maybe a
Nothing
)
| (Int
index, Rule
r0) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Rule]
rules
, let b :: Bool
b = forall a. IsFun a => a -> Bool
isConsFun (forall function. Rul function -> function
funRule Rule
r0) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (forall fun. Rul fun -> Cat
valCat Rule
r0) (forall function. CFG function -> [Cat]
cfgReversibleCats CF
cf)
, let r :: Rule
r = forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b forall f. Rul f -> Rul f
revSepListRule Rule
r0
, let (Fun
p,[MetaVar]
m0) = Int -> KeywordEnv -> Rule -> (Fun, [MetaVar])
generatePatterns Int
index KeywordEnv
env Rule
r
, let m :: [MetaVar]
m = forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b forall a. [a] -> [a]
reverse [MetaVar]
m0
]
generateAction :: IsFun f => String -> NonTerminal -> f -> [MetaVar]
-> Bool
-> Action
generateAction :: forall f. IsFun f => Fun -> Cat -> f -> [MetaVar] -> Bool -> Fun
generateAction Fun
packageAbsyn Cat
nt f
f [MetaVar]
ms Bool
rev
| forall a. IsFun a => a -> Bool
isNilFun f
f = Fun
"$result = new " forall a. [a] -> [a] -> [a]
++ Fun
c forall a. [a] -> [a] -> [a]
++ Fun
"();"
| forall a. IsFun a => a -> Bool
isOneFun f
f = Fun
"$result = new " forall a. [a] -> [a] -> [a]
++ Fun
c forall a. [a] -> [a] -> [a]
++ Fun
"(); $result.addLast("
forall a. [a] -> [a] -> [a]
++ Fun
p_1 forall a. [a] -> [a] -> [a]
++ Fun
");"
| forall a. IsFun a => a -> Bool
isConsFun f
f = Fun
"$result = " forall a. [a] -> [a] -> [a]
++ Fun
p_2 forall a. [a] -> [a] -> [a]
++ Fun
"; "
forall a. [a] -> [a] -> [a]
++ Fun
"$result." forall a. [a] -> [a] -> [a]
++ Fun
add forall a. [a] -> [a] -> [a]
++ Fun
"(" forall a. [a] -> [a] -> [a]
++ Fun
p_1 forall a. [a] -> [a] -> [a]
++ Fun
");"
| forall a. IsFun a => a -> Bool
isCoercion f
f = Fun
"$result = " forall a. [a] -> [a] -> [a]
++ Fun
p_1 forall a. [a] -> [a] -> [a]
++ Fun
";"
| forall a. IsFun a => a -> Bool
isDefinedRule f
f = Fun
"$result = " forall a. [a] -> [a] -> [a]
++ Fun
packageAbsyn forall a. [a] -> [a] -> [a]
++ Fun
"Def." forall a. [a] -> [a] -> [a]
++ Fun -> Fun
sanitize (forall a. IsFun a => a -> Fun
funName f
f)
forall a. [a] -> [a] -> [a]
++ Fun
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate Fun
"," (forall a b. (a -> b) -> [a] -> [b]
map MetaVar -> Fun
resultvalue [MetaVar]
ms) forall a. [a] -> [a] -> [a]
++ Fun
");"
| Bool
otherwise = Fun
"$result = new " forall a. [a] -> [a] -> [a]
++ Fun
c
forall a. [a] -> [a] -> [a]
++ Fun
"(" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate Fun
"," (forall a b. (a -> b) -> [a] -> [b]
map MetaVar -> Fun
resultvalue [MetaVar]
ms) forall a. [a] -> [a] -> [a]
++ Fun
");"
where
sanitize :: Fun -> Fun
sanitize = Fun -> Fun
getRuleName
c :: Fun
c = Fun
packageAbsyn forall a. [a] -> [a] -> [a]
++ Fun
"." forall a. [a] -> [a] -> [a]
++
if forall a. IsFun a => a -> Bool
isNilFun f
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isOneFun f
f Bool -> Bool -> Bool
|| forall a. IsFun a => a -> Bool
isConsFun f
f
then Cat -> Fun
identCat (Cat -> Cat
normCat Cat
nt) else forall a. IsFun a => a -> Fun
funName f
f
p_1 :: Fun
p_1 = MetaVar -> Fun
resultvalue forall a b. (a -> b) -> a -> b
$ [MetaVar]
msforall a. [a] -> Int -> a
!!Int
0
p_2 :: Fun
p_2 = MetaVar -> Fun
resultvalue forall a b. (a -> b) -> a -> b
$ [MetaVar]
msforall a. [a] -> Int -> a
!!Int
1
add :: Fun
add = if Bool
rev then Fun
"addLast" else Fun
"addFirst"
gettext :: Fun
gettext = Fun
"getText()"
removeQuotes :: Fun -> Fun
removeQuotes Fun
x = Fun
"substring(1, "forall a. [a] -> [a] -> [a]
++ Fun
x Fun -> Fun -> Fun
+.+ Fun
gettext Fun -> Fun -> Fun
+.+ Fun
"length()-1)"
parseint :: Fun -> Fun
parseint Fun
x = Fun
"Integer.parseInt("forall a. [a] -> [a] -> [a]
++Fun
xforall a. [a] -> [a] -> [a]
++Fun
")"
parsedouble :: Fun -> Fun
parsedouble Fun
x = Fun
"Double.parseDouble("forall a. [a] -> [a] -> [a]
++Fun
xforall a. [a] -> [a] -> [a]
++Fun
")"
charat :: Fun
charat = Fun
"charAt(1)"
resultvalue :: MetaVar -> Fun
resultvalue (Fun
n,Cat
c) = case Cat
c of
TokenCat Fun
"Ident" -> Fun
n'Fun -> Fun -> Fun
+.+Fun
gettext
TokenCat Fun
"Integer" -> Fun -> Fun
parseint forall a b. (a -> b) -> a -> b
$ Fun
n'Fun -> Fun -> Fun
+.+Fun
gettext
TokenCat Fun
"Char" -> Fun
n'Fun -> Fun -> Fun
+.+Fun
gettextFun -> Fun -> Fun
+.+Fun
charat
TokenCat Fun
"Double" -> Fun -> Fun
parsedouble forall a b. (a -> b) -> a -> b
$ Fun
n'Fun -> Fun -> Fun
+.+Fun
gettext
TokenCat Fun
"String" -> Fun
n'Fun -> Fun -> Fun
+.+Fun
gettextFun -> Fun -> Fun
+.+Fun -> Fun
removeQuotes Fun
n'
Cat
_ -> Fun -> Fun -> Fun
(+.+) Fun
n' (if Cat -> Bool
isTokenCat Cat
c then Fun
gettext else Fun
"result")
where n' :: Fun
n' = Char
'$'forall a. a -> [a] -> [a]
:Fun
n
generatePatterns :: Int -> KeywordEnv -> Rule -> (Pattern,[MetaVar])
generatePatterns :: Int -> KeywordEnv -> Rule -> (Fun, [MetaVar])
generatePatterns Int
ind KeywordEnv
env Rule
r =
case forall function. Rul function -> SentForm
rhsRule Rule
r of
[] -> (Fun
" /* empty */ ", [])
SentForm
its -> ( [Fun] -> Fun
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall {a}. Show a => a -> Either Cat Fun -> Maybe Fun
mkIt) [(Int, Either Cat Fun)]
nits
, [ (forall {a}. Show a => a -> Fun
var Int
i, Cat
cat) | (Int
i, Left Cat
cat) <- [(Int, Either Cat Fun)]
nits ]
)
where
nits :: [(Int, Either Cat Fun)]
nits = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] SentForm
its
var :: a -> Fun
var a
i = Fun
"p_" forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> Fun
show Int
ind forall a. [a] -> [a] -> [a]
++Fun
"_"forall a. [a] -> [a] -> [a]
++ forall {a}. Show a => a -> Fun
show a
i
mkIt :: a -> Either Cat Fun -> Maybe Fun
mkIt a
i = \case
Left Cat
c -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => a -> Fun
var a
i forall a. [a] -> [a] -> [a]
++ Fun
"=" forall a. [a] -> [a] -> [a]
++ Cat -> Fun
catToNT Cat
c
Right Fun
s -> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Fun
s KeywordEnv
env
catToNT :: Cat -> String
catToNT :: Cat -> Fun
catToNT = \case
TokenCat Fun
"Ident" -> Fun
"IDENT"
TokenCat Fun
"Integer" -> Fun
"INTEGER"
TokenCat Fun
"Char" -> Fun
"CHAR"
TokenCat Fun
"Double" -> Fun
"DOUBLE"
TokenCat Fun
"String" -> Fun
"STRING"
Cat
c | Cat -> Bool
isTokenCat Cat
c -> Cat -> Fun
identCat Cat
c
| Bool
otherwise -> Fun -> Fun
firstLowerCase forall a b. (a -> b) -> a -> b
$ Fun -> Fun
getRuleName forall a b. (a -> b) -> a -> b
$ Cat -> Fun
identCat Cat
c
prRules :: String -> Rules -> String
prRules :: Fun -> Rules -> Fun
prRules Fun
packabs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a -> b) -> a -> b
$ \case
PDef Maybe Fun
_mlhs Cat
_nt [] -> Fun
""
PDef Maybe Fun
mlhs Cat
nt ((Fun, Fun, Maybe Fun)
rhs : [(Fun, Fun, Maybe Fun)]
rhss) -> [Fun] -> Fun
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ [Fun] -> Fun
unwords [ forall a. a -> Maybe a -> a
fromMaybe Fun
nt' Maybe Fun
mlhs
, Fun
"returns" , Fun
"[" , Fun
packabsFun -> Fun -> Fun
+.+Fun
normcat , Fun
"result" , Fun
"]"
]
]
, Fun -> (Fun, Fun, Maybe Fun) -> [Fun]
alternative Fun
" :" (Fun, Fun, Maybe Fun)
rhs
, forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Fun -> (Fun, Fun, Maybe Fun) -> [Fun]
alternative Fun
" |") [(Fun, Fun, Maybe Fun)]
rhss
, [ Fun
" ;" ]
]
where
alternative :: Fun -> (Fun, Fun, Maybe Fun) -> [Fun]
alternative Fun
sep (Fun
p, Fun
a, Maybe Fun
label) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ [Fun] -> Fun
unwords [ Fun
sep , Fun
p ] ]
, [ [Fun] -> Fun
unwords [ Fun
" {" , Fun
a , Fun
"}" ] ]
, [ [Fun] -> Fun
unwords [ Fun
" #" , Fun -> Fun
antlrRuleLabel Fun
l ] | Just Fun
l <- [Maybe Fun
label] ]
]
catid :: Fun
catid = Cat -> Fun
identCat Cat
nt
normcat :: Fun
normcat = Cat -> Fun
identCat (Cat -> Cat
normCat Cat
nt)
nt' :: Fun
nt' = Fun -> Fun
getRuleName forall a b. (a -> b) -> a -> b
$ Fun -> Fun
firstLowerCase Fun
catid
antlrRuleLabel :: Fun -> String
antlrRuleLabel :: Fun -> Fun
antlrRuleLabel Fun
fnc
| forall a. IsFun a => a -> Bool
isNilFun Fun
fnc = Fun
catid forall a. [a] -> [a] -> [a]
++ Fun
"_Empty"
| forall a. IsFun a => a -> Bool
isOneFun Fun
fnc = Fun
catid forall a. [a] -> [a] -> [a]
++ Fun
"_AppendLast"
| forall a. IsFun a => a -> Bool
isConsFun Fun
fnc = Fun
catid forall a. [a] -> [a] -> [a]
++ Fun
"_PrependFirst"
| forall a. IsFun a => a -> Bool
isCoercion Fun
fnc = Fun
"Coercion_" forall a. [a] -> [a] -> [a]
++ Fun
catid
| Bool
otherwise = Fun -> Fun
getLabelName Fun
fnc