{-
    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 :: [Char] -> CF -> [Char]
cf2Abstract [Char]
_ CF
cf = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
  [Char]
"(* OCaml module generated by the BNF converter *)\n\n" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:
  [[Char]] -> [[Char]]
mutualRecDefs (([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (CF -> [Char] -> [Char]
prSpecialData CF
cf) (CF -> [[Char]]
specialCats CF
cf) [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ (Data -> [Char]) -> [Data] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Data -> [Char]
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 :: [[Char]] -> [[Char]]
mutualRecDefs [[Char]]
ss = case [[Char]]
ss of
    [] -> []
    [[Char]
x] -> [[Char]
"type" [Char] -> [Char] -> [Char]
+++ [Char]
x]
    [Char]
x:[[Char]]
xs -> ([Char]
"type" [Char] -> [Char] -> [Char]
+++ [Char]
x)  [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:  ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"and" [Char] -> [Char] -> [Char]
+++) [[Char]]
xs



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

prRule :: ([Char], [Cat]) -> [Char]
prRule ([Char]
fun,[])   = [Char]
fun
prRule ([Char]
fun,[Cat]
cats) = [Char]
fun [Char] -> [Char] -> [Char]
+++ [Char]
"of" [Char] -> [Char] -> [Char]
+++ Doc -> [Char]
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 ([Char] -> Doc
text ([Char] -> Doc) -> (Cat -> [Char]) -> Cat -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> [Char]
fixType)

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

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

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