module Text.XML.HaXml.DtdToHaskell.TypeDef
(
TypeDef(..)
, Constructors
, AttrFields
, StructType(..)
, ppTypeDef
, ppHName
, ppXName
, ppAName
, 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
data Name = Name { xName :: String
, hName :: String
}
deriving Eq
data TypeDef =
DataDef Bool Name AttrFields Constructors
| EnumDef Name [Name]
deriving Eq
type Constructors = [(Name,[StructType])]
type AttrFields = [(Name, StructType)]
data StructType =
Maybe StructType
| Defaultable StructType String
| List StructType
| List1 StructType
| Tuple [StructType]
| OneOf [StructType]
| Any
| String
| Defined Name
deriving Eq
instance Show StructType where
showsPrec p (Maybe s) = showsPrec (p+1) s . showChar '?'
showsPrec p (Defaultable s _) = shows s
showsPrec p (List s) = showsPrec (p+1) s . showChar '*'
showsPrec p (List1 s) = showsPrec (p+1) s . showChar '+'
showsPrec p (Tuple ss) = showChar '('
. foldr1 (.) (intersperse (showChar ',')
(map shows ss))
. showChar ')'
showsPrec p (OneOf ss) = showChar '('
. foldr1 (.) (intersperse (showChar '|')
(map shows ss))
. showChar ')'
showsPrec p (Any) = showString "ANY"
showsPrec p (String) = showString "#PCDATA"
showsPrec p (Defined (Name n _)) = showString n
ppTypeDef :: TypeDef -> Doc
ppTypeDef (DataDef _ n [] []) =
let name = ppHName n in
text "data" <+> name <+> text "=" <+> name <+> text "\t\t" <> derives
ppTypeDef (DataDef _ n [] [c@(_,[_])]) =
text "newtype" <+> ppHName n <+> text "=" <+> ppC c <+> text "\t\t" <> derives
ppTypeDef (DataDef _ n [] cs) =
text "data" <+> ppHName n <+>
( text "=" <+> ppC (head cs) $$
vcat (map (\c-> text "|" <+> ppC c) (tail cs)) $$
derives )
ppTypeDef (DataDef _ n fs []) =
let name = ppHName n in
text "data" <+> name <+> text "=" <+> name $$
nest 4 ( text "{" <+> ppF (head fs) $$
vcat (map (\f-> text "," <+> ppF f) (tail fs)) $$
text "}" <+> derives )
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 )
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 String = text "String"
ppST Any = text "ANYContent"
ppST (Defined n) = ppHName n
ppC :: (Name,[StructType]) -> Doc
ppC (n,sts) = ppHName n <+> fsep (map ppST sts)
ppF :: (Name,StructType) -> Doc
ppF (n,st) = ppHName n <+> text "::" <+> ppST st
ppAC :: Doc -> (Name,[StructType]) -> Doc
ppAC atype (n,sts) = ppHName n <+> fsep (atype: map ppST sts)
ppHName :: Name -> Doc
ppHName (Name _ s) = text s
ppXName :: Name -> Doc
ppXName (Name s _) = text s
ppAName :: Name -> Doc
ppAName (Name _ s) = text s <> text "_Attrs"
derives = text "deriving" <+> parens (commaList (map text ["Eq","Show"]))
name :: String -> Name
name n = Name n (mangle n)
name_ :: String -> Name
name_ n = Name n (mangle n ++ "_")
name_a :: String -> String -> Name
name_a e n = Name n (mangle e ++ "_" ++ map decolonify n)
name_ac :: String -> String -> String -> Name
name_ac e t n = Name n (mangle e ++ "_" ++ map decolonify t
++ "_" ++ map decolonify n)
name_f :: String -> String -> Name
name_f e n = Name n (manglef e ++ mangle n)
mangle :: String -> String
mangle (n:ns)
| isLower n = toUpper n: map decolonify ns
| isDigit n = 'I': n: map decolonify ns
| otherwise = n: map decolonify ns
manglef :: String -> String
manglef (n:ns)
| isUpper n = toLower n: map decolonify ns
| isDigit n = '_': n: map decolonify ns
| otherwise = n: map decolonify ns
decolonify :: Char -> Char
decolonify ':' = '\''
decolonify '-' = '_'
decolonify c = c
commaList = hcat . intersperse comma