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

-}

-- based on BNFC Haskell backend

module BNFC.Backend.OCaml.CFtoOCamlAbs (cf2Abstract) where

import Text.PrettyPrint

import BNFC.CF
import BNFC.Utils((+++))
import Data.List(intersperse)
import BNFC.Backend.OCaml.OCamlUtil

-- to produce an OCaml module
cf2Abstract :: String -> CF -> String
cf2Abstract :: String -> CF -> String
cf2Abstract String
_ CF
cf = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  String
"(* OCaml module generated by the BNF converter *)\n\n" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
  [String] -> [String]
mutualRecDefs ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CF -> String -> String
prSpecialData CF
cf) (CF -> [String]
specialCats CF
cf) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (Data -> String) -> [Data] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Data -> String
prData (CF -> [Data]
cf2data CF
cf))

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



prData :: Data -> String
prData :: Data -> String
prData (Cat
cat,[(String, [Cat])]
rules) =
  Cat -> String
fixType Cat
cat String -> String -> String
+++ String
"=\n   " String -> String -> String
forall a. [a] -> [a] -> [a]
++
  [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"\n | " (((String, [Cat]) -> String) -> [(String, [Cat])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, [Cat]) -> String
prRule [(String, [Cat])]
rules)) String -> String -> String
forall a. [a] -> [a] -> [a]
++
  String
"\n"

prRule :: (String, [Cat]) -> String
prRule (String
fun,[])   = String
fun
prRule (String
fun,[Cat]
cats) = String
fun String -> String -> String
+++ String
"of" String -> String -> String
+++ Doc -> String
render ([Cat] -> Doc
mkTupleType [Cat]
cats)

-- | Creates an OCaml type tuple by intercalating * between type names
-- >>> mkTupleType [Cat "A"]
-- a
--
-- >>> mkTupleType [Cat "A", Cat "Abc", Cat "S"]
-- a * abc * s
mkTupleType :: [Cat] -> Doc
mkTupleType :: [Cat] -> Doc
mkTupleType = [Doc] -> Doc
hsep ([Doc] -> Doc) -> ([Cat] -> [Doc]) -> [Cat] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (Char -> Doc
char Char
'*') ([Doc] -> [Doc]) -> ([Cat] -> [Doc]) -> [Cat] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cat -> Doc) -> [Cat] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc) -> (Cat -> String) -> Cat -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> String
fixType)

prSpecialData :: CF -> TokenCat -> String
prSpecialData :: CF -> String -> String
prSpecialData CF
cf String
cat = Cat -> String
fixType (String -> Cat
TokenCat String
cat) String -> String -> String
+++ String
"=" String -> String -> String
+++ String
cat String -> String -> String
+++ String
"of" String -> String -> String
+++ CF -> String -> String
contentSpec CF
cf String
cat

--  unwords ["newtype",cat,"=",cat,contentSpec cf cat,"deriving (Eq,Ord,Show)"]

contentSpec :: CF -> TokenCat -> String
contentSpec :: CF -> String -> String
contentSpec CF
cf String
cat = -- if isPositionCat cf cat then "((Int,Int),String)" else "String"
    if CF -> String -> Bool
forall f. CFG f -> String -> Bool
isPositionCat CF
cf String
cat then String
"((int * int) * string)" else String
"string"