{-# 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
lang Fun
packageAbsyn CF
cf RecordPositions
_ KeywordEnv
env = [Fun] -> Fun
unlines ([Fun] -> Fun) -> [Fun] -> Fun
forall a b. (a -> b) -> a -> b
$ [[Fun]] -> [Fun]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ Fun
header
, Fun
tokens
, Fun
""
, Fun -> Rules -> Fun
prRules Fun
packageAbsyn (Rules -> Fun) -> Rules -> Fun
forall a b. (a -> b) -> a -> b
$ (Cat -> PDef) -> [Cat] -> Rules
forall a b. (a -> b) -> [a] -> [b]
map Cat -> PDef
entrypoint ([Cat] -> Rules) -> [Cat] -> Rules
forall a b. (a -> b) -> a -> b
$ NonEmpty Cat -> [Cat]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (NonEmpty Cat -> [Cat]) -> NonEmpty Cat -> [Cat]
forall a b. (a -> b) -> a -> b
$ CF -> NonEmpty Cat
forall f. CFG f -> NonEmpty Cat
allEntryPoints CF
cf
, Fun -> Rules -> Fun
prRules Fun
packageAbsyn (Rules -> Fun) -> Rules -> Fun
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
lang Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"Parser;"
]
tokens :: String
tokens :: Fun
tokens = [Fun] -> Fun
unlines
[ Fun
"options {"
, Fun
" tokenVocab = " Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
lang Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"Lexer;"
, Fun
"}"
]
entrypoint :: Cat -> PDef
entrypoint :: Cat -> PDef
entrypoint Cat
cat =
Maybe Fun -> Cat -> [(Fun, Fun, Maybe Fun)] -> PDef
PDef (Fun -> Maybe Fun
forall a. a -> Maybe a
Just Fun
nt) Cat
cat [(Fun
pat, Fun
act, Maybe Fun
forall {a}. Maybe a
fun)]
where
nt :: Fun
nt = Fun -> Fun
firstLowerCase (Fun -> Fun) -> Fun -> Fun
forall a b. (a -> b) -> a -> b
$ Fun -> Fun
startSymbol (Fun -> Fun) -> Fun -> Fun
forall a b. (a -> b) -> a -> b
$ Cat -> Fun
identCat Cat
cat
pat :: Fun
pat = Fun
"x=" Fun -> Fun -> Fun
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 = Maybe a
forall {a}. Maybe a
Nothing
rulesForAntlr4 :: String -> CF -> KeywordEnv -> Rules
rulesForAntlr4 :: Fun -> CF -> KeywordEnv -> Rules
rulesForAntlr4 Fun
packageAbsyn CF
cf KeywordEnv
env = ((Cat, [Rule]) -> PDef) -> [(Cat, [Rule])] -> Rules
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 Maybe Fun
forall {a}. Maybe a
Nothing Cat
nt ([(Fun, Fun, Maybe Fun)] -> PDef)
-> [(Fun, Fun, Maybe Fun)] -> PDef
forall a b. (a -> b) -> a -> b
$
[ ( Fun
p
, Fun -> Cat -> RFun -> [MetaVar] -> Bool -> Fun
forall f. IsFun f => Fun -> Cat -> f -> [MetaVar] -> Bool -> Fun
generateAction Fun
packageAbsyn Cat
nt (Rule -> RFun
forall function. Rul function -> function
funRule Rule
r) [MetaVar]
m Bool
b
, Maybe Fun
forall {a}. Maybe a
Nothing
)
| (Int
index, Rule
r0) <- [Int] -> [Rule] -> [(Int, Rule)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [Rule]
rules
, let b :: Bool
b = RFun -> Bool
forall a. IsFun a => a -> Bool
isConsFun (Rule -> RFun
forall function. Rul function -> function
funRule Rule
r0) Bool -> Bool -> Bool
&& Cat -> [Cat] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Rule -> Cat
forall fun. Rul fun -> Cat
valCat Rule
r0) (CF -> [Cat]
forall function. CFG function -> [Cat]
cfgReversibleCats CF
cf)
, let r :: Rule
r = Bool -> (Rule -> Rule) -> Rule -> Rule
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b Rule -> Rule
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 = Bool -> ([MetaVar] -> [MetaVar]) -> [MetaVar] -> [MetaVar]
forall a. Bool -> (a -> a) -> a -> a
applyWhen Bool
b [MetaVar] -> [MetaVar]
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
| f -> Bool
forall a. IsFun a => a -> Bool
isNilFun f
f = Fun
"$result = new " Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
c Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"();"
| f -> Bool
forall a. IsFun a => a -> Bool
isOneFun f
f = Fun
"$result = new " Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
c Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"(); $result.addLast("
Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
p_1 Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
");"
| f -> Bool
forall a. IsFun a => a -> Bool
isConsFun f
f = Fun
"$result = " Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
p_2 Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"; "
Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"$result." Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
add Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"(" Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
p_1 Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
");"
| f -> Bool
forall a. IsFun a => a -> Bool
isCoercion f
f = Fun
"$result = " Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
p_1 Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
";"
| f -> Bool
forall a. IsFun a => a -> Bool
isDefinedRule f
f = Fun
"$result = " Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
packageAbsyn Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"Def." Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun -> Fun
sanitize (f -> Fun
forall a. IsFun a => a -> Fun
funName f
f)
Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"(" Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun -> [Fun] -> Fun
forall a. [a] -> [[a]] -> [a]
intercalate Fun
"," ((MetaVar -> Fun) -> [MetaVar] -> [Fun]
forall a b. (a -> b) -> [a] -> [b]
map MetaVar -> Fun
resultvalue [MetaVar]
ms) Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
");"
| Bool
otherwise = Fun
"$result = new " Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
c
Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"(" Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun -> [Fun] -> Fun
forall a. [a] -> [[a]] -> [a]
intercalate Fun
"," ((MetaVar -> Fun) -> [MetaVar] -> [Fun]
forall a b. (a -> b) -> [a] -> [b]
map MetaVar -> Fun
resultvalue [MetaVar]
ms) Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
");"
where
sanitize :: Fun -> Fun
sanitize = Fun -> Fun
getRuleName
c :: Fun
c = Fun
packageAbsyn Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"." Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++
if f -> Bool
forall a. IsFun a => a -> Bool
isNilFun f
f Bool -> Bool -> Bool
|| f -> Bool
forall a. IsFun a => a -> Bool
isOneFun f
f Bool -> Bool -> Bool
|| f -> Bool
forall a. IsFun a => a -> Bool
isConsFun f
f
then Cat -> Fun
identCat (Cat -> Cat
normCat Cat
nt) else f -> Fun
forall a. IsFun a => a -> Fun
funName f
f
p_1 :: Fun
p_1 = MetaVar -> Fun
resultvalue (MetaVar -> Fun) -> MetaVar -> Fun
forall a b. (a -> b) -> a -> b
$ [MetaVar]
ms[MetaVar] -> Int -> MetaVar
forall a. HasCallStack => [a] -> Int -> a
!!Int
0
p_2 :: Fun
p_2 = MetaVar -> Fun
resultvalue (MetaVar -> Fun) -> MetaVar -> Fun
forall a b. (a -> b) -> a -> b
$ [MetaVar]
ms[MetaVar] -> Int -> MetaVar
forall a. HasCallStack => [a] -> Int -> a
!!Int
1
add :: Fun
add = if Bool
rev then Fun
"addLast" else Fun
"addFirst"
removeQuotes :: Fun -> Fun
removeQuotes Fun
x = Fun
x Fun -> Fun -> Fun
+.+ Fun
"substring(1, " Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
x Fun -> Fun -> Fun
+.+ Fun
"length()-1)"
unescape :: Fun -> Fun
unescape Fun
x = Fun -> Fun
removeQuotes Fun
x Fun -> Fun -> Fun
+.+ Fun
"translateEscapes()"
resultvalue :: MetaVar -> Fun
resultvalue (Fun
n,Cat
c) = case Cat
c of
TokenCat Fun
"Double" -> [Fun] -> Fun
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Fun
"Double.parseDouble(", Fun
txt, Fun
")" ]
TokenCat Fun
"Integer" -> [Fun] -> Fun
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Fun
"Integer.parseInt(" , Fun
txt, Fun
")" ]
TokenCat Fun
"Char" -> Fun -> Fun
unescape Fun
txt Fun -> Fun -> Fun
+.+ Fun
"charAt(0)"
TokenCat Fun
"String" -> Fun -> Fun
unescape Fun
txt
TokenCat Fun
"Ident" -> Fun
txt
Cat
c | Cat -> Bool
isTokenCat Cat
c -> Fun
txt
| Bool
otherwise -> [Fun] -> Fun
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Fun
"$", Fun
n, Fun
".result" ]
where txt :: Fun
txt = Char
'$'Char -> Fun -> Fun
forall a. a -> [a] -> [a]
:Fun
n Fun -> Fun -> Fun
+.+ Fun
"getText()"
generatePatterns :: Int -> KeywordEnv -> Rule -> (Pattern,[MetaVar])
generatePatterns :: Int -> KeywordEnv -> Rule -> (Fun, [MetaVar])
generatePatterns Int
ind KeywordEnv
env Rule
r =
case Rule -> SentForm
forall function. Rul function -> SentForm
rhsRule Rule
r of
[] -> (Fun
" /* empty */ ", [])
SentForm
its -> ( [Fun] -> Fun
unwords ([Fun] -> Fun) -> [Fun] -> Fun
forall a b. (a -> b) -> a -> b
$ ((Int, Either Cat Fun) -> Maybe Fun)
-> [(Int, Either Cat Fun)] -> [Fun]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Int -> Either Cat Fun -> Maybe Fun)
-> (Int, Either Cat Fun) -> Maybe Fun
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Either Cat Fun -> Maybe Fun
forall {a}. Show a => a -> Either Cat Fun -> Maybe Fun
mkIt) [(Int, Either Cat Fun)]
nits
, [ (Int -> Fun
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 = [Int] -> SentForm -> [(Int, Either Cat Fun)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 :: Int ..] SentForm
its
var :: a -> Fun
var a
i = Fun
"p_" Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Int -> Fun
forall {a}. Show a => a -> Fun
show Int
ind Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++Fun
"_"Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ a -> Fun
forall {a}. Show a => a -> Fun
show a
i
mkIt :: a -> Either Cat Fun -> Maybe Fun
mkIt a
i = \case
Left Cat
c -> Fun -> Maybe Fun
forall a. a -> Maybe a
Just (Fun -> Maybe Fun) -> Fun -> Maybe Fun
forall a b. (a -> b) -> a -> b
$ a -> Fun
forall {a}. Show a => a -> Fun
var a
i Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"=" Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Cat -> Fun
catToNT Cat
c
Right Fun
s -> Fun -> KeywordEnv -> Maybe Fun
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 (Fun -> Fun) -> Fun -> Fun
forall a b. (a -> b) -> a -> b
$ Fun -> Fun
getRuleName (Fun -> Fun) -> Fun -> Fun
forall a b. (a -> b) -> a -> b
$ Cat -> Fun
identCat Cat
c
prRules :: String -> Rules -> String
prRules :: Fun -> Rules -> Fun
prRules Fun
packabs = (PDef -> Fun) -> Rules -> Fun
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((PDef -> Fun) -> Rules -> Fun) -> (PDef -> Fun) -> Rules -> Fun
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 ([Fun] -> Fun) -> [Fun] -> Fun
forall a b. (a -> b) -> a -> b
$ [[Fun]] -> [Fun]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ [Fun] -> Fun
unwords [ Fun -> Maybe Fun -> Fun
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
, ((Fun, Fun, Maybe Fun) -> [Fun])
-> [(Fun, Fun, Maybe Fun)] -> [Fun]
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) = [[Fun]] -> [Fun]
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 (Fun -> Fun) -> Fun -> Fun
forall a b. (a -> b) -> a -> b
$ Fun -> Fun
firstLowerCase Fun
catid
antlrRuleLabel :: Fun -> String
antlrRuleLabel :: Fun -> Fun
antlrRuleLabel Fun
fnc
| Fun -> Bool
forall a. IsFun a => a -> Bool
isNilFun Fun
fnc = Fun
catid Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"_Empty"
| Fun -> Bool
forall a. IsFun a => a -> Bool
isOneFun Fun
fnc = Fun
catid Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"_AppendLast"
| Fun -> Bool
forall a. IsFun a => a -> Bool
isConsFun Fun
fnc = Fun
catid Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
"_PrependFirst"
| Fun -> Bool
forall a. IsFun a => a -> Bool
isCoercion Fun
fnc = Fun
"Coercion_" Fun -> Fun -> Fun
forall a. [a] -> [a] -> [a]
++ Fun
catid
| Bool
otherwise = Fun -> Fun
getLabelName Fun
fnc