{-# 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 p :: Int
p (Maybe s :: StructType
s) = Int -> StructType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) StructType
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar '?'
showsPrec _ (Defaultable s :: StructType
s _) = StructType -> ShowS
forall a. Show a => a -> ShowS
shows StructType
s
showsPrec p :: Int
p (List s :: StructType
s) = Int -> StructType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) StructType
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar '*'
showsPrec p :: Int
p (List1 s :: StructType
s) = Int -> StructType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Int
pInt -> Int -> Int
forall a. Num a => a -> a -> a
+1) StructType
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar '+'
showsPrec _ (Tuple ss :: [StructType]
ss) = Char -> ShowS
showChar '('
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 ',')
((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 ')'
showsPrec _ (OneOf ss :: [StructType]
ss) = Char -> ShowS
showChar '('
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 '|')
((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 ')'
showsPrec _ (StructType
Any) = String -> ShowS
showString "ANY"
showsPrec _ (StructType
StringMixed) = String -> ShowS
showString "#PCDATA"
showsPrec _ (StructType
String) = String -> ShowS
showString "#PCDATA"
showsPrec _ (Defined (Name n :: String
n _)) = String -> ShowS
showString String
n
ppTypeDef :: TypeDef -> Doc
ppTypeDef :: TypeDef -> Doc
ppTypeDef (DataDef _ n :: Name
n [] []) =
let nme :: Doc
nme = Name -> Doc
ppHName Name
n in
String -> Doc
text "data" Doc -> Doc -> Doc
<+> Doc
nme Doc -> Doc -> Doc
<+> String -> Doc
text "=" Doc -> Doc -> Doc
<+> Doc
nme Doc -> Doc -> Doc
<+> String -> Doc
text "\t\t" Doc -> Doc -> Doc
<> Doc
derives
ppTypeDef (DataDef _ n :: Name
n [] [c :: (Name, [StructType])
c@(_,[_])]) =
String -> Doc
text "newtype" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text "=" Doc -> Doc -> Doc
<+> (Name, [StructType]) -> Doc
ppC (Name, [StructType])
c Doc -> Doc -> Doc
<+> String -> Doc
text "\t\t" Doc -> Doc -> Doc
<> Doc
derives
ppTypeDef (DataDef _ n :: Name
n [] cs :: Constructors
cs) =
String -> Doc
text "data" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+>
( String -> Doc
text "=" Doc -> Doc -> Doc
<+> (Name, [StructType]) -> Doc
ppC (Constructors -> (Name, [StructType])
forall a. [a] -> a
head Constructors
cs) Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat (((Name, [StructType]) -> Doc) -> Constructors -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: (Name, [StructType])
c-> String -> Doc
text "|" Doc -> Doc -> Doc
<+> (Name, [StructType]) -> Doc
ppC (Name, [StructType])
c) (Constructors -> Constructors
forall a. [a] -> [a]
tail Constructors
cs)) Doc -> Doc -> Doc
$$
Doc
derives )
ppTypeDef (DataDef _ n :: Name
n fs :: AttrFields
fs []) =
let nme :: Doc
nme = Name -> Doc
ppHName Name
n in
String -> Doc
text "data" Doc -> Doc -> Doc
<+> Doc
nme Doc -> Doc -> Doc
<+> String -> Doc
text "=" Doc -> Doc -> Doc
<+> Doc
nme Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest 4 ( String -> Doc
text "{" Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
ppF (AttrFields -> (Name, StructType)
forall a. [a] -> a
head AttrFields
fs) Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat (((Name, StructType) -> Doc) -> AttrFields -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\f :: (Name, StructType)
f-> String -> Doc
text "," Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
ppF (Name, StructType)
f) (AttrFields -> AttrFields
forall a. [a] -> [a]
tail AttrFields
fs)) Doc -> Doc -> Doc
$$
String -> Doc
text "}" Doc -> Doc -> Doc
<+> Doc
derives )
ppTypeDef (DataDef _ n :: Name
n fs :: AttrFields
fs cs :: Constructors
cs) =
let attr :: Doc
attr = Name -> Doc
ppAName Name
n in
String -> Doc
text "data" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+>
( String -> Doc
text "=" Doc -> Doc -> Doc
<+> Doc -> (Name, [StructType]) -> Doc
ppAC Doc
attr (Constructors -> (Name, [StructType])
forall a. [a] -> a
head Constructors
cs) Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat (((Name, [StructType]) -> Doc) -> Constructors -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\c :: (Name, [StructType])
c-> String -> Doc
text "|" Doc -> Doc -> Doc
<+> Doc -> (Name, [StructType]) -> Doc
ppAC Doc
attr (Name, [StructType])
c) (Constructors -> Constructors
forall a. [a] -> [a]
tail Constructors
cs)) Doc -> Doc -> Doc
$$
Doc
derives ) Doc -> Doc -> Doc
$$
String -> Doc
text "data" Doc -> Doc -> Doc
<+> Doc
attr Doc -> Doc -> Doc
<+> String -> Doc
text "=" Doc -> Doc -> Doc
<+> Doc
attr Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest 4 ( String -> Doc
text "{" Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
ppF (AttrFields -> (Name, StructType)
forall a. [a] -> a
head AttrFields
fs) Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat (((Name, StructType) -> Doc) -> AttrFields -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\f :: (Name, StructType)
f-> String -> Doc
text "," Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
ppF (Name, StructType)
f) (AttrFields -> AttrFields
forall a. [a] -> [a]
tail AttrFields
fs)) Doc -> Doc -> Doc
$$
String -> Doc
text "}" Doc -> Doc -> Doc
<+> Doc
derives )
ppTypeDef (EnumDef n :: Name
n es :: [Name]
es) =
String -> Doc
text "data" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+>
( String -> Doc
text "=" Doc -> Doc -> Doc
<+>
[Doc] -> Doc
fsep (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text " | ") ((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 st :: StructType
st _) = Doc -> Doc
parens (String -> Doc
text "Defaultable" Doc -> Doc -> Doc
<+> StructType -> Doc
ppST StructType
st)
ppST (Maybe st :: StructType
st) = Doc -> Doc
parens (String -> Doc
text "Maybe" Doc -> Doc -> Doc
<+> StructType -> Doc
ppST StructType
st)
ppST (List st :: StructType
st) = String -> Doc
text "[" Doc -> Doc -> Doc
<> StructType -> Doc
ppST StructType
st Doc -> Doc -> Doc
<> String -> Doc
text "]"
ppST (List1 st :: StructType
st) = Doc -> Doc
parens (String -> Doc
text "List1" Doc -> Doc -> Doc
<+> StructType -> Doc
ppST StructType
st)
ppST (Tuple sts :: [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 sts :: [StructType]
sts) = Doc -> Doc
parens (String -> Doc
text "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 StringMixed= String -> Doc
text "String"
ppST String = String -> Doc
text "String"
ppST Any = String -> Doc
text "ANYContent"
ppST (Defined n :: Name
n) = Name -> Doc
ppHName Name
n
ppC :: (Name,[StructType]) -> Doc
ppC :: (Name, [StructType]) -> Doc
ppC (n :: Name
n,sts :: [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 (n :: Name
n,st :: StructType
st) = Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text "::" Doc -> Doc -> Doc
<+> StructType -> Doc
ppST StructType
st
ppAC :: Doc -> (Name,[StructType]) -> Doc
ppAC :: Doc -> (Name, [StructType]) -> Doc
ppAC atype :: Doc
atype (n :: Name
n,sts :: [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 _ s :: String
s) = String -> Doc
text String
s
ppXName :: Name -> Doc
ppXName :: Name -> Doc
ppXName (Name s :: String
s _) = String -> Doc
text String
s
ppAName :: Name -> Doc
ppAName :: Name -> Doc
ppAName (Name _ s :: String
s) = String -> Doc
text String
s Doc -> Doc -> Doc
<> String -> Doc
text "_Attrs"
derives :: Doc
derives :: Doc
derives = String -> Doc
text "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 ["Eq","Show"]))
name :: String -> Name
name :: String -> Name
name n :: 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_ n :: 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]
++ "_" }
name_a :: String -> String -> Name
name_a :: String -> String -> Name
name_a e :: String
e n :: 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 -> 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 e :: String
e t :: String
t n :: 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 -> 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 -> 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 e :: String
e n :: 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 (n :: Char
n:ns :: 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 = '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 "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"
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 :: String
n = String
n
manglef :: String -> String
manglef :: ShowS
manglef (n :: Char
n:ns :: 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 -> 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 ':' = '\''
decolonify '-' = '_'
decolonify '.' = '_'
decolonify c :: 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