{-# 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 (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 (N \"" <> 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 (N \"" <> 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 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"
            (StringMixed)     -> ap <+> text "text"
            (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
        (StringMixed)     -> text "toText" <+> 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 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 (N \"" <> ppXName tag <> text "\")"<+> attrexp
              <+> parens (mkToElem sts vs) <+> text ") ()]")