{-# LANGUAGE CPP #-}
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
#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
data Name = Name { Name -> String
xName :: String
, Name -> String
hName :: String
}
deriving Name -> Name -> Bool
(Name -> Name -> Bool) -> (Name -> Name -> Bool) -> Eq Name
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
| EnumDef Name [Name]
deriving TypeDef -> TypeDef -> Bool
(TypeDef -> TypeDef -> Bool)
-> (TypeDef -> TypeDef -> Bool) -> Eq TypeDef
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
| List StructType
| List1 StructType
| Tuple [StructType]
| OneOf [StructType]
| Any
| StringMixed
| String
| Defined Name
deriving StructType -> StructType -> Bool
(StructType -> StructType -> Bool)
-> (StructType -> StructType -> Bool) -> Eq StructType
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
instance Show StructType where
showsPrec :: Int -> StructType -> ShowS
showsPrec Int
p (Maybe StructType
s) = Int -> StructType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) StructType
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'?'
showsPrec Int
_ (Defaultable StructType
s String
_) = StructType -> ShowS
forall a. Show a => a -> ShowS
shows StructType
s
showsPrec Int
p (List StructType
s) = Int -> StructType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) StructType
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'*'
showsPrec Int
p (List1 StructType
s) = Int -> StructType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) StructType
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'+'
showsPrec Int
_ (Tuple [StructType]
ss) = Char -> ShowS
showChar Char
'('
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
',')
((StructType -> ShowS) -> [StructType] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> ShowS
forall a. Show a => a -> ShowS
shows [StructType]
ss))
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'
showsPrec Int
_ (OneOf [StructType]
ss) = Char -> ShowS
showChar Char
'('
ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShowS -> ShowS -> ShowS) -> [ShowS] -> ShowS
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
(.) (ShowS -> [ShowS] -> [ShowS]
forall a. a -> [a] -> [a]
intersperse (Char -> ShowS
showChar Char
'|')
((StructType -> ShowS) -> [StructType] -> [ShowS]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> ShowS
forall a. Show a => a -> ShowS
shows [StructType]
ss))
ShowS -> ShowS -> ShowS
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
ppTypeDef :: TypeDef -> Doc
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
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
ppTypeDef (DataDef Bool
_ Name
n [] [(Name, [StructType])]
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 ([(Name, [StructType])] -> (Name, [StructType])
forall a. [a] -> a
head [(Name, [StructType])]
cs) Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat (((Name, [StructType]) -> Doc) -> [(Name, [StructType])] -> [Doc]
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) ([(Name, [StructType])] -> [(Name, [StructType])]
forall a. [a] -> [a]
tail [(Name, [StructType])]
cs)) Doc -> Doc -> Doc
$$
Doc
derives )
ppTypeDef (DataDef Bool
_ Name
n [(Name, StructType)]
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 ([(Name, StructType)] -> (Name, StructType)
forall a. [a] -> a
head [(Name, StructType)]
fs) Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat (((Name, StructType) -> Doc) -> [(Name, StructType)] -> [Doc]
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) ([(Name, StructType)] -> [(Name, StructType)]
forall a. [a] -> [a]
tail [(Name, StructType)]
fs)) Doc -> Doc -> Doc
$$
String -> Doc
text String
"}" Doc -> Doc -> Doc
<+> Doc
derives )
ppTypeDef (DataDef Bool
_ Name
n [(Name, StructType)]
fs [(Name, [StructType])]
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 ([(Name, [StructType])] -> (Name, [StructType])
forall a. [a] -> a
head [(Name, [StructType])]
cs) Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat (((Name, [StructType]) -> Doc) -> [(Name, [StructType])] -> [Doc]
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) ([(Name, [StructType])] -> [(Name, [StructType])]
forall a. [a] -> [a]
tail [(Name, [StructType])]
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 ([(Name, StructType)] -> (Name, StructType)
forall a. [a] -> a
head [(Name, StructType)]
fs) Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat (((Name, StructType) -> Doc) -> [(Name, StructType)] -> [Doc]
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) ([(Name, StructType)] -> [(Name, StructType)]
forall a. [a] -> [a]
tail [(Name, StructType)]
fs)) Doc -> Doc -> Doc
$$
String -> Doc
text String
"}" Doc -> Doc -> Doc
<+> Doc
derives )
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 (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
" | ") ((Name -> Doc) -> [Name] -> [Doc]
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 ((StructType -> Doc) -> [StructType] -> [Doc]
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 (Int -> String
forall a. Show a => a -> String
show ([StructType] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [StructType]
sts)) Doc -> Doc -> Doc
<+>
[Doc] -> Doc
hsep ((StructType -> Doc) -> [StructType] -> [Doc]
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
ppC :: (Name,[StructType]) -> Doc
ppC :: (Name, [StructType]) -> Doc
ppC (Name
n,[StructType]
sts) = Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep ((StructType -> Doc) -> [StructType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> Doc
ppST [StructType]
sts)
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
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
atypeDoc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (StructType -> Doc) -> [StructType] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map StructType -> Doc
ppST [StructType]
sts)
ppHName :: Name -> Doc
ppHName :: Name -> Doc
ppHName (Name String
_ String
s) = String -> Doc
text String
s
ppXName :: Name -> Doc
ppXName :: Name -> Doc
ppXName (Name String
s String
_) = String -> Doc
text String
s
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 ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text [String
"Eq",String
"Show"]))
name :: String -> Name
name :: String -> Name
name String
n = Name :: String -> String -> Name
Name { xName :: String
xName = String
n
, hName :: String
hName = ShowS
mangle String
n }
name_ :: String -> Name
name_ :: String -> Name
name_ String
n = Name :: String -> String -> Name
Name { xName :: String
xName = String
n
, hName :: String
hName = ShowS
mangle String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" }
name_a :: String -> String -> Name
name_a :: String -> String -> Name
name_a String
e String
n = Name :: String -> String -> Name
Name { xName :: String
xName = String
n
, hName :: String
hName = ShowS
mangle String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
n }
name_ac :: String -> String -> String -> Name
name_ac :: String -> String -> String -> Name
name_ac String
e String
t String
n = Name :: String -> String -> Name
Name { xName :: String
xName = String
n
, hName :: String
hName = ShowS
mangle String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
t
String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"_" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
n }
name_f :: String -> String -> Name
name_f :: String -> String -> Name
name_f String
e String
n = Name :: String -> String -> Name
Name { xName :: String
xName = String
n
, hName :: String
hName = ShowS
manglef String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
mangle String
n }
mangle :: String -> String
mangle :: ShowS
mangle (Char
n:String
ns)
| Char -> Bool
isLower Char
n = ShowS
notPrelude (Char -> Char
toUpper Char
nChar -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns)
| Char -> Bool
isDigit Char
n = Char
'I'Char -> ShowS
forall a. a -> [a] -> [a]
: Char
nChar -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns
| Bool
otherwise = ShowS
notPrelude (Char
nChar -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns)
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"
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
manglef :: String -> String
manglef :: ShowS
manglef (Char
n:String
ns)
| Char -> Bool
isUpper Char
n = Char -> Char
toLower Char
nChar -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns
| Char -> Bool
isDigit Char
n = Char
'_'Char -> ShowS
forall a. a -> [a] -> [a]
: Char
nChar -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns
| Bool
otherwise = Char
nChar -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
decolonify String
ns
decolonify :: Char -> Char
decolonify :: Char -> Char
decolonify Char
':' = Char
'\''
decolonify Char
'-' = Char
'_'
decolonify Char
'.' = Char
'_'
decolonify Char
c = Char
c
commaList :: [Doc] -> Doc
commaList :: [Doc] -> Doc
commaList = [Doc] -> Doc
hcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse Doc
comma