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


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

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

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


identRule :: String -> CF -> String
identRule String
absMod CF
cf = String -> CF -> String -> String
ownPrintRule String
absMod CF
cf String
catIdent

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

-- copy and paste from CFtoTemplate

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

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


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

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

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