{-
    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
  [Char] -> MakeComment -> [Char] -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile ([Char]
name [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
".dtd") MakeComment
comment ([Char] -> Backend) -> [Char] -> Backend
forall a b. (a -> b) -> a -> b
$ Coding -> [Char] -> CF -> [Char]
cf2DTD Coding
typ [Char]
name CF
cf
  let absmod :: [Char]
absmod = [Char]
"XML" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
name
  [Char] -> MakeComment -> [Char] -> Backend
forall c. FileContent c => [Char] -> MakeComment -> c -> Backend
mkfile (SharedOptions -> [Char]
xmlFile SharedOptions
opts) MakeComment
Haskell.comment ([Char] -> Backend) -> [Char] -> Backend
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 " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
name [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
" [",
  MakeComment
elemEmp [Char]
"Integer",
  MakeComment
elemEmp [Char]
"Double",
  MakeComment
elemEmp [Char]
"String",
  if CF -> Coding
forall f. CFG f -> Coding
hasIdent CF
cf then MakeComment
elemEmp [Char]
"Ident" else [Char]
"",
  [[Char]] -> [Char]
unlines [MakeComment
elemEmp [Char]
own | [Char]
own <- CF -> [[Char]]
forall f. CFG f -> [[Char]]
tokenNames CF
cf],
  [[Char]] -> [Char]
unlines (((Cat, [([Char], [Cat])]) -> [Char])
-> [(Cat, [([Char], [Cat])])] -> [[Char]]
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]
"<" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
">"

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

attlist :: [Char] -> MakeComment
attlist [Char]
t [Char]
a =
  MakeComment
tag ([Char]
"!ATTLIST " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
t [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
a [Char] -> MakeComment
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
element (Cat -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Cat
cat) ((([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], [Char]) -> [Char]
forall a b. (a, b) -> b
snd [([Char], [Char])]
fs) [Char] -> [[Char]] -> [[Char]]
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 [[Char]] -> Coding
forall a. [a] -> Coding
forall (t :: * -> *) a. Foldable t => t a -> Coding
null [[Char]]
ts then [Char]
"EMPTY" else MakeComment
parenth MakeComment -> MakeComment
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
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 CF -> (Cat, [([Char], [Cat])]) -> [Char]
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 ([Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ([Char]
fun [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (Cat -> [Char]) -> [Cat] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> [Char]
render (Doc -> [Char]) -> (Cat -> Doc) -> Cat -> [Char]
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 [Cat] -> Coding
forall a. [a] -> Coding
forall (t :: * -> *) a. Foldable t => t a -> Coding
null [Cat]
cs then [Char]
"EMPTY" else [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((Cat -> [Char]) -> [Cat] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (Doc -> [Char]
render (Doc -> [Char]) -> (Cat -> Doc) -> Cat -> [Char]
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  = Cat -> Doc
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 = Cat -> Doc
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 Cat -> [(Cat, [([Char], [Cat])])] -> Maybe [([Char], [Cat])]
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 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> [Doc] -> [Doc]
punctuate Doc
"|" ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (([Char], [Cat]) -> Doc) -> [([Char], [Cat])] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> Doc
text ([Char] -> Doc)
-> (([Char], [Cat]) -> [Char]) -> ([Char], [Cat]) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Cat]) -> [Char]
forall a b. (a, b) -> a
fst) [([Char], [Cat])]
fcs
       Maybe [([Char], [Cat])]
_        -> Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Cat -> Doc
forall a. Pretty a => a -> Doc
pretty Cat
k

parenth :: MakeComment
parenth [Char]
s = [Char]
"(" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> MakeComment
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,
  CF -> [Char]
forall {p}. p -> [Char]
integerRule CF
cf,
  CF -> [Char]
forall {p}. p -> [Char]
doubleRule CF
cf,
  CF -> [Char]
forall {p}. p -> [Char]
stringRule CF
cf,
  if CF -> Coding
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
_) <- CF -> [([Char], 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 Target -> Target -> Coding
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 " [Char] -> MakeComment
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 " [Char] -> MakeComment
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 = p -> MakeComment
forall {p}. p -> MakeComment
showsPrintRule p
cf [Char]
"Integer"
doubleRule :: p -> [Char]
doubleRule p
cf = p -> MakeComment
forall {p}. p -> MakeComment
showsPrintRule p
cf [Char]
"Double"
stringRule :: p -> [Char]
stringRule p
cf = p -> MakeComment
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 " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
t [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
" where",
  [Char]
"  prt i x = elemTokS i" [Char] -> MakeComment
+++ [Char]
"\"" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
t [Char] -> MakeComment
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
  [ [Char]
"instance XPrint " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
cat [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
" where"
  , [Char]
"  prt i (" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
cat [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
posn [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
") = elemTok i" [Char] -> MakeComment
+++ [Char]
"\"" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
cat [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
"\"" [Char] -> MakeComment
+++ [Char]
"x"
  ]
 where
   posn :: [Char]
posn = if CF -> [Char] -> Coding
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
  ((Cat, [([Char], [Cat])]) -> [Char])
-> [(Cat, [([Char], [Cat])])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Cat
s, [([Char], [Cat])]
xs) -> Cat -> [([Char], [[Char]])] -> [Char]
case_fun Cat
s ((([Char], [Cat]) -> ([Char], [[Char]]))
-> [([Char], [Cat])] -> [([Char], [[Char]])]
forall a b. (a -> b) -> [a] -> [b]
map (([Cat] -> [[Char]]) -> ([Char], [Cat]) -> ([Char], [[Char]])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second [Cat] -> [[Char]]
toArgs) [([Char], [Cat])]
xs)) ([(Cat, [([Char], [Cat])])] -> [[Char]])
-> [(Cat, [([Char], [Cat])])] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ CF -> [(Cat, [([Char], [Cat])])]
cf2data CF
cf
 where
   toArgs :: [Cat] -> [[Char]]
toArgs [Cat]
args = [[Char]] -> Int -> [[Char]]
forall {t}. (Show t, Num t) => [[Char]] -> t -> [[Char]]
names ((Cat -> [Char]) -> [Cat] -> [[Char]]
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 [Char] -> [[Char]] -> Coding
forall a. Eq a => a -> [a] -> Coding
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Coding
`elem` [[Char]]
xs = ([Char]
x [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ t -> [Char]
forall a. Show a => a -> [Char]
show t
n) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> t -> [[Char]]
names [[Char]]
xs (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1)
     | Coding
otherwise   = [Char]
x             [Char] -> [[Char]] -> [[Char]]
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 ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [[[Char]]] -> [[Char]]
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"
    ]
  , ((([Char], [[Char]]) -> [Char]) -> [([Char], [[Char]])] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
`map` [([Char], [[Char]])]
xs) ((([Char], [[Char]]) -> [Char]) -> [[Char]])
-> (([Char], [[Char]]) -> [Char]) -> [[Char]]
forall a b. (a -> b) -> a -> b
$ \ ([Char]
c, [[Char]]
xx) ->
    [Char]
"   " [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
c [Char] -> MakeComment
+++ [[Char]] -> [Char]
unwords [[Char]]
xx [Char] -> MakeComment
+++ [Char]
"-> P.concat $ " [Char] -> MakeComment
+++
    [Char]
"elemFun i' \"" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
"\" \"" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
c [Char] -> MakeComment
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 \"" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
c [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
"\" \"" [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
s [Char] -> MakeComment
forall a. [a] -> [a] -> [a]
++ [Char]
"\"]]"
  ]
  where
  s :: [Char]
s = Cat -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Cat
cat