{-# 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 (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 (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 (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. [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. [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 (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. [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. [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. [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. [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. [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. [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 (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 :: [b] -> [Doc]
nameSupply  [b]
ss = Int -> [Doc] -> [Doc]
forall a. Int -> [a] -> [a]
take ([b] -> 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
") ()]")