{-# LANGUAGE LambdaCase #-}
module BNFC.Backend.OCaml.CFtoOCamlYacc
(
cf2ocamlyacc, terminal, epName
)
where
import Data.Foldable ( toList )
import Data.List ( intercalate )
import BNFC.CF
import BNFC.Options ( OCamlParser(..) )
import BNFC.Utils ( (+++), capitalize, table )
import BNFC.Backend.Common
import BNFC.Backend.OCaml.OCamlUtil
type Pattern = String
type Action = String
type MetaVar = String
cf2ocamlyacc :: OCamlParser -> String -> CF -> String
cf2ocamlyacc :: OCamlParser -> TokenCat -> CF -> TokenCat
cf2ocamlyacc OCamlParser
ocamlParser TokenCat
absName CF
cf = [TokenCat] -> TokenCat
unlines
[ OCamlParser -> TokenCat -> TokenCat
header OCamlParser
ocamlParser TokenCat
absName
, TokenCat -> CF -> TokenCat
declarations TokenCat
absName CF
cf
, TokenCat
"%%"
, TokenCat
""
, OCamlParser -> CF -> TokenCat
rules OCamlParser
ocamlParser CF
cf
]
header :: OCamlParser -> String -> String
OCamlParser
ocamlParser TokenCat
absName = [TokenCat] -> TokenCat
unlines
[ [TokenCat] -> TokenCat
unwords [ TokenCat
"/* Parser definition for use with", forall a. OCamlParserName a => a -> TokenCat
ocamlParserName OCamlParser
ocamlParser, TokenCat
"*/" ]
, TokenCat
""
, TokenCat
"%{"
, TokenCat
"open " forall a. [a] -> [a] -> [a]
++ TokenCat
absName
, TokenCat
"open Lexing"
, TokenCat
"%}"
]
declarations :: String -> CF -> String
declarations :: TokenCat -> CF -> TokenCat
declarations TokenCat
absName CF
cf =
[TokenCat] -> TokenCat
unlines forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate [TokenCat
""]
[ [TokenCat] -> [TokenCat] -> [TokenCat]
tokens (CF -> [TokenCat]
unicodeAndSymbols CF
cf) (CF -> [TokenCat]
asciiKeywords CF
cf)
, CF -> [TokenCat]
specialTokens CF
cf
, TokenCat -> CF -> [TokenCat]
entryPoints TokenCat
absName CF
cf
, forall a b. (a -> b) -> [a] -> [b]
map (Cat -> TokenCat
catTyping forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rule])]
ruleGroups CF
cf
, forall a b. (a -> b) -> [a] -> [b]
map (Cat -> TokenCat
catTyping forall b c a. (b -> c) -> (a -> b) -> a -> c
. TokenCat -> Cat
TokenCat) forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> [TokenCat]
literals CF
cf
]
where
catTyping :: Cat -> TokenCat
catTyping Cat
c = TokenCat -> Cat -> TokenCat -> TokenCat
typing TokenCat
absName Cat
c (Cat -> TokenCat
nonterminal Cat
c)
tokens :: [String] -> [String] -> [String]
tokens :: [TokenCat] -> [TokenCat] -> [TokenCat]
tokens [TokenCat]
symbols [TokenCat]
reswords =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ [TokenCat] -> TokenCat
unwords forall a b. (a -> b) -> a -> b
$ TokenCat
"%token" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (TokenCat
"KW_" forall a. [a] -> [a] -> [a]
++) [TokenCat]
reswords | Bool
hasReserved ]
, [ TokenCat
"" | Bool
hasReserved ]
, (forall a b. (a -> b) -> [a] -> [b]
`map` forall a b. [a] -> [b] -> [(a, b)]
zip [TokenCat]
symbols [Int
1::Int ..]) forall a b. (a -> b) -> a -> b
$ \ (TokenCat
s, Int
n) ->
TokenCat
"%token SYMB" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> TokenCat
show Int
n TokenCat -> TokenCat -> TokenCat
+++ TokenCat
"/*" TokenCat -> TokenCat -> TokenCat
+++ TokenCat
s TokenCat -> TokenCat -> TokenCat
+++ TokenCat
"*/"
]
where
hasReserved :: Bool
hasReserved = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TokenCat]
reswords
terminal :: CF -> String -> String
terminal :: CF -> TokenCat -> TokenCat
terminal CF
cf = \ TokenCat
s ->
if TokenCat
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TokenCat]
kws then TokenCat
"KW_" forall a. [a] -> [a] -> [a]
++ TokenCat
s
else case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup TokenCat
s (forall a b. [a] -> [b] -> [(a, b)]
zip (CF -> [TokenCat]
unicodeAndSymbols CF
cf) [Int
1::Int ..]) of
Just Int
i -> TokenCat
"SYMB" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> TokenCat
show Int
i
Maybe Int
Nothing -> forall a. HasCallStack => TokenCat -> a
error forall a b. (a -> b) -> a -> b
$ TokenCat
"CFtoOCamlYacc: terminal " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> TokenCat
show TokenCat
s forall a. [a] -> [a] -> [a]
++ TokenCat
" not defined in CF."
where
kws :: [TokenCat]
kws = CF -> [TokenCat]
asciiKeywords CF
cf
nonterminal :: Cat -> String
nonterminal :: Cat -> TokenCat
nonterminal Cat
c = forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
spaceToUnderscore (Cat -> TokenCat
fixType Cat
c)
where spaceToUnderscore :: Char -> Char
spaceToUnderscore Char
' ' = Char
'_'
spaceToUnderscore Char
x = Char
x
specialTokens :: CF -> [String]
specialTokens :: CF -> [TokenCat]
specialTokens CF
cf = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ [ TokenCat
"%token TOK_EOF" ]
, TokenCat -> [[TokenCat]] -> [TokenCat]
table TokenCat
" " [ TokenCat -> TokenCat -> [TokenCat]
prToken (TokenCat -> TokenCat
ty TokenCat
n) TokenCat
n | TokenCat
n <- [TokenCat]
specialCatsP ]
, TokenCat -> [[TokenCat]] -> [TokenCat]
table TokenCat
" " [ TokenCat -> TokenCat -> [TokenCat]
prToken (Bool -> TokenCat
posTy Bool
pos) TokenCat
n | TokenReg RFun
n0 Bool
pos Reg
_ <- forall function. CFG function -> [Pragma]
cfgPragmas CF
cf, let n :: TokenCat
n = forall a. WithPosition a -> a
wpThing RFun
n0 ]
]
where
prToken :: TokenCat -> TokenCat -> [TokenCat]
prToken TokenCat
t TokenCat
n = [ TokenCat
"%token" TokenCat -> TokenCat -> TokenCat
+++ TokenCat
t, TokenCat
"TOK_" forall a. [a] -> [a] -> [a]
++ TokenCat
n ]
ty :: TokenCat -> TokenCat
ty = \case
TokenCat
"Ident" -> TokenCat
"<string>"
TokenCat
"String" -> TokenCat
"<string>"
TokenCat
"Integer" -> TokenCat
"<int>"
TokenCat
"Double" -> TokenCat
"<float>"
TokenCat
"Char" -> TokenCat
"<char>"
TokenCat
_ -> forall a. HasCallStack => a
undefined
posTy :: Bool -> TokenCat
posTy = \case
Bool
True -> TokenCat
"<(int * int) * string>"
Bool
False -> TokenCat
"<string>"
entryPoints :: String -> CF -> [String]
entryPoints :: TokenCat -> CF -> [TokenCat]
entryPoints TokenCat
absName CF
cf =
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ [TokenCat] -> TokenCat
unwords forall a b. (a -> b) -> a -> b
$ TokenCat
"%start" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Cat -> TokenCat
epName [Cat]
eps ]
, forall a b. (a -> b) -> [a] -> [b]
map (\ Cat
c -> TokenCat -> Cat -> TokenCat -> TokenCat
typing TokenCat
absName Cat
c (Cat -> TokenCat
epName Cat
c)) [Cat]
eps
]
where
eps :: [Cat]
eps = 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
typing :: String -> Cat -> String -> String
typing :: TokenCat -> Cat -> TokenCat -> TokenCat
typing TokenCat
absName Cat
c TokenCat
s = TokenCat
"%type" TokenCat -> TokenCat -> TokenCat
+++ TokenCat
"<" forall a. [a] -> [a] -> [a]
++ Cat -> TokenCat
qualify (Cat -> Cat
normCat Cat
c) forall a. [a] -> [a] -> [a]
++ TokenCat
">" TokenCat -> TokenCat -> TokenCat
+++ TokenCat
s
where
qualify :: Cat -> TokenCat
qualify Cat
c = if Cat
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ TokenCat -> Cat
TokenCat TokenCat
"Integer", TokenCat -> Cat
TokenCat TokenCat
"Double", TokenCat -> Cat
TokenCat TokenCat
"Char",
TokenCat -> Cat
TokenCat TokenCat
"String", Cat -> Cat
ListCat (TokenCat -> Cat
TokenCat TokenCat
"Integer"),
Cat -> Cat
ListCat (TokenCat -> Cat
TokenCat TokenCat
"Double"),
Cat -> Cat
ListCat (TokenCat -> Cat
TokenCat TokenCat
"Char"),
Cat -> Cat
ListCat (TokenCat -> Cat
TokenCat TokenCat
"String") ]
then Cat -> TokenCat
fixType Cat
c
else TokenCat
absName forall a. [a] -> [a] -> [a]
++ TokenCat
"." forall a. [a] -> [a] -> [a]
++ Cat -> TokenCat
fixType Cat
c
epName :: Cat -> String
epName :: Cat -> TokenCat
epName Cat
c = TokenCat
"p" forall a. [a] -> [a] -> [a]
++ TokenCat -> TokenCat
capitalize (Cat -> TokenCat
nonterminal Cat
c)
entryPointRules :: OCamlParser -> CF -> [String]
entryPointRules :: OCamlParser -> CF -> [TokenCat]
entryPointRules OCamlParser
ocamlParser CF
cf =
forall a b. (a -> b) -> [a] -> [b]
map ([TokenCat] -> TokenCat
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> [TokenCat]
mkRule) 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
where
mkRule :: Cat -> [String]
mkRule :: Cat -> [TokenCat]
mkRule = case OCamlParser
ocamlParser of
OCamlParser
Menhir -> \ Cat
cat ->
[ Cat -> TokenCat
epRule Cat
cat forall a. [a] -> [a] -> [a]
++ TokenCat
";" ]
OCamlParser
OCamlYacc -> \ Cat
cat ->
[ Cat -> TokenCat
epRule Cat
cat
, TokenCat
" /* Delete this error clause to get a Parsing.Parse_error exception instead: */"
, TokenCat
ocamlYaccErrorCase
, TokenCat
" ;"
]
epRule :: Cat -> String
epRule :: Cat -> TokenCat
epRule Cat
cat = Cat -> TokenCat
epName Cat
cat forall a. [a] -> [a] -> [a]
++ TokenCat
" : " forall a. [a] -> [a] -> [a]
++ Cat -> TokenCat
nonterminal Cat
cat forall a. [a] -> [a] -> [a]
++ TokenCat
" TOK_EOF { $1 }"
ocamlYaccErrorCase :: String
ocamlYaccErrorCase :: TokenCat
ocamlYaccErrorCase = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ TokenCat
" | error { raise (BNFC_Util.Parse_error ("
, TokenCat
"Parsing.symbol_start_pos ()"
, TokenCat
", "
, TokenCat
"Parsing.symbol_end_pos ()"
, TokenCat
")) }"
]
rules :: OCamlParser -> CF -> String
rules :: OCamlParser -> CF -> TokenCat
rules OCamlParser
ocamlParser CF
cf = [TokenCat] -> TokenCat
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ OCamlParser -> CF -> [TokenCat]
entryPointRules OCamlParser
ocamlParser CF
cf
, forall a b. (a -> b) -> [a] -> [b]
map ((Cat, [(TokenCat, TokenCat)]) -> TokenCat
prOne forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat, [Rule]) -> (Cat, [(TokenCat, TokenCat)])
mkOne) forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rule])]
ruleGroups CF
cf
, CF -> [TokenCat]
specialRules CF
cf
]
where
mkOne :: (Cat, [Rule]) -> (Cat, [(TokenCat, TokenCat)])
mkOne (Cat
cat,[Rule]
rules) = (Cat
cat, (TokenCat -> TokenCat) -> [Rule] -> Cat -> [(TokenCat, TokenCat)]
constructRule (CF -> TokenCat -> TokenCat
terminal CF
cf) [Rule]
rules Cat
cat)
prOne :: (Cat, [(TokenCat, TokenCat)]) -> TokenCat
prOne (Cat
_ , [] ) = []
prOne (Cat
cat, (TokenCat, TokenCat)
l:[(TokenCat, TokenCat)]
ls) = [TokenCat] -> TokenCat
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ [TokenCat] -> TokenCat
unwords [ TokenCat
nt, TokenCat
":", (TokenCat, TokenCat) -> TokenCat
rule (TokenCat, TokenCat)
l ] ]
, forall a b. (a -> b) -> [a] -> [b]
map ((TokenCat
" | " forall a. [a] -> [a] -> [a]
++) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TokenCat, TokenCat) -> TokenCat
rule) [(TokenCat, TokenCat)]
ls
, [ TokenCat
" ;" ]
]
where
rule :: (TokenCat, TokenCat) -> TokenCat
rule (TokenCat
p,TokenCat
a) = [TokenCat] -> TokenCat
unwords [ TokenCat
p, TokenCat
"{", TokenCat
a , TokenCat
"}" ]
nt :: TokenCat
nt = Cat -> TokenCat
nonterminal Cat
cat
constructRule :: (String -> String) -> [Rule] -> NonTerminal -> [(Pattern,Action)]
constructRule :: (TokenCat -> TokenCat) -> [Rule] -> Cat -> [(TokenCat, TokenCat)]
constructRule TokenCat -> TokenCat
terminal [Rule]
rules Cat
nt =
[ (TokenCat
p, forall a. IsFun a => Cat -> a -> [TokenCat] -> TokenCat
generateAction Cat
nt (forall function. Rul function -> function
funRule Rule
r) [TokenCat]
m)
| Rule
r <- [Rule]
rules
, let (TokenCat
p, [TokenCat]
m) = (TokenCat -> TokenCat) -> Rule -> (TokenCat, [TokenCat])
generatePatterns TokenCat -> TokenCat
terminal Rule
r
]
generateAction :: IsFun a => NonTerminal -> a -> [MetaVar] -> Action
generateAction :: forall a. IsFun a => Cat -> a -> [TokenCat] -> TokenCat
generateAction Cat
_ a
f [TokenCat]
ms = (if forall a. IsFun a => a -> Bool
isCoercion a
f then TokenCat
"" else TokenCat
f') TokenCat -> TokenCat -> TokenCat
+++ [TokenCat] -> TokenCat
mkTuple [TokenCat]
ms
where
f' :: TokenCat
f' = case forall a. IsFun a => a -> TokenCat
funName a
f of
TokenCat
"(:[])" -> TokenCat
"(fun x -> [x])"
TokenCat
"(:)" -> TokenCat
"(fun (x,xs) -> x::xs)"
TokenCat
x -> TokenCat -> TokenCat
sanitizeOcaml TokenCat
x
generatePatterns :: (String -> String) -> Rule -> (Pattern,[MetaVar])
generatePatterns :: (TokenCat -> TokenCat) -> Rule -> (TokenCat, [TokenCat])
generatePatterns TokenCat -> TokenCat
terminal Rule
r = case forall function. Rul function -> SentForm
rhsRule Rule
r of
[] -> (TokenCat
"/* empty */",[])
SentForm
its -> ([TokenCat] -> TokenCat
unwords (forall a b. (a -> b) -> [a] -> [b]
map Either Cat TokenCat -> TokenCat
mkIt SentForm
its), forall {a} {b}. [Either a b] -> [TokenCat]
metas SentForm
its)
where
mkIt :: Either Cat TokenCat -> TokenCat
mkIt Either Cat TokenCat
i = case Either Cat TokenCat
i of
Left Cat
c -> Cat -> TokenCat
nonterminal Cat
c
Right TokenCat
s -> TokenCat -> TokenCat
terminal TokenCat
s
metas :: [Either a b] -> [TokenCat]
metas [Either a b]
its = [ (Char
'$'forall a. a -> [a] -> [a]
: forall a. Show a => a -> TokenCat
show Int
i) | (Int
i, Left a
_c) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ::Int ..] [Either a b]
its ]
specialRules :: CF -> [String]
specialRules :: CF -> [TokenCat]
specialRules CF
cf = (forall a b. (a -> b) -> [a] -> [b]
`map` forall f. CFG f -> [TokenCat]
literals CF
cf) forall a b. (a -> b) -> a -> b
$ \case
TokenCat
"Ident" -> TokenCat
"ident : TOK_Ident { Ident $1 };"
TokenCat
"String" -> TokenCat
"string : TOK_String { $1 };"
TokenCat
"Integer" -> TokenCat
"int : TOK_Integer { $1 };"
TokenCat
"Double" -> TokenCat
"float : TOK_Double { $1 };"
TokenCat
"Char" -> TokenCat
"char : TOK_Char { $1 };"
TokenCat
own -> forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
[ Cat -> TokenCat
fixType (TokenCat -> Cat
TokenCat TokenCat
own), TokenCat
" : TOK_", TokenCat
own, TokenCat
" { ", TokenCat
own, TokenCat
" (", TokenCat
posn, TokenCat
"$1)};" ]
where
posn :: TokenCat
posn = TokenCat
""