module DtdToHaskell.Instance

( mkInstance

) where

import Data.List (intersperse)

import DtdToHaskell.TypeDef

import Text.PrettyPrint.HughesPJ

{- | Convert typedef to appropriate instance declaration, either @XmlContent@,

@XmlAttributes@, or @XmlAttrType@. -}

mkInstance :: TypeDef -> Doc

-- no constructors - represents an element with empty content but attributes.

mkInstance (DataDef _ n fs []) =

let (_, 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 HTypeable" <+> ppHName n <+> text "where" $$

nest 4 ( text "toHType _ = Defined \"" <> ppXName n <> text "\" [] []" )

$$

text "instance XmlContent" <+> ppHName n <+> text "where" $$

nest 4 (

text "toContents" <+> topatval <+> text "=" $$

nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""

<+> toattr <+> text "[]) ()]")

$$

text "parseContents = do" $$

nest 4 (text ("{ (Elem _ " ++ (if null fs then "_" else

"as") ++ " []) <- element [\"")

<> ppXName n <> text "\"]" $$

text "; return" <+> frretval $$

text "} `adjustErr` (\"in <" <> ppXName n

<> 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 HTypeable" <+> ppHName n <+> text "where" $$

nest 4 ( text "toHType _ = Defined \"" <> ppXName n <> text "\" [] []" )

$$

text "instance XmlContent" <+> ppHName n <+> text "where" $$

nest 4 (

text "toContents" <+> parens (mkCpat n0 topat vs) <+> text "=" $$

nest 4 (text "[CElem (Elem \"" <> ppXName n <> text "\""

<+> toattr <+> parens (mkToElem sts vs)

<> text ") ()]")

$$

text "parseContents = do" $$

nest 4 (text "{ e@(Elem _" <+> frpat <+> text "_) <- element [\""

<> ppXName n <> text "\"]"

$$ text "; interior e $"

<+> mkParseConstr frattr (n0, sts)

$$ text "} `adjustErr` (\"in <" <> ppXName n

<> text ">, \"++)")

)

$$

mkInstanceAttrs Extended n fs

{- single constructor, auxiliary type (i.e. no corresponding element tag)

cannot be attributes here? -}

mkInstance (DataDef True n [] [(n0, sts)]) =

let vs = nameSupply sts

in

text "instance HTypeable" <+> ppHName n <+> text "where" $$

nest 4 ( text "toHType _ = Defined \"" <> ppXName n <> text "\" [] []" )

$$

text "instance XmlContent" <+> ppHName n <+> text "where" $$

nest 4 ( text "toContents" <+> parens (mkCpat n0 empty vs)

<+> text "="

$$ nest 4 (parens (mkToElem sts vs))

$$

text "parseContents =" <+> mkParseConstr empty (n0, sts)

)

-- multiple constructors (real)

mkInstance (DataDef False n fs cs) =

let _ = nameSupply cs

(frpat, frattr, topat, toattr) = attrpats fs

_ = not (null fs)

in

text "instance HTypeable" <+> ppHName n <+> text "where" $$

nest 4 ( text "toHType _ = Defined \"" <> ppXName n <> text "\" [] []" )

$$

text "instance XmlContent" <+> ppHName n <+> text "where" $$

nest 4 ( vcat (map (mkToMult n topat toattr) cs)

$$ text "parseContents = do "

$$ nest 4 (text "{ e@(Elem _" <+> frpat <+> text "_) <- element [\""

<> ppXName n <> text "\"]"

$$ text "; interior e $ oneOf"

$$ nest 4 ( text "[" <+> mkParseConstr frattr (head cs)

$$ vcat (map (\ c -> text "," <+> mkParseConstr frattr c)

(tail cs))

$$ text "] `adjustErr` (\"in <" <> ppXName n

<> text ">, \"++)"

)

$$ text "}"

)

)

$$

mkInstanceAttrs Extended n fs

-- multiple constructors (auxiliary)

mkInstance (DataDef True n fs cs) =

let _ = nameSupply cs

(_, frattr, _, _) = attrpats fs

mixattrs = not (null fs)

in

text "instance HTypeable" <+> ppHName n <+> text "where" $$

nest 4 ( text "toHType _ = Defined \"" <> ppXName n <> text "\" [] []" )

$$

text "instance XmlContent" <+> ppHName n <+> text "where" $$

nest 4 ( vcat (map (mkToAux mixattrs) cs)

$$ text "parseContents = oneOf"

$$ nest 4 ( text "[" <+> mkParseConstr frattr (head cs)

$$ vcat (map (\ c -> text "," <+> mkParseConstr frattr c)

(tail cs))

$$ text "] `adjustErr` (\"in <" <> ppXName n

<> text ">, \"++)"

)

)

$$

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 _ _ [] = 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 _ (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 _) -> text "fromElem" <+> cvo

(List String) -> text "many fromText" <+> cvo

(List _) -> 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 _) -> 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 m <> text "\"" <+> cvo

(Defaultable _ _) -> text "nyi_fromElem_Defaultable" <+> cvo

) -}

--

{-

mkParseContents :: Name -> [StructType] -> [Doc] -> Doc -> Doc

mkParseContents 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 (

)

-}

mkParseConstr :: Doc -> (Name, [StructType]) -> Doc

mkParseConstr frattr (c, sts) =

fsep (text "return" <+> parens (ppHName c <+> frattr)

: map mkParseContents sts)

mkParseContents :: StructType -> Doc

mkParseContents st =

let ap = text "`apply`" in

case st of

(Maybe String) -> ap <+> text "optional text"

(Maybe _) -> ap <+> text "optional parseContents"

(List String) -> ap <+> text "many text"

(List _) -> ap <+> text "many parseContents"

(List1 _) -> ap <+> text "parseContents"

(Tuple _) -> ap <+> text "parseContents"

(OneOf _) -> ap <+> text "parseContents"

(String) -> ap <+> text "(text `onFail` return \"\")"

(Any) -> ap <+> text "parseContents"

(Defined _) -> ap <+> text "parseContents"

(Defaultable _ _) -> ap <+> text "nyi_fromElem_Defaultable"

--

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 _) -> text "maybe [] toContents" <+> v

(List String) -> text "concatMap toText" <+> v

(List _) -> text "concatMap toContents" <+> v

(List1 _) -> text "toContents" <+> v

(Tuple _) -> text "toContents" <+> v

(OneOf _) -> text "toContents" <+> v

(String) -> text "toText" <+> v

(Any) -> text "toContents" <+> v

(Defined _) -> text "toContents" <+> 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 :: [b] -> [Doc]

nameSupply ss = take (length ss) (map char ['a' .. 'z']

++ map text [ [a, n] | n <- ['0' .. '9']

, a <- ['a' .. 'z'] ])

-- 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 :: Name -> Doc

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) innr =

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 innr

)

blah [st] [_] =

blahblahblah st (text "c0")

blah sts vs =

let ns = nameSupply2 vs

cvs = zip ns (text "c0": init ns)

blahblah (st,v,(cvi,cvo)) innr =

parens (text "\\" <> parens (v<>comma<>cvi) <> text "->" $$

nest 2 innr) $$

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 _) -> text "fromElem" <+> cvo

(List String) -> text "many fromText" <+> cvo

(List _) -> text "many fromElem" <+> cvo

(List1 _) -> text "fromElem" <+> cvo

(Tuple _) -> text "fromElem" <+> cvo -- ??

(OneOf _) -> text "fromElem" <+> cvo

(String) -> text "fromText" <+> cvo

(Any) -> text "fromElem" <+> cvo

(Defined _) -> text "fromElem" <+> cvo

)

failpat sts =

let fp st =

case st of

(Maybe _) -> text "Nothing"

(List _) -> text "[]"

(List1 _) -> text "_"

(Tuple _) -> text "_"

(OneOf _) -> text "_"

(String) -> text "_"

(Any) -> text "_"

(Defined _) -> text "_"

in parens (hcat (intersperse comma (map fp sts++[text "_"])))

succpat sts vs =

let sp st v =

case st of

(Maybe _) -> v

(List _) -> v

(List1 _) -> text "Just" <+> v

(Tuple _) -> text "Just" <+> v

(OneOf _) -> text "Just" <+> v

(String) -> text "Just" <+> v

(Any) -> text "Just" <+> v

(Defined _) -> 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 "toContents" <+> 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 "toContents" <+> parens (mkCpat n attrpat vs) <+> text "="

$$ nest 4 (text "[CElem (Elem \"" <> ppXName tag <> text "\"" <+> attrexp

<+> parens (mkToElem sts vs) <+> text ") ()]")