content: module DtdToHaskell.Instance
    ( mkInstance
    ) where
  
  import Data.List (intersperse)
  
  import DtdToHaskell.TypeDef
  import Text.PrettyPrint.HughesPJ as PP
  
  {- | Convert typedef to appropriate instance declaration, either @XmlContent@,
  @XmlAttributes@, or @XmlAttrType@. -}
  mkInstance :: TypeDef -> Doc
  
  -- no constructors - represents an element with empty content but attributes.
  mkInstance (DataDef _ n fs []) =
      let (_, frattr, topat, toattr) = attrpats fs
          frretval = if null fs then ppHName n else frattr
          topatval = if null fs then ppHName n else topat
      in
      text "instance HTypeable" <+> ppHName n <+> text "where" $$
      nest 4 (text "toHType _ = Defined \"" PP.<> ppXName n
               PP.<> text "\" [] []" )
      $$
      text "instance XmlContent" <+> ppHName n <+> text "where" $$
      nest 4 (
               text "toContents" <+> topatval <+> text "=" $$
               nest 4 (text "[CElem (Elem (N \"" PP.<> ppXName n PP.<> text "\")"
                            <+> toattr <+> text "[]) ()]")
             $$
               text "parseContents = do" $$
               nest 4 (text (if not (null fs) then
                        "{ (Elem _ as []) <- element [\""
                       else
                        "{ (Elem _ _ []) <- element [\"")
                               PP.<> ppXName n PP.<> text "\"]" $$
                       text "; return" <+> frretval $$
                       text "} `adjustErr` (\"in <" PP.<> ppXName n
                                                    PP.<> text ">, \"++)"
                      )
             )
      $$
      mkInstanceAttrs Same n fs
  
  -- single constructor, "real" (non-auxiliary) type
  mkInstance (DataDef False n fs [(n0, sts)]) =
      let vs = nameSupply sts
          (frpat, frattr, topat, toattr) = attrpats fs
      in
      text "instance HTypeable" <+> ppHName n <+> text "where" $$
      nest 4 ( text "toHType _ = Defined \"" PP.<> ppXName n PP.<> text "\" [] []" )
      $$
      text "instance XmlContent" <+> ppHName n <+> text "where" $$
      nest 4 (
               text "toContents" <+> parens (mkCpat n0 topat vs) <+> text "=" $$
               nest 4 (text "[CElem (Elem (N \"" PP.<> ppXName n PP.<> text "\")"
                            <+> toattr <+> parens (mkToElem sts vs)
                            PP.<> text ") ()]")
             $$
               text "parseContents = do" $$
               nest 4 (text "{ e@(Elem _" <+> frpat <+> text "_) <- element [\""
                               PP.<> ppXName n PP.<> text "\"]"
                       $$ text "; interior e $"
                             <+> mkParseConstr frattr (n0, sts)
                       $$ text "} `adjustErr` (\"in <" PP.<> ppXName n
                                                       PP.<> text ">, \"++)")
             )
      $$
      mkInstanceAttrs Extended n fs
  
  {- single constructor, auxiliary type (i.e. no corresponding element tag)
  cannot be attributes here? -}
  mkInstance (DataDef True n [] [(n0, sts)]) =
      let vs = nameSupply sts
      in
      text "instance HTypeable" <+> ppHName n <+> text "where" $$
      nest 4 ( text "toHType _ = Defined \"" PP.<> ppXName n PP.<> text "\" [] []" )
      $$
      text "instance XmlContent" <+> ppHName n <+> text "where" $$
      nest 4 ( text "toContents" <+> parens (mkCpat n0 empty vs)
                                 <+> text "="
                                 $$ nest 4 (parens (mkToElem sts vs))
             $$
               text "parseContents =" <+> mkParseConstr empty (n0, sts)
             )
  
  -- multiple constructors (real)
  mkInstance (DataDef False n fs cs) =
      let _ = nameSupply cs
          (frpat, frattr, topat, toattr) = attrpats fs
          _ = not (null fs)
      in
      text "instance HTypeable" <+> ppHName n <+> text "where" $$
      nest 4 ( text "toHType _ = Defined \"" PP.<> ppXName n PP.<> 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 [\""
                                                    PP.<> ppXName n PP.<> text "\"]"
                       $$ text "; interior e $ oneOf"
                       $$ nest 4 ( text "[" <+> mkParseConstr frattr (head cs)
                                 $$ vcat (map (\ c -> text "," <+> mkParseConstr frattr c)
                                              (tail cs))
                                 $$ text "] `adjustErr` (\"in <" PP.<> ppXName n
                                                               PP.<> text ">, \"++)"
                                 )
                       $$ text "}"
                       )
             )
      $$
      mkInstanceAttrs Extended n fs
  
  -- multiple constructors (auxiliary)
  mkInstance (DataDef True n fs cs) =
      let _ = nameSupply cs
          (_, frattr, _, _) = attrpats fs
          mixattrs = not (null fs)
      in
      text "instance HTypeable" <+> ppHName n <+> text "where" $$
      nest 4 ( text "toHType _ = Defined \"" PP.<> ppXName n PP.<> 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 <" PP.<> ppXName n
                                                       PP.<> 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"
              (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 \"" PP.<> ppXName n PP.<> text "\" =" <+>
                text "Just" <+> ppHName n
  
  mkToAttr :: Name -> Doc
  mkToAttr n = text "toAttrFrTyp n" <+> ppHName n <+> text "=" <+>
               text "Just (n, str2attr" <+> doubleQuotes (ppXName n) PP.<> 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 \"" PP.<> ppXName tag PP.<> text "\")" <+> attrexp
                <+> parens (mkToElem sts vs) <+> text ") ()]")
  