{-# 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 :: [Char] -> CF -> [Char]
cf2Abstract [Char]
_ CF
cf = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [[Char]] -> [[Char]]
mutualRecDefs ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (CF -> [Char] -> [Char]
prSpecialData CF
cf) (CF -> [[Char]]
specialCats CF
cf)
    , (Data -> [Char]) -> [Data] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Data -> [Char]
prData (CF -> [Data]
cf2data CF
cf)
    ]
  , Bool -> [[Char]] -> [[Char]]
forall m. Monoid m => Bool -> m -> m
unless ([[Char]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
defs) ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
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 = (Define -> [Char]) -> [Define] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Define -> [Char]
mkDef ([Define] -> [[Char]]) -> [Define] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [Define]
forall f. CFG f -> [Define]
definitions CF
cf
  where
    mkDef :: Define -> [Char]
mkDef (Define RFun
f Telescope
args Exp
e Base
_) =
      [Char]
"let " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
sanitizeOcaml (RFun -> [Char]
forall a. IsFun a => a -> [Char]
funName RFun
f) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [[Char]] -> [Char]
mkTuple ((([Char], Base) -> [Char]) -> Telescope -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
sanitizeOcaml ([Char] -> [Char])
-> (([Char], Base) -> [Char]) -> ([Char], Base) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Base) -> [Char]
forall a b. (a, b) -> a
fst) Telescope
args) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" = " [Char] -> [Char] -> [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 ([Char] -> [Char]) -> [Char] -> [Char]
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 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
sanitizeOcaml [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> [Char] -> [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 ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
sanitizeOcaml [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
' ' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [[Char]] -> [Char]
mkTuple ((Exp -> [Char]) -> [Exp] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Exp -> [Char]
ocamlExp Bool
False) [Exp]
es)
      LitInt Integer
i    -> Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
i
      LitDouble Double
d -> Double -> [Char]
forall a. Show a => a -> [Char]
show Double
d
      LitChar Char
c   -> [Char]
"\'" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
"\'"
      LitString [Char]
s -> [Char]
"\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\""

-- 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 :: (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)

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