{-# LANGUAGE CPP #-}
-- | 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

#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif

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 { Name -> String
xName :: String       -- ^ original XML name
                 , Name -> String
hName :: String       -- ^ mangled Haskell name
                 }
          deriving Name -> Name -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Name -> Name -> Bool
$c/= :: Name -> Name -> Bool
== :: Name -> Name -> Bool
$c== :: Name -> Name -> Bool
Eq

data TypeDef =
      DataDef Bool Name AttrFields Constructors -- ^ Bool for main\/aux.
    | EnumDef Name [Name]
    deriving TypeDef -> TypeDef -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypeDef -> TypeDef -> Bool
$c/= :: TypeDef -> TypeDef -> Bool
== :: TypeDef -> TypeDef -> Bool
$c== :: TypeDef -> TypeDef -> Bool
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 StructType -> StructType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: StructType -> StructType -> Bool
$c/= :: StructType -> StructType -> Bool
== :: StructType -> StructType -> Bool
$c== :: StructType -> StructType -> Bool
Eq

-- used for converting StructType (roughly) back to an XML content model
instance Show StructType where
    showsPrec :: Int -> StructType -> ShowS
showsPrec Int
p (Maybe StructType
s)         = forall a. Show a => Int -> a -> ShowS
showsPrec (Int
pforall a. Num a => a -> a -> a
+Int
1) StructType
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'?'
    showsPrec Int
_ (Defaultable StructType
s String
_) = forall a. Show a => a -> ShowS
shows StructType
s
    showsPrec Int
p (List StructType
s)          = forall a. Show a => Int -> a -> ShowS
showsPrec (Int
pforall a. Num a => a -> a -> a
+Int
1) StructType
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'*'
    showsPrec Int
p (List1 StructType
s)         = forall a. Show a => Int -> a -> ShowS
showsPrec (Int
pforall a. Num a => a -> a -> a
+Int
1) StructType
s forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'+'
    showsPrec Int
_ (Tuple [StructType]
ss)        = Char -> ShowS
showChar Char
'('
                                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
',')
                                                              (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> ShowS
shows [StructType]
ss))
                                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'
    showsPrec Int
_ (OneOf [StructType]
ss)        = Char -> ShowS
showChar Char
'('
                                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
'|')
                                                              (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> ShowS
shows [StructType]
ss))
                                    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'
    showsPrec Int
_ StructType
Any               = String -> ShowS
showString String
"ANY"
    showsPrec Int
_ StructType
StringMixed       = String -> ShowS
showString String
"#PCDATA"
    showsPrec Int
_ StructType
String            = String -> ShowS
showString String
"#PCDATA"
    showsPrec Int
_ (Defined (Name String
n String
_)) = String -> ShowS
showString String
n


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

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

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

--      no attrs, multiple constrs
ppTypeDef (DataDef Bool
_ Name
n [] Constructors
cs) =
    String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+>
           ( String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> (Name, [StructType]) -> Doc
ppC (forall a. [a] -> a
head Constructors
cs) Doc -> Doc -> Doc
$$
             [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (\(Name, [StructType])
c-> String -> Doc
text String
"|" Doc -> Doc -> Doc
<+> (Name, [StructType]) -> Doc
ppC (Name, [StructType])
c) (forall a. [a] -> [a]
tail Constructors
cs)) Doc -> Doc -> Doc
$$
             Doc
derives )

--      nonzero attrs, no constructors
ppTypeDef (DataDef Bool
_ Name
n AttrFields
fs []) =
    let nme :: Doc
nme = Name -> Doc
ppHName Name
n in
    String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> Doc
nme Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> Doc
nme Doc -> Doc -> Doc
$$
    Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"{" Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
ppF (forall a. [a] -> a
head AttrFields
fs) Doc -> Doc -> Doc
$$
             [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (\(Name, StructType)
f-> String -> Doc
text String
"," Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
ppF (Name, StructType)
f) (forall a. [a] -> [a]
tail AttrFields
fs)) Doc -> Doc -> Doc
$$
             String -> Doc
text String
"}" Doc -> Doc -> Doc
<+> Doc
derives )

--      nonzero attrs, one or more constrs
ppTypeDef (DataDef Bool
_ Name
n AttrFields
fs Constructors
cs) =
    let attr :: Doc
attr = Name -> Doc
ppAName Name
n in
    String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+>
           ( String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> Doc -> (Name, [StructType]) -> Doc
ppAC Doc
attr (forall a. [a] -> a
head Constructors
cs) Doc -> Doc -> Doc
$$
             [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (\(Name, [StructType])
c-> String -> Doc
text String
"|" Doc -> Doc -> Doc
<+> Doc -> (Name, [StructType]) -> Doc
ppAC Doc
attr (Name, [StructType])
c) (forall a. [a] -> [a]
tail Constructors
cs)) Doc -> Doc -> Doc
$$
             Doc
derives )  Doc -> Doc -> Doc
$$
    String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> Doc
attr Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> Doc
attr Doc -> Doc -> Doc
$$
    Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"{" Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
ppF (forall a. [a] -> a
head AttrFields
fs) Doc -> Doc -> Doc
$$
             [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (\(Name, StructType)
f-> String -> Doc
text String
"," Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
ppF (Name, StructType)
f) (forall a. [a] -> [a]
tail AttrFields
fs)) Doc -> Doc -> Doc
$$
             String -> Doc
text String
"}" Doc -> Doc -> Doc
<+> Doc
derives )

--      enumerations (of attribute values)
ppTypeDef (EnumDef Name
n [Name]
es) =
    String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+>
    ( String -> Doc
text String
"=" Doc -> Doc -> Doc
<+>
      [Doc] -> Doc
fsep (forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
" | ") (forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
ppHName [Name]
es))
    Doc -> Doc -> Doc
$$ Doc
derives )


ppST :: StructType -> Doc
ppST :: StructType -> Doc
ppST (Defaultable StructType
st String
_)  = Doc -> Doc
parens (String -> Doc
text String
"Defaultable" Doc -> Doc -> Doc
<+> StructType -> Doc
ppST StructType
st)
ppST (Maybe StructType
st)  = Doc -> Doc
parens (String -> Doc
text String
"Maybe" Doc -> Doc -> Doc
<+> StructType -> Doc
ppST StructType
st)
ppST (List StructType
st)   = String -> Doc
text String
"[" Doc -> Doc -> Doc
<> StructType -> Doc
ppST StructType
st Doc -> Doc -> Doc
<> String -> Doc
text String
"]"
ppST (List1 StructType
st)  = Doc -> Doc
parens (String -> Doc
text String
"List1" Doc -> Doc -> Doc
<+> StructType -> Doc
ppST StructType
st)
ppST (Tuple [StructType]
sts) = Doc -> Doc
parens ([Doc] -> Doc
commaList (forall a b. (a -> b) -> [a] -> [b]
map StructType -> Doc
ppST [StructType]
sts))
ppST (OneOf [StructType]
sts) = Doc -> Doc
parens (String -> Doc
text String
"OneOf" Doc -> Doc -> Doc
<> String -> Doc
text (forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [StructType]
sts)) Doc -> Doc -> Doc
<+>
                           [Doc] -> Doc
hsep (forall a b. (a -> b) -> [a] -> [b]
map StructType -> Doc
ppST [StructType]
sts))
ppST  StructType
StringMixed= String -> Doc
text String
"String"
ppST  StructType
String     = String -> Doc
text String
"String"
ppST  StructType
Any        = String -> Doc
text String
"ANYContent"
ppST (Defined Name
n) = Name -> Doc
ppHName Name
n

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

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

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

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

derives :: Doc
derives :: Doc
derives = String -> Doc
text String
"deriving" Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Doc] -> Doc
commaList (forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String
"Eq",String
"Show"]))


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

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

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

-- | Prefix an attribute enumeration type name with its containing element
--   name.
name_a :: String -> String -> Name
name_a :: String -> String -> Name
name_a String
e String
n = Name { xName :: String
xName = String
n
                  , hName :: String
hName = ShowS
mangle String
e forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
n }

-- | Prefix an attribute enumeration constructor with its element-tag name,
--   and its enumeration type name.
name_ac :: String -> String -> String -> Name
name_ac :: String -> String -> String -> Name
name_ac String
e String
t String
n = Name { xName :: String
xName = String
n
                     , hName :: String
hName = ShowS
mangle String
e forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
t
                                        forall a. [a] -> [a] -> [a]
++ String
"_" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
n }

-- | Prefix a field name with its enclosing element name.
name_f :: String -> String -> Name
name_f :: String -> String -> Name
name_f String
e String
n = Name { xName :: String
xName = String
n
                  , hName :: String
hName = ShowS
manglef String
e forall a. [a] -> [a] -> [a]
++ ShowS
mangle String
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 :: ShowS
mangle (Char
n:String
ns)
    | Char -> Bool
isLower Char
n   = ShowS
notPrelude (Char -> Char
toUpper Char
nforall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns)
    | Char -> Bool
isDigit Char
n   = Char
'I'forall a. a -> [a] -> [a]
: Char
nforall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns
    | Bool
otherwise   = ShowS
notPrelude (Char
nforall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns)

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

-- | Convert an XML name to a Haskell varid.
manglef :: String -> String
manglef :: ShowS
manglef (Char
n:String
ns)
    | Char -> Bool
isUpper Char
n   = Char -> Char
toLower Char
nforall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns
    | Char -> Bool
isDigit Char
n   = Char
'_'forall a. a -> [a] -> [a]
: Char
nforall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns
    | Bool
otherwise   = Char
nforall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns

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

commaList :: [Doc] -> Doc
commaList :: [Doc] -> Doc
commaList = [Doc] -> Doc
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse Doc
comma