module Text.XML.HaXml.DtdToHaskell.Instance
( mkInstance
) where
import List (intersperse)
import Text.XML.HaXml.DtdToHaskell.TypeDef
import Text.PrettyPrint.HughesPJ
mkInstance :: TypeDef -> Doc
mkInstance (DataDef aux n fs []) =
let (frpat, frattr, topat, toattr) = attrpats fs
frretval = if null fs then ppHName n else frattr
topatval = if null fs then ppHName n else topat
in
text "instance XmlContent" <+> ppHName n <+> text "where" $$
nest 4 ( text "fromElem (CElem (Elem \"" <> ppXName n <> text "\""
<+> frpat <+> text "[]):rest) =" $$
nest 4 (text "(Just" <+> frretval <> text ", rest)") $$
text "fromElem (CMisc _:rest) = fromElem rest" $$
text "fromElem (CString _ s:rest) | all isSpace s = fromElem rest" $$
text "fromElem rest = (Nothing, rest)"
$$
text "toElem" <+> topatval <+> text "=" $$
nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""
<+> toattr <+> text "[])]")
)
$$
mkInstanceAttrs Same n fs
mkInstance (DataDef False n fs [(n0,sts)]) =
let vs = nameSupply sts
(frpat, frattr, topat, toattr) = attrpats fs
in
text "instance XmlContent" <+> ppHName n <+> text "where" $$
nest 4 ( text "fromElem (CElem (Elem \"" <> ppXName n <> text "\""
<+> frpat <+> text "c0):rest) =" $$
nest 4 (mkFrElem n sts vs (
text "(Just" <+> parens (mkCpat n0 frattr vs)
<> text ", rest)")
) $$
text "fromElem (CMisc _:rest) = fromElem rest" $$
text "fromElem (CString _ s:rest) | all isSpace s = fromElem rest" $$
text "fromElem rest = (Nothing, rest)"
$$
text "toElem" <+> parens (mkCpat n0 topat vs) <+> text "=" $$
nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""
<+> toattr <+> parens (mkToElem sts vs) <> text ")]")
)
$$
mkInstanceAttrs Extended n fs
mkInstance (DataDef True n fs [(n0,sts)]) =
let vs = nameSupply sts
(frpat, frattr, topat, toattr) = attrpats fs
in
text "instance XmlContent" <+> ppHName n <+> text "where" $$
nest 4 ( text "fromElem c0 =" $$
mkFrAux True frattr [(n0,sts)]
$$
text "toElem" <+> parens (mkCpat n0 topat vs) <+> text "=" $$
nest 4 (parens (mkToElem sts vs))
)
$$
mkInstanceAttrs Extended n fs
mkInstance (DataDef aux n fs cs) =
let vs = nameSupply cs
(frpat, frattr, topat, toattr) = attrpats fs
mixattrs = if null fs then False else True
in
text "instance XmlContent" <+> ppHName n <+> text "where" $$
nest 4 ( ( if aux then text "fromElem c0 ="
else text "fromElem (CElem (Elem \"" <> ppXName n <> text "\""
<+> frpat <+> text "c0):rest) =" ) $$
mkFrAux aux frattr cs $$
text "fromElem (CMisc _:rest) = fromElem rest" $$
text "fromElem (CString _ s:rest) | all isSpace s = fromElem rest" $$
text "fromElem rest = (Nothing, rest)"
$$
if aux then vcat (map (mkToAux mixattrs) cs)
else vcat (map (mkToMult n topat toattr) cs)
)
$$
mkInstanceAttrs Extended n fs
mkInstance (EnumDef n es) =
text "instance XmlAttrType" <+> ppHName n <+> text "where" $$
nest 4 ( text "fromAttrToTyp n (n',v)" $$
nest 4 (text "| n==n' = translate (attr2str v)" $$
text "| otherwise = Nothing") $$
nest 2 (text "where" <+> mkTranslate es)
$$
vcat (map mkToAttr es)
)
data SameName = Same | Extended
mkInstanceAttrs :: SameName -> Name -> AttrFields -> Doc
mkInstanceAttrs s n [] = empty
mkInstanceAttrs s n fs =
let ppName = case s of { Same-> ppHName; Extended-> ppAName; }
in
text "instance XmlAttributes" <+> ppName n <+> text "where" $$
nest 4 ( text "fromAttrs as =" $$
nest 4 ( ppName n $$
nest 2 (vcat ((text "{" <+> mkFrFld n (head fs)):
map (\x-> comma <+> mkFrFld n x) (tail fs)) $$
text "}"))
$$
text "toAttrs v = catMaybes " $$
nest 4 (vcat ((text "[" <+> mkToFld (head fs)):
map (\x-> comma <+> mkToFld x) (tail fs)) $$
text "]")
)
attrpats :: AttrFields -> (Doc,Doc,Doc,Doc)
attrpats fs =
if null fs then (text "[]", empty, empty, text "[]")
else (text "as", parens (text "fromAttrs as"), text "as", parens (text "toAttrs as"))
mkFrElem :: Name -> [StructType] -> [Doc] -> Doc -> Doc
mkFrElem n sts vs inner =
foldr (frElem n) inner (zip3 sts vs cvs)
where
cvs = let ns = nameSupply2 vs
in zip ns (text "c0": init ns)
frElem n (st,v,(cvi,cvo)) inner =
parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$
nest 2 inner) $$
parens (
case st of
(Maybe String) -> text "fromText" <+> cvo
(Maybe s) -> text "fromElem" <+> cvo
(List String) -> text "many fromText" <+> cvo
(List s) -> text "many fromElem" <+> cvo
(List1 s) -> text "definite fromElem"
<+> text "\"" <> text (show s)<> text "+\""
<+> text "\"" <> ppXName n <> text "\""
<+> cvo
(Tuple ss) -> text "definite fromElem"
<+> text "\"(" <> hcat (intersperse (text ",")
(map (text.show) ss))
<> text ")\""
<+> text "\"" <> ppXName n <> text "\""
<+> cvo
(OneOf ss) -> text "definite fromElem"
<+> text "\"OneOf\""
<+> text "\"" <> ppXName n <> text "\""
<+> cvo
(String) -> text "definite fromText" <+> text "\"text\" \"" <>
ppXName n <> text "\"" <+> cvo
(Any) -> text "definite fromElem" <+> text "\"ANY\" \"" <>
ppXName n <> text "\"" <+> cvo
(Defined m) -> text "definite fromElem" <+>
text "\"<" <> ppXName m <> text ">\" \"" <>
ppXName n <> text "\"" <+> cvo
(Defaultable _ _) -> text "nyi_fromElem_Defaultable" <+> cvo
)
mkToElem :: [StructType] -> [Doc] -> Doc
mkToElem [] [] = text "[]"
mkToElem sts vs =
fsep (intersperse (text "++") (zipWith toElem sts vs))
where
toElem st v =
case st of
(Maybe String) -> text "maybe [] toText" <+> v
(Maybe s) -> text "maybe [] toElem" <+> v
(List String) -> text "concatMap toText" <+> v
(List s) -> text "concatMap toElem" <+> v
(List1 s) -> text "toElem" <+> v
(Tuple ss) -> text "toElem" <+> v
(OneOf ss) -> text "toElem" <+> v
(String) -> text "toText" <+> v
(Any) -> text "toElem" <+> v
(Defined m) -> text "toElem" <+> v
(Defaultable _ _) -> text "nyi_toElem_Defaultable" <+> v
mkRpat :: [Doc] -> Doc
mkRpat [v] = v
mkRpat vs = (parens . hcat . intersperse comma) vs
mkCpat :: Name -> Doc -> [Doc] -> Doc
mkCpat n i vs = ppHName n <+> i <+> fsep vs
nameSupply,nameSupply2 :: [b] -> [Doc]
nameSupply ss = take (length ss) (map char ['a'..])
nameSupply2 ss = take (length ss) [ text ('c':v:[]) | v <- ['a'..]]
mkTranslate :: [Name] -> Doc
mkTranslate es =
vcat (map trans es) $$
text "translate _ = Nothing"
where
trans n = text "translate \"" <> ppXName n <> text "\" =" <+>
text "Just" <+> ppHName n
mkToAttr n = text "toAttrFrTyp n" <+> ppHName n <+> text "=" <+>
text "Just (n, str2attr" <+> doubleQuotes (ppXName n) <> text ")"
mkFrFld :: Name -> (Name,StructType) -> Doc
mkFrFld tag (n,st) =
ppHName n <+> text "=" <+>
( case st of
(Defaultable String s) -> text "defaultA fromAttrToStr" <+>
doubleQuotes (text s)
(Defaultable _ s) -> text "defaultA fromAttrToTyp" <+> text s
(Maybe String) -> text "possibleA fromAttrToStr"
(Maybe _) -> text "possibleA fromAttrToTyp"
String -> text "definiteA fromAttrToStr" <+>
doubleQuotes (ppXName tag)
_ -> text "definiteA fromAttrToTyp" <+>
doubleQuotes (ppXName tag)
) <+> doubleQuotes (ppXName n) <+> text "as"
mkToFld :: (Name,StructType) -> Doc
mkToFld (n,st) =
( case st of
(Defaultable String _) -> text "defaultToAttr toAttrFrStr"
(Defaultable _ _) -> text "defaultToAttr toAttrFrTyp"
(Maybe String) -> text "maybeToAttr toAttrFrStr"
(Maybe _) -> text "maybeToAttr toAttrFrTyp"
String -> text "toAttrFrStr"
_ -> text "toAttrFrTyp"
) <+> doubleQuotes (ppXName n) <+> parens (ppHName n <+> text "v")
mkFrAux :: Bool -> Doc -> [(Name,[StructType])] -> Doc
mkFrAux keeprest attrs cs = foldr frAux inner cs
where
inner = text "(Nothing, c0)"
rest = if keeprest then text "rest" else text "_"
frAux (n,sts) inner =
let vs = nameSupply sts in
nest 4 (text "case" <+> blah sts vs <+> text "of" $$
succpat sts vs <+> text "-> (Just" <+>
parens (mkCpat n attrs vs) <> text ", rest)"
$$
failpat sts <+> text "->" $$ nest 4 inner
)
blah [st] [v] =
blahblahblah st (text "c0")
blah sts vs =
let ns = nameSupply2 vs
cvs = zip ns (text "c0": init ns)
blahblah (st,v,(cvi,cvo)) inner =
parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$
nest 2 inner) $$
blahblahblah st cvo
in
foldr blahblah (mkRpat (vs++[last ns])) (zip3 sts vs cvs)
blahblahblah st cvo = parens (
case st of
(Maybe String) -> text "fromText" <+> cvo
(Maybe s) -> text "fromElem" <+> cvo
(List String) -> text "many fromText" <+> cvo
(List s) -> text "many fromElem" <+> cvo
(List1 s) -> text "fromElem" <+> cvo
(Tuple ss) -> text "fromElem" <+> cvo
(OneOf ss) -> text "fromElem" <+> cvo
(String) -> text "fromText" <+> cvo
(Any) -> text "fromElem" <+> cvo
(Defined m) -> text "fromElem" <+> cvo
)
failpat sts =
let fp st =
case st of
(Maybe s) -> text "Nothing"
(List s) -> text "[]"
(List1 s) -> text "_"
(Tuple ss) -> text "_"
(OneOf ss) -> text "_"
(String) -> text "_"
(Any) -> text "_"
(Defined m) -> text "_"
in parens (hcat (intersperse comma (map fp sts++[text "_"])))
succpat sts vs =
let sp st v =
case st of
(Maybe s) -> v
(List s) -> v
(List1 s) -> text "Just" <+> v
(Tuple ss) -> text "Just" <+> v
(OneOf ss) -> text "Just" <+> v
(String) -> text "Just" <+> v
(Any) -> text "Just" <+> v
(Defined m) -> text "Just" <+> v
in parens (hcat (intersperse comma (zipWith sp sts vs++[rest])))
mkToAux :: Bool -> (Name,[StructType]) -> Doc
mkToAux mixattrs (n,sts) =
let vs = nameSupply sts
attrs = if mixattrs then text "as" else empty
in
text "toElem" <+> parens (mkCpat n attrs vs) <+> text "=" <+>
mkToElem sts vs
mkToMult :: Name -> Doc -> Doc -> (Name,[StructType]) -> Doc
mkToMult tag attrpat attrexp (n,sts) =
let vs = nameSupply sts
in
text "toElem" <+> parens (mkCpat n attrpat vs) <+> text "=" <+>
text "[CElem (Elem \"" <> ppXName tag <> text "\""<+> attrexp <+>
parens (mkToElem sts vs) <+> text ")]"