{-
    BNF Converter: Non-pretty-printer generator (no "deriving Show" in OCaml...)
    Copyright (C) 2005  Author:  Kristofer Johannisson

-}

-- there is no "deriving Show" in OCaml, although there are solutions based
-- on camlp4. Here we generate our own "show module".

{-# LANGUAGE LambdaCase #-}

module BNFC.Backend.OCaml.CFtoOCamlShow (cf2show, showsFunQual) where

import Data.Char(toLower)
import Data.List (intersperse)
import Data.Maybe (fromJust)

import BNFC.CF
import BNFC.Utils
import BNFC.Backend.OCaml.OCamlUtil

cf2show :: String -> ModuleName -> CF -> String
cf2show :: [Char] -> [Char] -> CF -> [Char]
cf2show [Char]
_name [Char]
absMod CF
cf = [[Char]] -> [Char]
unlines
  [ [Char]
prologue
  , [Char]
integerRule
  , [Char]
doubleRule
  , if CF -> Bool
forall f. CFG f -> Bool
hasIdent CF
cf then [Char] -> CF -> [Char]
identRule [Char]
absMod CF
cf else [Char]
""
  , [[Char]] -> [Char]
unlines [ [Char] -> CF -> [Char] -> [Char]
ownPrintRule [Char]
absMod CF
cf [Char]
own | ([Char]
own,Reg
_) <- CF -> [([Char], Reg)]
forall f. CFG f -> [([Char], Reg)]
tokenPragmas CF
cf ]
  , [Char] -> CF -> [Char]
rules [Char]
absMod CF
cf
  ]


prologue :: String
prologue :: [Char]
prologue = [[Char]] -> [Char]
unlines [
  [Char]
"(* show functions *)",
  [Char]
"",
  [Char]
"(* use string buffers for efficient string concatenations *)",
  [Char]
"type showable = Buffer.t -> unit",
  [Char]
"",
  [Char]
"let show (s : showable) : string = ",
  [Char]
"    let init_size = 16 in (* you may want to adjust this *)",
  [Char]
"    let b = Buffer.create init_size in",
  [Char]
"    s b;",
  [Char]
"    Buffer.contents b",
  [Char]
"    ",
  [Char]
"let emptyS : showable = fun buf -> ()",
  [Char]
"",
  [Char]
"let c2s (c:char) : showable = fun buf -> Buffer.add_char buf c",
  [Char]
"let s2s (s:string) : showable = fun buf -> Buffer.add_string buf s",
  [Char]
"",
  [Char]
"let ( >> ) (s1 : showable) (s2 : showable) : showable = fun buf -> s1 buf; s2 buf",
  [Char]
"",
  [Char]
"let showChar (c:char) : showable = fun buf -> ",
  [Char]
"    Buffer.add_string buf (\"'\" ^ Char.escaped c ^ \"'\")",
  [Char]
"",
  [Char]
"let showString (s:string) : showable = fun buf -> ",
  [Char]
"    Buffer.add_string buf (\"\\\"\" ^ String.escaped s ^ \"\\\"\")",
  [Char]
"",
  [Char]
"let showList (showFun : 'a -> showable) (xs : 'a list) : showable = fun buf -> ",
  [Char]
"    let rec f ys = match ys with",
  [Char]
"        [] -> ()",
  [Char]
"      | [y] -> showFun y buf",
  [Char]
"      | y::ys -> showFun y buf; Buffer.add_string buf \"; \"; f ys ",
  [Char]
"    in",
  [Char]
"        Buffer.add_char buf '[';",
  [Char]
"        f xs;",
  [Char]
"        Buffer.add_char buf ']'",
  [Char]
""
  ]

integerRule :: String
integerRule :: [Char]
integerRule = [Char]
"let showInt (i:int) : showable = s2s (string_of_int i)"

doubleRule :: String
doubleRule :: [Char]
doubleRule = [Char]
"let showFloat (f:float) : showable = s2s (string_of_float f)"

identRule :: ModuleName -> CF -> String
identRule :: [Char] -> CF -> [Char]
identRule [Char]
absMod CF
cf = [Char] -> CF -> [Char] -> [Char]
ownPrintRule [Char]
absMod CF
cf [Char]
catIdent

ownPrintRule :: ModuleName -> CF -> TokenCat -> String
ownPrintRule :: [Char] -> CF -> [Char] -> [Char]
ownPrintRule [Char]
absMod CF
cf [Char]
own =
  [Char]
"let rec" [Char] -> [Char] -> [Char]
+++ Cat -> [Char]
showsFun ([Char] -> Cat
TokenCat [Char]
own) [Char] -> [Char] -> [Char]
+++ [Char]
"(" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
absMod [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
own [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
posn [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") : showable = s2s \""
  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
own [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" \" >> showString i"
 where
   posn :: [Char]
posn = if CF -> [Char] -> Bool
forall f. CFG f -> [Char] -> Bool
isPositionCat CF
cf [Char]
own then [Char]
" (_,i)" else [Char]
" i"

-- copy and paste from CFtoTemplate

rules :: ModuleName -> CF -> String
rules :: [Char] -> CF -> [Char]
rules [Char]
absMod CF
cf = [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
mutualDefs ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
  (Data -> [Char]) -> [Data] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Cat
s, [([Char], [Cat])]
xs) -> [Char]
-> Cat
-> [(([Char], [[Char]]), (Cat, [Either Cat [Char]]))]
-> [Char]
forall a t.
[Char]
-> Cat -> [(([Char], [[Char]]), (a, [Either Cat t]))] -> [Char]
case_fun [Char]
absMod Cat
s ([(([Char], [[Char]]), (Cat, [Either Cat [Char]]))] -> [Char])
-> [(([Char], [[Char]]), (Cat, [Either Cat [Char]]))] -> [Char]
forall a b. (a -> b) -> a -> b
$ (([Char], [Cat])
 -> (([Char], [[Char]]), (Cat, [Either Cat [Char]])))
-> [([Char], [Cat])]
-> [(([Char], [[Char]]), (Cat, [Either Cat [Char]]))]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Cat]) -> (([Char], [[Char]]), (Cat, [Either Cat [Char]]))
toArgs [([Char], [Cat])]
xs) ([Data] -> [[Char]]) -> [Data] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [Data]
cf2data CF
cf
  where
   toArgs :: ([Char], [Cat]) -> (([Char], [[Char]]), (Cat, [Either Cat [Char]]))
toArgs ([Char]
cons,[Cat]
args) = (([Char]
cons, [[Char]] -> Int -> [[Char]]
forall {t}. (Show t, Num t) => [[Char]] -> t -> [[Char]]
names ((Cat -> [Char]) -> [Cat] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> [Char]
checkRes ([Char] -> [Char]) -> (Cat -> [Char]) -> Cat -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cat -> [Char]
var) [Cat]
args) (Int
0 :: Int)),
                         [Char] -> (Cat, [Either Cat [Char]])
ruleOf [Char]
cons)
   names :: [[Char]] -> t -> [[Char]]
names [] t
_ = []
   names ([Char]
x:[[Char]]
xs) t
n
     | [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
x [[Char]]
xs = ([Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ t -> [Char]
forall a. Show a => a -> [Char]
show t
n) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> t -> [[Char]]
names [[Char]]
xs (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1)
     | Bool
otherwise = [Char]
x             [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> t -> [[Char]]
names [[Char]]
xs t
n
   var :: Cat -> [Char]
var (ListCat Cat
c)      = Cat -> [Char]
var Cat
c [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"s"
   var (Cat [Char]
"Ident")    = [Char]
"id"
   var (Cat [Char]
"Integer")  = [Char]
"n"
   var (Cat [Char]
"String")   = [Char]
"str"
   var (Cat [Char]
"Char")     = [Char]
"c"
   var (Cat [Char]
"Double")   = [Char]
"d"
   var Cat
cat              = (Char -> Char) -> [Char] -> [Char]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (Cat -> [Char]
catToStr Cat
cat)
   checkRes :: [Char] -> [Char]
checkRes [Char]
s
        | [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
s [[Char]]
reservedOCaml = [Char]
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
        | Bool
otherwise              = [Char]
s
   ruleOf :: [Char] -> (Cat, [Either Cat [Char]])
ruleOf [Char]
s = Maybe (Cat, [Either Cat [Char]]) -> (Cat, [Either Cat [Char]])
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Cat, [Either Cat [Char]]) -> (Cat, [Either Cat [Char]]))
-> Maybe (Cat, [Either Cat [Char]]) -> (Cat, [Either Cat [Char]])
forall a b. (a -> b) -> a -> b
$ WithPosition [Char]
-> [Rul (WithPosition [Char])] -> Maybe (Cat, [Either Cat [Char]])
forall f. Eq f => f -> [Rul f] -> Maybe (Cat, [Either Cat [Char]])
lookupRule ([Char] -> WithPosition [Char]
forall a. a -> WithPosition a
noPosition [Char]
s) (CF -> [Rul (WithPosition [Char])]
forall function. CFG function -> [Rul function]
cfgRules CF
cf)

-- case_fun :: Cat -> [(Constructor,Rule)] -> String
case_fun :: String
         -> Cat -> [((String, [String]), (a, [Either Cat t]))] -> String
case_fun :: forall a t.
[Char]
-> Cat -> [(([Char], [[Char]]), (a, [Either Cat t]))] -> [Char]
case_fun [Char]
absMod Cat
cat [(([Char], [[Char]]), (a, [Either Cat t]))]
xs = [[Char]] -> [Char]
unlines [
  Cat -> [Char]
showsFun Cat
cat [Char] -> [Char] -> [Char]
+++ [Char]
"(e : " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> Cat -> [Char]
fixTypeQual [Char]
absMod Cat
cat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
") : showable = match e with",
  [[Char]] -> [Char]
unlines ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
insertBar ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ((([Char], [[Char]]), (a, [Either Cat t])) -> [Char])
-> [(([Char], [[Char]]), (a, [Either Cat t]))] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (([Char]
c,[[Char]]
xx),(a, [Either Cat t])
r) ->
    [Char]
"   " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
absMod [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"." [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
c [Char] -> [Char] -> [Char]
+++ [[Char]] -> [Char]
mkTuple [[Char]]
xx [Char] -> [Char] -> [Char]
+++ [Char]
"->" [Char] -> [Char] -> [Char]
+++
    [Char]
"s2s" [Char] -> [Char] -> [Char]
+++ [Char] -> [Char]
forall a. Show a => a -> [Char]
show [Char]
c [Char] -> [Char] -> [Char]
+++
    case [[Char]] -> [Either Cat t] -> [Char]
forall t. [[Char]] -> [Either Cat t] -> [Char]
mkRhs [[Char]]
xx ((a, [Either Cat t]) -> [Either Cat t]
forall a b. (a, b) -> b
snd (a, [Either Cat t])
r) of {[] -> []; [Char]
str -> [Char]
">> c2s ' ' >> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str}
    )
    [(([Char], [[Char]]), (a, [Either Cat t]))]
xs
  ]

mkRhs :: [String] -> [Either Cat t] -> String
mkRhs :: forall t. [[Char]] -> [Either Cat t] -> [Char]
mkRhs [[Char]]
args [Either Cat t]
its =
  case [[Char]] -> [Char]
unwords ([Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
intersperse [Char]
" >> s2s \", \" >> " ([[Char]] -> [Either Cat t] -> [[Char]]
forall {b}. [[Char]] -> [Either Cat b] -> [[Char]]
mk [[Char]]
args [Either Cat t]
its)) of
    [] -> [Char]
""
    [Char]
str -> [Char]
"c2s '(' >> " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
str [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" >> c2s ')'"
 where
  mk :: [[Char]] -> [Either Cat b] -> [[Char]]
mk ([Char]
arg:[[Char]]
args) (Left Cat
c : [Either Cat b]
items)  = (Cat -> [Char]
showsFun Cat
c [Char] -> [Char] -> [Char]
+++ [Char]
arg)        [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [Either Cat b] -> [[Char]]
mk [[Char]]
args [Either Cat b]
items
  mk [[Char]]
args       (Right b
_ : [Either Cat b]
items) = [[Char]] -> [Either Cat b] -> [[Char]]
mk [[Char]]
args [Either Cat b]
items
  mk [[Char]]
_ [Either Cat b]
_ = []

showsFun :: Cat -> String
showsFun :: Cat -> [Char]
showsFun = ([Char] -> [Char]) -> Cat -> [Char]
showsFunQual [Char] -> [Char]
forall a. a -> a
id

showsFunQual :: (String -> String) -> Cat -> String
showsFunQual :: ([Char] -> [Char]) -> Cat -> [Char]
showsFunQual [Char] -> [Char]
qual = Cat -> [Char]
loop where
  loop :: Cat -> [Char]
loop = \case
    ListCat Cat
c -> [Char] -> [Char]
qual [Char]
"showList" [Char] -> [Char] -> [Char]
+++ Cat -> [Char]
loop Cat
c
    Cat
c         -> [Char] -> [Char]
qual [Char]
"show" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Cat -> [Char]
fixTypeUpper (Cat -> [Char]) -> Cat -> [Char]
forall a b. (a -> b) -> a -> b
$ Cat -> Cat
normCat Cat
c)