    -- | Defines an internal representation of Haskell data\/newtype definitions
    --   that correspond to the XML DTD types, and provides pretty-printers to
    --   convert these types into the 'Doc' type of "Text.PrettyPrint.HughesPJ".

    module Text.XML.HaXml.DtdToHaskell.TypeDef
      ( -- * Internal representation of types
        TypeDef(..)
      , Constructors
      , AttrFields
      , StructType(..)
      -- * Pretty-print a TypeDef
      , ppTypeDef
      , ppHName
      , ppXName
      , ppAName
      -- * Name mangling
      , Name(..)
      , name, name_, name_a, name_ac, name_f, mangle, manglef
      ) where

    import Char (isLower, isUpper, toLower, toUpper, isDigit)
    import List (intersperse)
    import Text.PrettyPrint.HughesPJ

    ---- Internal representation for typedefs ----

    -- | Need to keep both the XML and Haskell versions of a name.
    data Name = Name { xName :: String       -- ^ original XML name
                     , hName :: String       -- ^ mangled Haskell name
                     }
              deriving Eq

    data TypeDef =
          DataDef Bool Name AttrFields Constructors -- ^ Bool for main\/aux.
        | EnumDef Name [Name]
        deriving Eq
    type Constructors = [(Name,[StructType])]
    type AttrFields   = [(Name, StructType)]
    data StructType =
          Maybe StructType
        | Defaultable StructType String     -- ^ String holds default value.
        | List StructType
        | List1 StructType                  -- ^ Non-empty lists.
        | Tuple [StructType]
        | OneOf [StructType]
        | Any                               -- ^ XML's contentspec allows ANY
        | StringMixed			-- ^ mixed (#PCDATA | ... )*
        | String				-- ^ string only (#PCDATA)
        | Defined Name
        deriving Eq

    -- used for converting StructType (roughly) back to an XML content model
    instance Show StructType where
        showsPrec p (Maybe s)         = showsPrec (p+1) s . showChar '?'
        showsPrec _ (Defaultable s _) = shows s
        showsPrec p (List s)          = showsPrec (p+1) s . showChar '*'
        showsPrec p (List1 s)         = showsPrec (p+1) s . showChar '+'
        showsPrec _ (Tuple ss)        = showChar '('
                                        . foldr1 (.) (intersperse (showChar ',')
                                                                  (map shows ss))
                                        . showChar ')'
        showsPrec _ (OneOf ss)        = showChar '('
                                        . foldr1 (.) (intersperse (showChar '|')
                                                                  (map shows ss))
                                        . showChar ')'
        showsPrec _ (Any)             = showString "ANY"
        showsPrec _ (StringMixed)     = showString "#PCDATA"
        showsPrec _ (String)          = showString "#PCDATA"
        showsPrec _ (Defined (Name n _)) = showString n

    ---- Pretty-printing typedefs ----
    ppTypeDef :: TypeDef -> Doc

    --      no attrs, no constructors
    ppTypeDef (DataDef _ n [] []) =
        let nme = ppHName n in
        text "data" <+> nme <+> text "=" <+> nme <+> text "\t\t" <> derives

    --      no attrs, single constructor
    ppTypeDef (DataDef _ n [] [c@(_,[_])]) =
        text "newtype" <+> ppHName n <+> text "=" <+> ppC c <+> text "\t\t" <> derives

    --      no attrs, multiple constrs
    ppTypeDef (DataDef _ n [] cs) =
        text "data" <+> ppHName n <+>
               ( text "=" <+> ppC (head cs) $$
                 vcat (map (\c-> text "|" <+> ppC c) (tail cs)) $$
                 derives )

    --      nonzero attrs, no constructors
    ppTypeDef (DataDef _ n fs []) =
        let nme = ppHName n in
        text "data" <+> nme <+> text "=" <+> nme $$
        nest 4 ( text "{" <+> ppF (head fs) $$
                 vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$
                 text "}" <+> derives )

    --      nonzero attrs, one or more constrs
    ppTypeDef (DataDef _ n fs cs) =
        let attr = ppAName n in
        text "data" <+> ppHName n <+>
               ( text "=" <+> ppAC attr (head cs) $$
                 vcat (map (\c-> text "|" <+> ppAC attr c) (tail cs)) $$
                 derives )  $$
        text "data" <+> attr <+> text "=" <+> attr $$
        nest 4 ( text "{" <+> ppF (head fs) $$
                 vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$
                 text "}" <+> derives )

    --      enumerations (of attribute values)
    ppTypeDef (EnumDef n es) =
        text "data" <+> ppHName n <+>
        ( text "=" <+>
          fsep (intersperse (text " | ") (map ppHName es))
        $$ derives )

    ppST :: StructType -> Doc
    ppST (Defaultable st _)  = parens (text "Defaultable" <+> ppST st)
    ppST (Maybe st)  = parens (text "Maybe" <+> ppST st)
    ppST (List st)   = text "[" <> ppST st <> text "]"
    ppST (List1 st)  = parens (text "List1" <+> ppST st)
    ppST (Tuple sts) = parens (commaList (map ppST sts))
    ppST (OneOf sts) = parens (text "OneOf" <> text (show (length sts)) <+>
                               hsep (map ppST sts))
    ppST  StringMixed= text "String"
    ppST  String     = text "String"
    ppST  Any        = text "ANYContent"
    ppST (Defined n) = ppHName n

    -- constructor and components
    ppC :: (Name,[StructType]) -> Doc
    ppC (n,sts) = ppHName n <+> fsep (map ppST sts)

    -- attribute (fieldname and type)
    ppF :: (Name,StructType) -> Doc
    ppF (n,st) = ppHName n <+> text "::" <+> ppST st

    -- constructor and components with initial attr-type
    ppAC :: Doc -> (Name,[StructType]) -> Doc
    ppAC atype (n,sts) = ppHName n <+> fsep (atype: map ppST sts)

    -- | Pretty print Haskell name.
    ppHName :: Name -> Doc
    ppHName (Name _ s) = text s
    -- | Pretty print XML name.
    ppXName :: Name -> Doc
    ppXName (Name s _) = text s
    -- | Pretty print Haskell attributes name.
    ppAName :: Name -> Doc
    ppAName (Name _ s) = text s <> text "_Attrs"

    derives :: Doc
    derives = text "deriving" <+> parens (commaList (map text ["Eq","Show"]))

    ---- Some operations on Names ----

    -- | Make a type name valid in both XML and Haskell.
    name :: String -> Name
    name n     = Name { xName = n
                      , hName = mangle n }

    -- | Append an underscore to the Haskell version of the name.
    name_ :: String -> Name
    name_ n    = Name { xName = n
                      , hName = mangle n ++ "_" }

    -- | Prefix an attribute enumeration type name with its containing element
    --   name.
    name_a :: String -> String -> Name
    name_a e n = Name { xName = n
                      , hName = mangle e ++ "_" ++ map decolonify n }

    -- | Prefix an attribute enumeration constructor with its element-tag name,
    --   and its enumeration type name.
    name_ac :: String -> String -> String -> Name
    name_ac e t n = Name { xName = n
                         , hName = mangle e ++ "_" ++ map decolonify t
                                            ++ "_" ++ map decolonify n }

    -- | Prefix a field name with its enclosing element name.
    name_f :: String -> String -> Name
    name_f e n = Name { xName = n
                      , hName = manglef e ++ mangle n }

    ---- obsolete
    -- elementname_at :: String -> Name
    -- elementname_at n  = Name n (mangle n ++ "_Attrs")

    -- | Convert an XML name to a Haskell conid.
    mangle :: String -> String
    mangle (n:ns)
        | isLower n   = notPrelude (toUpper n: map decolonify ns)
        | isDigit n   = 'I': n: map decolonify ns
        | otherwise   = notPrelude (n: map decolonify ns)

    -- | Ensure a generated name does not conflict with a standard haskell one.
    notPrelude :: String -> String
    notPrelude "Bool"    = "ABool"
    notPrelude "Bounded" = "ABounded"
    notPrelude "Char"    = "AChar"
    notPrelude "Double"  = "ADouble"
    notPrelude "Either"  = "AEither"
    notPrelude "Enum"    = "AEnum"
    notPrelude "Eq"      = "AEq"
    notPrelude "FilePath"= "AFilePath"
    notPrelude "Float"   = "AFloat"
    notPrelude "Floating"= "AFloating"
    notPrelude "Fractional"= "AFractional"
    notPrelude "Functor" = "AFunctor"
    notPrelude "IO"      = "AIO"
    notPrelude "IOError" = "AIOError"
    notPrelude "Int"     = "AInt"
    notPrelude "Integer" = "AInteger"
    notPrelude "Integral"= "AIntegral"
    notPrelude "List1"   = "AList1" -- part of HaXml
    notPrelude "Maybe"   = "AMaybe"
    notPrelude "Monad"   = "AMonad"
    notPrelude "Num"     = "ANum"
    notPrelude "Ord"     = "AOrd"
    notPrelude "Ordering"= "AOrdering"
    notPrelude "Rational"= "ARational"
    notPrelude "Read"    = "ARead"
    notPrelude "ReadS"   = "AReadS"
    notPrelude "Real"    = "AReal"
    notPrelude "RealFloat" = "ARealFloat"
    notPrelude "RealFrac"= "ARealFrac"
    notPrelude "Show"    = "AShow"
    notPrelude "ShowS"   = "AShowS"
    notPrelude "String"  = "AString"
    notPrelude n         = n

    -- | Convert an XML name to a Haskell varid.
    manglef :: String -> String
    manglef (n:ns)
        | isUpper n   = toLower n: map decolonify ns
        | isDigit n   = '_': n: map decolonify ns
        | otherwise   = n: map decolonify ns

    -- | Convert colon to prime, hyphen to underscore.
    decolonify :: Char -> Char
    decolonify ':' = '\''   -- TODO: turn namespaces into qualified identifiers
    decolonify '-' = '_'
    decolonify '.' = '_'
    decolonify  c  = c

    commaList :: [Doc] -> Doc
    commaList = hcat . intersperse comma