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