-- | 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 Data.Char (isLower, isUpper, toLower, toUpper, isDigit)
import Data.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