{-
    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 _name absMod cf = unlines
  [ prologue
  , integerRule
  , doubleRule
  , if hasIdent cf then identRule absMod cf else ""
  , unlines [ ownPrintRule absMod cf own | (own,_) <- tokenPragmas cf ]
  , rules absMod cf
  ]


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

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

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


identRule absMod cf = ownPrintRule absMod cf catIdent

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

-- copy and paste from CFtoTemplate

rules :: ModuleName -> CF -> String
rules absMod cf = unlines $ mutualDefs $
  map (\ (s, xs) -> case_fun absMod s $ map toArgs xs) $ cf2data cf
  where
   toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)),
                         ruleOf cons)
   names [] _ = []
   names (x:xs) n
     | elem x xs = (x ++ show n) : names xs (n+1)
     | otherwise = x             : names xs n
   var (ListCat c)      = var c ++ "s"
   var (Cat "Ident")    = "id"
   var (Cat "Integer")  = "n"
   var (Cat "String")   = "str"
   var (Cat "Char")     = "c"
   var (Cat "Double")   = "d"
   var cat              = map toLower (catToStr cat)
   checkRes s
        | elem s reservedOCaml = s ++ "'"
        | otherwise              = s
   ruleOf s = fromJust $ lookupRule (noPosition s) (cfgRules cf)

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


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

showsFun :: Cat -> String
showsFun = showsFunQual id

showsFunQual :: (String -> String) -> Cat -> String
showsFunQual qual = loop where
  loop = \case
    ListCat c -> qual "showList" +++ loop c
    c         -> qual "show" ++ (fixTypeUpper $ normCat c)