{-
    BNF Converter: Pretty-printer generator
    Copyright (C) 2005  Author:  Kristofer Johannisson

-}

-- based on BNFC Haskell backend

{-# LANGUAGE OverloadedStrings #-}

module BNFC.Backend.OCaml.CFtoOCamlPrinter (cf2Printer, prtFun) where

import Prelude hiding ((<>))

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

import BNFC.CF
import BNFC.Utils
import BNFC.Backend.OCaml.OCamlUtil
import BNFC.PrettyPrint
import BNFC.Backend.Haskell.CFtoPrinter (compareRules)


-- derive pretty-printer from a BNF grammar. AR 15/2/2002
cf2Printer :: String -> ModuleName -> CF -> String
cf2Printer :: String -> String -> CF -> String
cf2Printer String
_name String
absMod CF
cf = [String] -> String
unlines [
  String
prologue,
  CF -> String
charRule CF
cf,
  CF -> String
integerRule CF
cf,
  CF -> String
doubleRule CF
cf,
  CF -> String
stringRule CF
cf,
  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
"(* pretty-printer generated by the BNF converter *)",
  String
"",
  String
"open Printf",
  String
"",
  String
"(* We use string buffers for efficient string concatenation.",
  String
"   A document takes a buffer and an indentation, has side effects on the buffer",
  String
"   and returns a new indentation. The indentation argument indicates the level",
  String
"   of indentation to be used if a new line has to be started (because of what is",
  String
"   already in the buffer) *)",
  String
"type doc = Buffer.t -> int -> int",
  String
"",
  String
"let rec printTree (printer : int -> 'a -> doc) (tree : 'a) : string = ",
  String
"    let buffer_init_size = 64 (* you may want to change this *)",
  String
"    in let buffer = Buffer.create buffer_init_size",
  String
"    in ",
  String
"        let _ = printer 0 tree buffer 0 in (* discard return value *)",
  String
"        Buffer.contents buffer",
  String
"",
  String
"let indent_width = 4",
  String
"",
  String
"let indent (i: int) : string = \"\\n\" ^ String.make i ' '",
  String
"",
  String
"(* To avoid dependency on package extlib, which has",
  String
"   Extlib.ExtChar.Char.is_whitespace, we employ the following awkward",
  String
"   way to check a character for whitespace.",
  String
"   Note: String.trim exists in the core libraries since Ocaml 4.00. *)",
  String
"let isWhiteSpace (c: char) : bool = String.trim (String.make 1 c) = \"\"",
  String
"",
  String
"(* this render function is written for C-style languages, you may want to change it *)",
  String
"let render (s : string) : doc = fun buf i -> ",
  String
"    (* invariant: last char of the buffer is never whitespace *)",
  String
"    let n = Buffer.length buf in",
  String
"    let last = if n = 0 then None else Some (Buffer.nth buf (n-1)) in",
  String
"    let whitespace = match last with",
  String
"        None -> \"\" ",
  String
"      | Some '{' -> indent i",
  String
"      | Some '}' -> (match s with",
  String
"            \";\" -> \"\"",
  String
"          | _ -> indent i)",
  String
"      | Some ';' -> indent i",
  String
"      | (Some '[') |  (Some '(') -> \"\"",
  String
"      | Some c -> if isWhiteSpace c then \"\" else (match s with",
  String
"            \",\" | \")\" | \"]\" -> \"\"",
  String
"           | _ -> if String.trim s = \"\" then \"\" else \" \") in",
  String
"    let newindent = match s with",
  String
"        \"{\" -> i + indent_width",
  String
"      | \"}\" -> i - indent_width",
  String
"      | _ -> i in",
  String
"    Buffer.add_string buf whitespace;",
  String
"    Buffer.add_string buf s;",
  String
"    newindent",
  String
"",
  String
"let emptyDoc : doc = fun buf i -> i",
  String
"",
  String
"let concatD (ds : doc list) : doc = fun buf i -> ",
  String
"    List.fold_left (fun accIndent elemDoc -> elemDoc buf accIndent) (emptyDoc buf i) ds",
  String
"",
  String
"let parenth (d:doc) : doc = concatD [render \"(\"; d; render \")\"]",
  String
"",
  String
"let prPrec (i:int) (j:int) (d:doc) : doc = if j<i then parenth d else d",
  String
""
  ]

charRule :: CF -> String
charRule CF
cf = [String] -> String
unlines [
    String
"let rec prtChar (_:int) (c:char) : doc = render (\"'\" ^ Char.escaped c ^ \"'\")",
    CF -> Cat -> String
ifList CF
cf (String -> Cat
TokenCat String
catChar),
    String
""
    ]

integerRule :: CF -> String
integerRule CF
cf = [String] -> String
unlines [
    String
"let rec prtInt (_:int) (i:int) : doc = render (string_of_int i)",
    CF -> Cat -> String
ifList CF
cf (String -> Cat
TokenCat String
catInteger),
    String
""
    ]

doubleRule :: CF -> String
doubleRule CF
cf = [String] -> String
unlines [
    String
"let rec prtFloat (_:int) (f:float) : doc = render (sprintf \"%.15g\" f)",
    CF -> Cat -> String
ifList CF
cf (String -> Cat
TokenCat String
catDouble),
    String
""
    ]

stringRule :: CF -> String
stringRule CF
cf = [String] -> String
unlines [
    String
"let rec prtString (_:int) (s:string) : doc = render (\"\\\"\" ^ String.escaped s ^ \"\\\"\")",
    CF -> Cat -> String
ifList CF
cf (String -> Cat
TokenCat String
catString),
    String
""
    ]

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] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [
  String
"let rec" String -> String -> String
+++ Cat -> String
prtFun (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
") : doc = render i",
  CF -> Cat -> String
ifList CF
cf (String -> Cat
TokenCat String
own)
  ]
 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
case_fun String
absMod Cat
s (((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) String -> String -> String
forall a. [a] -> [a] -> [a]
++ CF -> Cat -> String
ifList CF
cf Cat
s) ([(Cat, [(String, [Cat])])] -> [String])
-> [(Cat, [(String, [Cat])])] -> [String]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [(String, [Cat])])]
cf2data CF
cf
 where
   reserved :: [String]
reserved = String
"i"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
"e"String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
reservedOCaml
   toArgs :: (String, [Cat]) -> ((String, [String]), (Cat, [Either Cat String]))
toArgs (String
cons,[Cat]
args) = ((String
cons, [String] -> NameStyle -> [String] -> [String]
mkNames [String]
reserved NameStyle
LowerCase ((Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Cat -> String
var [Cat]
args)), String -> (Cat, [Either Cat String])
ruleOf String
cons)
   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
xs        = (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
xs)
   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]), (Cat, [Either Cat String]))]
-> String
case_fun String
absMod Cat
cat [((String, [String]), (Cat, [Either Cat String]))]
xs = [String] -> String
unlines [
--  "instance Print" +++ cat +++ "where",
  Cat -> String
prtFun Cat
cat String -> String -> String
+++String
"(i:int)" 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
") : doc = 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]), (Cat, [Either Cat String])) -> String)
-> [((String, [String]), (Cat, [Either Cat String]))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ ((String
c,[String]
xx),(Cat, [Either Cat String])
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
"prPrec i" String -> String -> String
+++ Integer -> String
forall a. Show a => a -> String
show (Cat -> Integer
precCat ((Cat, [Either Cat String]) -> Cat
forall a b. (a, b) -> a
fst (Cat, [Either Cat String])
r)) String -> String -> String
+++ [String] -> [Either Cat String] -> String
mkRhs [String]
xx ((Cat, [Either Cat String]) -> [Either Cat String]
forall a b. (a, b) -> b
snd (Cat, [Either Cat String])
r)) [((String, [String]), (Cat, [Either Cat String]))]
xs
  ]

-- ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where
--   nil cat  = ["    []    -> " ++ mkRhs [] its |
--                             Rule f c its <- rulesOfCF cf, isNilFun f , normCatOfList c == cat]
--   one cat  = ["  | [x]   -> " ++ mkRhs ["x"] its |
--                             Rule f c its <- rulesOfCF cf, isOneFun f , normCatOfList c == cat]
--   cons cat = ["  | x::xs -> " ++ mkRhs ["x","xs"] its |
--                             Rule f c its <- rulesOfCF cf, isConsFun f , normCatOfList c == cat]
--   mkListRule [] = ""
--   mkListRule rs = unlines $ ("and prt" ++ fixTypeUpper cat ++ "ListBNFC" +++ "_ es : doc = match es with"):rs

ifList :: CF -> Cat -> String
ifList :: CF -> Cat -> String
ifList CF
cf Cat
cat = case [Doc]
cases of
    []        -> String
""
    Doc
first:[Doc]
rest -> Doc -> String
render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat
        [ Doc
"and prt" Doc -> Doc -> Doc
<> String -> Doc
text (Cat -> String
fixTypeUpper Cat
cat)  Doc -> Doc -> Doc
<> Doc
"ListBNFC i es : doc = match (i, es) with"
        , Int -> Doc -> Doc
nest Int
4 Doc
first
        , Int -> Doc -> Doc
nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ((Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc
"|" Doc -> Doc -> Doc
<+>) [Doc]
rest)
        ]
  where
    rules :: [Rul (WithPosition String)]
rules = (Rul (WithPosition String)
 -> Rul (WithPosition String) -> Ordering)
-> [Rul (WithPosition String)] -> [Rul (WithPosition String)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy Rul (WithPosition String) -> Rul (WithPosition String) -> Ordering
forall f. IsFun f => Rul f -> Rul f -> Ordering
compareRules ([Rul (WithPosition String)] -> [Rul (WithPosition String)])
-> [Rul (WithPosition String)] -> [Rul (WithPosition String)]
forall a b. (a -> b) -> a -> b
$ CF -> Cat -> [Rul (WithPosition String)]
rulesForNormalizedCat CF
cf (Cat -> Cat
ListCat Cat
cat)
    cases :: [Doc]
cases = [ Rul (WithPosition String) -> Doc
mkPrtListCase Rul (WithPosition String)
r | Rul (WithPosition String)
r <- [Rul (WithPosition String)]
rules ]


-- | Pattern match on the list constructor and the coercion level
--
-- >>> mkPrtListCase (npRule "[]" (ListCat (Cat "Foo")) [] Parsable)
-- (_,[]) -> (concatD [])
--
-- >>> mkPrtListCase (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "Foo")] Parsable)
-- (_,[x]) -> (concatD [prtFoo 0 x])
--
-- >>> mkPrtListCase (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable)
-- (_,x::xs) -> (concatD [prtFoo 0 x ; prtFooListBNFC 0 xs])
--
-- >>> mkPrtListCase (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable)
-- (2,[]) -> (concatD [])
--
-- >>> mkPrtListCase (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable)
-- (2,[x]) -> (concatD [prtFoo 2 x])
--
-- >>> mkPrtListCase (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable)
-- (2,x::xs) -> (concatD [prtFoo 2 x ; prtFooListBNFC 2 xs])
--
mkPrtListCase :: Rule -> Doc
mkPrtListCase :: Rul (WithPosition String) -> Doc
mkPrtListCase (Rule WithPosition String
f (WithPosition Position
_ (ListCat Cat
c)) [Either Cat String]
rhs InternalRule
_)
  | WithPosition String -> Bool
forall a. IsFun a => a -> Bool
isNilFun WithPosition String
f  = Doc -> Doc
parens (Doc
precPattern Doc -> Doc -> Doc
<> Doc
"," Doc -> Doc -> Doc
<> Doc
"[]") Doc -> Doc -> Doc
<+> Doc
"->" Doc -> Doc -> Doc
<+> Doc
body
  | WithPosition String -> Bool
forall a. IsFun a => a -> Bool
isOneFun WithPosition String
f  = Doc -> Doc
parens (Doc
precPattern Doc -> Doc -> Doc
<> Doc
"," Doc -> Doc -> Doc
<> Doc
"[x]") Doc -> Doc -> Doc
<+> Doc
"->" Doc -> Doc -> Doc
<+> Doc
body
  | WithPosition String -> Bool
forall a. IsFun a => a -> Bool
isConsFun WithPosition String
f = Doc -> Doc
parens (Doc
precPattern Doc -> Doc -> Doc
<> Doc
"," Doc -> Doc -> Doc
<>Doc
"x::xs") Doc -> Doc -> Doc
<+> Doc
"->" Doc -> Doc -> Doc
<+> Doc
body
  | Bool
otherwise = Doc
empty -- (++) constructor
  where
    precPattern :: Doc
precPattern = case Cat -> Integer
precCat Cat
c of Integer
0 -> Doc
"_" ; Integer
p -> Integer -> Doc
integer Integer
p
    body :: Doc
body = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> [Either Cat String] -> String
mkRhs [String
"x", String
"xs"] [Either Cat String]
rhs
mkPrtListCase Rul (WithPosition String)
_ = String -> Doc
forall a. HasCallStack => String -> a
error String
"mkPrtListCase undefined for non-list categories"

mkRhs :: [String] -> [Either Cat String] -> String
mkRhs [String]
args [Either Cat String]
its =
  String
"(concatD [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
";" ([String] -> [Either Cat String] -> [String]
mk [String]
args [Either Cat String]
its)) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"])"
 where
  mk :: [String] -> [Either Cat String] -> [String]
mk (String
arg:[String]
args) (Left Cat
c : [Either Cat String]
items)  = (Cat -> String
prt Cat
c String -> String -> String
+++ String
arg)        String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [Either Cat String] -> [String]
mk [String]
args [Either Cat String]
items
  mk [String]
args       (Right String
s : [Either Cat String]
items) = (String
"render " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkEsc String
s) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [Either Cat String] -> [String]
mk [String]
args [Either Cat String]
items
  mk [String]
_ [Either Cat String]
_ = []
  prt :: Cat -> String
prt Cat
c = Cat -> String
prtFun Cat
c String -> String -> String
+++ Integer -> String
forall a. Show a => a -> String
show (Cat -> Integer
precCat Cat
c)

prtFun :: Cat -> String
prtFun :: Cat -> String
prtFun (ListCat Cat
c) = Cat -> String
prtFun Cat
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"ListBNFC"
prtFun Cat
c = String
"prt" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
fixTypeUpper (Cat -> Cat
normCat Cat
c)