{-
    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 BNFC.CF
import BNFC.Utils ((+++))
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 :: String -> String -> String -> CF -> String
cf2ocamlyacc :: String -> String -> String -> CF -> String
cf2ocamlyacc String
name String
absName String
lexName CF
cf
 = [String] -> String
unlines
    [String -> String -> String -> CF -> String
header String
name String
absName String
lexName CF
cf,
    String -> CF -> String
declarations String
absName CF
cf,
    String
"%%",
    CF -> String
rules CF
cf
    ]


header :: String -> String -> String -> CF -> String
header :: String -> String -> String -> CF -> String
header String
_ String
absName String
_ CF
cf = [String] -> String
unlines
         [String
"/* This ocamlyacc file was machine-generated by the BNF converter */",
          String
"%{",
          String
"open " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
absName,
          String
"open Lexing",
          String
"",
          CF -> String
definedRules CF
cf,
          String
"%}"
         ]

definedRules :: CF -> String
definedRules :: CF -> String
definedRules CF
cf = [String] -> String
unlines [ RFun -> [String] -> Exp -> String
forall a. IsFun a => a -> [String] -> Exp -> String
mkDef RFun
f [String]
xs Exp
e | FunDef RFun
f [String]
xs Exp
e <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf ]
  where
    mkDef :: a -> [String] -> Exp -> String
mkDef a
f [String]
xs Exp
e = String
"let " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. IsFun a => a -> String
funName a
f String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
mkTuple [String]
xs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Exp -> String
ocamlExp Exp
e

    ocamlExp :: Exp -> String
    ocamlExp :: Exp -> String
ocamlExp = \case
      Var String
s       -> String
s
      App String
s [Exp]
es    -> String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: [String] -> String
mkTuple ((Exp -> String) -> [Exp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> String
ocamlExp [Exp]
es)
      LitInt Integer
i    -> Integer -> String
forall a. Show a => a -> String
show Integer
i
      LitDouble Double
d -> Double -> String
forall a. Show a => a -> String
show Double
d
      LitChar Char
c   -> String
"\'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
"\'"
      LitString String
s -> String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

declarations :: String -> CF -> String
declarations :: String -> CF -> String
declarations String
absName CF
cf =
  [String] -> String
unlines
    [ [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
    ]

-- | Declare keyword and symbol tokens.

tokens :: [String] -> [String] -> String
tokens :: [String] -> [String] -> String
tokens [String]
symbols [String]
reswords =
  [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] -> 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, Integer) -> String) -> [(String, Integer)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
`map` [String] -> [Integer] -> [(String, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
symbols [Integer
1..]) (((String, Integer) -> String) -> [String])
-> ((String, Integer) -> String) -> [String]
forall a b. (a -> b) -> a -> b
$ \ (String
s, Integer
n) ->
        String
"%token SYMB" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
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, Integer)] -> Maybe Integer
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s ([String] -> [Integer] -> [(String, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip (CF -> [String]
unicodeAndSymbols CF
cf) [Integer
1..]) of
      Just Integer
i -> String
"SYMB" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
i
      Maybe Integer
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
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]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
  [ [ String
"%token TOK_EOF" ]
  , [ String -> String -> String
prToken (String -> String
ty String
n)      String
n | String
n                 <- [String]
specialCatsP  ]
  , [ String -> String -> String
prToken (Bool -> String
posTy Bool
pos) String
n | TokenReg RFun
n0 Bool
pos Reg
_ <- CF -> [Pragma]
forall function. CFG function -> [Pragma]
cfgPragmas CF
cf, let n :: String
n = RFun -> String
forall a. WithPosition a -> a
wpThing RFun
n0 ]
  ]
  where
  prToken :: String -> String -> String
prToken String
t String
n = String
"%token" String -> String -> String
+++ String
t String -> String -> String
+++ 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>"
  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
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    (String
"%start" String -> String -> String
+++ [String] -> String
unwords ((Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
epName [Cat]
eps))
    String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
    ((Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
typing [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 :: Cat -> String
          typing :: Cat -> String
typing Cat
c = 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
+++ Cat -> String
epName Cat
c
          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]
++ String -> String
capitalize (Cat -> String
nonterminal Cat
c)
            where capitalize :: String -> String
capitalize String
s = case String
s of
                    [] -> []
                    Char
c:String
cs -> Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
cs

entryPointRules :: CF -> String
entryPointRules :: CF -> String
entryPointRules CF
cf = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map 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 Cat
s = [String] -> String
unlines [
            Cat -> String
epName Cat
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
nonterminal Cat
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" TOK_EOF { $1 }",
            String
"  | error { raise (BNFC_Util.Parse_error (Parsing.symbol_start_pos (), Parsing.symbol_end_pos ())) };"
            ]

rules :: CF -> String
rules :: CF -> String
rules CF
cf = [String] -> String
unlines [
    CF -> String
entryPointRules CF
cf,
    ([String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((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) (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
nt,((String
p,String
a):[(String, String)]
ls)) =
          [String] -> String
unwords [String
nt', String
":" , String
p, String
"{", String
a, String
"}", String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
pr [(String, String)]
ls] String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
";\n"
         where
           nt' :: String
nt' = Cat -> String
nonterminal Cat
nt
           pr :: [(String, String)] -> String
pr [] = []
           pr ((String
p,String
a):[(String, String)]
ls) =
             [String] -> String
unlines [ [String] -> String
unwords [ String
"  |", String
p, String
"{", String
a , String
"}" ] ] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
pr [(String, String)]
ls



-- 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 -> RFun -> [String] -> String
forall a. IsFun a => Cat -> a -> [String] -> String
generateAction Cat
nt (Rule -> RFun
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
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
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((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 ""