CFtoOCamlAbs.hs

{-
    BNF Converter: OCaml Abstract Syntax Generator
    Copyright (C) 2005  Author:  Kristofer Johannisson

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

-- based on BNFC Haskell backend

module CFtoOCamlAbs (cf2Abstract) where

import CF
import Utils((+++),(++++))
import Data.List(intersperse)
import OCamlUtil

-- to produce an OCaml module
cf2Abstract :: String -> CF -> String
cf2Abstract name cf = unlines $ 
  "(* OCaml module generated by the BNF converter *)\n\n" :
  mutualRecDefs (map (prSpecialData cf) (specialCats cf) ++ map prData (cf2data cf))

-- allow mutual recursion so that we do not have to sort the type definitions in
-- dependency order
mutualRecDefs :: [String] -> [String]
mutualRecDefs ss = case ss of
    [] -> []
    [x] -> ["type" +++ x]
    x:xs -> ("type" +++ x)  :  map ("and" +++) xs
  


prData :: Data -> String
prData (cat,rules) = 
  fixType cat +++ "=\n   " ++
  concat (intersperse "\n | " (map prRule rules)) ++
  "\n"

prRule (fun,[])   = fun
prRule (fun,cats) = fun +++ "of" +++ mkTupleType cats

mkTupleType [c] = fixType c
mkTupleType (c:cs) = fixType c +++ "*" +++ mkTupleType cs

prSpecialData :: CF -> Cat -> String
prSpecialData cf cat = fixType cat +++ "=" +++ cat +++ "of" +++ contentSpec cf cat
--  unwords ["newtype",cat,"=",cat,contentSpec cf cat,"deriving (Eq,Ord,Show)"]

contentSpec :: CF -> Cat -> String
contentSpec cf cat = -- if isPositionCat cf cat then "((Int,Int),String)" else "String"
    if isPositionCat cf cat then "((int * int) * string)" else "string"