module Text.XML.HaXml.DtdToHaskell.Instance ( mkInstance ) where import List (intersperse) import Text.XML.HaXml.DtdToHaskell.TypeDef import Text.PrettyPrint.HughesPJ -- | Convert typedef to appropriate instance declaration, either @XmlContent@, -- @XmlAttributes@, or @XmlAttrType@. mkInstance :: TypeDef -> Doc -- no constructors 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 -- single constructor, "real" (non-auxiliary) type 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 -- single constructor, auxiliary type 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 (text "[CElem (Elem \"" <> ppXName n <> text "\"" -- <+> toattr <+> parens (mkToElem sts vs) <> text ")]") nest 4 (parens (mkToElem sts vs)) ) $$ mkInstanceAttrs Extended n fs -- multiple constructors 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 -- enumeration of attribute values 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 "]") ) -- respectively (frpat,frattr,topat,toattr) 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 ")]"