{-
    BNF Converter: ocamlyacc Generator
    Copyright (C) 2005  Author:  Kristofer Johannisson

-}

-- based on BNFC Haskell backend

{-# LANGUAGE LambdaCase #-}

module BNFC.Backend.OCaml.CFtoOCamlYacc
       (
       cf2ocamlyacc, terminal, epName
       )
        where

import Data.Char
import Data.Foldable ( toList )
import Data.List     ( intercalate )

import BNFC.CF
import BNFC.Options  ( OCamlParser(..) )
import BNFC.Utils    ( (+++), mapHead, table )
import BNFC.Backend.Common
import BNFC.Backend.OCaml.OCamlUtil

-- Type declarations

type Pattern     = String
type Action      = String
type MetaVar     = String

-- The main function, that given a CF
-- generates a ocamlyacc module.
cf2ocamlyacc :: OCamlParser -> String -> CF -> String
cf2ocamlyacc :: OCamlParser -> String -> CF -> String
cf2ocamlyacc OCamlParser
ocamlParser String
absName CF
cf = [String] -> String
unlines
  [ OCamlParser -> String -> String
header OCamlParser
ocamlParser String
absName
  , String -> CF -> String
declarations String
absName CF
cf
  , String
"%%"
  , String
""
  , OCamlParser -> CF -> String
rules OCamlParser
ocamlParser CF
cf
  ]


header :: OCamlParser -> String -> String
header :: OCamlParser -> String -> String
header OCamlParser
ocamlParser String
absName = [String] -> String
unlines
  [ [String] -> String
unwords [ String
"/* Parser definition for use with", OCamlParser -> String
forall a. OCamlParserName a => a -> String
ocamlParserName OCamlParser
ocamlParser, String
"*/" ]
  , String
""
  , String
"%{"
  , String
"open " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
absName
  , String
"open Lexing"
  , String
"%}"
  ]

declarations :: String -> CF -> String
declarations :: String -> CF -> String
declarations String
absName CF
cf =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
intercalate [String
""]
    [ [String] -> [String] -> [String]
tokens (CF -> [String]
unicodeAndSymbols CF
cf) (CF -> [String]
asciiKeywords CF
cf)
    , CF -> [String]
specialTokens CF
cf
    , String -> CF -> [String]
entryPoints String
absName CF
cf
    , ((Cat, [Rule]) -> String) -> [(Cat, [Rule])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> String
catTyping (Cat -> String)
-> ((Cat, [Rule]) -> Cat) -> (Cat, [Rule]) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat, [Rule]) -> Cat
forall a b. (a, b) -> a
fst)      ([(Cat, [Rule])] -> [String]) -> [(Cat, [Rule])] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rule])]
ruleGroups CF
cf
    , (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Cat -> String
catTyping (Cat -> String) -> (String -> Cat) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Cat
TokenCat) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [String]
forall f. CFG f -> [String]
literals CF
cf
    ]
  where
    catTyping :: Cat -> String
catTyping Cat
c = String -> Cat -> String -> String
typing String
absName Cat
c (Cat -> String
nonterminal Cat
c)

-- | Declare keyword and symbol tokens.

tokens :: [String] -> [String] -> [String]
tokens :: [String] -> [String] -> [String]
tokens [String]
symbols [String]
reswords =
  [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"%token" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"KW_" String -> String -> String
forall a. [a] -> [a] -> [a]
++) [String]
reswords | Bool
hasReserved ]
    , [ String
"" | Bool
hasReserved ]
    , (((String, Int) -> String) -> [(String, Int)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
`map` [String] -> [Int] -> [(String, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
symbols [Int
1::Int ..]) (((String, Int) -> String) -> [String])
-> ((String, Int) -> String) -> [String]
forall a b. (a -> b) -> a -> b
$ \ (String
s, Int
n) ->
        String
"%token SYMB" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> String -> String
+++ String
"/*" String -> String -> String
+++ String
s String -> String -> String
+++ String
"*/"
    ]
  where
  hasReserved :: Bool
hasReserved = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
reswords

-- | map a CF terminal into a ocamlyacc token
terminal :: CF -> String -> String
terminal :: CF -> String -> String
terminal CF
cf = \ String
s ->
    -- Use a lambda here to make sure that kws is computed before the
    -- second argument is applied.
    -- The GHC manual says that let-floating is not consistently applied
    -- so just writing @terminal cf s = ...@ could result in computing
    -- kws for every @s@ anew.
    if String
s String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
kws then String
"KW_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
    else case String -> [(String, Int)] -> Maybe Int
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s ([String] -> [Int] -> [(String, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (CF -> [String]
unicodeAndSymbols CF
cf) [Int
1::Int ..]) of
      Just Int
i -> String
"SYMB" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
      Maybe Int
Nothing -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"CFtoOCamlYacc: terminal " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" not defined in CF."
  where
  kws :: [String]
kws = CF -> [String]
asciiKeywords CF
cf

-- | map a CF nonterminal into a ocamlyacc symbol
nonterminal :: Cat -> String
nonterminal :: Cat -> String
nonterminal Cat
c = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
spaceToUnderscore (Cat -> String
fixType Cat
c)
    where spaceToUnderscore :: Char -> Char
spaceToUnderscore Char
' ' = Char
'_'
          spaceToUnderscore Char
x = Char
x

specialTokens :: CF -> [String]
specialTokens :: CF -> [String]
specialTokens CF
cf = [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
  [ [ String
"%token TOK_EOF" ]
  , String -> [[String]] -> [String]
table String
" " [ String -> String -> [String]
prToken (String -> String
ty String
n)      String
n | String
n                 <- [String]
specialCatsP  ]
  , String -> [[String]] -> [String]
table String
" " [ String -> String -> [String]
prToken (Bool -> String
posTy Bool
pos) String
n | TokenReg RString
n0 Bool
pos Reg
_ <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf, let n :: String
n = RString -> String
forall a. WithPosition a -> a
wpThing RString
n0 ]
  ]
  where
  prToken :: String -> String -> [String]
prToken String
t String
n = [ String
"%token" String -> String -> String
+++ String
t, String
"TOK_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n ]
  ty :: String -> String
ty = \case
    String
"Ident"   -> String
"<string>"
    String
"String"  -> String
"<string>"
    String
"Integer" -> String
"<int>"
    String
"Double"  -> String
"<float>"
    String
"Char"    -> String
"<char>"
    String
_ -> String
forall a. HasCallStack => a
undefined
  posTy :: Bool -> String
posTy = \case
    Bool
True  -> String
"<(int * int) * string>"
    Bool
False -> String
"<string>"

entryPoints :: String -> CF -> [String]
entryPoints :: String -> CF -> [String]
entryPoints String
absName CF
cf =
  [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
"%start" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
epName [Cat]
eps ]
    , (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ Cat
c -> String -> Cat -> String -> String
typing String
absName Cat
c (Cat -> String
epName Cat
c)) [Cat]
eps
    ]
  where
    eps :: [Cat]
eps = NonEmpty Cat -> [Cat]
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

typing :: String -> Cat -> String -> String
typing :: String -> Cat -> String -> String
typing String
absName Cat
c String
s = String
"%type" String -> String -> String
+++ String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
qualify (Cat -> Cat
normCat Cat
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">" String -> String -> String
+++ String
s
    where
          qualify :: Cat -> String
qualify Cat
c = if Cat
c Cat -> [Cat] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ String -> Cat
TokenCat String
"Integer", String -> Cat
TokenCat String
"Double", String -> Cat
TokenCat String
"Char",
                                    String -> Cat
TokenCat String
"String", Cat -> Cat
ListCat (String -> Cat
TokenCat String
"Integer"),
                                    Cat -> Cat
ListCat (String -> Cat
TokenCat String
"Double"),
                                    Cat -> Cat
ListCat (String -> Cat
TokenCat String
"Char"),
                                    Cat -> Cat
ListCat (String -> Cat
TokenCat String
"String") ]
                      then Cat -> String
fixType Cat
c
                      else String
absName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
fixType Cat
c

epName :: Cat -> String
epName :: Cat -> String
epName Cat
c = String
"p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> String -> String
forall a. (a -> a) -> [a] -> [a]
mapHead Char -> Char
toUpper (Cat -> String
nonterminal Cat
c)

entryPointRules :: OCamlParser -> CF -> [String]
entryPointRules :: OCamlParser -> CF -> [String]
entryPointRules OCamlParser
ocamlParser CF
cf =
  (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
unlines ([String] -> String) -> (Cat -> [String]) -> Cat -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> [String]
mkRule) ([Cat] -> [String]) -> [Cat] -> [String]
forall a b. (a -> b) -> a -> b
$ NonEmpty Cat -> [Cat]
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
  where
  mkRule :: Cat -> [String]
  mkRule :: Cat -> [String]
mkRule = case OCamlParser
ocamlParser of
    OCamlParser
Menhir    -> \ Cat
cat ->
      [ Cat -> String
epRule Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";" ]
    OCamlParser
OCamlYacc -> \ Cat
cat ->
      [ Cat -> String
epRule Cat
cat
          -- Andreas, 2022-02-10, issue 414:
          -- We keep the 'error' token rule, throwing BNFC_Util.Parse_error,
          -- for API stability.
          -- It would be more uniform with the Menhir backend to just drop this rule
          -- and let the user catch the Parsing.Parse_error exception.
      , String
"  /* Delete this error clause to get a Parsing.Parse_error exception instead: */"
      , String
ocamlYaccErrorCase
      , String
"  ;"
      ]
  epRule :: Cat -> String
  epRule :: Cat -> String
epRule Cat
cat = Cat -> String
epName Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
nonterminal Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" TOK_EOF { $1 }"

ocamlYaccErrorCase :: String
ocamlYaccErrorCase :: String
ocamlYaccErrorCase = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ String
"  | error { raise (BNFC_Util.Parse_error ("
  , String
"Parsing.symbol_start_pos ()"
  , String
", "
  , String
"Parsing.symbol_end_pos ()"
  , String
")) }"
  ]

rules :: OCamlParser -> CF -> String
rules :: OCamlParser -> CF -> String
rules OCamlParser
ocamlParser CF
cf = [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
    [ OCamlParser -> CF -> [String]
entryPointRules OCamlParser
ocamlParser CF
cf
    , ((Cat, [Rule]) -> String) -> [(Cat, [Rule])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Cat, [(String, String)]) -> String
prOne ((Cat, [(String, String)]) -> String)
-> ((Cat, [Rule]) -> (Cat, [(String, String)]))
-> (Cat, [Rule])
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat, [Rule]) -> (Cat, [(String, String)])
mkOne) ([(Cat, [Rule])] -> [String]) -> [(Cat, [Rule])] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [Rule])]
ruleGroups CF
cf
    , CF -> [String]
specialRules CF
cf
    ]
  where
    mkOne :: (Cat, [Rule]) -> (Cat, [(String, String)])
mkOne (Cat
cat,[Rule]
rules) = (Cat
cat, (String -> String) -> [Rule] -> Cat -> [(String, String)]
constructRule (CF -> String -> String
terminal CF
cf) [Rule]
rules Cat
cat)
    prOne :: (Cat, [(String, String)]) -> String
prOne (Cat
_  , []  ) = [] -- nt has only internal use
    prOne (Cat
cat, (String, String)
l:[(String, String)]
ls) = [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] -> String
unwords [ String
nt, String
":", (String, String) -> String
rule (String, String)
l ] ]
        , ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String
"  | " String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> ((String, String) -> String) -> (String, String) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, String) -> String
rule) [(String, String)]
ls
        , [ String
"  ;" ]
        ]
      where
        rule :: (String, String) -> String
rule (String
p,String
a) = [String] -> String
unwords [ String
p, String
"{", String
a , String
"}" ]
        nt :: String
nt = Cat -> String
nonterminal Cat
cat


-- For every non-terminal, we construct a set of rules. A rule is a sequence of
-- terminals and non-terminals, and an action to be performed
constructRule :: (String -> String) -> [Rule] -> NonTerminal -> [(Pattern,Action)]
constructRule :: (String -> String) -> [Rule] -> Cat -> [(String, String)]
constructRule String -> String
terminal [Rule]
rules Cat
nt =
  [ (String
p, Cat -> RString -> [String] -> String
forall a. IsFun a => Cat -> a -> [String] -> String
generateAction Cat
nt (Rule -> RString
forall function. Rul function -> function
funRule Rule
r) [String]
m)
  | Rule
r <- [Rule]
rules
  , let (String
p, [String]
m) = (String -> String) -> Rule -> (String, [String])
generatePatterns String -> String
terminal Rule
r
  ]



-- Generates a string containing the semantic action.
-- An action can for example be: Sum $1 $2, that is, construct an AST
-- with the constructor Sum applied to the two metavariables $1 and $2.
generateAction :: IsFun a => NonTerminal -> a -> [MetaVar] -> Action
generateAction :: Cat -> a -> [String] -> String
generateAction Cat
_ a
f [String]
ms = (if a -> Bool
forall a. IsFun a => a -> Bool
isCoercion a
f then String
"" else String
f') String -> String -> String
+++ [String] -> String
mkTuple [String]
ms
    where
    f' :: String
f' = case a -> String
forall a. IsFun a => a -> String
funName a
f of -- ocaml cons is somehow not a standard infix oper, right?
           String
"(:[])" -> String
"(fun x -> [x])"
           String
"(:)"   -> String
"(fun (x,xs) -> x::xs)"
           String
x       -> String -> String
sanitizeOcaml String
x


generatePatterns :: (String -> String) -> Rule -> (Pattern,[MetaVar])
generatePatterns :: (String -> String) -> Rule -> (String, [String])
generatePatterns String -> String
terminal Rule
r = case Rule -> SentForm
forall function. Rul function -> SentForm
rhsRule Rule
r of
  []  -> (String
"/* empty */",[])
  SentForm
its -> ([String] -> String
unwords ((Either Cat String -> String) -> SentForm -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Either Cat String -> String
mkIt SentForm
its), SentForm -> [String]
forall a b. [Either a b] -> [String]
metas SentForm
its)
 where
   mkIt :: Either Cat String -> String
mkIt Either Cat String
i = case Either Cat String
i of
     Left Cat
c -> Cat -> String
nonterminal Cat
c
     Right String
s -> String -> String
terminal String
s
   metas :: [Either a b] -> [String]
metas [Either a b]
its = [ (Char
'$'Char -> String -> String
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
i) | (Int
i, Left a
_c) <- [Int] -> [Either a b] -> [(Int, Either a b)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ::Int ..] [Either a b]
its ]

specialRules :: CF -> [String]
specialRules :: CF -> [String]
specialRules CF
cf = ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
`map` CF -> [String]
forall f. CFG f -> [String]
literals CF
cf) ((String -> String) -> [String]) -> (String -> String) -> [String]
forall a b. (a -> b) -> a -> b
$ \case
  String
"Ident"   -> String
"ident : TOK_Ident  { Ident $1 };"
  String
"String"  -> String
"string : TOK_String { $1 };"
  String
"Integer" -> String
"int :  TOK_Integer  { $1 };"
  String
"Double"  -> String
"float : TOK_Double  { $1 };"
  String
"Char"    -> String
"char : TOK_Char { $1 };"
  String
own       -> [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    [ Cat -> String
fixType (String -> Cat
TokenCat String
own), String
" : TOK_", String
own, String
" { ", String
own, String
" (",  String
posn, String
"$1)};" ]
    where -- ignore position categories for now
    posn :: String
posn = String
"" -- if isPositionCat cf own then "mkPosToken " else ""