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

-}

-- based on BNFC Haskell backend


module BNFC.Backend.OCaml.CFtoOCamlTemplate (
                    cf2Template
                    ) where

import BNFC.CF
import Data.Char
import BNFC.Backend.OCaml.OCamlUtil


type ModuleName = String
type Constructor = String

cf2Template :: ModuleName -> ModuleName  -> CF -> String
cf2Template :: ModuleName -> ModuleName -> CF -> ModuleName
cf2Template ModuleName
skelName ModuleName
absName CF
cf = [ModuleName] -> ModuleName
unlines
  [
  ModuleName
"module "ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
skelName ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" = struct\n",
  ModuleName
"(* OCaml module generated by the BNF converter *)\n",
  ModuleName
"open " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
absName ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
"\n",
  ModuleName
"type result = string\n",
  ModuleName
"let failure x = failwith \"Undefined case.\" (* x discarded *)\n",
  [ModuleName] -> ModuleName
unlines ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> [ModuleName]
mutualDefs ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ ((Cat, [(ModuleName, [Cat])]) -> ModuleName)
-> [(Cat, [(ModuleName, [Cat])])] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (\(Cat
s,[(ModuleName, [Cat])]
xs) -> Cat -> [ModuleName] -> ModuleName
case_fun Cat
s ([(ModuleName, [Cat])] -> [ModuleName]
toArgs [(ModuleName, [Cat])]
xs)) ([(Cat, [(ModuleName, [Cat])])] -> [ModuleName])
-> [(Cat, [(ModuleName, [Cat])])] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [(ModuleName, [Cat])])]
specialData CF
cf [(Cat, [(ModuleName, [Cat])])]
-> [(Cat, [(ModuleName, [Cat])])] -> [(Cat, [(ModuleName, [Cat])])]
forall a. [a] -> [a] -> [a]
++ CF -> [(Cat, [(ModuleName, [Cat])])]
cf2data CF
cf,
  ModuleName
"end"
  ]
 where toArgs :: [(ModuleName, [Cat])] -> [ModuleName]
toArgs               [] = []
       toArgs ((ModuleName
cons,[Cat]
args):[(ModuleName, [Cat])]
xs)
           = (ModuleName
cons ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++  ([ModuleName] -> ModuleName
mkTuple ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> Int -> [ModuleName]
names ((Cat -> ModuleName) -> [Cat] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleName -> ModuleName
checkRes (ModuleName -> ModuleName)
-> (Cat -> ModuleName) -> Cat -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> ModuleName
var) [Cat]
args) (Int
0 :: Int))) ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [(ModuleName, [Cat])] -> [ModuleName]
toArgs [(ModuleName, [Cat])]
xs
       names :: [String] -> Int -> [String]
       names :: [ModuleName] -> Int -> [ModuleName]
names [] Int
_ = []
       names (ModuleName
x:[ModuleName]
xs) Int
n
        | ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ModuleName
x [ModuleName]
xs = (ModuleName
x ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ Int -> ModuleName
forall a. Show a => a -> ModuleName
show Int
n) ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName] -> Int -> [ModuleName]
names [ModuleName]
xs (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        | Bool
otherwise = ModuleName
x ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: [ModuleName] -> Int -> [ModuleName]
names [ModuleName]
xs Int
n
       var :: Cat -> ModuleName
var (ListCat Cat
c)      = Cat -> ModuleName
var Cat
c ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
"s"
       var (Cat ModuleName
"Ident")    = ModuleName
"id"
       var (Cat ModuleName
"Integer")  = ModuleName
"n"
       var (Cat ModuleName
"String")   = ModuleName
"str"
       var (Cat ModuleName
"Char")     = ModuleName
"c"
       var (Cat ModuleName
"Double")   = ModuleName
"d"
       var Cat
cat              = (Char -> Char) -> ModuleName -> ModuleName
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Cat -> ModuleName
forall a. Show a => a -> ModuleName
show Cat
cat)
       checkRes :: ModuleName -> ModuleName
checkRes ModuleName
s
        | ModuleName -> [ModuleName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ModuleName
s [ModuleName]
reservedOCaml = ModuleName
s ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
"'"
        | Bool
otherwise              = ModuleName
s


case_fun :: Cat -> [Constructor] -> String
case_fun :: Cat -> [ModuleName] -> ModuleName
case_fun Cat
cat [ModuleName]
xs =
 [ModuleName] -> ModuleName
unlines ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$
         [ModuleName
"trans" ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ Cat -> ModuleName
forall a. Show a => a -> ModuleName
show Cat
cat ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" (x : " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ Cat -> ModuleName
fixType Cat
cat ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
") : result = match x with",
          [ModuleName] -> ModuleName
unlines ([ModuleName] -> ModuleName) -> [ModuleName] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [ModuleName] -> [ModuleName]
insertBar ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ (ModuleName -> ModuleName) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map (\ModuleName
s -> ModuleName
s ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
" -> " ModuleName -> ModuleName -> ModuleName
forall a. [a] -> [a] -> [a]
++ ModuleName
"failure x") [ModuleName]
xs]