content: {- | This module performs the translation of a parsed XML DTD into the
  internal representation of corresponding Haskell data\/newtypes. -}
  --
  {- Note that dtdToTypeDef is partial - it will crash if you resolve
  qualified names (namespaces) to URIs beforehand.  It will only work
  on the original literal name forms "prefix:name". -}
  
  module DtdToHaskell.Convert
    ( dtd2TypeDef
    ) where
  
  import Data.List (intercalate, nub)
  
  import Text.XML.HaXml.Types hiding (Name)
  import DtdToHaskell.TypeDef
  
  
  -- -- Internal representation for database of DTD decls ----
  data Record = R [AttDef] ContentSpec
  -- type Db = [(QName,Record)]
  
  
  {- -- Build a database of DTD decls then convert them to typedefs ----
  -- (Done in two steps because we need to merge ELEMENT and ATTLIST decls.)
  -- Apparently multiple ATTLIST decls for the same element are permitted,
  -- although only one ELEMENT decl for it is allowed. -}
  dtd2TypeDef :: [MarkupDecl] -> [TypeDef]
  dtd2TypeDef = concatMap convert . reverse . database []
    where
    database db [] = db
    database db (m : ms) =
        case m of
          (Element (ElementDecl n cs)) ->
            case lookup n db of
              Nothing -> database ((n, R [] cs) : db) ms
              (Just (R as _)) -> database (replace n (R as cs) db) ms
          (AttList (AttListDecl n as)) ->
            case lookup n db of
              Nothing -> database ((n, R as EMPTY) : db) ms
              (Just (R a cs)) -> database (replace n (R (nub (a ++ as)) cs) db) ms
      -- (MarkupPE _ m') -> database db (m':ms)
          _ -> database db ms
  
    replace _ _ [] = error "dtd2TypeDef.replace: no element to replace"
    replace n v (x@(n0, _) : db)
        | n == n0 = (n, v) : db
        | otherwise = x : replace n v db
  
  
  -- -- Convert DTD record to typedef ----
  convert :: (QName, Record) -> [TypeDef]
  convert (QN _ _, R _ _) = [] -- TODO: mb change this stub later
  convert (N n, R as cs) =
      case cs of
        EMPTY -> modifier None []
        ANY -> modifier None [[Any]]
                                   -- error "NYI: contentspec of ANY"
        (Mixed PCDATA) -> modifier None [[String]]
        (Mixed (PCDATAplus ns)) -> modifier Star ([StringMixed]
                                                  : map ((: []) . Defined . name
                                                         . \ (N n') -> n')
                                                         ns)
        (ContentSpec cp) ->
            case cp of
              (TagName (QN _ _) _) -> [] -- TODO: mb change this stub later
              (TagName (N n') m) -> modifier m [[Defined (name n')]]
              (Choice cps m) -> modifier m (map ((: []) . inner) cps)
              (Seq cps m) -> modifier m [map inner cps]
      ++ concatMap (mkAttrDef (N n)) as
    where
      attrs :: AttrFields
      attrs = map (mkAttrField (N n)) as
  
      modifier None sts = mkData sts attrs False (name n)
      modifier m [[st]] = mkData [[modf m st]] attrs False (name n)
      modifier m sts = mkData [[modf m (Defined (name_ n))]]
                                                  attrs False (name n) ++
                            mkData sts [] True (name_ n)
  
      inner :: CP -> StructType
      inner (TagName (QN _ _) _ ) = Any
      inner (TagName (N n') m) = modf m (Defined (name n'))
      inner (Choice cps m) = modf m (OneOf (map inner cps))
      inner (Seq cps None) = Tuple (map inner cps)
      inner (Seq cps m) = modf m (Tuple (map inner cps))
  
      modf None x = x
      modf Query x = Maybe x
      modf Star x = List x
      modf Plus x = List1 x
  
  mkData :: [[StructType]] -> AttrFields -> Bool -> Name -> [TypeDef]
  mkData [] fs aux n = [DataDef aux n fs []]
  mkData [ts] fs aux n = [DataDef aux n fs [(n, ts)]]
  mkData tss fs aux n = [DataDef aux n fs (map (mkConstr n) tss)]
    where
      mkConstr m ts = (mkConsName m ts, ts)
      mkConsName (Name x m) sts = Name x (m ++ intercalate "_" (map flatten sts))
      flatten (Defaultable _ _) = "" -- TODO: mb change this stub later
      flatten (Maybe st) = {- "Maybe_" ++ -} flatten st
      flatten (List st) = {- "List_" ++ -} flatten st
      flatten (List1 st) = {- "List1_" ++ -} flatten st
      flatten (Tuple sts) = -- "Tuple" ++ show (length sts) ++ "_" ++
                              intercalate "_" (map flatten sts)
      flatten StringMixed = "Str"
      flatten String = "Str"
      flatten (OneOf sts) = -- "OneOf" ++ show (length sts) ++ "_" ++
                              intercalate "_" (map flatten sts)
      flatten Any = "Any"
      flatten (Defined (Name _ m)) = m
  
  mkAttrDef :: QName -> AttDef -> [TypeDef]
  mkAttrDef _ (AttDef _ StringType _) =
      []
  mkAttrDef _ (AttDef _ (TokenizedType _) _) =
      [] -- mkData [[String]] [] False (name n)
  mkAttrDef (N e) (AttDef (N n) (EnumeratedType (NotationType nt)) _) =
      [EnumDef (name_a e n) (map (name_ac e n) nt)]
  mkAttrDef (N e) (AttDef (N n) (EnumeratedType (Enumeration es)) _) =
      [EnumDef (name_a e n) (map (name_ac e n) es)]
          -- Default attribute values not handled here
  mkAttrDef _ _ = []
  
  mkAttrField :: QName -> AttDef -> (Name, StructType)
  mkAttrField (N e) (AttDef (N n) typ req) = (name_f e n, mkType typ req)
    where
      mkType StringType REQUIRED = String
      mkType StringType IMPLIED = Maybe String
      mkType StringType (DefaultTo v@(AttValue _) _) = Defaultable String (show v)
      mkType (TokenizedType _) REQUIRED = String
      mkType (TokenizedType _) IMPLIED = Maybe String
      mkType (TokenizedType _) (DefaultTo v@(AttValue _) _) =
                                                          Defaultable String (show v)
      mkType (EnumeratedType _) REQUIRED = Defined (name_a e n)
      mkType (EnumeratedType _) IMPLIED = Maybe (Defined (name_a e n))
      mkType (EnumeratedType _) (DefaultTo v@(AttValue _) _) =
                  Defaultable (Defined (name_a e n)) (hName (name_ac e n (show v)))
  
  mkAttrField _ _ = (Name "" "", Any)
  