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

-}

-- based on BNFC Haskell backend


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

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


type ModuleName = String
type Constructor = String

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


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