{-# LANGUAGE CPP #-}
module Text.XML.HaXml.DtdToHaskell.Instance
( mkInstance
) where
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif
import Data.List (intersperse)
import Text.XML.HaXml.DtdToHaskell.TypeDef
import Text.PrettyPrint.HughesPJ
mkInstance :: TypeDef -> Doc
mkInstance :: TypeDef -> Doc
mkInstance (DataDef Bool
_ Name
n AttrFields
fs []) =
let (Doc
_, Doc
frattr, Doc
topat, Doc
toattr) = AttrFields -> (Doc, Doc, Doc, Doc)
attrpats AttrFields
fs
frretval :: Doc
frretval = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null AttrFields
fs then Name -> Doc
ppHName Name
n else Doc
frattr
topatval :: Doc
topatval = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null AttrFields
fs then Name -> Doc
ppHName Name
n else Doc
topat
in
String -> Doc
text String
"instance HTypeable" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"toHType x = Defined \"" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\" [] []" )
Doc -> Doc -> Doc
$$
String -> Doc
text String
"instance XmlContent" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 (
String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc
topatval Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"[CElem (Elem (N \"" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\")"
Doc -> Doc -> Doc
<+> Doc
toattr Doc -> Doc -> Doc
<+> String -> Doc
text String
"[]) ()]")
Doc -> Doc -> Doc
$$
String -> Doc
text String
"parseContents = do" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"{ (Elem _ as []) <- element [\""
Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\"]" Doc -> Doc -> Doc
$$
String -> Doc
text String
"; return" Doc -> Doc -> Doc
<+> Doc
frretval Doc -> Doc -> Doc
$$
String -> Doc
text String
"} `adjustErr` (\"in <" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n
Doc -> Doc -> Doc
<> String -> Doc
text String
">, \"++)"
)
)
Doc -> Doc -> Doc
$$
SameName -> Name -> AttrFields -> Doc
mkInstanceAttrs SameName
Same Name
n AttrFields
fs
mkInstance (DataDef Bool
False Name
n AttrFields
fs [(Name
n0,[StructType]
sts)]) =
let vs :: [Doc]
vs = forall b. [b] -> [Doc]
nameSupply [StructType]
sts
(Doc
frpat, Doc
frattr, Doc
topat, Doc
toattr) = AttrFields -> (Doc, Doc, Doc, Doc)
attrpats AttrFields
fs
in
String -> Doc
text String
"instance HTypeable" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"toHType x = Defined \"" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\" [] []" )
Doc -> Doc -> Doc
$$
String -> Doc
text String
"instance XmlContent" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 (
String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Name -> Doc -> [Doc] -> Doc
mkCpat Name
n0 Doc
topat [Doc]
vs) Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"[CElem (Elem (N \"" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\")"
Doc -> Doc -> Doc
<+> Doc
toattr Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([StructType] -> [Doc] -> Doc
mkToElem [StructType]
sts [Doc]
vs)
Doc -> Doc -> Doc
<> String -> Doc
text String
") ()]")
Doc -> Doc -> Doc
$$
String -> Doc
text String
"parseContents = do" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"{ e@(Elem _"Doc -> Doc -> Doc
<+> Doc
frpat Doc -> Doc -> Doc
<+> String -> Doc
text String
"_) <- element [\""
Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\"]"
Doc -> Doc -> Doc
$$ String -> Doc
text String
"; interior e $"
Doc -> Doc -> Doc
<+> Doc -> (Name, [StructType]) -> Doc
mkParseConstr Doc
frattr (Name
n0,[StructType]
sts)
Doc -> Doc -> Doc
$$ String -> Doc
text String
"} `adjustErr` (\"in <" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n
Doc -> Doc -> Doc
<> String -> Doc
text String
">, \"++)")
)
Doc -> Doc -> Doc
$$
SameName -> Name -> AttrFields -> Doc
mkInstanceAttrs SameName
Extended Name
n AttrFields
fs
mkInstance (DataDef Bool
True Name
n [] [(Name
n0,[StructType]
sts)]) =
let vs :: [Doc]
vs = forall b. [b] -> [Doc]
nameSupply [StructType]
sts
in
String -> Doc
text String
"instance HTypeable" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"toHType x = Defined \"" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\" [] []" )
Doc -> Doc -> Doc
$$
String -> Doc
text String
"instance XmlContent" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Name -> Doc -> [Doc] -> Doc
mkCpat Name
n0 Doc
empty [Doc]
vs)
Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (Doc -> Doc
parens ([StructType] -> [Doc] -> Doc
mkToElem [StructType]
sts [Doc]
vs))
Doc -> Doc -> Doc
$$
String -> Doc
text String
"parseContents =" Doc -> Doc -> Doc
<+> Doc -> (Name, [StructType]) -> Doc
mkParseConstr Doc
empty (Name
n0,[StructType]
sts)
)
mkInstance (DataDef Bool
False Name
n AttrFields
fs [(Name, [StructType])]
cs) =
let [Doc]
_ = forall b. [b] -> [Doc]
nameSupply [(Name, [StructType])]
cs
(Doc
frpat, Doc
frattr, Doc
topat, Doc
toattr) = AttrFields -> (Doc, Doc, Doc, Doc)
attrpats AttrFields
fs
Bool
_ = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null AttrFields
fs)
in
String -> Doc
text String
"instance HTypeable" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"toHType x = Defined \"" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\" [] []" )
Doc -> Doc -> Doc
$$
String -> Doc
text String
"instance XmlContent" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Doc -> Doc -> (Name, [StructType]) -> Doc
mkToMult Name
n Doc
topat Doc
toattr) [(Name, [StructType])]
cs)
Doc -> Doc -> Doc
$$ String -> Doc
text String
"parseContents = do "
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"{ e@(Elem _"Doc -> Doc -> Doc
<+> Doc
frpat Doc -> Doc -> Doc
<+> String -> Doc
text String
"_) <- element [\""
Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\"]"
Doc -> Doc -> Doc
$$ String -> Doc
text String
"; interior e $ oneOf"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"[" Doc -> Doc -> Doc
<+> Doc -> (Name, [StructType]) -> Doc
mkParseConstr Doc
frattr (forall a. [a] -> a
head [(Name, [StructType])]
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
mkParseConstr Doc
frattr (Name, [StructType])
c)
(forall a. [a] -> [a]
tail [(Name, [StructType])]
cs))
Doc -> Doc -> Doc
$$ String -> Doc
text String
"] `adjustErr` (\"in <" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n
Doc -> Doc -> Doc
<> String -> Doc
text String
">, \"++)"
)
Doc -> Doc -> Doc
$$ String -> Doc
text String
"}"
)
)
Doc -> Doc -> Doc
$$
SameName -> Name -> AttrFields -> Doc
mkInstanceAttrs SameName
Extended Name
n AttrFields
fs
mkInstance (DataDef Bool
True Name
n AttrFields
fs [(Name, [StructType])]
cs) =
let [Doc]
_ = forall b. [b] -> [Doc]
nameSupply [(Name, [StructType])]
cs
(Doc
_, Doc
frattr, Doc
_, Doc
_) = AttrFields -> (Doc, Doc, Doc, Doc)
attrpats AttrFields
fs
mixattrs :: Bool
mixattrs = Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null AttrFields
fs)
in
String -> Doc
text String
"instance HTypeable" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"toHType x = Defined \"" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\" [] []" )
Doc -> Doc -> Doc
$$
String -> Doc
text String
"instance XmlContent" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( [Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map (Bool -> (Name, [StructType]) -> Doc
mkToAux Bool
mixattrs) [(Name, [StructType])]
cs)
Doc -> Doc -> Doc
$$ String -> Doc
text String
"parseContents = oneOf"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"[" Doc -> Doc -> Doc
<+> Doc -> (Name, [StructType]) -> Doc
mkParseConstr Doc
frattr (forall a. [a] -> a
head [(Name, [StructType])]
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
mkParseConstr Doc
frattr (Name, [StructType])
c)
(forall a. [a] -> [a]
tail [(Name, [StructType])]
cs))
Doc -> Doc -> Doc
$$ String -> Doc
text String
"] `adjustErr` (\"in <" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n
Doc -> Doc -> Doc
<> String -> Doc
text String
">, \"++)"
)
)
Doc -> Doc -> Doc
$$
SameName -> Name -> AttrFields -> Doc
mkInstanceAttrs SameName
Extended Name
n AttrFields
fs
mkInstance (EnumDef Name
n [Name]
es) =
String -> Doc
text String
"instance XmlAttrType" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"fromAttrToTyp n (N n',v)" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"| n==n' = translate (attr2str v)" Doc -> Doc -> Doc
$$
String -> Doc
text String
"| otherwise = Nothing") Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
2 (String -> Doc
text String
"where" Doc -> Doc -> Doc
<+> [Name] -> Doc
mkTranslate [Name]
es)
Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
mkToAttr [Name]
es)
)
data SameName = Same | Extended
mkInstanceAttrs :: SameName -> Name -> AttrFields -> Doc
mkInstanceAttrs :: SameName -> Name -> AttrFields -> Doc
mkInstanceAttrs SameName
_ Name
_ [] = Doc
empty
mkInstanceAttrs SameName
s Name
n AttrFields
fs =
let ppName :: Name -> Doc
ppName = case SameName
s of { SameName
Same-> Name -> Doc
ppHName; SameName
Extended-> Name -> Doc
ppAName; }
in
String -> Doc
text String
"instance XmlAttributes" Doc -> Doc -> Doc
<+> Name -> Doc
ppName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"where" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( String -> Doc
text String
"fromAttrs as =" Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ( Name -> Doc
ppName Name
n Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
2 ([Doc] -> Doc
vcat ((String -> Doc
text String
"{" Doc -> Doc -> Doc
<+> Name -> (Name, StructType) -> Doc
mkFrFld Name
n (forall a. [a] -> a
head AttrFields
fs))forall a. a -> [a] -> [a]
:
forall a b. (a -> b) -> [a] -> [b]
map (\(Name, StructType)
x-> Doc
comma Doc -> Doc -> Doc
<+> Name -> (Name, StructType) -> Doc
mkFrFld Name
n (Name, StructType)
x) (forall a. [a] -> [a]
tail AttrFields
fs)) Doc -> Doc -> Doc
$$
String -> Doc
text String
"}"))
Doc -> Doc -> Doc
$$
String -> Doc
text String
"toAttrs v = catMaybes " Doc -> Doc -> Doc
$$
Int -> Doc -> Doc
nest Int
4 ([Doc] -> Doc
vcat ((String -> Doc
text String
"[" Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
mkToFld (forall a. [a] -> a
head AttrFields
fs))forall a. a -> [a] -> [a]
:
forall a b. (a -> b) -> [a] -> [b]
map (\(Name, StructType)
x-> Doc
comma Doc -> Doc -> Doc
<+> (Name, StructType) -> Doc
mkToFld (Name, StructType)
x) (forall a. [a] -> [a]
tail AttrFields
fs)) Doc -> Doc -> Doc
$$
String -> Doc
text String
"]")
)
attrpats :: AttrFields -> (Doc,Doc,Doc,Doc)
attrpats :: AttrFields -> (Doc, Doc, Doc, Doc)
attrpats AttrFields
fs =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null AttrFields
fs then (String -> Doc
text String
"[]", Doc
empty, Doc
empty, String -> Doc
text String
"[]")
else (String -> Doc
text String
"as", Doc -> Doc
parens (String -> Doc
text String
"fromAttrs as"), String -> Doc
text String
"as", Doc -> Doc
parens (String -> Doc
text String
"toAttrs as"))
mkParseConstr :: Doc -> (Name, [StructType]) -> Doc
mkParseConstr :: Doc -> (Name, [StructType]) -> Doc
mkParseConstr Doc
frattr (Name
c,[StructType]
sts) =
[Doc] -> Doc
fsep (String -> Doc
text String
"return" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Name -> Doc
ppHName Name
c Doc -> Doc -> Doc
<+> Doc
frattr)
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map StructType -> Doc
mkParseContents [StructType]
sts)
mkParseContents :: StructType -> Doc
mkParseContents :: StructType -> Doc
mkParseContents StructType
st =
let ap :: Doc
ap = String -> Doc
text String
"`apply`" in
case StructType
st of
(Maybe StructType
String) -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"optional text"
(Maybe StructType
_) -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"optional parseContents"
(List StructType
String) -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"many text"
(List StructType
_) -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"many parseContents"
(List1 StructType
_) -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"parseContents"
(Tuple [StructType]
_) -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"parseContents"
(OneOf [StructType]
_) -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"parseContents"
StructType
StringMixed -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"text"
StructType
String -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"(text `onFail` return \"\")"
StructType
Any -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"parseContents"
(Defined Name
_) -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"parseContents"
(Defaultable StructType
_ String
_) -> Doc
ap Doc -> Doc -> Doc
<+> String -> Doc
text String
"nyi_fromElem_Defaultable"
mkToElem :: [StructType] -> [Doc] -> Doc
mkToElem :: [StructType] -> [Doc] -> Doc
mkToElem [] [] = String -> Doc
text String
"[]"
mkToElem [StructType]
sts [Doc]
vs =
[Doc] -> Doc
fsep (forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
"++") (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith StructType -> Doc -> Doc
toElem [StructType]
sts [Doc]
vs))
where
toElem :: StructType -> Doc -> Doc
toElem StructType
st Doc
v =
case StructType
st of
(Maybe StructType
String) -> String -> Doc
text String
"maybe [] toText" Doc -> Doc -> Doc
<+> Doc
v
(Maybe StructType
_) -> String -> Doc
text String
"maybe [] toContents" Doc -> Doc -> Doc
<+> Doc
v
(List StructType
String) -> String -> Doc
text String
"concatMap toText" Doc -> Doc -> Doc
<+> Doc
v
(List StructType
_) -> String -> Doc
text String
"concatMap toContents" Doc -> Doc -> Doc
<+> Doc
v
(List1 StructType
_) -> String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc
v
(Tuple [StructType]
_) -> String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc
v
(OneOf [StructType]
_) -> String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc
v
StructType
StringMixed -> String -> Doc
text String
"toText" Doc -> Doc -> Doc
<+> Doc
v
StructType
String -> String -> Doc
text String
"toText" Doc -> Doc -> Doc
<+> Doc
v
StructType
Any -> String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc
v
(Defined Name
_) -> String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc
v
(Defaultable StructType
_ String
_) -> String -> Doc
text String
"nyi_toElem_Defaultable" Doc -> Doc -> Doc
<+> Doc
v
mkCpat :: Name -> Doc -> [Doc] -> Doc
mkCpat :: Name -> Doc -> [Doc] -> Doc
mkCpat Name
n Doc
i [Doc]
vs = Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> Doc
i Doc -> Doc -> Doc
<+> [Doc] -> Doc
fsep [Doc]
vs
nameSupply :: [b] -> [Doc]
nameSupply :: forall b. [b] -> [Doc]
nameSupply [b]
ss = forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length [b]
ss) (forall a b. (a -> b) -> [a] -> [b]
map Char -> Doc
char [Char
'a'..Char
'z']
forall a. [a] -> [a] -> [a]
++ [ String -> Doc
text [Char
a,Char
n] | Char
n <- [Char
'0'..Char
'9']
, Char
a <- [Char
'a'..Char
'z'] ])
mkTranslate :: [Name] -> Doc
mkTranslate :: [Name] -> Doc
mkTranslate [Name]
es =
[Doc] -> Doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
trans [Name]
es) Doc -> Doc -> Doc
$$
String -> Doc
text String
"translate _ = Nothing"
where
trans :: Name -> Doc
trans Name
n = String -> Doc
text String
"translate \"" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\" =" Doc -> Doc -> Doc
<+>
String -> Doc
text String
"Just" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n
mkToAttr :: Name -> Doc
mkToAttr :: Name -> Doc
mkToAttr Name
n = String -> Doc
text String
"toAttrFrTyp n" Doc -> Doc -> Doc
<+> Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+>
String -> Doc
text String
"Just (N n, str2attr" Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (Name -> Doc
ppXName Name
n) Doc -> Doc -> Doc
<> String -> Doc
text String
")"
mkFrFld :: Name -> (Name,StructType) -> Doc
mkFrFld :: Name -> (Name, StructType) -> Doc
mkFrFld Name
tag (Name
n,StructType
st) =
Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+>
( case StructType
st of
(Defaultable StructType
String String
s) -> String -> Doc
text String
"defaultA fromAttrToStr" Doc -> Doc -> Doc
<+>
Doc -> Doc
doubleQuotes (String -> Doc
text String
s)
(Defaultable StructType
_ String
s) -> String -> Doc
text String
"defaultA fromAttrToTyp" Doc -> Doc -> Doc
<+> String -> Doc
text String
s
(Maybe StructType
String) -> String -> Doc
text String
"possibleA fromAttrToStr"
(Maybe StructType
_) -> String -> Doc
text String
"possibleA fromAttrToTyp"
StructType
String -> String -> Doc
text String
"definiteA fromAttrToStr" Doc -> Doc -> Doc
<+>
Doc -> Doc
doubleQuotes (Name -> Doc
ppXName Name
tag)
StructType
_ -> String -> Doc
text String
"definiteA fromAttrToTyp" Doc -> Doc -> Doc
<+>
Doc -> Doc
doubleQuotes (Name -> Doc
ppXName Name
tag)
) Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (Name -> Doc
ppXName Name
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"as"
mkToFld :: (Name,StructType) -> Doc
mkToFld :: (Name, StructType) -> Doc
mkToFld (Name
n,StructType
st) =
( case StructType
st of
(Defaultable StructType
String String
_) -> String -> Doc
text String
"defaultToAttr toAttrFrStr"
(Defaultable StructType
_ String
_) -> String -> Doc
text String
"defaultToAttr toAttrFrTyp"
(Maybe StructType
String) -> String -> Doc
text String
"maybeToAttr toAttrFrStr"
(Maybe StructType
_) -> String -> Doc
text String
"maybeToAttr toAttrFrTyp"
StructType
String -> String -> Doc
text String
"toAttrFrStr"
StructType
_ -> String -> Doc
text String
"toAttrFrTyp"
) Doc -> Doc -> Doc
<+> Doc -> Doc
doubleQuotes (Name -> Doc
ppXName Name
n) Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Name -> Doc
ppHName Name
n Doc -> Doc -> Doc
<+> String -> Doc
text String
"v")
mkToAux :: Bool -> (Name,[StructType]) -> Doc
mkToAux :: Bool -> (Name, [StructType]) -> Doc
mkToAux Bool
mixattrs (Name
n,[StructType]
sts) =
let vs :: [Doc]
vs = forall b. [b] -> [Doc]
nameSupply [StructType]
sts
attrs :: Doc
attrs = if Bool
mixattrs then String -> Doc
text String
"as" else Doc
empty
in
String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Name -> Doc -> [Doc] -> Doc
mkCpat Name
n Doc
attrs [Doc]
vs) Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+>
[StructType] -> [Doc] -> Doc
mkToElem [StructType]
sts [Doc]
vs
mkToMult :: Name -> Doc -> Doc -> (Name,[StructType]) -> Doc
mkToMult :: Name -> Doc -> Doc -> (Name, [StructType]) -> Doc
mkToMult Name
tag Doc
attrpat Doc
attrexp (Name
n,[StructType]
sts) =
let vs :: [Doc]
vs = forall b. [b] -> [Doc]
nameSupply [StructType]
sts
in
String -> Doc
text String
"toContents" Doc -> Doc -> Doc
<+> Doc -> Doc
parens (Name -> Doc -> [Doc] -> Doc
mkCpat Name
n Doc
attrpat [Doc]
vs) Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"[CElem (Elem (N \"" Doc -> Doc -> Doc
<> Name -> Doc
ppXName Name
tag Doc -> Doc -> Doc
<> String -> Doc
text String
"\")"Doc -> Doc -> Doc
<+> Doc
attrexp
Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([StructType] -> [Doc] -> Doc
mkToElem [StructType]
sts [Doc]
vs) Doc -> Doc -> Doc
<+> String -> Doc
text String
") ()]")