HaXml-1.25.8: src/Text/XML/HaXml/Schema/PrettyHaskell.hs
{-# LANGUAGE CPP #-}
-- | Pretty-print the internal Haskell model of XSD datatypes to a real
-- Haskell module containing type declarations, and instances for parsing
-- (and printing - though not yet implemented) values of those datatypes
-- from(/to) XML.
module Text.XML.HaXml.Schema.PrettyHaskell
( ppComment
, ppModule
, ppHighLevelDecl
, ppHighLevelDecls
, ppvList
) where
#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif
import Text.XML.HaXml.Types (QName(..),Namespace(..))
import Text.XML.HaXml.Schema.HaskellTypeModel
import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..))
import Text.XML.HaXml.Schema.NameConversion
import Text.PrettyPrint.HughesPJ as PP
import Data.List (intersperse,notElem,inits)
import Data.Maybe (isJust,fromJust,fromMaybe,catMaybes)
import Data.Char (toLower)
-- | Vertically pretty-print a list of things, with open and close brackets,
-- and separators.
ppvList :: String -> String -> String -> (a->Doc) -> [a] -> Doc
ppvList open sep close pp [] = text open <> text close
ppvList open sep close pp (x:xs) = text open <+> pp x
$$ vcat (map (\y-> text sep <+> pp y) xs)
$$ text close
data CommentPosition = Before | After
-- | Generate aligned haddock-style documentation.
-- (but without escapes in comment text yet)
ppComment :: CommentPosition -> Comment -> Doc
ppComment _ Nothing = empty
ppComment pos (Just s) =
text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c
$$
vcat (map (\x-> text "-- " <+> text x) cs)
where
(c:cs) = lines (paragraph 60 s)
-- | Generate aligned haddock-style docs for choices (where each choice
-- has its own documentation, but haddock cannot place it directly next
-- to the appropriate component.
ppCommentForChoice :: CommentPosition -> Comment -> [[Element]] -> Doc
ppCommentForChoice pos outer nested =
text "--" <+> text (case pos of Before -> "|"; After -> "^") <+> text c
$$ vcat (map (\x-> text "-- " <+> text x) cs)
$$ vcat (map (\x-> text "-- " <+> text x) bullets)
where
(c:cs) = lines intro
intro = maybe "Choice between:"
(\s-> paragraph 60 s++"\n\nChoice between:")
outer
bullets = concatMap lines
$ zipWith (\n seq-> case seq of
[x]-> "\n("++show n++") "++paragraph 56 x
_ -> "\n("++show n++") Sequence of:"
++ concatMap (\s->"\n\n * "
++paragraph 52 s)
seq)
[1..]
$ map (map safeComment) nested
safeComment Text = "mixed text"
safeComment e@Element{} = fromMaybe (xname $ elem_name e) (elem_comment e)
safeComment e = fromMaybe "unknown" (elem_comment e)
xname (XName (N x)) = x
xname (XName (QN ns x)) = nsPrefix ns++":"++x
-- | Pretty-print a Haskell-style name.
ppHName :: HName -> Doc
ppHName (HName x) = text x
-- | Pretty-print an XML-style name.
ppXName :: XName -> Doc
ppXName (XName (N x)) = text x
ppXName (XName (QN ns x)) = text (nsPrefix ns) <> text ":" <> text x
-- | Some different ways of using a Haskell identifier.
ppModId, ppConId, ppVarId, ppUnqConId, ppUnqVarId, ppFwdConId
:: NameConverter -> XName -> Doc
ppModId nx = ppHName . modid nx
ppConId nx = ppHName . conid nx
ppVarId nx = ppHName . varid nx
ppUnqConId nx = ppHName . unqconid nx
ppUnqVarId nx = ppHName . unqvarid nx
ppFwdConId nx = ppHName . fwdconid nx
ppJoinConId, ppFieldId :: NameConverter -> XName -> XName -> Doc
ppJoinConId nx p q = ppHName (conid nx p) <> text "_" <> ppHName (conid nx q)
ppFieldId nx t = ppHName . fieldid nx t
-- | Convert a whole document from HaskellTypeModel to Haskell source text.
ppModule :: NameConverter -> Module -> Doc
ppModule nx m =
text "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}"
$$ text "{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}"
$$ text "module" <+> ppModId nx (module_name m)
$$ nest 2 (text "( module" <+> ppModId nx (module_name m)
$$ vcat (map (\(XSDInclude ex com)->
ppComment Before com
$$ text ", module" <+> ppModId nx ex)
(module_re_exports m))
$$ text ") where")
$$ text " "
$$ text "import Text.XML.HaXml.Schema.Schema (SchemaType(..),SimpleType(..),Extension(..),Restricts(..))"
$$ text "import Text.XML.HaXml.Schema.Schema as Schema"
$$ text "import Text.XML.HaXml.OneOfN"
$$ (case module_xsd_ns m of
Nothing -> text "import Text.XML.HaXml.Schema.PrimitiveTypes as Xsd"
Just ns -> text "import qualified Text.XML.HaXml.Schema.PrimitiveTypes as"<+>ppConId nx ns)
$$ vcat (map (ppHighLevelDecl nx)
(module_re_exports m ++ module_import_only m))
$$ text " "
$$ text "-- Some hs-boot imports are required, for fwd-declaring types."
$$ vcat (map ppFwdDecl $ concatMap imports $ module_decls m)
$$ vcat (map ppFwdElem $ concatMap importElems $ module_decls m)
$$ text " "
$$ ppHighLevelDecls nx (module_decls m)
where
imports (ElementsAttrsAbstract _ deps _) = deps
imports (ExtendComplexTypeAbstract _ _ deps _ _ _) = deps
imports _ = []
importElems (ElementAbstractOfType _ _ deps _) = deps
importElems _ = []
ppFwdDecl (_, Nothing) = empty
ppFwdDecl (name,Just mod) = text "import {-# SOURCE #-}" <+> ppModId nx mod
<+> text "(" <+> ppConId nx name <+> text ")"
ppFwdElem (_, Nothing) = empty
ppFwdElem (name,Just mod) = text "import {-# SOURCE #-}" <+> ppModId nx mod
<+> text "("
<+> (text "element" <> ppUnqConId nx name)
<> (text ", elementToXML" <> ppUnqConId nx name)
<+> text ")"
-- | Generate a fragmentary parser for an attribute.
ppAttr :: Attribute -> Int -> Doc
ppAttr a n = (text "a"<>text (show n)) <+> text "<-"
<+> (if attr_required a then empty
else text "optional $")
<+> text "getAttribute \""
<> ppXName (attr_name a)
<> text "\" e pos"
-- | Generate a fragmentary toXML for an attribute.
toXmlAttr :: Attribute -> Doc
toXmlAttr a = (if attr_required a then id
else (\d-> text "maybe []" <+> parens d))
(text "toXMLAttribute \"" <> ppXName (attr_name a) <> text "\"")
-- | Generate a fragmentary parser for an element.
ppElem :: NameConverter -> Element -> Doc
ppElem nx e@Element{}
| elem_byRef e = ppElemModifier (elem_modifier e)
(text "element"
<> ppUnqConId nx (elem_name e))
| otherwise = ppElemModifier (elem_modifier e)
(text "parseSchemaType \""
<> ppXName (elem_name e)
<> text "\"")
ppElem nx e@AnyElem{} = ppElemModifier (elem_modifier e)
(text "parseAnyElement")
ppElem nx e@Text{} = text "parseText"
ppElem nx e@OneOf{} = ppElemModifier (liftedElemModifier e)
(text "oneOf'" <+> ppvList "[" "," "]"
(ppOneOf n)
(zip (elem_oneOf e) [1..n]))
where
n = length (elem_oneOf e)
ppOneOf n (e,i) = text "(\"" <> hsep (map (ppElemTypeName nx id)
. cleanChoices $ e)
<> text "\","
<+> text "fmap" <+> text (ordinal i ++"Of"++show n)
<+> parens (ppSeqElem . cleanChoices $ e)
<> text ")"
ordinal i | i <= 20 = ordinals!!i
| otherwise = "Choice" ++ show i
ordinals = ["Zero","One","Two","Three","Four","Five","Six","Seven","Eight"
,"Nine","Ten","Eleven","Twelve","Thirteen","Fourteen","Fifteen"
,"Sixteen","Seventeen","Eighteen","Nineteen","Twenty"]
ppSeqElem [] = PP.empty
ppSeqElem [e] = ppElem nx e
ppSeqElem es = text ("return ("++replicate (length es-1) ','++")")
<+> vcat (map (\e-> text "`apply`" <+> ppElem nx e) es)
-- | Generate a fragmentary toXML for an element. Fragment must still be
-- applied to an actual element value.
toXmlElem :: NameConverter -> Element -> Doc
toXmlElem nx e@Element{}
| elem_byRef e = xmlElemModifier (elem_modifier e)
(text "elementToXML"
<> ppUnqConId nx (elem_name e))
| otherwise = xmlElemModifier (elem_modifier e)
(text "schemaTypeToXML \""
<> ppXName (elem_name e)
<> text "\"")
toXmlElem nx e@AnyElem{} = xmlElemModifier (elem_modifier e)
(text "toXMLAnyElement")
toXmlElem nx e@Text{} = text "toXMLText"
toXmlElem nx e@OneOf{} = xmlElemModifier (liftedElemModifier e)
(text "foldOneOf" <> text (show n)
<+> ppvList "" "" "" xmlOneOf (elem_oneOf e))
where
n = length (elem_oneOf e)
xmlOneOf e = parens (xmlSeqElem . cleanChoices $ e)
xmlSeqElem [] = PP.empty
xmlSeqElem [e] = toXmlElem nx e
xmlSeqElem es = text "\\ (" <> hcat (intersperse (text ",") vars)
<> text ") -> concat"
<+> ppvList "[" "," "]" (\(e,v)-> toXmlElem nx e <+> v)
(zip es vars)
where vars = map (text.(:[])) . take (length es) $ ['a'..'z']
-- | Convert multiple HaskellTypeModel Decls to Haskell source text.
ppHighLevelDecls :: NameConverter -> [Decl] -> Doc
ppHighLevelDecls nx hs = vcat (intersperse (text " ")
(map (ppHighLevelDecl nx) hs))
-- | Convert a single Haskell Decl into Haskell source text.
ppHighLevelDecl :: NameConverter -> Decl -> Doc
ppHighLevelDecl nx (NamedSimpleType t s comm) =
ppComment Before comm
$$ text "type" <+> ppUnqConId nx t <+> text "=" <+> ppConId nx s
$$ text "-- No instances required: synonym is isomorphic to the original."
ppHighLevelDecl nx (RestrictSimpleType t s r comm) =
ppComment Before comm
$$ text "newtype" <+> ppUnqConId nx t <+> text "="
<+> ppUnqConId nx t <+> ppConId nx s
<+> text "deriving (Eq,Show)"
$$ text "instance Restricts" <+> ppUnqConId nx t <+> ppConId nx s
<+> text "where"
$$ nest 4 (text "restricts (" <> ppUnqConId nx t <+> text "x) = x")
$$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "parseSchemaType s = do"
$$ nest 4 (text "e <- element [s]"
$$ text "commit $ interior e $ parseSimpleType")
)
$$ nest 4 (text "schemaTypeToXML s ("<> ppUnqConId nx t <+> text "x) = "
$$ nest 4 (text "toXMLElement s [] [toXMLText (simpleTypeText x)]")
)
$$ text "instance SimpleType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "acceptingParser = fmap" <+> ppUnqConId nx t
<+> text "acceptingParser"
-- XXX should enforce the restrictions somehow. (?)
$$ text "-- XXX should enforce the restrictions somehow?"
$$ text "-- The restrictions are:"
$$ vcat (map ((text "-- " <+>) . ppRestrict) r))
$$ nest 4 (text "simpleTypeText (" <> ppUnqConId nx t
<+> text "x) = simpleTypeText x")
where
ppRestrict (RangeR occ comm) = text "(RangeR"
<+> ppOccurs occ <> text ")"
ppRestrict (Pattern regexp comm) = text ("(Pattern "++regexp++")")
ppRestrict (Enumeration items) = text "(Enumeration"
<+> hsep (map (text . fst) items)
<> text ")"
ppRestrict (StrLength occ comm) = text "(StrLength"
<+> ppOccurs occ <> text ")"
ppOccurs = parens . text . show
ppHighLevelDecl nx (ExtendSimpleType t s as comm) =
ppComment Before comm
$$ text "data" <+> ppUnqConId nx t <+> text "="
<+> ppUnqConId nx t <+> ppConId nx s
<+> ppConId nx t_attrs
<+> text "deriving (Eq,Show)"
$$ text "data" <+> ppConId nx t_attrs <+> text "=" <+> ppConId nx t_attrs
$$ nest 4 (ppFields nx t_attrs [] as
$$ text "deriving (Eq,Show)")
$$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "parseSchemaType s = do"
$$ nest 4 (text "(pos,e) <- posnElement [s]"
$$ text "commit $ do"
$$ nest 2
(vcat (zipWith ppAttr as [0..])
$$ text "reparse [CElem e pos]"
$$ text "v <- parseSchemaType s"
$$ text "return $" <+> ppUnqConId nx t
<+> text "v"
<+> attrsValue as)
)
)
$$ nest 4 (text "schemaTypeToXML s ("<> ppUnqConId nx t
<+> text "bt at) ="
$$ nest 4 (text "addXMLAttributes"
<+> ppvList "[" "," "]"
(\a-> toXmlAttr a <+> text "$"
<+> ppFieldId nx t_attrs (attr_name a)
<+> text "at")
as
$$ nest 4 (text "$ schemaTypeToXML s bt"))
)
$$ text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx s
<+> text "where"
$$ nest 4 (text "supertype (" <> ppUnqConId nx t <> text " s _) = s")
where
t_attrs = let (XName (N t_base)) = t in XName (N (t_base++"Attributes"))
attrsValue [] = ppConId nx t_attrs
attrsValue as = parens (ppConId nx t_attrs <+>
hsep [text ("a"++show n) | n <- [0..length as-1]])
-- do element [s]
-- blah <- attribute foo
-- interior e $ do
-- simple <- parseText acceptingParser
-- return (T simple blah)
ppHighLevelDecl nx (UnionSimpleTypes t sts comm) =
ppComment Before comm
$$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t
$$ text "-- Placeholder for a Union type, not yet implemented."
ppHighLevelDecl nx (EnumSimpleType t [] comm) =
ppComment Before comm
$$ text "data" <+> ppUnqConId nx t
ppHighLevelDecl nx (EnumSimpleType t is comm) =
ppComment Before comm
$$ text "data" <+> ppUnqConId nx t
$$ nest 4 ( ppvList "=" "|" "deriving (Eq,Show,Enum)" item is )
$$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "parseSchemaType s = do"
$$ nest 4 (text "e <- element [s]"
$$ text "commit $ interior e $ parseSimpleType")
)
$$ nest 4 (text "schemaTypeToXML s x = "
$$ nest 4 (text "toXMLElement s [] [toXMLText (simpleTypeText x)]")
)
$$ text "instance SimpleType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "acceptingParser ="
<+> ppvList "" "`onFail`" "" parseItem is
$$ vcat (map enumText is))
where
item (i,c) = (ppUnqConId nx t <> text "_" <> ppConId nx i)
$$ ppComment After c
parseItem (i,_) = text "do literal \"" <> ppXName i <> text "\"; return"
<+> (ppUnqConId nx t <> text "_" <> ppConId nx i)
enumText (i,_) = text "simpleTypeText"
<+> (ppUnqConId nx t <> text "_" <> ppConId nx i)
<+> text "= \"" <> ppXName i <> text "\""
ppHighLevelDecl nx (ElementsAttrs t es as comm) =
ppComment Before comm
$$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t
$$ nest 8 (ppFields nx t (uniqueify es) as
$$ text "deriving (Eq,Show)")
$$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "parseSchemaType s = do"
$$ nest 4 (text "(pos,e) <- posnElement [s]"
-- $$ text "commit $ do"
-- $$ nest 2
$$ (vcat (zipWith ppAttr as [0..])
$$ text "commit $ interior e $ return"
<+> returnValue as
$$ nest 4 (vcat (map ppApplyElem es))
)
)
)
$$ nest 4 (text "schemaTypeToXML s x@"<> ppUnqConId nx t <> text "{} ="
$$ nest 4 (text "toXMLElement s"
<+> ppvList "[" "," "]"
(\a-> toXmlAttr a <+> text "$"
<+> ppFieldId nx t (attr_name a)
<+> text "x")
as
$$ nest 4 (ppvList "[" "," "]"
(\ (e,i)-> toXmlElem nx e
<+> text "$"
<+> ppFieldName nx t e i
<+> text "x")
(zip es [0..]))
)
)
where
returnValue [] = ppUnqConId nx t
returnValue as = parens (ppUnqConId nx t <+>
hsep [text ("a"++show n) | n <- [0..length as-1]])
ppApplyElem e = text "`apply`" <+> ppElem nx e
ppHighLevelDecl nx (ElementsAttrsAbstract t [] comm) =
ppComment Before comm
$$ text "-- (There are no subtypes defined for this abstract type.)"
$$ text "data" <+> ppUnqConId nx t <+> text "=" <+> ppUnqConId nx t
<+> text "deriving (Eq,Show)"
$$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "parseSchemaType s = fail" <+> errmsg)
$$ nest 4 (text "schemaTypeToXML s _ = toXMLElement s [] []")
where
errmsg = text "\"Parse failed when expecting an extension type of"
<+> ppXName t <> text ":\\n No extension types are known.\""
ppHighLevelDecl nx (ElementsAttrsAbstract t insts comm) =
ppComment Before comm
$$ text "data" <+> ppUnqConId nx t
$$ nest 8 (ppvList "=" "|" "" ppAbstrCons insts
$$ text "deriving (Eq,Show)")
-- $$ text "-- instance SchemaType" <+> ppUnqConId nx t
-- <+> text "(declared in Instance module)"
-- *** Declare instance here
$$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "parseSchemaType s = do"
$$ nest 4 (vcat (intersperse (text "`onFail`")
(map ppParse insts)
++ [text "`onFail` fail" <+> errmsg])))
$$ nest 4 (vcat (map toXML insts))
-- $$ text ""
-- $$ vcat (map ppFwdDecl $ filter (isJust . snd) insts)
where
ppAbstrCons (name,Nothing) = con name <+> ppConId nx name
ppAbstrCons (name,Just mod) = con name <+> ppConId nx name
-- *** Declare FwdDecl type here (proxy for type declared in later module)
-- ppAbstrCons (name,Just mod) = text "forall q . (FwdDecl" <+>
-- fwd name <+> text "q," <+>
-- text "SchemaType q) =>" <+>
-- con name <+>
-- text "("<>fwd name<>text"->q)" <+> fwd name
ppParse (name,Nothing) = text "(fmap" <+> con name <+>
text "$ parseSchemaType s)"
ppParse (name,Just _) = ppParse (name,Nothing)
-- ppParse (name,Just _) = text "(return" <+> con name <+>
-- text "`apply` (fmap const $ parseSchemaType s)" <+>
-- text "`apply` return" <+> fwd name <> text ")"
-- ppFwdDecl (name,Just mod)
-- = text "-- | Proxy:" <+> ppConId nx name
-- <+> text "declared later in" <+> ppModId nx mod
-- $$ text "data" <+> fwd name <+> text "=" <+> fwd name
errmsg = text "\"Parse failed when expecting an extension type of"
<+> ppXName t <> text ",\\n\\\n\\ namely one of:\\n\\\n\\"
<> hcat (intersperse (text ",")
(map (ppXName . fst) insts))
<> text "\""
-- fwd name = ppFwdConId nx name
con name = ppJoinConId nx t name
-- This is probably an unportable hack, but because an abstract type never
-- has an element in its own name, we need to guess at the name of the
-- possible subtype elements that could substitute for it.
toXML (name,_) = text "schemaTypeToXML _s ("
<> con name <+> text "x) = schemaTypeToXML \""
<> ppXName (initLower name) <> text "\" x"
initLower (XName (N (c:cs))) = XName $ N (toLower c:cs)
initLower (XName (QN ns (c:cs))) = XName $ QN ns (toLower c:cs)
ppHighLevelDecl nx (ElementOfType e@Element{}) =
ppComment Before (elem_comment e)
$$ (text "element" <> ppUnqConId nx (elem_name e)) <+> text "::"
<+> text "XMLParser" <+> ppConId nx (elem_type e)
$$ (text "element" <> ppUnqConId nx (elem_name e)) <+> text "="
<+> (text "parseSchemaType \"" <> ppXName (elem_name e) <> text "\"")
$$ (text "elementToXML" <> ppUnqConId nx (elem_name e)) <+> text "::"
<+> ppConId nx (elem_type e) <+> text "-> [Content ()]"
$$ (text "elementToXML" <> ppUnqConId nx (elem_name e)) <+> text "="
<+> (text "schemaTypeToXML \"" <> ppXName (elem_name e) <> text "\"")
ppHighLevelDecl nx e@(ElementAbstractOfType n t [] comm) =
ppComment Before comm
$$ text "-- (There are no elements in any substitution group for this element.)"
$$ (text "element" <> ppUnqConId nx n) <+> text "::"
<+> text "XMLParser" <+> ppConId nx t
$$ (text "element" <> ppUnqConId nx n) <+> text "="
<+> text "fail" <+> errmsg
$$ (text "elementToXML" <> ppUnqConId nx n) <+> text "::"
<+> ppConId nx t <+> text "-> [Content ()]"
$$ (text "elementToXML" <> ppUnqConId nx n) <+> text "="
<+> (text "schemaTypeToXML \"" <> ppXName n <> text "\"")
where
errmsg = text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <"
<> ppXName n <> text ">,\\n\\\n\\ There are no substitutable elements.\""
ppHighLevelDecl nx e@(ElementAbstractOfType n t substgrp comm)
-- | any notInScope substgrp
-- = (text "-- element" <> ppUnqConId nx n) <+> text "::"
-- <+> text "XMLParser" <+> ppConId nx t
-- $$ text "-- declared in Instances module"
{- | otherwise-} = ppComment Before comm
$$ (text "element" <> ppUnqConId nx n) <+> text "::"
<+> text "XMLParser" <+> ppConId nx t
$$ (text "element" <> ppUnqConId nx n) <+> text "="
<+> vcat (intersperse (text "`onFail`") (map ppOne substgrp)
++ [text "`onFail` fail" <+> errmsg])
$$ (text "elementToXML" <> ppUnqConId nx n) <+> text "::"
<+> ppConId nx t <+> text "-> [Content ()]"
$$ (text "elementToXML" <> ppUnqConId nx n) <+> text "="
<+> (text "schemaTypeToXML \"" <> ppXName n <> text "\"")
-- $$ vcat (map elementToXML substgrp)
-- | otherwise = ppElementAbstractOfType nx e
where
notInScope (_,Just _) = True
notInScope (_,Nothing) = False
ppOne (c,Nothing) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c
<+> (text "element" <> ppConId nx c)
ppOne (c,Just _) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c
<+> (text "element" <> ppConId nx c)
<+> text "-- FIXME: element is forward-declared"
errmsg = text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <"
<> ppXName n <> text ">,\\n\\\n\\ namely one of:\\n\\\n\\<"
<> hcat (intersperse (text ">, <")
(map (ppXName . fst) substgrp))
<> text ">\""
-- elementToXML (c,_) = (text "elementToXML" <> ppUnqConId nx n)
-- <+> text "(" <> ppJoinConId nx t c
-- <+> text " x) = elementToXML" <> ppUnqConId nx c
-- <+> text "x"
ppHighLevelDecl nx (Choice t es comm) =
ppComment Before comm
$$ text "data" <+> ppUnqConId nx t
<+> nest 4 ( ppvList "=" "|" "" choices (zip es [1..])
$$ text "deriving (Eq,Show)" )
where
choices (e,n) = (ppUnqConId nx t <> text (show n))
<+> ppConId nx (elem_type e)
-- Comment out the Group for now. Groups get inlined into the ComplexType
-- where they are used, so it may not be sensible to declare them separately
-- as well.
ppHighLevelDecl nx (Group t es comm) = PP.empty
-- ppComment Before comm
-- $$ text "data" <+> ppConId nx t <+> text "="
-- <+> ppConId nx t <+> hsep (map (ppConId nx . elem_type) es)
-- Possibly we want to declare a really more restrictive type, e.g.
-- to remove optionality, (Maybe Foo) -> (Foo), [Foo] -> Foo
-- consequently the "restricts" method should do a proper translation,
-- not merely an unwrapping.
ppHighLevelDecl nx (RestrictComplexType t s comm) =
ppComment Before comm
$$ text "newtype" <+> ppUnqConId nx t <+> text "="
<+> ppUnqConId nx t <+> ppConId nx s
<+> text "deriving (Eq,Show)"
$$ text "-- plus different (more restrictive) parser"
$$ text "-- (parsing restrictions currently unimplemented)"
$$ text "instance Restricts" <+> ppUnqConId nx t <+> ppConId nx s
<+> text "where"
$$ nest 4 (text "restricts (" <> ppUnqConId nx t <+> text "x) = x")
$$ text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "parseSchemaType = fmap " <+> ppUnqConId nx t <+>
text ". parseSchemaType")
-- XXX should enforce the restriction.
$$ nest 4 (text "schemaTypeToXML s (" <> ppUnqConId nx t <+> text "x)")
<+> text "= schemaTypeToXML s x"
{-
ppHighLevelDecl nx (ExtendComplexType t s es as _ comm)
| length es + length as = 1 =
ppComment Before comm
$$ text "data" <+> ppConId nx t <+> text "="
<+> ppConId nx t <+> ppConId nx s
<+> ppFields nx t es as
<+> text "deriving (Eq,Show)"
$$ text "instance Extension" <+> ppConId nx t <+> ppConId nx s
<+> ppAuxConId nx t <+> text "where"
$$ nest 4 (text "supertype (" <> ppConId nx t <> text " s e) = s"
$$ text "extension (" <> ppConId nx t <> text " s e) = e")
-}
ppHighLevelDecl nx (ExtendComplexType t s oes oas es as
fwdReqd absSup grandsuper comm) =
ppHighLevelDecl nx (ElementsAttrs t (oes++es) (oas++as) comm)
$$ ppExtension nx t s fwdReqd absSup oes oas es as
$$ (if not (null grandsuper) -- && not (isJust fwdReqd) -- && isJust fwdReqd
then ppSuperExtension nx s grandsuper (t,Nothing)
else empty)
ppHighLevelDecl nx (ExtendComplexTypeAbstract t s insts
fwdReqd grandsuper comm) =
ppHighLevelDecl nx (ElementsAttrsAbstract t insts comm)
$$ ppExtension nx t s fwdReqd True [] [] [] []
-- $$ if not (null grandsuper)
-- then vcat (map (ppSuperExtension nx t grandsuper) insts)
-- -- FIXME some instances are missing!
-- else empty
ppHighLevelDecl nx (XSDInclude m comm) =
ppComment After comm
$$ text "import" <+> ppModId nx m
ppHighLevelDecl nx (XSDImport m ma comm) =
ppComment After comm
$$ text "import" <+> ppModId nx m
<+> maybe empty (\a->text "as"<+>ppConId nx a) ma
ppHighLevelDecl nx (XSDComment comm) =
ppComment Before comm
{-------------------------------------------------------------------------------
-- | Instances that depend on FwdDecl'd types, need to be declared in a
-- different module. So they have been separated out from ppHighLevelDecl.
ppHighLevelInstances :: NameConverter -> Decl -> Doc
ppHighLevelInstances nx (ElementsAttrsAbstract t insts comm) =
text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"
$$ nest 4 (text "parseSchemaType s = do"
$$ nest 4 (vcat (intersperse (text "`onFail`")
(map ppParse insts)
++ [text "`onFail` fail" <+> errmsg])))
where
ppParse (name,Nothing) = text "(fmap" <+> con name <+>
text "$ parseSchemaType s)"
ppParse (name,Just _) = text "(return" <+> con name <+>
text "`apply` (fmap const $ parseSchemaType s)" <+>
text "`apply` return" <+> fwd name <> text ")"
errmsg = text "\"Parse failed when expecting an extension type of"
<+> ppXName t <> text ",\\n\\\n\\ namely one of:\\n\\\n\\"
<> hcat (intersperse (text ",")
(map (ppXName . fst) insts))
<> text "\""
fwd name = ppFwdConId nx name
con name = ppJoinConId nx t name
ppHighLevelInstances nx e@(ElementAbstractOfType n t substgrp comm)
| any notInScope substgrp = ppElementAbstractOfType nx e
| otherwise = empty
where
notInScope (_,Just _) = True
notInScope (_,Nothing) = False
ppHighLevelInstances nx (ExtendComplexType t s oes oas es as
fwdReqd absSup grandsuper comm) =
empty
-- ppExtension nx t s fwdReqd absSup oes oas es as
-- $$ (if not (null grandsuper) && isJust fwdReqd
-- then ppSuperExtension nx s grandsuper (t,Nothing)
-- else empty)
ppHighLevelInstances nx (ExtendComplexTypeAbstract t s insts
fwdReqd grandsuper comm) =
ppHighLevelInstances nx (ElementsAttrsAbstract t insts comm)
-- $$ ppExtension nx t s fwdReqd True [] [] [] []
-- $$ if not (null grandsuper)
-- then vcat (map (ppSuperExtension nx t grandsuper) insts)
-- -- FIXME some instances are missing!
-- else empty
ppElementAbstractOfType nx (ElementAbstractOfType n t substgrp comm) =
ppComment Before comm
$$ (text "element" <> ppUnqConId nx n) <+> text "::"
<+> text "XMLParser" <+> ppConId nx t
$$ (text "element" <> ppUnqConId nx n) <+> text "="
<+> vcat (intersperse (text "`onFail`") (map ppOne substgrp)
++ [text "`onFail` fail" <+> errmsg])
where
ppOne (c,Nothing) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c
<+> (text "element" <> ppConId nx c)
ppOne (c,Just _) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c
<+> (text "element" <> ppConId nx c)
<+> text "-- FIXME: element is forward-declared"
errmsg = text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <"
<> ppXName n <> text ">,\\n\\\n\\ namely one of:\\n\\\n\\<"
<> hcat (intersperse (text ">, <")
(map (ppXName . fst) substgrp))
<> text ">\""
----------------------------------------------------------------------------- -}
--------------------------------------------------------------------------------
-- | Generate an instance of the Extension class for a subtype/supertype pair.
ppExtension :: NameConverter -> XName -> XName -> Maybe XName -> Bool ->
[Element] -> [Attribute] -> [Element] -> [Attribute] -> Doc
ppExtension nx t s fwdReqd abstractSuper oes oas es as =
text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx s
<+> text "where"
$$ (if abstractSuper then
nest 4 (text "supertype v" <+> text "="
<+> ppJoinConId nx s t <+>
-- (if isJust fwdReqd
-- then text "(\\_-> v)" <+> ppFwdConId nx t
-- else text "v")
text "v")
else
nest 4 (text "supertype (" <> ppType t (oes++es) (oas++as)
<> text ") ="
$$ nest 11 (ppType s oes oas) ))
-- $$ (if isJust fwdReqd then
-- -- text "data" <+> fwd t <+> text "=" <+> fwd t $$ -- already defined
-- text ""
-- $$ text "-- | Proxy" <+> fwd t <+> text "was declared earlier in"
-- <+> ppModId nx (fromJust fwdReqd)
-- $$ text "instance FwdDecl" <+> fwd t <+> ppConId nx t
-- else empty)
where
fwd name = ppFwdConId nx name
ppType t es as = ppUnqConId nx t
<+> hsep (take (length as) [text ('a':show n) | n<-[0..]])
<+> hsep (take (length es) [text ('e':show n) | n<-[0..]])
-- | Generate an instance of the Extension class for a type and its
-- "grand"-supertype, that is, the supertype of its supertype.
ppSuperExtension :: NameConverter -> XName -> [XName]
-> (XName,Maybe XName) -> Doc
{-
ppSuperExtension nx super (grandSuper:_) (t,Nothing) =
text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx grandSuper
<+> text "where"
$$ nest 4 (text "supertype = (supertype ::"
<+> ppUnqConId nx super
<+> text "->"
<+> ppConId nx grandSuper <> text ")"
$$ nest 12 (text ". (supertype ::"
<+> ppUnqConId nx t
<+> text "->"
<+> ppConId nx super <> text ")"))
-}
ppSuperExtension nx super grandSupers (t,Just mod) = -- fwddecl
text "-- Note that" <+> ppUnqConId nx t
<+> text "will be declared later in module" <+> ppModId nx mod
$$ ppSuperExtension nx super grandSupers (t,Nothing)
ppSuperExtension nx super grandSupers (t,Nothing) =
vcat (map (ppSuper t . reverse) (drop 2 . inits $ super: grandSupers))
where
ppSuper :: XName -> [XName] -> Doc
ppSuper t gss@(gs:_) =
text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx gs
<+> text "where"
$$ nest 4 (text "supertype" <+>
ppvList "=" "." "" coerce (zip (tail gss++[t]) gss))
coerce (a,b) = text "(supertype ::" <+> ppUnqConId nx a
<+> text "->"
<+> ppConId nx b <> text ")"
-- | Generate named fields from elements and attributes.
ppFields :: NameConverter -> XName -> [Element] -> [Attribute] -> Doc
ppFields nx t es as | null es && null as = empty
ppFields nx t es as = ppvList "{" "," "}" id fields
where
fields = map (ppFieldAttribute nx t) as ++
zipWith (ppFieldElement nx t) es [0..]
-- | Generate a single named field (including type sig) from an element.
ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldElement nx t e@Element{} i = ppFieldName nx t e i
<+> text "::" <+> ppElemTypeName nx id e
$$ ppComment After (elem_comment e)
ppFieldElement nx t e@OneOf{} i = ppFieldName nx t e i
<+> text "::" <+> ppElemTypeName nx id e
$$ ppCommentForChoice After (elem_comment e)
(elem_oneOf e)
ppFieldElement nx t e@AnyElem{} i = ppFieldName nx t e i
<+> text "::" <+> ppElemTypeName nx id e
$$ ppComment After (elem_comment e)
ppFieldElement nx t e@Text{} i = ppFieldName nx t e i
<+> text "::" <+> ppElemTypeName nx id e
-- | Generate a single named field (no type sig) from an element.
ppFieldName :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldName nx t e@Element{} _ = ppFieldId nx t (elem_name e)
ppFieldName nx t e@OneOf{} i = ppFieldId nx t (XName $ N $ "choice"++show i)
ppFieldName nx t e@AnyElem{} i = ppFieldId nx t (XName $ N $ "any"++show i)
ppFieldName nx t e@Text{} i = ppFieldId nx t (XName $ N $ "text"++show i)
-- | What is the name of the type for an Element (or choice of Elements)?
ppElemTypeName :: NameConverter -> (Doc->Doc) -> Element -> Doc
ppElemTypeName nx brack e@Element{} =
ppTypeModifier (elem_modifier e) brack $ ppConId nx (elem_type e)
ppElemTypeName nx brack e@OneOf{} =
brack $ ppTypeModifier (liftedElemModifier e) parens $
text "OneOf" <> text (show (length (elem_oneOf e)))
<+> hsep (map (ppSeq . cleanChoices) (elem_oneOf e))
where
ppSeq [] = text "()"
ppSeq [e] = ppElemTypeName nx parens e
ppSeq es = text "(" <> hcat (intersperse (text ",")
(map (ppElemTypeName nx parens) es))
<> text ")"
ppElemTypeName nx brack e@AnyElem{} =
brack $ ppTypeModifier (elem_modifier e) id $
text "AnyElement"
ppElemTypeName nx brack e@Text{} =
text "String"
-- | Generate a single named field from an attribute.
ppFieldAttribute :: NameConverter -> XName -> Attribute -> Doc
ppFieldAttribute nx t a = ppFieldId nx t (attr_name a) <+> text "::"
<+> (if attr_required a then empty
else text "Maybe")
<+> ppConId nx (attr_type a)
$$ ppComment After (attr_comment a)
-- | Generate a list or maybe type name (possibly parenthesised).
ppTypeModifier :: Modifier -> (Doc->Doc) -> Doc -> Doc
ppTypeModifier Single _ d = d
ppTypeModifier Optional k d = k $ text "Maybe" <+> k d
ppTypeModifier (Range (Occurs Nothing Nothing)) _ d = d
ppTypeModifier (Range (Occurs (Just 0) Nothing)) k d = k $ text "Maybe" <+> k d
ppTypeModifier (Range (Occurs _ _)) _ d = text "[" <> d <> text "]"
-- | Generate a parser for a list or Maybe value.
ppElemModifier :: Modifier -> Doc -> Doc
ppElemModifier Single doc = doc
ppElemModifier Optional doc = text "optional" <+> parens doc
ppElemModifier (Range (Occurs Nothing Nothing)) doc = doc
ppElemModifier (Range (Occurs (Just 0) Nothing)) doc = text "optional"
<+> parens doc
ppElemModifier (Range (Occurs (Just 0) (Just n))) doc
| n==maxBound = text "many" <+> parens doc
ppElemModifier (Range (Occurs Nothing (Just n))) doc
| n==maxBound = text "many1" <+> parens doc
ppElemModifier (Range (Occurs (Just 1) (Just n))) doc
| n==maxBound = text "many1" <+> parens doc
ppElemModifier (Range o) doc = text "between" <+> (parens (text (show o))
$$ parens doc)
-- | Generate a toXML for a list or Maybe value.
xmlElemModifier :: Modifier -> Doc -> Doc
xmlElemModifier Single doc = doc
xmlElemModifier Optional doc = text "maybe []" <+> parens doc
xmlElemModifier (Range (Occurs Nothing Nothing)) doc = doc
xmlElemModifier (Range (Occurs (Just 0) Nothing)) doc = text "maybe []"
<+> parens doc
xmlElemModifier (Range (Occurs _ _)) doc = text "concatMap" <+> parens doc
-- | Eliminate a Maybe type modifier, when it occurs directly inside a
-- choice construct (since a parsed Nothing would always be preferred over
-- a real value later in the choice). Likewise, empty lists must
-- be disallowed inside choice.
cleanChoices :: [Element] -> [Element]
cleanChoices [e@Element{}] = (:[]) $
case elem_modifier e of
Range (Occurs (Just 0) Nothing) -> e{elem_modifier=Single}
Range (Occurs (Just 0) max)-> e{elem_modifier=Range (Occurs (Just 1) max)}
_ -> e
cleanChoices es = es
-- | Sometimes, a choice without a type modifier contains element sequences,
-- all of which have the same modifier. In that case, it makes sense to lift
-- the modifier (typically Maybe) to the outer layer.
liftedElemModifier :: Element -> Modifier
liftedElemModifier e@OneOf{} =
case elem_modifier e of
Range (Occurs Nothing Nothing) -> newModifier
Single -> newModifier
m -> m
where
newModifier = if all (\x-> case x of
Text -> True
_ -> case elem_modifier x of
Range (Occurs (Just 0) _) -> True
Optional -> True
_ -> False)
(concat (elem_oneOf e))
then Optional
else Single
-- | Split long lines of comment text into a paragraph with a maximum width.
paragraph :: Int -> String -> String
paragraph n s = go n (words s)
where go i [] = []
go i [x] | len<i = x
| otherwise = "\n"++x
where len = length x
go i (x:xs) | len<i = x++" "++go (i-len-1) xs
| otherwise = "\n"++x++" "++go (n-len-1) xs
where len = length x
uniqueify :: [Element] -> [Element]
uniqueify = go []
where
go seen [] = []
go seen (e@Element{}:es)
| show (elem_name e) `elem` seen
= let fresh = new (`elem`seen) (elem_name e) in
e{elem_name=fresh} : go (show fresh:seen) es
| otherwise = e: go (show (elem_name e): seen) es
go seen (e:es) = e : go seen es
new pred (XName (N n)) = XName $ N $ head $
dropWhile pred [n++show i | i <- [2..]]
new pred (XName (QN ns n)) = XName $ QN ns $ head $
dropWhile pred [n++show i | i <- [2..]]