{-# LANGUAGE LambdaCase #-}
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
cf2Abstract :: String -> CF -> String
cf2Abstract :: [Char] -> CF -> [Char]
cf2Abstract [Char]
_ CF
cf = [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [[Char]] -> [[Char]]
mutualRecDefs forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ forall a b. (a -> b) -> [a] -> [b]
map (CF -> [Char] -> [Char]
prSpecialData CF
cf) (CF -> [[Char]]
specialCats CF
cf)
, forall a b. (a -> b) -> [a] -> [b]
map Data -> [Char]
prData (CF -> [Data]
cf2data CF
cf)
]
, forall m. Monoid m => Bool -> m -> m
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
defs) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
[ [ [Char]
"(* defined constructors *)"
, [Char]
""
]
, [[Char]]
defs
]
]
where
defs :: [[Char]]
defs = CF -> [[Char]]
definedRules CF
cf
definedRules :: CF -> [String]
definedRules :: CF -> [[Char]]
definedRules CF
cf = forall a b. (a -> b) -> [a] -> [b]
map Define -> [Char]
mkDef forall a b. (a -> b) -> a -> b
$ forall f. CFG f -> [Define]
definitions CF
cf
where
mkDef :: Define -> [Char]
mkDef (Define RFun
f Telescope
args Exp
e Base
_) =
[Char]
"let " forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
sanitizeOcaml (forall a. IsFun a => a -> [Char]
funName RFun
f) forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
mkTuple (forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
sanitizeOcaml forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Telescope
args) forall a. [a] -> [a] -> [a]
++ [Char]
" = " forall a. [a] -> [a] -> [a]
++ Bool -> Exp -> [Char]
ocamlExp Bool
False Exp
e
ocamlExp :: Bool -> Exp -> String
ocamlExp :: Bool -> Exp -> [Char]
ocamlExp Bool
p = \case
Var [Char]
s -> [Char] -> [Char]
sanitizeOcaml [Char]
s
App [Char]
"(:)" Type
_ [Exp
e1, Exp
e2] -> Bool -> [Char] -> [Char]
parensIf Bool
p forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [ Bool -> Exp -> [Char]
ocamlExp Bool
True Exp
e1, [Char]
"::", Bool -> Exp -> [Char]
ocamlExp Bool
False Exp
e2 ]
App [Char]
s Type
_ [] -> [Char] -> [Char]
sanitizeOcaml [Char]
s
App [Char]
s Type
_ [Exp
e] -> Bool -> [Char] -> [Char]
parensIf Bool
p forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
sanitizeOcaml [Char]
s forall a. [a] -> [a] -> [a]
++ Char
' ' forall a. a -> [a] -> [a]
: Bool -> Exp -> [Char]
ocamlExp Bool
True Exp
e
App [Char]
s Type
_ [Exp]
es -> Bool -> [Char] -> [Char]
parensIf Bool
p forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
sanitizeOcaml [Char]
s forall a. [a] -> [a] -> [a]
++ Char
' ' forall a. a -> [a] -> [a]
: [[Char]] -> [Char]
mkTuple (forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Exp -> [Char]
ocamlExp Bool
False) [Exp]
es)
LitInt Integer
i -> forall a. Show a => a -> [Char]
show Integer
i
LitDouble Double
d -> forall a. Show a => a -> [Char]
show Double
d
LitChar Char
c -> [Char]
"\'" forall a. [a] -> [a] -> [a]
++ Char
c forall a. a -> [a] -> [a]
: [Char]
"\'"
LitString [Char]
s -> [Char]
"\"" forall a. [a] -> [a] -> [a]
++ [Char]
s forall a. [a] -> [a] -> [a]
++ [Char]
"\""
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) forall a. a -> [a] -> [a]
: 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 " forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse [Char]
"\n | " (forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Cat]) -> [Char]
prRule [([Char], [Cat])]
rules)) forall a. [a] -> [a] -> [a]
++
[Char]
"\n"
prRule :: (String, [Cat]) -> String
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)
mkTupleType :: [Cat] -> Doc
mkTupleType :: [Cat] -> Doc
mkTupleType = [Doc] -> Doc
hsep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (Char -> Doc
char Char
'*') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Doc
text 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
contentSpec :: CF -> TokenCat -> String
contentSpec :: CF -> [Char] -> [Char]
contentSpec CF
cf [Char]
cat =
if forall f. CFG f -> [Char] -> Bool
isPositionCat CF
cf [Char]
cat then [Char]
"((int * int) * string)" else [Char]
"string"