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

-}

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

{-# OPTIONS_GHC -fno-warn-missing-signatures #-}

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

import Prelude hiding ((<>))

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

import BNFC.CF
import BNFC.PrettyPrint
import BNFC.Utils
import BNFC.Backend.Base (Backend, mkfile)
import BNFC.Options (SharedOptions(..), pattern TargetHaskellGadt)
import BNFC.Backend.Haskell.CFtoTemplate ()
import BNFC.Backend.Haskell.HsOpts ( xmlFile, xmlFileM, absFileM )
import BNFC.Backend.Haskell.Utils  ( catToVar )
import qualified BNFC.Backend.Haskell.Utils as Haskell

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 :: [Char]
name = SharedOptions -> [Char]
lang SharedOptions
opts
  forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile ([Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
".dtd") MakeComment
comment forall a b. (a -> b) -> a -> b
$ Coding -> [Char] -> CF -> [Char]
cf2DTD Coding
typ [Char]
name CF
cf
  let absmod :: [Char]
absmod = [Char]
"XML" forall a. [a] -> [a] -> [a]
++ [Char]
name
  forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
xmlFile SharedOptions
opts) MakeComment
Haskell.comment forall a b. (a -> b) -> a -> b
$ Coding -> SharedOptions -> [Char] -> CF -> [Char]
cf2XMLPrinter Coding
typ SharedOptions
opts [Char]
absmod CF
cf

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

comment :: String -> String
comment :: MakeComment
comment [Char]
x = [[Char]] -> [Char]
unwords [ [Char]
"<!--", [Char]
x, [Char]
"-->" ]

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

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

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

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

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

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

-- choose between these two encodings:

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

-- coding 0: ---- not finished
-- to show both types and constructors as tags;
-- lengthy, but validation guarantees type correctness
-- flag -xmlt
elemDataConstrs :: CF -> (Cat, [([Char], [Cat])]) -> [Char]
elemDataConstrs CF
cf (Cat
cat,[([Char], [Cat])]
fcs) = Cat -> [([Char], [Char])] -> [Char]
elemc Cat
cat [([Char]
f,CF -> [Char] -> [Cat] -> [Char]
rhsCat CF
cf [Char]
f [Cat]
cs) | ([Char]
f,[Cat]
cs) <- [([Char], [Cat])]
fcs]

efunDefConstrs :: String
efunDefConstrs :: [Char]
efunDefConstrs = [Char]
"elemFun i t x = [P.replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"

endtagDefConstrs :: String
endtagDefConstrs :: [Char]
endtagDefConstrs = [Char]
"endtag _ 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, [([Char], [Cat])]) -> [Char]
elemDataConstr CF
cf (Cat
cat,[([Char], [Cat])]
fcs) = Cat -> [([Char], [Char])] -> [Char]
elemc Cat
cat [([Char]
f,CF -> [Char] -> [Cat] -> [Char]
rhsCat CF
cf [Char]
f [Cat]
cs) | ([Char]
f,[Cat]
cs) <- [([Char], [Cat])]
fcs]
efunDefConstr :: [Char]
efunDefConstr = [Char]
"elemFun i t x = [P.replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"
endtagDefConstr :: [Char]
endtagDefConstr = [Char]
"endtag _ c = tag (\"/\" ++ c)"

-- coding 2:
-- constructors as tags, no types.
-- clumsy DTD, but nice trees. Validation guarantees type correctness
-- flag -xml
elemDataNotyp :: CF -> (a, [([Char], [Cat])]) -> [Char]
elemDataNotyp CF
cf (a
_,[([Char], [Cat])]
fcs) = [[Char]] -> [Char]
unlines [[Char] -> [[Char]] -> [Char]
element [Char]
f [CF -> [Cat] -> [Char]
rhsCatNot CF
cf [Cat]
cs] | ([Char]
f,[Cat]
cs) <- [([Char], [Cat])]
fcs]
efunDefNotyp :: [Char]
efunDefNotyp = [Char]
"elemFun i _ x = [P.replicate (i+i) ' ' ++ tag x]"
endtagDefNotyp :: [Char]
endtagDefNotyp = [Char]
"endtag f _ = 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 -> [Char] -> [Cat] -> [Char]
rhsCat CF
cf [Char]
fun [Cat]
cs = MakeComment
parenth (forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([Char]
fun forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Doc -> [Char]
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> Cat -> Doc
symbCat CF
cf) [Cat]
cs))
rhsCatNot :: CF -> [Cat] -> [Char]
rhsCatNot CF
cf [Cat]
cs = if forall (t :: * -> *) a. Foldable t => t a -> Coding
null [Cat]
cs then [Char]
"EMPTY" else forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " (forall a b. (a -> b) -> [a] -> [b]
map (Doc -> [Char]
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. CF -> Cat -> Doc
symbCatNot CF
cf) [Cat]
cs)

symbCat :: CF -> Cat -> Doc
symbCat :: CF -> Cat -> Doc
symbCat CF
cf Cat
c
  | Cat -> Coding
isList Cat
c  = forall a. Pretty a => a -> Doc
pretty (Cat -> Cat
normCatOfList Cat
c) Doc -> Doc -> Doc
<> if CF -> Cat -> Coding
isEmptyListCat CF
cf Cat
c then Doc
"*" else Doc
"+"
  | Coding
otherwise = forall a. Pretty a => a -> Doc
pretty Cat
c

symbCatNot :: CF -> Cat -> Doc
symbCatNot :: CF -> Cat -> Doc
symbCatNot CF
cf Cat
c
  | Cat -> Coding
isList Cat
c  = Cat -> Doc
funs (Cat -> Cat
normCatOfList Cat
c) Doc -> Doc -> Doc
<> if CF -> Cat -> Coding
isEmptyListCat CF
cf Cat
c then Doc
"*" else Doc
"+"
  | Coding
otherwise = Cat -> Doc
funs Cat
c
 where
   funs :: Cat -> Doc
funs Cat
k =
     case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Cat
k (CF -> [(Cat, [([Char], [Cat])])]
cf2data CF
cf) of
       Just []  -> Doc
"EMPTY"
       Just [([Char], [Cat])]
fcs -> Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
"|" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [([Char], [Cat])]
fcs
       Maybe [([Char], [Cat])]
_        -> Doc -> Doc
parens forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Doc
pretty Cat
k

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

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

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

prologue :: Bool -> SharedOptions -> String -> String
prologue :: Coding -> SharedOptions -> MakeComment
prologue Coding
b SharedOptions
opts [Char]
_ = [[Char]] -> [Char]
unlines [
  [Char]
"-- Pretty printing to XML",
  [Char]
"",
  [Char]
"module " forall a. [a] -> [a] -> [a]
++ SharedOptions -> [Char]
xmlFileM SharedOptions
opts [Char] -> MakeComment
+++ [Char]
"where",
  [Char]
"",
  [Char]
"import Prelude",
  [Char]
"  ( Char, Double, Integer, String",
  [Char]
"  , (.), ($), (+), (++)",
  [Char]
"  )",
  [Char]
"import qualified Prelude as P",
  [Char]
"  ( Show(..), Int",
  [Char]
"  , concat, concatMap, replicate, unlines",
  [Char]
"  )",
  [Char]
"",
  [Char]
"import " forall a. [a] -> [a] -> [a]
++ SharedOptions -> [Char]
absFileM SharedOptions
opts,
  [Char]
"",
  [Char]
"-- the top-level printing method",
  [Char]
"printXML :: XPrint a => a -> String",
  [Char]
"printXML = render . prt 0",
  [Char]
"",
  [Char]
"render :: [String] -> String",
  [Char]
"render = P.unlines",
  [Char]
"",
  [Char]
"-- the printer class does the job",
  [Char]
"class XPrint a where",
  [Char]
"  prt :: P.Int -> a -> [String]",
  [Char]
"  prtList :: P.Int -> [a] -> [String]",
  [Char]
"  prtList = P.concatMap . prt",
  [Char]
"",
  [Char]
"instance XPrint a => XPrint [a] where",
  [Char]
"  prt = prtList",
  [Char]
"",
  [Char]
"tag, etag :: String -> String",
  [Char]
"tag t = \"<\" ++ t ++ \">\"",
  [Char]
"etag t = \"<\" ++ t ++ \"/>\"",
  [Char]
"",
  [Char]
"elemTok, elemTokS :: P.Show a => P.Int -> String -> a -> [String]",
  [Char]
"elemTok i t x = [P.replicate (i+i) ' ' ++ tag (t ++ \" value = \" ++ P.show x ++ \" /\")]",
  [Char]
"elemTokS i t x = elemTok i t (P.show x)",
  [Char]
"",
  [Char]
"elemFun :: P.Int -> String -> String -> [String]",
  Coding -> [Char]
efunDef Coding
b,
  [Char]
"",
  [Char]
"endtag :: String -> String -> String",
  Coding -> [Char]
endtagDef Coding
b,
  [Char]
""
  ]

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

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

identRule :: CF -> [Char]
identRule CF
cf = CF -> MakeComment
ownPrintRule CF
cf [Char]
catIdent

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

rules :: CF -> String
rules :: CF -> [Char]
rules CF
cf = [[Char]] -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
  forall a b. (a -> b) -> [a] -> [b]
map (\ (Cat
s, [([Char], [Cat])]
xs) -> Cat -> [([Char], [[Char]])] -> [Char]
case_fun Cat
s (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Cat] -> [[Char]]
toArgs) [([Char], [Cat])]
xs)) forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [([Char], [Cat])])]
cf2data CF
cf
 where
   toArgs :: [Cat] -> [[Char]]
toArgs [Cat]
args = forall {t}. (Show t, Num t) => [[Char]] -> t -> [[Char]]
names (forall a b. (a -> b) -> [a] -> [b]
map ([[Char]] -> Cat -> [Char]
catToVar [[Char]
"prt"]) [Cat]
args) (Int
0 :: Int)
   names :: [[Char]] -> t -> [[Char]]
names [] t
_ = []
   names ([Char]
x:[[Char]]
xs) t
n
     | [Char]
x forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Coding
`elem` [[Char]]
xs = ([Char]
x forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show t
n) forall a. a -> [a] -> [a]
: [[Char]] -> t -> [[Char]]
names [[Char]]
xs (t
nforall a. Num a => a -> a -> a
+t
1)
     | Coding
otherwise   = [Char]
x             forall a. a -> [a] -> [a]
: [[Char]] -> t -> [[Char]]
names [[Char]]
xs t
n

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