{-
    BNF Converter: OCaml backend utility module
    Copyright (C) 2005  Author:  Kristofer Johannisson

-}

{-# LANGUAGE LambdaCase #-}

module BNFC.Backend.OCaml.OCamlUtil where

import BNFC.CF
import BNFC.Utils
import Data.Char (toLower, toUpper)

-- Translate Haskell types to OCaml types
-- Note: OCaml (data-)types start with lowercase letter
fixType :: Cat -> String
fixType :: Cat -> [Char]
fixType = [Char] -> Cat -> [Char]
fixTypeQual [Char]
""

fixTypeQual :: String -- ^ Module name (or empty string for no qualification).
  -> Cat -> String
fixTypeQual :: [Char] -> Cat -> [Char]
fixTypeQual [Char]
m = \case
  ListCat Cat
c -> [Char] -> Cat -> [Char]
fixTypeQual [Char]
m Cat
c [Char] -> [Char] -> [Char]
+++ [Char]
"list"
  -- unqualified base types
  TokenCat [Char]
"Integer" -> [Char]
"int"
  TokenCat [Char]
"Double"  -> [Char]
"float"
  TokenCat [Char]
"String"  -> [Char]
"string"
  TokenCat [Char]
"Char"    -> [Char]
"char"
  Cat
cat -> if [Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
m then [Char]
base else [[Char]] -> [Char]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [Char]
m, [Char]
".", [Char]
base ]
    where
    Char
c:[Char]
cs = Cat -> [Char]
identCat Cat
cat
    ls :: [Char]
ls   = Char -> Char
toLower Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs
    base :: [Char]
base = if [Char]
ls [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
reservedOCaml then [Char]
ls [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"T" else [Char]
ls

-- as fixType, but leave first character in upper case
fixTypeUpper :: Cat -> String
fixTypeUpper :: Cat -> [Char]
fixTypeUpper Cat
c = case Cat -> [Char]
fixType Cat
c of
    [] -> []
    Char
c:[Char]
cs -> Char -> Char
toUpper Char
c Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
cs


reservedOCaml :: [String]
reservedOCaml :: [[Char]]
reservedOCaml = [
    [Char]
"and",[Char]
"as",[Char]
"assert",[Char]
"asr",[Char]
"begin",[Char]
"class",
    [Char]
"constraint",[Char]
"do",[Char]
"done",[Char]
"downto",[Char]
"else",[Char]
"end",
    [Char]
"exception",[Char]
"external",[Char]
"false",[Char]
"for",[Char]
"fun",[Char]
"function",
    [Char]
"functor",[Char]
"if",[Char]
"in",[Char]
"include",[Char]
"inherit",[Char]
"initializer",
    [Char]
"land",[Char]
"lazy",[Char]
"let",[Char]
"list",[Char]
"lor",[Char]
"lsl",[Char]
"lsr",
    [Char]
"lxor",[Char]
"match",[Char]
"method",[Char]
"mod",[Char]
"module",[Char]
"mutable",
    [Char]
"new",[Char]
"nonrec",[Char]
"object",[Char]
"of",[Char]
"open",[Char]
"or",
    [Char]
"private",[Char]
"rec",[Char]
"sig",[Char]
"struct",[Char]
"then",[Char]
"to",
    [Char]
"true",[Char]
"try",[Char]
"type",[Char]
"val",[Char]
"virtual",[Char]
"when",
    [Char]
"while",[Char]
"with"]

-- | Keywords of @ocamllex@.
reservedOCamlLex :: [String]
reservedOCamlLex :: [[Char]]
reservedOCamlLex =
  [ [Char]
"and"
  , [Char]
"as"
  , [Char]
"eof"
  , [Char]
"let"
  , [Char]
"parse"
  , [Char]
"refill"
  , [Char]
"rule"
  , [Char]
"shortest"
  ]

-- | Heuristics to produce name for ocamllex token definition that
-- does not clash with the ocamllex keywords.
ocamlTokenName :: String -> String
ocamlTokenName :: [Char] -> [Char]
ocamlTokenName [Char]
x0
  | [Char]
x [Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
reservedOCamlLex = [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"_"
  | Bool
otherwise                 = [Char]
x
  where x :: [Char]
x = (Char -> Char) -> [Char] -> [Char]
forall a. (a -> a) -> [a] -> [a]
mapHead Char -> Char
toLower [Char]
x0

mkTuple :: [String] -> String
mkTuple :: [[Char]] -> [Char]
mkTuple [] = [Char]
""
mkTuple [[Char]
x] = [Char]
x
mkTuple ([Char]
x:[[Char]]
xs) = [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char] -> [Char] -> [Char]) -> [Char] -> [[Char]] -> [Char]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\[Char]
acc [Char]
e -> [Char]
acc [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"," [Char] -> [Char] -> [Char]
+++ [Char]
e) [Char]
x [[Char]]
xs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

insertBar :: [String] -> [String]
insertBar :: [[Char]] -> [[Char]]
insertBar [] = []
insertBar [[Char]
x]    = [[Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x]
insertBar ([Char]
x:[[Char]]
xs) = ([Char]
"    " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
x ) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:  ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"  | " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++) [[Char]]
xs

mutualDefs :: [String] -> [String]
mutualDefs :: [[Char]] -> [[Char]]
mutualDefs [[Char]]
defs = case [[Char]]
defs of
     []   -> []
     [[Char]
d]  -> [[Char]
"let rec" [Char] -> [Char] -> [Char]
+++ [Char]
d]
     [Char]
d:[[Char]]
ds -> ([Char]
"let rec" [Char] -> [Char] -> [Char]
+++ [Char]
d) [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]]
ds

-- | Escape @"@ and @\@.  TODO: escape unprintable characters!?
mkEsc :: String -> String
mkEsc :: [Char] -> [Char]
mkEsc [Char]
s = [Char]
"\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Char -> [Char]) -> [Char] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> [Char]
f [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"\""
  where
  f :: Char -> [Char]
f Char
x = if Char
x Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'"',Char
'\\'] then [Char]
"\\" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char
x] else [Char
x]