    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 - 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 x = 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 _ 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 x = 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 x = 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
            _ = if null fs then False else True
        in
        text "instance HTypeable" <+> ppHName n <+> text "where" $$
        nest 4 ( text "toHType x = 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 = if null fs then False else True
        in
        text "instance HTypeable" <+> ppHName n <+> text "where" $$
        nest 4 ( text "toHType x = 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 ") ()]")