{-
    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 -> String
fixType = String -> Cat -> String
fixTypeQual String
""

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

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


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

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

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

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

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

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

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