    {-# LANGUAGE CPP #-}
    module Text.XML.HaXml.DtdToHaskell.Instance
      ( mkInstance
      ) where

    #if MIN_VERSION_base(4,11,0)
    import Prelude hiding ((<>))
    #endif

    import Data.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 :: TypeDef -> Doc
    mkInstance (DataDef Bool
    _ Name
    n AttrFields
    fs []) =
        let (Doc
    _, Doc
    frattr, Doc
    topat, Doc
    toattr) = AttrFields -> (Doc, Doc, Doc, Doc)
    attrpats AttrFields
    fs
            frretval :: Doc
    frretval = if AttrFields -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null AttrFields
    fs then Name -> Doc
    ppHName Name
    n else Doc
    frattr
            topatval :: Doc
    topatval = if AttrFields -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null AttrFields
    fs then Name -> Doc
    ppHName Name
    n else Doc
    topat
        in
        String -> Doc
    text String
    "instance HTypeable" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "toHType x = Defined \"" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\" [] []" )
        Doc -> Doc -> Doc
    $$
        String -> Doc
    text String
    "instance XmlContent" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 (
                 String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc
    topatval Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "=" Doc -> Doc -> Doc
    $$
                 Int -> Doc -> Doc
    nest Int
    4 (String -> Doc
    text String
    "[CElem (Elem (N \"" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\")"
                              Doc -> Doc -> Doc
    <+> Doc
    toattr Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "[]) ()]")
               Doc -> Doc -> Doc
    $$
                 String -> Doc
    text String
    "parseContents = do" Doc -> Doc -> Doc
    $$
                 Int -> Doc -> Doc
    nest Int
    4 (String -> Doc
    text String
    "{ (Elem _ as []) <- element [\""
                                 Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\"]" Doc -> Doc -> Doc
    $$
                         String -> Doc
    text String
    "; return" Doc -> Doc -> Doc
    <+> Doc
    frretval Doc -> Doc -> Doc
    $$
                         String -> Doc
    text String
    "} `adjustErr` (\"in <" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n
                                                      Doc -> Doc -> Doc
    <> String -> Doc
    text String
    ">, \"++)"
                        )
               )
        Doc -> Doc -> Doc
    $$
        SameName -> Name -> AttrFields -> Doc
    mkInstanceAttrs SameName
    Same Name
    n AttrFields
    fs

    -- single constructor, "real" (non-auxiliary) type
    mkInstance (DataDef Bool
    False Name
    n AttrFields
    fs [(Name
    n0,[StructType]
    sts)]) =
        let vs :: [Doc]
    vs = [StructType] -> [Doc]
    forall b. [b] -> [Doc]
    nameSupply [StructType]
    sts
            (Doc
    frpat, Doc
    frattr, Doc
    topat, Doc
    toattr) = AttrFields -> (Doc, Doc, Doc, Doc)
    attrpats AttrFields
    fs
        in
        String -> Doc
    text String
    "instance HTypeable" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "toHType x = Defined \"" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\" [] []" )
        Doc -> Doc -> Doc
    $$
        String -> Doc
    text String
    "instance XmlContent" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 (
                 String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc -> Doc
    parens (Name -> Doc -> [Doc] -> Doc
    mkCpat Name
    n0 Doc
    topat [Doc]
    vs) Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "=" Doc -> Doc -> Doc
    $$
                 Int -> Doc -> Doc
    nest Int
    4 (String -> Doc
    text String
    "[CElem (Elem (N \"" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\")"
                              Doc -> Doc -> Doc
    <+> Doc
    toattr Doc -> Doc -> Doc
    <+> Doc -> Doc
    parens ([StructType] -> [Doc] -> Doc
    mkToElem [StructType]
    sts [Doc]
    vs)
                              Doc -> Doc -> Doc
    <> String -> Doc
    text String
    ") ()]")
               Doc -> Doc -> Doc
    $$
                 String -> Doc
    text String
    "parseContents = do" Doc -> Doc -> Doc
    $$
                 Int -> Doc -> Doc
    nest Int
    4 (String -> Doc
    text String
    "{ e@(Elem _"Doc -> Doc -> Doc
    <+> Doc
    frpat Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "_) <- element [\""
                                 Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\"]"
                         Doc -> Doc -> Doc
    $$ String -> Doc
    text String
    "; interior e $"
                               Doc -> Doc -> Doc
    <+> Doc -> (Name, [StructType]) -> Doc
    mkParseConstr Doc
    frattr (Name
    n0,[StructType]
    sts)
                         Doc -> Doc -> Doc
    $$ String -> Doc
    text String
    "} `adjustErr` (\"in <" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n
                                                         Doc -> Doc -> Doc
    <> String -> Doc
    text String
    ">, \"++)")
               )
        Doc -> Doc -> Doc
    $$
        SameName -> Name -> AttrFields -> Doc
    mkInstanceAttrs SameName
    Extended Name
    n AttrFields
    fs

    -- single constructor, auxiliary type (i.e. no corresponding element tag)
    --   cannot be attributes here?
    mkInstance (DataDef Bool
    True Name
    n [] [(Name
    n0,[StructType]
    sts)]) =
        let vs :: [Doc]
    vs = [StructType] -> [Doc]
    forall b. [b] -> [Doc]
    nameSupply [StructType]
    sts
        in
        String -> Doc
    text String
    "instance HTypeable" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "toHType x = Defined \"" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\" [] []" )
        Doc -> Doc -> Doc
    $$
        String -> Doc
    text String
    "instance XmlContent" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc -> Doc
    parens (Name -> Doc -> [Doc] -> Doc
    mkCpat Name
    n0 Doc
    empty [Doc]
    vs)
                                   Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "="
                                   Doc -> Doc -> Doc
    $$  Int -> Doc -> Doc
    nest Int
    4 (Doc -> Doc
    parens ([StructType] -> [Doc] -> Doc
    mkToElem [StructType]
    sts [Doc]
    vs))
               Doc -> Doc -> Doc
    $$
                 String -> Doc
    text String
    "parseContents =" Doc -> Doc -> Doc
    <+> Doc -> (Name, [StructType]) -> Doc
    mkParseConstr Doc
    empty (Name
    n0,[StructType]
    sts)
               )

    -- multiple constructors (real)
    mkInstance (DataDef Bool
    False Name
    n AttrFields
    fs [(Name, [StructType])]
    cs) =
        let [Doc]
    _ = [(Name, [StructType])] -> [Doc]
    forall b. [b] -> [Doc]
    nameSupply [(Name, [StructType])]
    cs
            (Doc
    frpat, Doc
    frattr, Doc
    topat, Doc
    toattr) = AttrFields -> (Doc, Doc, Doc, Doc)
    attrpats AttrFields
    fs
            Bool
    _ = Bool -> Bool
    not (AttrFields -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null AttrFields
    fs)
        in
        String -> Doc
    text String
    "instance HTypeable" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "toHType x = Defined \"" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\" [] []" )
        Doc -> Doc -> Doc
    $$
        String -> Doc
    text String
    "instance XmlContent" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( [Doc] -> Doc
    vcat (((Name, [StructType]) -> Doc) -> [(Name, [StructType])] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name -> Doc -> Doc -> (Name, [StructType]) -> Doc
    mkToMult Name
    n Doc
    topat Doc
    toattr) [(Name, [StructType])]
    cs)
               Doc -> Doc -> Doc
    $$ String -> Doc
    text String
    "parseContents = do "
               Doc -> Doc -> Doc
    $$ Int -> Doc -> Doc
    nest Int
    4 (String -> Doc
    text String
    "{ e@(Elem _"Doc -> Doc -> Doc
    <+> Doc
    frpat Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "_) <- element [\""
                                                      Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\"]"
                         Doc -> Doc -> Doc
    $$ String -> Doc
    text String
    "; interior e $ oneOf"
                         Doc -> Doc -> Doc
    $$ Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "[" Doc -> Doc -> Doc
    <+> Doc -> (Name, [StructType]) -> Doc
    mkParseConstr Doc
    frattr ([(Name, [StructType])] -> (Name, [StructType])
    forall a. HasCallStack => [a] -> a
    head [(Name, [StructType])]
    cs)
                                   Doc -> Doc -> Doc
    $$ [Doc] -> Doc
    vcat (((Name, [StructType]) -> Doc) -> [(Name, [StructType])] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name, [StructType])
    c-> String -> Doc
    text String
    "," Doc -> Doc -> Doc
    <+> Doc -> (Name, [StructType]) -> Doc
    mkParseConstr Doc
    frattr (Name, [StructType])
    c)
                                                ([(Name, [StructType])] -> [(Name, [StructType])]
    forall a. HasCallStack => [a] -> [a]
    tail [(Name, [StructType])]
    cs))
                                   Doc -> Doc -> Doc
    $$ String -> Doc
    text String
    "] `adjustErr` (\"in <" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n
                                                                 Doc -> Doc -> Doc
    <> String -> Doc
    text String
    ">, \"++)"
                                   )
                         Doc -> Doc -> Doc
    $$ String -> Doc
    text String
    "}"
                         )
               )
        Doc -> Doc -> Doc
    $$
        SameName -> Name -> AttrFields -> Doc
    mkInstanceAttrs SameName
    Extended Name
    n AttrFields
    fs

    -- multiple constructors (auxiliary)
    mkInstance (DataDef Bool
    True Name
    n AttrFields
    fs [(Name, [StructType])]
    cs) =
        let [Doc]
    _ = [(Name, [StructType])] -> [Doc]
    forall b. [b] -> [Doc]
    nameSupply [(Name, [StructType])]
    cs
            (Doc
    _, Doc
    frattr, Doc
    _, Doc
    _) = AttrFields -> (Doc, Doc, Doc, Doc)
    attrpats AttrFields
    fs
            mixattrs :: Bool
    mixattrs = Bool -> Bool
    not (AttrFields -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null AttrFields
    fs)
        in
        String -> Doc
    text String
    "instance HTypeable" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "toHType x = Defined \"" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\" [] []" )
        Doc -> Doc -> Doc
    $$
        String -> Doc
    text String
    "instance XmlContent" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( [Doc] -> Doc
    vcat (((Name, [StructType]) -> Doc) -> [(Name, [StructType])] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map (Bool -> (Name, [StructType]) -> Doc
    mkToAux Bool
    mixattrs) [(Name, [StructType])]
    cs)
               Doc -> Doc -> Doc
    $$ String -> Doc
    text String
    "parseContents = oneOf"
               Doc -> Doc -> Doc
    $$ Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "[" Doc -> Doc -> Doc
    <+> Doc -> (Name, [StructType]) -> Doc
    mkParseConstr Doc
    frattr ([(Name, [StructType])] -> (Name, [StructType])
    forall a. HasCallStack => [a] -> a
    head [(Name, [StructType])]
    cs)
                         Doc -> Doc -> Doc
    $$ [Doc] -> Doc
    vcat (((Name, [StructType]) -> Doc) -> [(Name, [StructType])] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name, [StructType])
    c-> String -> Doc
    text String
    "," Doc -> Doc -> Doc
    <+> Doc -> (Name, [StructType]) -> Doc
    mkParseConstr Doc
    frattr (Name, [StructType])
    c)
                                      ([(Name, [StructType])] -> [(Name, [StructType])]
    forall a. HasCallStack => [a] -> [a]
    tail [(Name, [StructType])]
    cs))
                         Doc -> Doc -> Doc
    $$ String -> Doc
    text String
    "] `adjustErr` (\"in <" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n
                                                         Doc -> Doc -> Doc
    <> String -> Doc
    text String
    ">, \"++)"
                         )
               )
        Doc -> Doc -> Doc
    $$
        SameName -> Name -> AttrFields -> Doc
    mkInstanceAttrs SameName
    Extended Name
    n AttrFields
    fs

    -- enumeration of attribute values
    mkInstance (EnumDef Name
    n [Name]
    es) =
        String -> Doc
    text String
    "instance XmlAttrType" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "fromAttrToTyp n (N n',v)" Doc -> Doc -> Doc
    $$
                 Int -> Doc -> Doc
    nest Int
    4 (String -> Doc
    text String
    "| n==n'     = translate (attr2str v)" Doc -> Doc -> Doc
    $$
                         String -> Doc
    text String
    "| otherwise = Nothing") Doc -> Doc -> Doc
    $$
                 Int -> Doc -> Doc
    nest Int
    2 (String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    <+> [Name] -> Doc
    mkTranslate [Name]
    es)
               Doc -> Doc -> Doc
    $$
                 [Doc] -> Doc
    vcat ((Name -> Doc) -> [Name] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Doc
    mkToAttr [Name]
    es)
               )

    data SameName = Same | Extended

    mkInstanceAttrs        :: SameName -> Name -> AttrFields -> Doc
    mkInstanceAttrs :: SameName -> Name -> AttrFields -> Doc
    mkInstanceAttrs SameName
    _ Name
    _ []  = Doc
    empty
    mkInstanceAttrs SameName
    s Name
    n AttrFields
    fs  =
        let ppName :: Name -> Doc
    ppName = case SameName
    s of { SameName
    Same-> Name -> Doc
    ppHName;  SameName
    Extended-> Name -> Doc
    ppAName; }
        in
        String -> Doc
    text String
    "instance XmlAttributes" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "where" Doc -> Doc -> Doc
    $$
        Int -> Doc -> Doc
    nest Int
    4 ( String -> Doc
    text String
    "fromAttrs as =" Doc -> Doc -> Doc
    $$
                 Int -> Doc -> Doc
    nest Int
    4 ( Name -> Doc
    ppName Name
    n Doc -> Doc -> Doc
    $$
                          Int -> Doc -> Doc
    nest Int
    2 ([Doc] -> Doc
    vcat ((String -> Doc
    text String
    "{" Doc -> Doc -> Doc
    <+> Name -> (Name, StructType) -> Doc
    mkFrFld Name
    n (AttrFields -> (Name, StructType)
    forall a. HasCallStack => [a] -> a
    head AttrFields
    fs))Doc -> [Doc] -> [Doc]
    forall a. a -> [a] -> [a]
    :
                                         ((Name, StructType) -> Doc) -> AttrFields -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name, StructType)
    x-> Doc
    comma Doc -> Doc -> Doc
    <+> Name -> (Name, StructType) -> Doc
    mkFrFld Name
    n (Name, StructType)
    x) (AttrFields -> AttrFields
    forall a. HasCallStack => [a] -> [a]
    tail AttrFields
    fs)) Doc -> Doc -> Doc
    $$
                                  String -> Doc
    text String
    "}"))
               Doc -> Doc -> Doc
    $$
                 String -> Doc
    text String
    "toAttrs v = catMaybes " Doc -> Doc -> Doc
    $$
                 Int -> Doc -> Doc
    nest Int
    4 ([Doc] -> Doc
    vcat ((String -> Doc
    text String
    "[" Doc -> Doc -> Doc
    <+> (Name, StructType) -> Doc
    mkToFld (AttrFields -> (Name, StructType)
    forall a. HasCallStack => [a] -> a
    head AttrFields
    fs))Doc -> [Doc] -> [Doc]
    forall a. a -> [a] -> [a]
    :
                               ((Name, StructType) -> Doc) -> AttrFields -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name, StructType)
    x-> Doc
    comma Doc -> Doc -> Doc
    <+> (Name, StructType) -> Doc
    mkToFld (Name, StructType)
    x) (AttrFields -> AttrFields
    forall a. HasCallStack => [a] -> [a]
    tail AttrFields
    fs)) Doc -> Doc -> Doc
    $$
                         String -> Doc
    text String
    "]")
               )

    --                  respectively (frpat,frattr,topat,toattr)
    attrpats :: AttrFields -> (Doc,Doc,Doc,Doc)
    attrpats :: AttrFields -> (Doc, Doc, Doc, Doc)
    attrpats AttrFields
    fs =
      if AttrFields -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null AttrFields
    fs then (String -> Doc
    text String
    "[]", Doc
    empty, Doc
    empty, String -> Doc
    text String
    "[]")
      else (String -> Doc
    text String
    "as", Doc -> Doc
    parens (String -> Doc
    text String
    "fromAttrs as"), String -> Doc
    text String
    "as", Doc -> Doc
    parens (String -> Doc
    text String
    "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 :: Doc -> (Name, [StructType]) -> Doc
    mkParseConstr Doc
    frattr (Name
    c,[StructType]
    sts) =
            [Doc] -> Doc
    fsep (String -> Doc
    text String
    "return" Doc -> Doc -> Doc
    <+> Doc -> Doc
    parens (Name -> Doc
    ppHName Name
    c Doc -> Doc -> Doc
    <+> Doc
    frattr)
                 Doc -> [Doc] -> [Doc]
    forall a. a -> [a] -> [a]
    : (StructType -> Doc) -> [StructType] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map StructType -> Doc
    mkParseContents [StructType]
    sts)

    mkParseContents :: StructType -> Doc
    mkParseContents :: StructType -> Doc
    mkParseContents StructType
    st =
      let ap :: Doc
    ap = String -> Doc
    text String
    "`apply`" in
              case StructType
    st of
                (Maybe StructType
    String)    -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "optional text"
                (Maybe StructType
    _)         -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "optional parseContents"
                (List StructType
    String)     -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "many text"
                (List StructType
    _)          -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "many parseContents"
                (List1 StructType
    _)         -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "parseContents"
                (Tuple [StructType]
    _)         -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "parseContents"
                (OneOf [StructType]
    _)         -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "parseContents"
                StructType
    StringMixed       -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "text"
                StructType
    String            -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "(text `onFail` return \"\")"
                StructType
    Any               -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "parseContents"
                (Defined Name
    _)       -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "parseContents"
                (Defaultable StructType
    _ String
    _) -> Doc
    ap Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "nyi_fromElem_Defaultable"

    --
    mkToElem :: [StructType] -> [Doc] -> Doc
    mkToElem :: [StructType] -> [Doc] -> Doc
    mkToElem []  [] = String -> Doc
    text String
    "[]"
    mkToElem [StructType]
    sts [Doc]
    vs =
        [Doc] -> Doc
    fsep (Doc -> [Doc] -> [Doc]
    forall a. a -> [a] -> [a]
    intersperse (String -> Doc
    text String
    "++") ((StructType -> Doc -> Doc) -> [StructType] -> [Doc] -> [Doc]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith StructType -> Doc -> Doc
    toElem [StructType]
    sts [Doc]
    vs))
      where
        toElem :: StructType -> Doc -> Doc
    toElem StructType
    st Doc
    v =
          case StructType
    st of
            (Maybe StructType
    String)    -> String -> Doc
    text String
    "maybe [] toText" Doc -> Doc -> Doc
    <+> Doc
    v
            (Maybe StructType
    _)         -> String -> Doc
    text String
    "maybe [] toContents" Doc -> Doc -> Doc
    <+> Doc
    v
            (List StructType
    String)     -> String -> Doc
    text String
    "concatMap toText" Doc -> Doc -> Doc
    <+> Doc
    v
            (List StructType
    _)          -> String -> Doc
    text String
    "concatMap toContents" Doc -> Doc -> Doc
    <+> Doc
    v
            (List1 StructType
    _)         -> String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc
    v
            (Tuple [StructType]
    _)         -> String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc
    v
            (OneOf [StructType]
    _)         -> String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc
    v
            StructType
    StringMixed       -> String -> Doc
    text String
    "toText" Doc -> Doc -> Doc
    <+> Doc
    v
            StructType
    String            -> String -> Doc
    text String
    "toText" Doc -> Doc -> Doc
    <+> Doc
    v
            StructType
    Any               -> String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc
    v
            (Defined Name
    _)       -> String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc
    v
            (Defaultable StructType
    _ String
    _) -> String -> Doc
    text String
    "nyi_toElem_Defaultable" Doc -> Doc -> Doc
    <+> Doc
    v

    -- mkRpat :: [Doc] -> Doc
    -- mkRpat [v] = v
    -- mkRpat vs  = (parens . hcat . intersperse comma) vs

    mkCpat :: Name -> Doc -> [Doc] -> Doc
    mkCpat :: Name -> Doc -> [Doc] -> Doc
    mkCpat Name
    n Doc
    i [Doc]
    vs = Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> Doc
    i Doc -> Doc -> Doc
    <+> [Doc] -> Doc
    fsep [Doc]
    vs

    nameSupply :: [b] -> [Doc]
    nameSupply :: forall b. [b] -> [Doc]
    nameSupply  [b]
    ss = Int -> [Doc] -> [Doc]
    forall a. Int -> [a] -> [a]
    take ([b] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [b]
    ss) ((Char -> Doc) -> String -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map Char -> Doc
    char [Char
    'a'..Char
    'z']
                                      [Doc] -> [Doc] -> [Doc]
    forall a. [a] -> [a] -> [a]
    ++ [ String -> Doc
    text [Char
    a,Char
    n] | Char
    n <- [Char
    '0'..Char
    '9']
                                                      , Char
    a <- [Char
    'a'..Char
    'z'] ])
    -- nameSupply2 ss = take (length ss) [ text ('c':v:[]) | v <- ['a'..]]

    mkTranslate :: [Name] -> Doc
    mkTranslate :: [Name] -> Doc
    mkTranslate [Name]
    es =
        [Doc] -> Doc
    vcat ((Name -> Doc) -> [Name] -> [Doc]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Doc
    trans [Name]
    es) Doc -> Doc -> Doc
    $$
        String -> Doc
    text String
    "translate _ = Nothing"
      where
        trans :: Name -> Doc
    trans Name
    n = String -> Doc
    text String
    "translate \"" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    n Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\" =" Doc -> Doc -> Doc
    <+>
                  String -> Doc
    text String
    "Just" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n

    mkToAttr :: Name -> Doc
    mkToAttr :: Name -> Doc
    mkToAttr Name
    n = String -> Doc
    text String
    "toAttrFrTyp n" Doc -> Doc -> Doc
    <+> Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "=" Doc -> Doc -> Doc
    <+>
                 String -> Doc
    text String
    "Just (N n, str2attr" Doc -> Doc -> Doc
    <+> Doc -> Doc
    doubleQuotes (Name -> Doc
    ppXName Name
    n) Doc -> Doc -> Doc
    <> String -> Doc
    text String
    ")"

    mkFrFld :: Name -> (Name,StructType) -> Doc
    mkFrFld :: Name -> (Name, StructType) -> Doc
    mkFrFld Name
    tag (Name
    n,StructType
    st) =
        Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "=" Doc -> Doc -> Doc
    <+>
        ( case StructType
    st of
            (Defaultable StructType
    String String
    s) -> String -> Doc
    text String
    "defaultA fromAttrToStr" Doc -> Doc -> Doc
    <+>
                                                     Doc -> Doc
    doubleQuotes (String -> Doc
    text String
    s)
            (Defaultable StructType
    _ String
    s)      -> String -> Doc
    text String
    "defaultA fromAttrToTyp" Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    s
            (Maybe StructType
    String)         -> String -> Doc
    text String
    "possibleA fromAttrToStr"
            (Maybe StructType
    _)              -> String -> Doc
    text String
    "possibleA fromAttrToTyp"
            StructType
    String                 -> String -> Doc
    text String
    "definiteA fromAttrToStr" Doc -> Doc -> Doc
    <+>
                                                     Doc -> Doc
    doubleQuotes (Name -> Doc
    ppXName Name
    tag)
            StructType
    _                      -> String -> Doc
    text String
    "definiteA fromAttrToTyp" Doc -> Doc -> Doc
    <+>
                                                     Doc -> Doc
    doubleQuotes (Name -> Doc
    ppXName Name
    tag)
        ) Doc -> Doc -> Doc
    <+> Doc -> Doc
    doubleQuotes (Name -> Doc
    ppXName Name
    n) Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "as"

    mkToFld :: (Name,StructType) -> Doc
    mkToFld :: (Name, StructType) -> Doc
    mkToFld (Name
    n,StructType
    st) =
        ( case StructType
    st of
            (Defaultable StructType
    String String
    _) -> String -> Doc
    text String
    "defaultToAttr toAttrFrStr"
            (Defaultable StructType
    _ String
    _)      -> String -> Doc
    text String
    "defaultToAttr toAttrFrTyp"
            (Maybe StructType
    String)         -> String -> Doc
    text String
    "maybeToAttr toAttrFrStr"
            (Maybe StructType
    _)              -> String -> Doc
    text String
    "maybeToAttr toAttrFrTyp"
            StructType
    String                 -> String -> Doc
    text String
    "toAttrFrStr"
            StructType
    _                      -> String -> Doc
    text String
    "toAttrFrTyp"
        ) Doc -> Doc -> Doc
    <+> Doc -> Doc
    doubleQuotes (Name -> Doc
    ppXName Name
    n) Doc -> Doc -> Doc
    <+> Doc -> Doc
    parens (Name -> Doc
    ppHName Name
    n Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "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 :: Bool -> (Name, [StructType]) -> Doc
    mkToAux Bool
    mixattrs (Name
    n,[StructType]
    sts) =
        let vs :: [Doc]
    vs = [StructType] -> [Doc]
    forall b. [b] -> [Doc]
    nameSupply [StructType]
    sts
            attrs :: Doc
    attrs = if Bool
    mixattrs then String -> Doc
    text String
    "as" else Doc
    empty
        in
        String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc -> Doc
    parens (Name -> Doc -> [Doc] -> Doc
    mkCpat Name
    n Doc
    attrs [Doc]
    vs) Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "=" Doc -> Doc -> Doc
    <+>
        [StructType] -> [Doc] -> Doc
    mkToElem [StructType]
    sts [Doc]
    vs

    mkToMult :: Name -> Doc -> Doc -> (Name,[StructType]) -> Doc
    mkToMult :: Name -> Doc -> Doc -> (Name, [StructType]) -> Doc
    mkToMult Name
    tag Doc
    attrpat Doc
    attrexp (Name
    n,[StructType]
    sts) =
        let vs :: [Doc]
    vs = [StructType] -> [Doc]
    forall b. [b] -> [Doc]
    nameSupply [StructType]
    sts
        in
        String -> Doc
    text String
    "toContents" Doc -> Doc -> Doc
    <+> Doc -> Doc
    parens (Name -> Doc -> [Doc] -> Doc
    mkCpat Name
    n Doc
    attrpat [Doc]
    vs) Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    "="
        Doc -> Doc -> Doc
    $$ Int -> Doc -> Doc
    nest Int
    4 (String -> Doc
    text String
    "[CElem (Elem (N \"" Doc -> Doc -> Doc
    <> Name -> Doc
    ppXName Name
    tag Doc -> Doc -> Doc
    <> String -> Doc
    text String
    "\")"Doc -> Doc -> Doc
    <+> Doc
    attrexp
                  Doc -> Doc -> Doc
    <+> Doc -> Doc
    parens ([StructType] -> [Doc] -> Doc
    mkToElem [StructType]
    sts [Doc]
    vs) Doc -> Doc -> Doc
    <+> String -> Doc
    text String
    ") ()]")