{-
    BNF Converter: XML generator
    Copyright (C) 2004  Author:  Aarne Ranta

-}

module BNFC.Backend.XML ---- (cf2DTD, cf2XML)
  where

import Data.Bifunctor ( second )
import Data.List      ( intercalate )

import BNFC.CF
import BNFC.Utils
import BNFC.Backend.Base
import BNFC.Options hiding ( Backend )
import BNFC.Backend.Haskell.CFtoTemplate ()
import BNFC.Backend.Haskell.HsOpts ( xmlFile, xmlFileM, absFileM )
import BNFC.Backend.Haskell.Utils  ( catToVar )

type Coding = Bool ---- change to at least three values

makeXML :: SharedOptions -> Coding -> CF -> Backend
makeXML :: SharedOptions -> Coding -> CF -> Backend
makeXML SharedOptions
opts Coding
typ CF
cf = do
  let name :: String
name = SharedOptions -> String
lang SharedOptions
opts
  String -> String -> Backend
forall c. FileContent c => String -> c -> Backend
mkfile (String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".dtd") (String -> Backend) -> String -> Backend
forall a b. (a -> b) -> a -> b
$ Coding -> String -> CF -> String
cf2DTD Coding
typ String
name CF
cf
  let absmod :: String
absmod = String
"XML" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name
  String -> String -> Backend
forall c. FileContent c => String -> c -> Backend
mkfile (SharedOptions -> String
xmlFile SharedOptions
opts) (String -> Backend) -> String -> Backend
forall a b. (a -> b) -> a -> b
$ Coding -> SharedOptions -> String -> CF -> String
cf2XMLPrinter Coding
typ SharedOptions
opts String
absmod CF
cf

-- derive a DTD from a BNF grammar. AR 21/8/2004
cf2DTD :: Coding -> String -> CF -> String
cf2DTD :: Coding -> String -> CF -> String
cf2DTD Coding
typ String
name CF
cf = [String] -> String
unlines [
  String -> String
tag String
"?xml version=\"1.0\" standalone=\"yes\"?",
  String
"<!DOCTYPE " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" [",
  String -> String
elemEmp String
"Integer",
  String -> String
elemEmp String
"Double",
  String -> String
elemEmp String
"String",
  if CF -> Coding
forall f. CFG f -> Coding
hasIdent CF
cf then String -> String
elemEmp String
"Ident" else String
"",
  [String] -> String
unlines [String -> String
elemEmp String
own | String
own <- CF -> [String]
forall f. CFG f -> [String]
tokenNames CF
cf],
  [String] -> String
unlines (((Cat, [(String, [Cat])]) -> String)
-> [(Cat, [(String, [Cat])])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Coding -> CF -> (Cat, [(String, [Cat])]) -> String
elemData Coding
typ CF
cf) (CF -> [(Cat, [(String, [Cat])])]
cf2data CF
cf)),
  String
"]>"
  ]

-- | >>> tag "test"
-- "<test>"
tag :: String -> String
tag :: String -> String
tag String
s = String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"

element :: String -> [String] -> String
element :: String -> [String] -> String
element String
t [String]
ts =
  String -> String
tag (String
"!ELEMENT " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
alts [String]
ts)

attlist :: String -> String -> String
attlist String
t String
a =
  String -> String
tag (String
"!ATTLIST " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" CDATA #REQUIRED")
elemAtt :: String -> String -> [String] -> String
elemAtt String
t String
a [String]
ts = String -> [String] -> String
element String
t [String]
ts String -> String -> String
++++ String -> String -> String
attlist String
t String
a
elemt :: String -> [String] -> String
elemt String
t = String -> String -> [String] -> String
elemAtt String
t String
"name"

elemc :: Cat -> [(Fun, String)] -> String
elemc :: Cat -> [(String, String)] -> String
elemc Cat
cat [(String, String)]
fs = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
element (Cat -> String
forall a. Show a => a -> String
show Cat
cat) (((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> String
forall a b. (a, b) -> b
snd [(String, String)]
fs) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String -> [String] -> String
element String
f [] | (String
f,String
_) <- [(String, String)]
fs]

elemEmp :: String -> String
elemEmp :: String -> String
elemEmp String
t = String -> String -> [String] -> String
elemAtt String
t String
"value" []

alts :: [String] -> String
alts :: [String] -> String
alts [String]
ts = if [String] -> Coding
forall (t :: * -> *) a. Foldable t => t a -> Coding
null [String]
ts then String
"EMPTY" else String -> String
parenth (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" | " [String]
ts

-- choose between these two encodings:

elemData :: Coding -> CF -> (Cat, [(String, [Cat])]) -> String
elemData Coding
b  = if Coding
b then CF -> (Cat, [(String, [Cat])]) -> String
elemDataConstr else CF -> (Cat, [(String, [Cat])]) -> String
forall a. CF -> (a, [(String, [Cat])]) -> String
elemDataNotyp
efunDef :: Coding -> String
efunDef Coding
b   = if Coding
b then String
efunDefConstr else String
efunDefNotyp
endtagDef :: Coding -> String
endtagDef Coding
b = if Coding
b then String
endtagDefConstr else String
endtagDefNotyp

-- coding 0: ---- not finished
-- to show both types and constructors as tags;
-- lengthy, but validation guarantees type correctness
-- flag -xmlt
elemDataConstrs :: CF -> (Cat, [(String, [Cat])]) -> String
elemDataConstrs CF
cf (Cat
cat,[(String, [Cat])]
fcs) = Cat -> [(String, String)] -> String
elemc Cat
cat [(String
f,CF -> String -> [Cat] -> String
rhsCat CF
cf String
f [Cat]
cs) | (String
f,[Cat]
cs) <- [(String, [Cat])]
fcs]
efunDefConstrs :: String
efunDefConstrs = String
"elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"
endtagDefConstrs :: String
endtagDefConstrs = String
"endtag f c = tag (\"/\" ++ c)"

-- coding 1:
-- to show constructors as empty tags;
-- shorter than 0, but validation still guarantees type correctness
-- flag -xmlt
elemDataConstr :: CF -> (Cat, [(String, [Cat])]) -> String
elemDataConstr CF
cf (Cat
cat,[(String, [Cat])]
fcs) = Cat -> [(String, String)] -> String
elemc Cat
cat [(String
f,CF -> String -> [Cat] -> String
rhsCat CF
cf String
f [Cat]
cs) | (String
f,[Cat]
cs) <- [(String, [Cat])]
fcs]
efunDefConstr :: String
efunDefConstr = String
"elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"
endtagDefConstr :: String
endtagDefConstr = String
"endtag f c = tag (\"/\" ++ c)"

-- coding 2:
-- constructors as tags, no types.
-- clumsy DTD, but nice trees. Validation guarantees type correctness
-- flag -xml
elemDataNotyp :: CF -> (a, [(String, [Cat])]) -> String
elemDataNotyp CF
cf (a
_,[(String, [Cat])]
fcs) = [String] -> String
unlines [String -> [String] -> String
element String
f [CF -> [Cat] -> String
rhsCatNot CF
cf [Cat]
cs] | (String
f,[Cat]
cs) <- [(String, [Cat])]
fcs]
efunDefNotyp :: String
efunDefNotyp = String
"elemFun i t x = [replicate (i+i) ' ' ++ tag x]"
endtagDefNotyp :: String
endtagDefNotyp = String
"endtag f c = tag (\"/\" ++ f)"


-- to show constructors as attributes;
-- nice, but validation does not guarantee type correctness.
-- Therefore rejected.
-- elemDataAttr cf (cat,fcs) = elemt cat (nub [rhsCat cf cs | (_,cs) <- fcs])
-- efunDefAttr =  "elemFun i t x = [replicate (i+i) ' ' ++ tag (t ++ \" name = \" ++ x)]"

rhsCat :: CF -> Fun -> [Cat] -> String
rhsCat :: CF -> String -> [Cat] -> String
rhsCat CF
cf String
fun [Cat]
cs = String -> String
parenth (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (String
funString -> [String] -> [String]
forall a. a -> [a] -> [a]
:(Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CF -> Cat -> String
symbCat CF
cf) [Cat]
cs))
rhsCatNot :: CF -> [Cat] -> String
rhsCatNot CF
cf [Cat]
cs = if [Cat] -> Coding
forall (t :: * -> *) a. Foldable t => t a -> Coding
null [Cat]
cs then String
"EMPTY" else String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalateString
", " ((Cat -> String) -> [Cat] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CF -> Cat -> String
symbCatNot CF
cf) [Cat]
cs)

symbCat :: CF -> Cat -> String
symbCat CF
cf Cat
c
  | Cat -> Coding
isList Cat
c  = Cat -> String
forall a. Show a => a -> String
show (Cat -> Cat
normCatOfList Cat
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ if CF -> Cat -> Coding
isEmptyListCat CF
cf Cat
c then String
"*" else String
"+"
  | Coding
otherwise = Cat -> String
forall a. Show a => a -> String
show Cat
c

symbCatNot :: CF -> Cat -> String
symbCatNot CF
cf Cat
c
  | Cat -> Coding
isList Cat
c  = Cat -> String
funs (Cat -> Cat
normCatOfList Cat
c) String -> String -> String
forall a. [a] -> [a] -> [a]
++ if CF -> Cat -> Coding
isEmptyListCat CF
cf Cat
c then String
"*" else String
"+"
  | Coding
otherwise = Cat -> String
funs Cat
c
 where
   funs :: Cat -> String
funs Cat
k = case Cat -> [(Cat, [(String, [Cat])])] -> Maybe [(String, [Cat])]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Cat
k (CF -> [(Cat, [(String, [Cat])])]
cf2data CF
cf) of
     Just []  -> String
"EMPTY"
     Just [(String, [Cat])]
fcs -> String -> String
parenth (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" | " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((String, [Cat]) -> String) -> [(String, [Cat])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, [Cat]) -> String
forall a b. (a, b) -> a
fst [(String, [Cat])]
fcs
     Maybe [(String, [Cat])]
_ -> String -> String
parenth (Cat -> String
forall a. Show a => a -> String
show Cat
k) ----

parenth :: String -> String
parenth String
s = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- derive an XML printer from a BNF grammar
cf2XMLPrinter :: Bool -> SharedOptions -> String -> CF -> String
cf2XMLPrinter :: Coding -> SharedOptions -> String -> CF -> String
cf2XMLPrinter Coding
typ SharedOptions
opts String
absMod CF
cf = [String] -> String
unlines [
  SharedOptions -> String
pragmas SharedOptions
opts,
  Coding -> SharedOptions -> String -> String
prologue Coding
typ SharedOptions
opts String
absMod,
  CF -> String
forall p. p -> String
integerRule CF
cf,
  CF -> String
forall p. p -> String
doubleRule CF
cf,
  CF -> String
forall p. p -> String
stringRule CF
cf,
  if CF -> Coding
forall f. CFG f -> Coding
hasIdent CF
cf then CF -> String
identRule CF
cf else String
"",
  [String] -> String
unlines [CF -> String -> String
ownPrintRule CF
cf String
own | (String
own,Reg
_) <- CF -> [(String, Reg)]
forall f. CFG f -> [(String, Reg)]
tokenPragmas CF
cf],
  CF -> String
rules CF
cf
  ]

pragmas :: SharedOptions -> String
pragmas :: SharedOptions -> String
pragmas SharedOptions
opts =
  if SharedOptions -> Target
target SharedOptions
opts Target -> Target -> Coding
forall a. Eq a => a -> a -> Coding
== Target
TargetHaskellGadt
  then String
"{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GADTs #-}"
  else String
""

prologue :: Bool -> SharedOptions -> String -> String
prologue :: Coding -> SharedOptions -> String -> String
prologue Coding
b SharedOptions
opts String
_ = [String] -> String
unlines [
  String
"module " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SharedOptions -> String
xmlFileM SharedOptions
opts String -> String -> String
+++ String
"where\n",
  String
"-- pretty-printer generated by the BNF converter\n",
  String
"import " String -> String -> String
forall a. [a] -> [a] -> [a]
++ SharedOptions -> String
absFileM SharedOptions
opts,
  String
"import Data.Char",
  String
"",
  String
"-- the top-level printing method",
  String
"printXML :: XPrint a => a -> String",
  String
"printXML = render . prt 0",
  String
"",
  String
"render = unlines",
  String
"",
  String
"-- the printer class does the job",
  String
"class XPrint a where",
  String
"  prt :: Int -> a -> [String]",
  String
"  prtList :: Int -> [a] -> [String]",
  String
"  prtList i = concat . map (prt i)",
  String
"",
  String
"instance XPrint a => XPrint [a] where",
  String
"  prt = prtList",
  String
"",
  String
"tag t = \"<\" ++ t ++ \">\"",
  String
"etag t = \"<\" ++ t ++ \"/>\"",
  String
"elemTok i t x = [replicate (i+i) ' ' ++ tag (t ++ \" value = \" ++ show x ++ \" /\")]",
  String
"elemTokS i t x = elemTok i t (show x)",
  Coding -> String
efunDef Coding
b,
  Coding -> String
endtagDef Coding
b,
  String
""
  ]

integerRule :: p -> String
integerRule p
cf = p -> String -> String
forall p. p -> String -> String
showsPrintRule p
cf String
"Integer"
doubleRule :: p -> String
doubleRule p
cf = p -> String -> String
forall p. p -> String -> String
showsPrintRule p
cf String
"Double"
stringRule :: p -> String
stringRule p
cf = p -> String -> String
forall p. p -> String -> String
showsPrintRule p
cf String
"Char" String -> String -> String
++++ String
"  prtList i xs = elemTok i \"String\" xs"

showsPrintRule :: p -> String -> String
showsPrintRule p
_ String
t = [String] -> String
unlines [
  String
"instance XPrint " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where",
  String
"  prt i x = elemTokS i" String -> String -> String
+++ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> String
+++ String
"x"
  ]

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

ownPrintRule :: CF -> TokenCat -> String
ownPrintRule :: CF -> String -> String
ownPrintRule CF
cf String
cat = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
  [ String
"instance XPrint " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" where"
  , String
"  prt i (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
posn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") = elemTok i" String -> String -> String
+++ String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> String
+++ String
"x"
  ]
 where
   posn :: String
posn = if CF -> String -> Coding
forall f. CFG f -> String -> Coding
isPositionCat CF
cf String
cat then String
" (_,x)" else String
" x"

rules :: CF -> String
rules :: CF -> String
rules CF
cf = [String] -> String
unlines ([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) -> Cat -> [(String, [String])] -> String
case_fun Cat
s (((String, [Cat]) -> (String, [String]))
-> [(String, [Cat])] -> [(String, [String])]
forall a b. (a -> b) -> [a] -> [b]
map (([Cat] -> [String]) -> (String, [Cat]) -> (String, [String])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [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 :: [Cat] -> [String]
toArgs [Cat]
args = [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 Cat -> String
catToVar [Cat]
args) (Int
0 :: Int)
   names :: [String] -> t -> [String]
names [] t
_ = []
   names (String
x:[String]
xs) t
n
     | String
x String -> [String] -> Coding
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Coding
`elem` [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)
     | Coding
otherwise   = String
x             String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> t -> [String]
names [String]
xs t
n

case_fun :: Cat -> [(String, [String])] -> String
case_fun :: Cat -> [(String, [String])] -> String
case_fun Cat
cat [(String, [String])]
xs = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ [ String
"instance XPrint" String -> String -> String
+++ Cat -> String
forall a. Show a => a -> String
show Cat
cat String -> String -> String
+++ String
"where"
    , String
"  prt i" String -> String -> String
+++ String
"e = case e of"
    ]
  , (((String, [String]) -> String) -> [(String, [String])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
`map` [(String, [String])]
xs) (((String, [String]) -> String) -> [String])
-> ((String, [String]) -> String) -> [String]
forall a b. (a -> b) -> a -> b
$ \ (String
c, [String]
xx) ->
    String
"   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
+++ [String] -> String
unwords [String]
xx String -> String -> String
+++ String
"-> concat $ " String -> String -> String
+++
    String
"elemFun i \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
forall a. Show a => a -> String
show Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"" String -> String -> String
+++
    [String] -> String
unwords [String
": prt (i+1)" String -> String -> String
+++ String
x | String
x <- [String]
xx] String -> String -> String
+++ String
":" String -> String -> String
+++
    String
"[[replicate (i+i) ' ' ++ endtag \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\" \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Cat -> String
forall a. Show a => a -> String
show Cat
cat String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"]]"
  ]