{-# LANGUAGE LambdaCase #-}

{-
    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 ( (+++), unless, parensIf )
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]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [String] -> [String]
mutualRecDefs ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CF -> String -> String
prSpecialData CF
cf) (CF -> [String]
specialCats CF
cf)
    , (Data -> String) -> [Data] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Data -> String
prData (CF -> [Data]
cf2data CF
cf)
    ]
  , Bool -> [String] -> [String]
forall m. Monoid m => Bool -> m -> m
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
defs) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ String
"(* defined constructors *)"
      , String
""
      ]
    , [String]
defs
    ]
  ]
  where
  defs :: [String]
defs = CF -> [String]
definedRules CF
cf

definedRules :: CF -> [String]
definedRules :: CF -> [String]
definedRules CF
cf = (Define -> String) -> [Define] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Define -> String
mkDef ([Define] -> [String]) -> [Define] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [Define]
forall f. CFG f -> [Define]
definitions CF
cf
  where
    mkDef :: Define -> String
mkDef (Define RFun
f Telescope
args Exp
e Base
_) =
      String
"let " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
sanitizeOcaml (RFun -> String
forall a. IsFun a => a -> String
funName RFun
f) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
mkTuple (((String, Base) -> String) -> Telescope -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
sanitizeOcaml (String -> String)
-> ((String, Base) -> String) -> (String, Base) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Base) -> String
forall a b. (a, b) -> a
fst) Telescope
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> Exp -> String
ocamlExp Bool
False Exp
e

    ocamlExp :: Bool -> Exp -> String
    ocamlExp :: Bool -> Exp -> String
ocamlExp Bool
p = \case
      Var String
s       -> String -> String
sanitizeOcaml String
s
      App String
"(:)" Type
_ [Exp
e1, Exp
e2] -> Bool -> String -> String
parensIf Bool
p (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [ Bool -> Exp -> String
ocamlExp Bool
True Exp
e1, String
"::", Bool -> Exp -> String
ocamlExp Bool
False Exp
e2 ]
      App String
s Type
_ []  -> String -> String
sanitizeOcaml String
s
      App String
s Type
_ [Exp
e] -> Bool -> String -> String
parensIf Bool
p (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
sanitizeOcaml String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Bool -> Exp -> String
ocamlExp Bool
True Exp
e
      App String
s Type
_ [Exp]
es  -> Bool -> String -> String
parensIf Bool
p (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
sanitizeOcaml String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: [String] -> String
mkTuple ((Exp -> String) -> [Exp] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Exp -> String
ocamlExp Bool
False) [Exp]
es)
      LitInt Integer
i    -> Integer -> String
forall a. Show a => a -> String
show Integer
i
      LitDouble Double
d -> Double -> String
forall a. Show a => a -> String
show Double
d
      LitChar Char
c   -> String
"\'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
"\'"
      LitString String
s -> String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""

-- 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, [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"