{-# LANGUAGE CPP #-}
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)
ppvList :: String -> String -> String -> (a->Doc) -> [a] -> Doc
ppvList :: String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList open :: String
open sep :: String
sep close :: String
close pp :: a -> Doc
pp [] = String -> Doc
text String
open Doc -> Doc -> Doc
<> String -> Doc
text String
close
ppvList open :: String
open sep :: String
sep close :: String
close pp :: a -> Doc
pp (x :: a
x:xs :: [a]
xs) = String -> Doc
text String
open Doc -> Doc -> Doc
<+> a -> Doc
pp a
x
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((a -> Doc) -> [a] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\y :: a
y-> String -> Doc
text String
sep Doc -> Doc -> Doc
<+> a -> Doc
pp a
y) [a]
xs)
Doc -> Doc -> Doc
$$ String -> Doc
text String
close
data = Before | After
ppComment :: CommentPosition -> Comment -> Doc
_ Nothing = Doc
empty
ppComment pos :: CommentPosition
pos (Just s :: String
s) =
String -> Doc
text "--" Doc -> Doc -> Doc
<+> String -> Doc
text (case CommentPosition
pos of Before -> "|"; After -> "^") Doc -> Doc -> Doc
<+> String -> Doc
text String
c
Doc -> Doc -> Doc
$$
[Doc] -> Doc
vcat ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: String
x-> String -> Doc
text "-- " Doc -> Doc -> Doc
<+> String -> Doc
text String
x) [String]
cs)
where
(c :: String
c:cs :: [String]
cs) = String -> [String]
lines (Int -> String -> String
paragraph 60 String
s)
ppCommentForChoice :: CommentPosition -> Comment -> [[Element]] -> Doc
pos :: CommentPosition
pos outer :: Comment
outer nested :: [[Element]]
nested =
String -> Doc
text "--" Doc -> Doc -> Doc
<+> String -> Doc
text (case CommentPosition
pos of Before -> "|"; After -> "^") Doc -> Doc -> Doc
<+> String -> Doc
text String
c
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: String
x-> String -> Doc
text "-- " Doc -> Doc -> Doc
<+> String -> Doc
text String
x) [String]
cs)
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: String
x-> String -> Doc
text "-- " Doc -> Doc -> Doc
<+> String -> Doc
text String
x) [String]
bullets)
where
(c :: String
c:cs :: [String]
cs) = String -> [String]
lines String
intro
intro :: String
intro = String -> (String -> String) -> Comment -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "Choice between:"
(\s :: String
s-> Int -> String -> String
paragraph 60 String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++"\n\nChoice between:")
Comment
outer
bullets :: [String]
bullets = (String -> [String]) -> [String] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
lines
([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (Integer -> [String] -> String)
-> [Integer] -> [[String]] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\n :: Integer
n seq :: [String]
seq-> case [String]
seq of
[x :: String
x]-> "\n("String -> String -> String
forall a. [a] -> [a] -> [a]
++Integer -> String
forall a. Show a => a -> String
show Integer
nString -> String -> String
forall a. [a] -> [a] -> [a]
++") "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String -> String
paragraph 56 String
x
_ -> "\n("String -> String -> String
forall a. [a] -> [a] -> [a]
++Integer -> String
forall a. Show a => a -> String
show Integer
nString -> String -> String
forall a. [a] -> [a] -> [a]
++") Sequence of:"
String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\s :: String
s->"\n\n * "
String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String -> String
paragraph 52 String
s)
[String]
seq)
[1..]
([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$ ([Element] -> [String]) -> [[Element]] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map ((Element -> String) -> [Element] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Element -> String
safeComment)
([[Element]] -> [[String]]) -> [[Element]] -> [[String]]
forall a b. (a -> b) -> a -> b
$ [[Element]]
nested
safeComment :: Element -> String
safeComment Text = "mixed text"
safeComment e :: Element
e@Element{} = String -> Comment -> String
forall a. a -> Maybe a -> a
fromMaybe (XName -> String
xname (XName -> String) -> XName -> String
forall a b. (a -> b) -> a -> b
$ Element -> XName
elem_name Element
e) (Element -> Comment
elem_comment Element
e)
safeComment e :: Element
e@Element
_ = String -> Comment -> String
forall a. a -> Maybe a -> a
fromMaybe ("unknown") (Element -> Comment
elem_comment Element
e)
xname :: XName -> String
xname (XName (N x :: String
x)) = String
x
xname (XName (QN ns :: Namespace
ns x :: String
x)) = Namespace -> String
nsPrefix Namespace
nsString -> String -> String
forall a. [a] -> [a] -> [a]
++":"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
x
ppHName :: HName -> Doc
ppHName :: HName -> Doc
ppHName (HName x :: String
x) = String -> Doc
text String
x
ppXName :: XName -> Doc
ppXName :: XName -> Doc
ppXName (XName (N x :: String
x)) = String -> Doc
text String
x
ppXName (XName (QN ns :: Namespace
ns x :: String
x)) = String -> Doc
text (Namespace -> String
nsPrefix Namespace
ns) Doc -> Doc -> Doc
<> String -> Doc
text ":" Doc -> Doc -> Doc
<> String -> Doc
text String
x
ppModId, ppConId, ppVarId, ppUnqConId, ppUnqVarId, ppFwdConId
:: NameConverter -> XName -> Doc
ppModId :: NameConverter -> XName -> Doc
ppModId nx :: NameConverter
nx = HName -> Doc
ppHName (HName -> Doc) -> (XName -> HName) -> XName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConverter -> XName -> HName
modid NameConverter
nx
ppConId :: NameConverter -> XName -> Doc
ppConId nx :: NameConverter
nx = HName -> Doc
ppHName (HName -> Doc) -> (XName -> HName) -> XName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConverter -> XName -> HName
conid NameConverter
nx
ppVarId :: NameConverter -> XName -> Doc
ppVarId nx :: NameConverter
nx = HName -> Doc
ppHName (HName -> Doc) -> (XName -> HName) -> XName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConverter -> XName -> HName
varid NameConverter
nx
ppUnqConId :: NameConverter -> XName -> Doc
ppUnqConId nx :: NameConverter
nx = HName -> Doc
ppHName (HName -> Doc) -> (XName -> HName) -> XName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConverter -> XName -> HName
unqconid NameConverter
nx
ppUnqVarId :: NameConverter -> XName -> Doc
ppUnqVarId nx :: NameConverter
nx = HName -> Doc
ppHName (HName -> Doc) -> (XName -> HName) -> XName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConverter -> XName -> HName
unqvarid NameConverter
nx
ppFwdConId :: NameConverter -> XName -> Doc
ppFwdConId nx :: NameConverter
nx = HName -> Doc
ppHName (HName -> Doc) -> (XName -> HName) -> XName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConverter -> XName -> HName
fwdconid NameConverter
nx
ppJoinConId, ppFieldId :: NameConverter -> XName -> XName -> Doc
ppJoinConId :: NameConverter -> XName -> XName -> Doc
ppJoinConId nx :: NameConverter
nx p :: XName
p q :: XName
q = HName -> Doc
ppHName (NameConverter -> XName -> HName
conid NameConverter
nx XName
p) Doc -> Doc -> Doc
<> String -> Doc
text "_" Doc -> Doc -> Doc
<> HName -> Doc
ppHName (NameConverter -> XName -> HName
conid NameConverter
nx XName
q)
ppFieldId :: NameConverter -> XName -> XName -> Doc
ppFieldId nx :: NameConverter
nx = \t :: XName
t-> HName -> Doc
ppHName (HName -> Doc) -> (XName -> HName) -> XName -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NameConverter -> XName -> XName -> HName
fieldid NameConverter
nx XName
t
ppModule :: NameConverter -> Module -> Doc
ppModule :: NameConverter -> Module -> Doc
ppModule nx :: NameConverter
nx m :: Module
m =
String -> Doc
text "{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}"
Doc -> Doc -> Doc
$$ String -> Doc
text "{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}"
Doc -> Doc -> Doc
$$ String -> Doc
text "module" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx (Module -> XName
module_name Module
m)
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 2 (String -> Doc
text "( module" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx (Module -> XName
module_name Module
m)
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Decl -> Doc) -> [Decl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(XSDInclude ex :: XName
ex com :: Comment
com)->
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
com
Doc -> Doc -> Doc
$$ String -> Doc
text ", module" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
ex)
(Module -> [Decl]
module_re_exports Module
m))
Doc -> Doc -> Doc
$$ String -> Doc
text ") where")
Doc -> Doc -> Doc
$$ String -> Doc
text " "
Doc -> Doc -> Doc
$$ String -> Doc
text "import Text.XML.HaXml.Schema.Schema (SchemaType(..),SimpleType(..),Extension(..),Restricts(..))"
Doc -> Doc -> Doc
$$ String -> Doc
text "import Text.XML.HaXml.Schema.Schema as Schema"
Doc -> Doc -> Doc
$$ String -> Doc
text "import Text.XML.HaXml.OneOfN"
Doc -> Doc -> Doc
$$ (case Module -> Maybe XName
module_xsd_ns Module
m of
Nothing -> String -> Doc
text "import Text.XML.HaXml.Schema.PrimitiveTypes as Xsd"
Just ns :: XName
ns -> String -> Doc
text "import qualified Text.XML.HaXml.Schema.PrimitiveTypes as"Doc -> Doc -> Doc
<+>NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
ns)
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Decl -> Doc) -> [Decl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (NameConverter -> Decl -> Doc
ppHighLevelDecl NameConverter
nx)
(Module -> [Decl]
module_re_exports Module
m [Decl] -> [Decl] -> [Decl]
forall a. [a] -> [a] -> [a]
++ Module -> [Decl]
module_import_only Module
m))
Doc -> Doc -> Doc
$$ String -> Doc
text " "
Doc -> Doc -> Doc
$$ String -> Doc
text "-- Some hs-boot imports are required, for fwd-declaring types."
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat (((XName, Maybe XName) -> Doc) -> [(XName, Maybe XName)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName, Maybe XName) -> Doc
ppFwdDecl ([(XName, Maybe XName)] -> [Doc])
-> [(XName, Maybe XName)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Decl -> [(XName, Maybe XName)])
-> [Decl] -> [(XName, Maybe XName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl -> [(XName, Maybe XName)]
imports ([Decl] -> [(XName, Maybe XName)])
-> [Decl] -> [(XName, Maybe XName)]
forall a b. (a -> b) -> a -> b
$ Module -> [Decl]
module_decls Module
m)
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat (((XName, Maybe XName) -> Doc) -> [(XName, Maybe XName)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName, Maybe XName) -> Doc
ppFwdElem ([(XName, Maybe XName)] -> [Doc])
-> [(XName, Maybe XName)] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (Decl -> [(XName, Maybe XName)])
-> [Decl] -> [(XName, Maybe XName)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Decl -> [(XName, Maybe XName)]
importElems ([Decl] -> [(XName, Maybe XName)])
-> [Decl] -> [(XName, Maybe XName)]
forall a b. (a -> b) -> a -> b
$ Module -> [Decl]
module_decls Module
m)
Doc -> Doc -> Doc
$$ String -> Doc
text " "
Doc -> Doc -> Doc
$$ NameConverter -> [Decl] -> Doc
ppHighLevelDecls NameConverter
nx (Module -> [Decl]
module_decls Module
m)
where
imports :: Decl -> [(XName, Maybe XName)]
imports (ElementsAttrsAbstract _ deps :: [(XName, Maybe XName)]
deps _) = [(XName, Maybe XName)]
deps
imports (ExtendComplexTypeAbstract _ _ deps :: [(XName, Maybe XName)]
deps _ _ _) = [(XName, Maybe XName)]
deps
imports _ = []
importElems :: Decl -> [(XName, Maybe XName)]
importElems (ElementAbstractOfType _ _ deps :: [(XName, Maybe XName)]
deps _) = [(XName, Maybe XName)]
deps
importElems _ = []
ppFwdDecl :: (XName, Maybe XName) -> Doc
ppFwdDecl (_, Nothing) = Doc
empty
ppFwdDecl (name :: XName
name,Just mod :: XName
mod) = String -> Doc
text "import {-# SOURCE #-}" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
mod
Doc -> Doc -> Doc
<+> String -> Doc
text "(" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
name Doc -> Doc -> Doc
<+> String -> Doc
text ")"
ppFwdElem :: (XName, Maybe XName) -> Doc
ppFwdElem (_, Nothing) = Doc
empty
ppFwdElem (name :: XName
name,Just mod :: XName
mod) = String -> Doc
text "import {-# SOURCE #-}" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
mod
Doc -> Doc -> Doc
<+> String -> Doc
text "("
Doc -> Doc -> Doc
<+> (String -> Doc
text "element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
name)
Doc -> Doc -> Doc
<> (String -> Doc
text ", elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
name)
Doc -> Doc -> Doc
<+> String -> Doc
text ")"
ppAttr :: Attribute -> Int -> Doc
ppAttr :: Attribute -> Int -> Doc
ppAttr a :: Attribute
a n :: Int
n = (String -> Doc
text "a"Doc -> Doc -> Doc
<>String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
n)) Doc -> Doc -> Doc
<+> String -> Doc
text "<-"
Doc -> Doc -> Doc
<+> (if Attribute -> Bool
attr_required Attribute
a then Doc
empty
else String -> Doc
text "optional $")
Doc -> Doc -> Doc
<+> String -> Doc
text "getAttribute \""
Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Attribute -> XName
attr_name Attribute
a)
Doc -> Doc -> Doc
<> String -> Doc
text "\" e pos"
toXmlAttr :: Attribute -> Doc
toXmlAttr :: Attribute -> Doc
toXmlAttr a :: Attribute
a = (if Attribute -> Bool
attr_required Attribute
a then Doc -> Doc
forall a. a -> a
id
else (\d :: Doc
d-> String -> Doc
text "maybe []" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
d))
(String -> Doc
text "toXMLAttribute \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Attribute -> XName
attr_name Attribute
a) Doc -> Doc -> Doc
<> String -> Doc
text "\"")
ppElem :: NameConverter -> Element -> Doc
ppElem :: NameConverter -> Element -> Doc
ppElem nx :: NameConverter
nx e :: Element
e@Element{}
| Element -> Bool
elem_byRef Element
e = Modifier -> Doc -> Doc
ppElemModifier (Element -> Modifier
elem_modifier Element
e)
(String -> Doc
text "element"
Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e))
| Bool
otherwise = Modifier -> Doc -> Doc
ppElemModifier (Element -> Modifier
elem_modifier Element
e)
(String -> Doc
text "parseSchemaType \""
Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Element -> XName
elem_name Element
e)
Doc -> Doc -> Doc
<> String -> Doc
text "\"")
ppElem nx :: NameConverter
nx e :: Element
e@AnyElem{} = Modifier -> Doc -> Doc
ppElemModifier (Element -> Modifier
elem_modifier Element
e)
(String -> Doc
text "parseAnyElement")
ppElem nx :: NameConverter
nx e :: Element
e@Text{} = String -> Doc
text "parseText"
ppElem nx :: NameConverter
nx e :: Element
e@OneOf{} = Modifier -> Doc -> Doc
ppElemModifier (Element -> Modifier
liftedElemModifier Element
e)
(String -> Doc
text "oneOf'" Doc -> Doc -> Doc
<+> String
-> String
-> String
-> (([Element], Int) -> Doc)
-> [([Element], Int)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "[" "," "]"
(Int -> ([Element], Int) -> Doc
forall a. Show a => a -> ([Element], Int) -> Doc
ppOneOf Int
n)
([[Element]] -> [Int] -> [([Element], Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Element -> [[Element]]
elem_oneOf Element
e) [1..Int
n]))
where
n :: Int
n = [[Element]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Element -> [[Element]]
elem_oneOf Element
e)
ppOneOf :: a -> ([Element], Int) -> Doc
ppOneOf n :: a
n (e :: [Element]
e,i :: Int
i) = String -> Doc
text "(\"" Doc -> Doc -> Doc
<> [Doc] -> Doc
hsep ((Element -> Doc) -> [Element] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName NameConverter
nx Doc -> Doc
forall a. a -> a
id)
([Element] -> [Doc])
-> ([Element] -> [Element]) -> [Element] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> [Element]
cleanChoices ([Element] -> [Doc]) -> [Element] -> [Doc]
forall a b. (a -> b) -> a -> b
$ [Element]
e)
Doc -> Doc -> Doc
<> String -> Doc
text "\","
Doc -> Doc -> Doc
<+> String -> Doc
text "fmap" Doc -> Doc -> Doc
<+> String -> Doc
text (Int -> String
ordinal Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++"Of"String -> String -> String
forall a. [a] -> [a] -> [a]
++a -> String
forall a. Show a => a -> String
show a
n)
Doc -> Doc -> Doc
<+> Doc -> Doc
parens ([Element] -> Doc
ppSeqElem ([Element] -> Doc) -> ([Element] -> [Element]) -> [Element] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> [Element]
cleanChoices ([Element] -> Doc) -> [Element] -> Doc
forall a b. (a -> b) -> a -> b
$ [Element]
e)
Doc -> Doc -> Doc
<> String -> Doc
text ")"
ordinal :: Int -> String
ordinal i :: Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 20 = [String]
ordinals[String] -> Int -> String
forall a. [a] -> Int -> a
!!Int
i
| Bool
otherwise = "Choice" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
ordinals :: [String]
ordinals = ["Zero","One","Two","Three","Four","Five","Six","Seven","Eight"
,"Nine","Ten","Eleven","Twelve","Thirteen","Fourteen","Fifteen"
,"Sixteen","Seventeen","Eighteen","Nineteen","Twenty"]
ppSeqElem :: [Element] -> Doc
ppSeqElem [] = Doc
PP.empty
ppSeqElem [e :: Element
e] = NameConverter -> Element -> Doc
ppElem NameConverter
nx Element
e
ppSeqElem es :: [Element]
es = String -> Doc
text ("return ("String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> Char -> String
forall a. Int -> a -> [a]
replicate ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
esInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) ','String -> String -> String
forall a. [a] -> [a] -> [a]
++")")
Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat ((Element -> Doc) -> [Element] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\e :: Element
e-> String -> Doc
text "`apply`" Doc -> Doc -> Doc
<+> NameConverter -> Element -> Doc
ppElem NameConverter
nx Element
e) [Element]
es)
toXmlElem :: NameConverter -> Element -> Doc
toXmlElem :: NameConverter -> Element -> Doc
toXmlElem nx :: NameConverter
nx e :: Element
e@Element{}
| Element -> Bool
elem_byRef Element
e = Modifier -> Doc -> Doc
xmlElemModifier (Element -> Modifier
elem_modifier Element
e)
(String -> Doc
text "elementToXML"
Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e))
| Bool
otherwise = Modifier -> Doc -> Doc
xmlElemModifier (Element -> Modifier
elem_modifier Element
e)
(String -> Doc
text "schemaTypeToXML \""
Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Element -> XName
elem_name Element
e)
Doc -> Doc -> Doc
<> String -> Doc
text "\"")
toXmlElem nx :: NameConverter
nx e :: Element
e@AnyElem{} = Modifier -> Doc -> Doc
xmlElemModifier (Element -> Modifier
elem_modifier Element
e)
(String -> Doc
text "toXMLAnyElement")
toXmlElem nx :: NameConverter
nx e :: Element
e@Text{} = String -> Doc
text "toXMLText"
toXmlElem nx :: NameConverter
nx e :: Element
e@OneOf{} = Modifier -> Doc -> Doc
xmlElemModifier (Element -> Modifier
liftedElemModifier Element
e)
(String -> Doc
text "foldOneOf" Doc -> Doc -> Doc
<> String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
n)
Doc -> Doc -> Doc
<+> String
-> String -> String -> ([Element] -> Doc) -> [[Element]] -> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "" "" "" [Element] -> Doc
xmlOneOf (Element -> [[Element]]
elem_oneOf Element
e))
where
n :: Int
n = [[Element]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Element -> [[Element]]
elem_oneOf Element
e)
xmlOneOf :: [Element] -> Doc
xmlOneOf e :: [Element]
e = Doc -> Doc
parens ([Element] -> Doc
xmlSeqElem ([Element] -> Doc) -> ([Element] -> [Element]) -> [Element] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> [Element]
cleanChoices ([Element] -> Doc) -> [Element] -> Doc
forall a b. (a -> b) -> a -> b
$ [Element]
e)
xmlSeqElem :: [Element] -> Doc
xmlSeqElem [] = Doc
PP.empty
xmlSeqElem [e :: Element
e] = NameConverter -> Element -> Doc
toXmlElem NameConverter
nx Element
e
xmlSeqElem es :: [Element]
es = String -> Doc
text "\\ (" Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text ",") [Doc]
vars)
Doc -> Doc -> Doc
<> String -> Doc
text ") -> concat"
Doc -> Doc -> Doc
<+> String
-> String
-> String
-> ((Element, Doc) -> Doc)
-> [(Element, Doc)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "[" "," "]" (\(e :: Element
e,v :: Doc
v)-> NameConverter -> Element -> Doc
toXmlElem NameConverter
nx Element
e Doc -> Doc -> Doc
<+> Doc
v)
([Element] -> [Doc] -> [(Element, Doc)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Element]
es [Doc]
vars)
where vars :: [Doc]
vars = (Char -> Doc) -> String -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text(String -> Doc) -> (Char -> String) -> Char -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Char -> String -> String
forall a. a -> [a] -> [a]
:[])) (String -> [Doc]) -> (String -> String) -> String -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> String
forall a. Int -> [a] -> [a]
take ([Element] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
es) (String -> [Doc]) -> String -> [Doc]
forall a b. (a -> b) -> a -> b
$ ['a'..'z']
ppHighLevelDecls :: NameConverter -> [Decl] -> Doc
ppHighLevelDecls :: NameConverter -> [Decl] -> Doc
ppHighLevelDecls nx :: NameConverter
nx hs :: [Decl]
hs = [Doc] -> Doc
vcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text " ")
((Decl -> Doc) -> [Decl] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (NameConverter -> Decl -> Doc
ppHighLevelDecl NameConverter
nx) [Decl]
hs))
ppHighLevelDecl :: NameConverter -> Decl -> Doc
ppHighLevelDecl :: NameConverter -> Decl -> Doc
ppHighLevelDecl nx :: NameConverter
nx (NamedSimpleType t :: XName
t s :: XName
s comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "type" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
s
Doc -> Doc -> Doc
$$ String -> Doc
text "-- No instances required: synonym is isomorphic to the original."
ppHighLevelDecl nx :: NameConverter
nx (RestrictSimpleType t :: XName
t s :: XName
s r :: [Restrict]
r comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "newtype" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
s
Doc -> Doc -> Doc
<+> String -> Doc
text "deriving (Eq,Show)"
Doc -> Doc -> Doc
$$ String -> Doc
text "instance Restricts" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
s
Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "restricts (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "x) = x")
Doc -> Doc -> Doc
$$ String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "parseSchemaType s = do"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "e <- element [s]"
Doc -> Doc -> Doc
$$ String -> Doc
text "commit $ interior e $ parseSimpleType")
)
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "schemaTypeToXML s ("Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "x) = "
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "toXMLElement s [] [toXMLText (simpleTypeText x)]")
)
Doc -> Doc -> Doc
$$ String -> Doc
text "instance SimpleType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "acceptingParser = fmap" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
<+> String -> Doc
text "acceptingParser"
Doc -> Doc -> Doc
$$ String -> Doc
text "-- XXX should enforce the restrictions somehow?"
Doc -> Doc -> Doc
$$ String -> Doc
text "-- The restrictions are:"
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Restrict -> Doc) -> [Restrict] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Doc
text "-- " Doc -> Doc -> Doc
<+>) (Doc -> Doc) -> (Restrict -> Doc) -> Restrict -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Restrict -> Doc
ppRestrict) [Restrict]
r))
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "simpleTypeText (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
<+> String -> Doc
text "x) = simpleTypeText x")
where
ppRestrict :: Restrict -> Doc
ppRestrict (RangeR occ :: Occurs
occ comm :: Comment
comm) = String -> Doc
text "(RangeR"
Doc -> Doc -> Doc
<+> Occurs -> Doc
ppOccurs Occurs
occ Doc -> Doc -> Doc
<> String -> Doc
text ")"
ppRestrict (Pattern regexp :: String
regexp comm :: Comment
comm) = String -> Doc
text ("(Pattern "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
regexpString -> String -> String
forall a. [a] -> [a] -> [a]
++")")
ppRestrict (Enumeration items :: [(String, Comment)]
items) = String -> Doc
text "(Enumeration"
Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (((String, Comment) -> Doc) -> [(String, Comment)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Doc
text (String -> Doc)
-> ((String, Comment) -> String) -> (String, Comment) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Comment) -> String
forall a b. (a, b) -> a
fst) [(String, Comment)]
items)
Doc -> Doc -> Doc
<> String -> Doc
text ")"
ppRestrict (StrLength occ :: Occurs
occ comm :: Comment
comm) = String -> Doc
text "(StrLength"
Doc -> Doc -> Doc
<+> Occurs -> Doc
ppOccurs Occurs
occ Doc -> Doc -> Doc
<> String -> Doc
text ")"
ppOccurs :: Occurs -> Doc
ppOccurs = Doc -> Doc
parens (Doc -> Doc) -> (Occurs -> Doc) -> Occurs -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> Doc) -> (Occurs -> String) -> Occurs -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Occurs -> String
forall a. Show a => a -> String
show
ppHighLevelDecl nx :: NameConverter
nx (ExtendSimpleType t :: XName
t s :: XName
s as :: [Attribute]
as comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
s
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs
Doc -> Doc -> Doc
<+> String -> Doc
text "deriving (Eq,Show)"
Doc -> Doc -> Doc
$$ String -> Doc
text "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs Doc -> Doc -> Doc
<+> String -> Doc
text "=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (NameConverter -> XName -> [Element] -> [Attribute] -> Doc
ppFields NameConverter
nx XName
t_attrs [] [Attribute]
as
Doc -> Doc -> Doc
$$ String -> Doc
text "deriving (Eq,Show)")
Doc -> Doc -> Doc
$$ String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "parseSchemaType s = do"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "(pos,e) <- posnElement [s]"
Doc -> Doc -> Doc
$$ String -> Doc
text "commit $ do"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 2
([Doc] -> Doc
vcat ((Attribute -> Int -> Doc) -> [Attribute] -> [Int] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Attribute -> Int -> Doc
ppAttr [Attribute]
as [0..])
Doc -> Doc -> Doc
$$ String -> Doc
text "reparse [CElem e pos]"
Doc -> Doc -> Doc
$$ String -> Doc
text "v <- parseSchemaType s"
Doc -> Doc -> Doc
$$ String -> Doc
text "return $" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
<+> String -> Doc
text "v"
Doc -> Doc -> Doc
<+> [Attribute] -> Doc
forall a. [a] -> Doc
attrsValue [Attribute]
as)
)
)
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "schemaTypeToXML s ("Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
<+> String -> Doc
text "bt at) ="
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "addXMLAttributes"
Doc -> Doc -> Doc
<+> String
-> String -> String -> (Attribute -> Doc) -> [Attribute] -> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "[" "," "]"
(\a :: Attribute
a-> Attribute -> Doc
toXmlAttr Attribute
a Doc -> Doc -> Doc
<+> String -> Doc
text "$"
Doc -> Doc -> Doc
<+> NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t_attrs (Attribute -> XName
attr_name Attribute
a)
Doc -> Doc -> Doc
<+> String -> Doc
text "at")
[Attribute]
as
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "$ schemaTypeToXML s bt"))
)
Doc -> Doc -> Doc
$$ String -> Doc
text "instance Extension" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
s
Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "supertype (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text " s _) = s")
where
t_attrs :: XName
t_attrs = let (XName (N t_base :: String
t_base)) = XName
t in QName -> XName
XName (String -> QName
N (String
t_baseString -> String -> String
forall a. [a] -> [a] -> [a]
++"Attributes"))
attrsValue :: [a] -> Doc
attrsValue [] = NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs
attrsValue as :: [a]
as = Doc -> Doc
parens (NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs Doc -> Doc -> Doc
<+>
[Doc] -> Doc
hsep [String -> Doc
text ("a"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
n) | Int
n <- [0..[a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
asInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]])
ppHighLevelDecl nx :: NameConverter
nx (UnionSimpleTypes t :: XName
t sts :: [XName]
sts comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
$$ String -> Doc
text "-- Placeholder for a Union type, not yet implemented."
ppHighLevelDecl nx :: NameConverter
nx (EnumSimpleType t :: XName
t [] comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
ppHighLevelDecl nx :: NameConverter
nx (EnumSimpleType t :: XName
t is :: [(XName, Comment)]
is comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 ( String
-> String
-> String
-> ((XName, Comment) -> Doc)
-> [(XName, Comment)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "=" "|" "deriving (Eq,Show,Enum)" (XName, Comment) -> Doc
item [(XName, Comment)]
is )
Doc -> Doc -> Doc
$$ String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "parseSchemaType s = do"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "e <- element [s]"
Doc -> Doc -> Doc
$$ String -> Doc
text "commit $ interior e $ parseSimpleType")
)
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "schemaTypeToXML s x = "
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "toXMLElement s [] [toXMLText (simpleTypeText x)]")
)
Doc -> Doc -> Doc
$$ String -> Doc
text "instance SimpleType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "acceptingParser ="
Doc -> Doc -> Doc
<+> String
-> String
-> String
-> ((XName, Comment) -> Doc)
-> [(XName, Comment)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "" "`onFail`" "" (XName, Comment) -> Doc
forall b. (XName, b) -> Doc
parseItem [(XName, Comment)]
is
Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat (((XName, Comment) -> Doc) -> [(XName, Comment)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName, Comment) -> Doc
forall b. (XName, b) -> Doc
enumText [(XName, Comment)]
is))
where
item :: (XName, Comment) -> Doc
item (i :: XName
i,c :: Comment
c) = (NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text "_" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
i)
Doc -> Doc -> Doc
$$ CommentPosition -> Comment -> Doc
ppComment CommentPosition
After Comment
c
parseItem :: (XName, b) -> Doc
parseItem (i :: XName
i,_) = String -> Doc
text "do literal \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
i Doc -> Doc -> Doc
<> String -> Doc
text "\"; return"
Doc -> Doc -> Doc
<+> (NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text "_" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
i)
enumText :: (XName, b) -> Doc
enumText (i :: XName
i,_) = String -> Doc
text "simpleTypeText"
Doc -> Doc -> Doc
<+> (NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text "_" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
i)
Doc -> Doc -> Doc
<+> String -> Doc
text "= \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
i Doc -> Doc -> Doc
<> String -> Doc
text "\""
ppHighLevelDecl nx :: NameConverter
nx (ElementsAttrs t :: XName
t es :: [Element]
es as :: [Attribute]
as comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 8 (NameConverter -> XName -> [Element] -> [Attribute] -> Doc
ppFields NameConverter
nx XName
t ([Element] -> [Element]
uniqueify [Element]
es) [Attribute]
as
Doc -> Doc -> Doc
$$ String -> Doc
text "deriving (Eq,Show)")
Doc -> Doc -> Doc
$$ String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "parseSchemaType s = do"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "(pos,e) <- posnElement [s]"
Doc -> Doc -> Doc
$$ ([Doc] -> Doc
vcat ((Attribute -> Int -> Doc) -> [Attribute] -> [Int] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Attribute -> Int -> Doc
ppAttr [Attribute]
as [0..])
Doc -> Doc -> Doc
$$ String -> Doc
text "commit $ interior e $ return"
Doc -> Doc -> Doc
<+> [Attribute] -> Doc
forall a. [a] -> Doc
returnValue [Attribute]
as
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 ([Doc] -> Doc
vcat ((Element -> Doc) -> [Element] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Doc
ppApplyElem [Element]
es))
)
)
)
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "schemaTypeToXML s x@"Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text "{} ="
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "toXMLElement s"
Doc -> Doc -> Doc
<+> String
-> String -> String -> (Attribute -> Doc) -> [Attribute] -> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "[" "," "]"
(\a :: Attribute
a-> Attribute -> Doc
toXmlAttr Attribute
a Doc -> Doc -> Doc
<+> String -> Doc
text "$"
Doc -> Doc -> Doc
<+> NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t (Attribute -> XName
attr_name Attribute
a)
Doc -> Doc -> Doc
<+> String -> Doc
text "x")
[Attribute]
as
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String
-> String
-> String
-> ((Element, Int) -> Doc)
-> [(Element, Int)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "[" "," "]"
(\ (e :: Element
e,i :: Int
i)-> NameConverter -> Element -> Doc
toXmlElem NameConverter
nx Element
e
Doc -> Doc -> Doc
<+> String -> Doc
text "$"
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
Doc -> Doc -> Doc
<+> String -> Doc
text "x")
([Element] -> [Int] -> [(Element, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Element]
es [0..]))
)
)
where
returnValue :: [a] -> Doc
returnValue [] = NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
returnValue as :: [a]
as = Doc -> Doc
parens (NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+>
[Doc] -> Doc
hsep [String -> Doc
text ("a"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
n) | Int
n <- [0..[a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
asInt -> Int -> Int
forall a. Num a => a -> a -> a
-1]])
ppApplyElem :: Element -> Doc
ppApplyElem e :: Element
e = String -> Doc
text "`apply`" Doc -> Doc -> Doc
<+> NameConverter -> Element -> Doc
ppElem NameConverter
nx Element
e
ppHighLevelDecl nx :: NameConverter
nx (ElementsAttrsAbstract t :: XName
t [] comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "-- (There are no subtypes defined for this abstract type.)"
Doc -> Doc -> Doc
$$ String -> Doc
text "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
<+> String -> Doc
text "deriving (Eq,Show)"
Doc -> Doc -> Doc
$$ String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "parseSchemaType s = fail" Doc -> Doc -> Doc
<+> Doc
errmsg)
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "schemaTypeToXML s _ = toXMLElement s [] []")
where
errmsg :: Doc
errmsg = String -> Doc
text "\"Parse failed when expecting an extension type of"
Doc -> Doc -> Doc
<+> XName -> Doc
ppXName XName
t Doc -> Doc -> Doc
<> String -> Doc
text ":\\n No extension types are known.\""
ppHighLevelDecl nx :: NameConverter
nx (ElementsAttrsAbstract t :: XName
t insts :: [(XName, Maybe XName)]
insts comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 8 (String
-> String
-> String
-> ((XName, Maybe XName) -> Doc)
-> [(XName, Maybe XName)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "=" "|" "" (XName, Maybe XName) -> Doc
forall a. (XName, Maybe a) -> Doc
ppAbstrCons [(XName, Maybe XName)]
insts
Doc -> Doc -> Doc
$$ String -> Doc
text "deriving (Eq,Show)")
Doc -> Doc -> Doc
$$ String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "parseSchemaType s = do"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 ([Doc] -> Doc
vcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text "`onFail`")
(((XName, Maybe XName) -> Doc) -> [(XName, Maybe XName)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName, Maybe XName) -> Doc
forall a. (XName, Maybe a) -> Doc
ppParse [(XName, Maybe XName)]
insts)
[Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [String -> Doc
text "`onFail` fail" Doc -> Doc -> Doc
<+> Doc
errmsg])))
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 ([Doc] -> Doc
vcat (((XName, Maybe XName) -> Doc) -> [(XName, Maybe XName)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName, Maybe XName) -> Doc
forall b. (XName, b) -> Doc
toXML [(XName, Maybe XName)]
insts))
where
ppAbstrCons :: (XName, Maybe a) -> Doc
ppAbstrCons (name :: XName
name,Nothing) = XName -> Doc
con XName
name Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
name
ppAbstrCons (name :: XName
name,Just mod :: a
mod) = XName -> Doc
con XName
name Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
name
ppParse :: (XName, Maybe a) -> Doc
ppParse (name :: XName
name,Nothing) = String -> Doc
text "(fmap" Doc -> Doc -> Doc
<+> XName -> Doc
con XName
name Doc -> Doc -> Doc
<+>
String -> Doc
text "$ parseSchemaType s)"
ppParse (name :: XName
name,Just _) = (XName, Maybe a) -> Doc
ppParse (XName
name,Maybe a
forall a. Maybe a
Nothing)
errmsg :: Doc
errmsg = String -> Doc
text "\"Parse failed when expecting an extension type of"
Doc -> Doc -> Doc
<+> XName -> Doc
ppXName XName
t Doc -> Doc -> Doc
<> String -> Doc
text ",\\n\\\n\\ namely one of:\\n\\\n\\"
Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text ",")
(((XName, Maybe XName) -> Doc) -> [(XName, Maybe XName)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName -> Doc
ppXName (XName -> Doc)
-> ((XName, Maybe XName) -> XName) -> (XName, Maybe XName) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XName, Maybe XName) -> XName
forall a b. (a, b) -> a
fst) [(XName, Maybe XName)]
insts))
Doc -> Doc -> Doc
<> String -> Doc
text "\""
con :: XName -> Doc
con name :: XName
name = NameConverter -> XName -> XName -> Doc
ppJoinConId NameConverter
nx XName
t XName
name
toXML :: (XName, b) -> Doc
toXML (name :: XName
name,_) = String -> Doc
text "schemaTypeToXML _s ("
Doc -> Doc -> Doc
<> XName -> Doc
con XName
name Doc -> Doc -> Doc
<+> String -> Doc
text "x) = schemaTypeToXML \""
Doc -> Doc -> Doc
<> XName -> Doc
ppXName (XName -> XName
initLower XName
name) Doc -> Doc -> Doc
<> String -> Doc
text "\" x"
initLower :: XName -> XName
initLower (XName (N (c :: Char
c:cs :: String
cs))) = QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ String -> QName
N (Char -> Char
toLower Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs)
initLower (XName (QN ns :: Namespace
ns (c :: Char
c:cs :: String
cs))) = QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ Namespace -> String -> QName
QN Namespace
ns (Char -> Char
toLower Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:String
cs)
ppHighLevelDecl nx :: NameConverter
nx (ElementOfType e :: Element
e@Element{}) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before (Element -> Comment
elem_comment Element
e)
Doc -> Doc -> Doc
$$ (String -> Doc
text "element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e)) Doc -> Doc -> Doc
<+> String -> Doc
text "::"
Doc -> Doc -> Doc
<+> String -> Doc
text "XMLParser" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx (Element -> XName
elem_type Element
e)
Doc -> Doc -> Doc
$$ (String -> Doc
text "element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e)) Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> (String -> Doc
text "parseSchemaType \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Element -> XName
elem_name Element
e) Doc -> Doc -> Doc
<> String -> Doc
text "\"")
Doc -> Doc -> Doc
$$ (String -> Doc
text "elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e)) Doc -> Doc -> Doc
<+> String -> Doc
text "::"
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx (Element -> XName
elem_type Element
e) Doc -> Doc -> Doc
<+> String -> Doc
text "-> [Content ()]"
Doc -> Doc -> Doc
$$ (String -> Doc
text "elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e)) Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> (String -> Doc
text "schemaTypeToXML \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Element -> XName
elem_name Element
e) Doc -> Doc -> Doc
<> String -> Doc
text "\"")
ppHighLevelDecl nx :: NameConverter
nx e :: Decl
e@(ElementAbstractOfType n :: XName
n t :: XName
t [] comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "-- (There are no elements in any substitution group for this element.)"
Doc -> Doc -> Doc
$$ (String -> Doc
text "element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text "::"
Doc -> Doc -> Doc
<+> String -> Doc
text "XMLParser" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t
Doc -> Doc -> Doc
$$ (String -> Doc
text "element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> String -> Doc
text "fail" Doc -> Doc -> Doc
<+> Doc
errmsg
Doc -> Doc -> Doc
$$ (String -> Doc
text "elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text "::"
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "-> [Content ()]"
Doc -> Doc -> Doc
$$ (String -> Doc
text "elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> (String -> Doc
text "schemaTypeToXML \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
n Doc -> Doc -> Doc
<> String -> Doc
text "\"")
where
errmsg :: Doc
errmsg = String -> Doc
text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <"
Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
n Doc -> Doc -> Doc
<> String -> Doc
text ">,\\n\\\n\\ There are no substitutable elements.\""
ppHighLevelDecl nx :: NameConverter
nx e :: Decl
e@(ElementAbstractOfType n :: XName
n t :: XName
t substgrp :: [(XName, Maybe XName)]
substgrp comm :: Comment
comm)
| Bool
otherwise = CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ (String -> Doc
text "element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text "::"
Doc -> Doc -> Doc
<+> String -> Doc
text "XMLParser" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t
Doc -> Doc -> Doc
$$ (String -> Doc
text "element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text "`onFail`") (((XName, Maybe XName) -> Doc) -> [(XName, Maybe XName)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName, Maybe XName) -> Doc
forall a. (XName, Maybe a) -> Doc
ppOne [(XName, Maybe XName)]
substgrp)
[Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++ [String -> Doc
text "`onFail` fail" Doc -> Doc -> Doc
<+> Doc
errmsg])
Doc -> Doc -> Doc
$$ (String -> Doc
text "elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text "::"
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "-> [Content ()]"
Doc -> Doc -> Doc
$$ (String -> Doc
text "elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> (String -> Doc
text "schemaTypeToXML \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
n Doc -> Doc -> Doc
<> String -> Doc
text "\"")
where
notInScope :: (a, Maybe a) -> Bool
notInScope (_,Just _) = Bool
True
notInScope (_,Nothing) = Bool
False
ppOne :: (XName, Maybe a) -> Doc
ppOne (c :: XName
c,Nothing) = String -> Doc
text "fmap" Doc -> Doc -> Doc
<+> String -> Doc
text "supertype"
Doc -> Doc -> Doc
<+> (String -> Doc
text "element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
c)
ppOne (c :: XName
c,Just _) = String -> Doc
text "fmap" Doc -> Doc -> Doc
<+> String -> Doc
text "supertype"
Doc -> Doc -> Doc
<+> (String -> Doc
text "element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
c)
Doc -> Doc -> Doc
<+> String -> Doc
text "-- FIXME: element is forward-declared"
errmsg :: Doc
errmsg = String -> Doc
text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\ <"
Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
n Doc -> Doc -> Doc
<> String -> Doc
text ">,\\n\\\n\\ namely one of:\\n\\\n\\<"
Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text ">, <")
(((XName, Maybe XName) -> Doc) -> [(XName, Maybe XName)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName -> Doc
ppXName (XName -> Doc)
-> ((XName, Maybe XName) -> XName) -> (XName, Maybe XName) -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (XName, Maybe XName) -> XName
forall a b. (a, b) -> a
fst) [(XName, Maybe XName)]
substgrp))
Doc -> Doc -> Doc
<> String -> Doc
text ">\""
ppHighLevelDecl nx :: NameConverter
nx (Choice t :: XName
t es :: [Element]
es comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest 4 ( String
-> String
-> String
-> ((Element, Integer) -> Doc)
-> [(Element, Integer)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "=" "|" "" (Element, Integer) -> Doc
forall a. Show a => (Element, a) -> Doc
choices ([Element] -> [Integer] -> [(Element, Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Element]
es [1..])
Doc -> Doc -> Doc
$$ String -> Doc
text "deriving (Eq,Show)" )
where
choices :: (Element, a) -> Doc
choices (e :: Element
e,n :: a
n) = (NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text (a -> String
forall a. Show a => a -> String
show a
n))
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx (Element -> XName
elem_type Element
e)
ppHighLevelDecl nx :: NameConverter
nx (Group t :: XName
t es :: [Element]
es comm :: Comment
comm) = Doc
PP.empty
ppHighLevelDecl nx :: NameConverter
nx (RestrictComplexType t :: XName
t s :: XName
s comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "newtype" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
s
Doc -> Doc -> Doc
<+> String -> Doc
text "deriving (Eq,Show)"
Doc -> Doc -> Doc
$$ String -> Doc
text "-- plus different (more restrictive) parser"
Doc -> Doc -> Doc
$$ String -> Doc
text "-- (parsing restrictions currently unimplemented)"
Doc -> Doc -> Doc
$$ String -> Doc
text "instance Restricts" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
s
Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "restricts (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "x) = x")
Doc -> Doc -> Doc
$$ String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "parseSchemaType = fmap " Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+>
String -> Doc
text ". parseSchemaType")
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "schemaTypeToXML s (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text "x)")
Doc -> Doc -> Doc
<+> String -> Doc
text "= schemaTypeToXML s x"
ppHighLevelDecl nx :: NameConverter
nx (ExtendComplexType t :: XName
t s :: XName
s oes :: [Element]
oes oas :: [Attribute]
oas es :: [Element]
es as :: [Attribute]
as
fwdReqd :: Maybe XName
fwdReqd absSup :: Bool
absSup grandsuper :: [XName]
grandsuper comm :: Comment
comm) =
NameConverter -> Decl -> Doc
ppHighLevelDecl NameConverter
nx (XName -> [Element] -> [Attribute] -> Comment -> Decl
ElementsAttrs XName
t ([Element]
oes[Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++[Element]
es) ([Attribute]
oas[Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++[Attribute]
as) Comment
comm)
Doc -> Doc -> Doc
$$ NameConverter
-> XName
-> XName
-> Maybe XName
-> Bool
-> [Element]
-> [Attribute]
-> [Element]
-> [Attribute]
-> Doc
ppExtension NameConverter
nx XName
t XName
s Maybe XName
fwdReqd Bool
absSup [Element]
oes [Attribute]
oas [Element]
es [Attribute]
as
Doc -> Doc -> Doc
$$ (if Bool -> Bool
not ([XName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [XName]
grandsuper)
then NameConverter -> XName -> [XName] -> (XName, Maybe XName) -> Doc
ppSuperExtension NameConverter
nx XName
s [XName]
grandsuper (XName
t,Maybe XName
forall a. Maybe a
Nothing)
else Doc
empty)
ppHighLevelDecl nx :: NameConverter
nx (ExtendComplexTypeAbstract t :: XName
t s :: XName
s insts :: [(XName, Maybe XName)]
insts
fwdReqd :: Maybe XName
fwdReqd grandsuper :: [XName]
grandsuper comm :: Comment
comm) =
NameConverter -> Decl -> Doc
ppHighLevelDecl NameConverter
nx (XName -> [(XName, Maybe XName)] -> Comment -> Decl
ElementsAttrsAbstract XName
t [(XName, Maybe XName)]
insts Comment
comm)
Doc -> Doc -> Doc
$$ NameConverter
-> XName
-> XName
-> Maybe XName
-> Bool
-> [Element]
-> [Attribute]
-> [Element]
-> [Attribute]
-> Doc
ppExtension NameConverter
nx XName
t XName
s Maybe XName
fwdReqd Bool
True [] [] [] []
ppHighLevelDecl nx :: NameConverter
nx (XSDInclude m :: XName
m comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
After Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "import" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
m
ppHighLevelDecl nx :: NameConverter
nx (XSDImport m :: XName
m ma :: Maybe XName
ma comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
After Comment
comm
Doc -> Doc -> Doc
$$ String -> Doc
text "import" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
m
Doc -> Doc -> Doc
<+> Doc -> (XName -> Doc) -> Maybe XName -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
empty (\a :: XName
a->String -> Doc
text "as"Doc -> Doc -> Doc
<+>NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
a) Maybe XName
ma
ppHighLevelDecl nx :: NameConverter
nx (XSDComment comm :: Comment
comm) =
CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
ppExtension :: NameConverter -> XName -> XName -> Maybe XName -> Bool ->
[Element] -> [Attribute] -> [Element] -> [Attribute] -> Doc
ppExtension :: NameConverter
-> XName
-> XName
-> Maybe XName
-> Bool
-> [Element]
-> [Attribute]
-> [Element]
-> [Attribute]
-> Doc
ppExtension nx :: NameConverter
nx t :: XName
t s :: XName
s fwdReqd :: Maybe XName
fwdReqd abstractSuper :: Bool
abstractSuper oes :: [Element]
oes oas :: [Attribute]
oas es :: [Element]
es as :: [Attribute]
as =
String -> Doc
text "instance Extension" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
s
Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ (if Bool
abstractSuper then
Int -> Doc -> Doc
nest 4 (String -> Doc
text "supertype v" Doc -> Doc -> Doc
<+> String -> Doc
text "="
Doc -> Doc -> Doc
<+> NameConverter -> XName -> XName -> Doc
ppJoinConId NameConverter
nx XName
s XName
t Doc -> Doc -> Doc
<+>
String -> Doc
text "v")
else
Int -> Doc -> Doc
nest 4 (String -> Doc
text "supertype (" Doc -> Doc -> Doc
<> XName -> [Element] -> [Attribute] -> Doc
forall (t :: * -> *) (t :: * -> *) a a.
(Foldable t, Foldable t) =>
XName -> t a -> t a -> Doc
ppType XName
t ([Element]
oes[Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++[Element]
es) ([Attribute]
oas[Attribute] -> [Attribute] -> [Attribute]
forall a. [a] -> [a] -> [a]
++[Attribute]
as)
Doc -> Doc -> Doc
<> String -> Doc
text ") ="
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 11 (XName -> [Element] -> [Attribute] -> Doc
forall (t :: * -> *) (t :: * -> *) a a.
(Foldable t, Foldable t) =>
XName -> t a -> t a -> Doc
ppType XName
s [Element]
oes [Attribute]
oas) ))
where
fwd :: XName -> Doc
fwd name :: XName
name = NameConverter -> XName -> Doc
ppFwdConId NameConverter
nx XName
name
ppType :: XName -> t a -> t a -> Doc
ppType t :: XName
t es :: t a
es as :: t a
as = NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Int -> [Doc] -> [Doc]
forall a. Int -> [a] -> [a]
take (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
as) [String -> Doc
text ('a'Char -> String -> String
forall a. a -> [a] -> [a]
:Integer -> String
forall a. Show a => a -> String
show Integer
n) | Integer
n<-[0..]])
Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Int -> [Doc] -> [Doc]
forall a. Int -> [a] -> [a]
take (t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
es) [String -> Doc
text ('e'Char -> String -> String
forall a. a -> [a] -> [a]
:Integer -> String
forall a. Show a => a -> String
show Integer
n) | Integer
n<-[0..]])
ppSuperExtension :: NameConverter -> XName -> [XName]
-> (XName,Maybe XName) -> Doc
ppSuperExtension :: NameConverter -> XName -> [XName] -> (XName, Maybe XName) -> Doc
ppSuperExtension nx :: NameConverter
nx super :: XName
super grandSupers :: [XName]
grandSupers (t :: XName
t,Just mod :: XName
mod) =
String -> Doc
text "-- Note that" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
Doc -> Doc -> Doc
<+> String -> Doc
text "will be declared later in module" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
mod
Doc -> Doc -> Doc
$$ NameConverter -> XName -> [XName] -> (XName, Maybe XName) -> Doc
ppSuperExtension NameConverter
nx XName
super [XName]
grandSupers (XName
t,Maybe XName
forall a. Maybe a
Nothing)
ppSuperExtension nx :: NameConverter
nx super :: XName
super grandSupers :: [XName]
grandSupers (t :: XName
t,Nothing) =
[Doc] -> Doc
vcat (([XName] -> Doc) -> [[XName]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName -> [XName] -> Doc
ppSuper XName
t) (([XName] -> [XName]) -> [[XName]] -> [[XName]]
forall a b. (a -> b) -> [a] -> [b]
map [XName] -> [XName]
forall a. [a] -> [a]
reverse ([[XName]] -> [[XName]])
-> ([XName] -> [[XName]]) -> [XName] -> [[XName]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [[XName]] -> [[XName]]
forall a. Int -> [a] -> [a]
drop 2 ([[XName]] -> [[XName]])
-> ([XName] -> [[XName]]) -> [XName] -> [[XName]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XName] -> [[XName]]
forall a. [a] -> [[a]]
inits ([XName] -> [[XName]]) -> [XName] -> [[XName]]
forall a b. (a -> b) -> a -> b
$ XName
superXName -> [XName] -> [XName]
forall a. a -> [a] -> [a]
: [XName]
grandSupers))
where
ppSuper :: XName -> [XName] -> Doc
ppSuper :: XName -> [XName] -> Doc
ppSuper t :: XName
t gss :: [XName]
gss@(gs :: XName
gs:_) =
String -> Doc
text "instance Extension" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
gs
Doc -> Doc -> Doc
<+> String -> Doc
text "where"
Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest 4 (String -> Doc
text "supertype" Doc -> Doc -> Doc
<+>
(String
-> String
-> String
-> ((XName, XName) -> Doc)
-> [(XName, XName)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "=" "." "" (XName, XName) -> Doc
coerce ([XName] -> [XName] -> [(XName, XName)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([XName] -> [XName]
forall a. [a] -> [a]
tail [XName]
gss[XName] -> [XName] -> [XName]
forall a. [a] -> [a] -> [a]
++[XName
t]) [XName]
gss)))
coerce :: (XName, XName) -> Doc
coerce (a :: XName
a,b :: XName
b) = String -> Doc
text "(supertype ::" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
a
Doc -> Doc -> Doc
<+> String -> Doc
text "->"
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
b Doc -> Doc -> Doc
<> String -> Doc
text ")"
ppFields :: NameConverter -> XName -> [Element] -> [Attribute] -> Doc
ppFields :: NameConverter -> XName -> [Element] -> [Attribute] -> Doc
ppFields nx :: NameConverter
nx t :: XName
t es :: [Element]
es as :: [Attribute]
as | [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
es Bool -> Bool -> Bool
&& [Attribute] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attribute]
as = Doc
empty
ppFields nx :: NameConverter
nx t :: XName
t es :: [Element]
es as :: [Attribute]
as = String -> String -> String -> (Doc -> Doc) -> [Doc] -> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList "{" "," "}" Doc -> Doc
forall a. a -> a
id [Doc]
fields
where
fields :: [Doc]
fields = (Attribute -> Doc) -> [Attribute] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (NameConverter -> XName -> Attribute -> Doc
ppFieldAttribute NameConverter
nx XName
t) [Attribute]
as [Doc] -> [Doc] -> [Doc]
forall a. [a] -> [a] -> [a]
++
(Element -> Int -> Doc) -> [Element] -> [Int] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (NameConverter -> XName -> Element -> Int -> Doc
ppFieldElement NameConverter
nx XName
t) [Element]
es [0..]
ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldElement nx :: NameConverter
nx t :: XName
t e :: Element
e@Element{} i :: Int
i = NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
Doc -> Doc -> Doc
<+> String -> Doc
text "::" Doc -> Doc -> Doc
<+> NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName NameConverter
nx Doc -> Doc
forall a. a -> a
id Element
e
Doc -> Doc -> Doc
$$ CommentPosition -> Comment -> Doc
ppComment CommentPosition
After (Element -> Comment
elem_comment Element
e)
ppFieldElement nx :: NameConverter
nx t :: XName
t e :: Element
e@OneOf{} i :: Int
i = NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
Doc -> Doc -> Doc
<+> String -> Doc
text "::" Doc -> Doc -> Doc
<+> NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName NameConverter
nx Doc -> Doc
forall a. a -> a
id Element
e
Doc -> Doc -> Doc
$$ CommentPosition -> Comment -> [[Element]] -> Doc
ppCommentForChoice CommentPosition
After (Element -> Comment
elem_comment Element
e)
(Element -> [[Element]]
elem_oneOf Element
e)
ppFieldElement nx :: NameConverter
nx t :: XName
t e :: Element
e@AnyElem{} i :: Int
i = NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
Doc -> Doc -> Doc
<+> String -> Doc
text "::" Doc -> Doc -> Doc
<+> NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName NameConverter
nx Doc -> Doc
forall a. a -> a
id Element
e
Doc -> Doc -> Doc
$$ CommentPosition -> Comment -> Doc
ppComment CommentPosition
After (Element -> Comment
elem_comment Element
e)
ppFieldElement nx :: NameConverter
nx t :: XName
t e :: Element
e@Text{} i :: Int
i = NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
Doc -> Doc -> Doc
<+> String -> Doc
text "::" Doc -> Doc -> Doc
<+> NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName NameConverter
nx Doc -> Doc
forall a. a -> a
id Element
e
ppFieldName :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldName :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldName nx :: NameConverter
nx t :: XName
t e :: Element
e@Element{} _ = NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t (Element -> XName
elem_name Element
e)
ppFieldName nx :: NameConverter
nx t :: XName
t e :: Element
e@OneOf{} i :: Int
i = NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t (QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ String -> QName
N (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$"choice"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i)
ppFieldName nx :: NameConverter
nx t :: XName
t e :: Element
e@AnyElem{} i :: Int
i = NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t (QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ String -> QName
N (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$"any"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i)
ppFieldName nx :: NameConverter
nx t :: XName
t e :: Element
e@Text{} i :: Int
i = NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t (QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ String -> QName
N (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$"text"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i)
ppElemTypeName :: NameConverter -> (Doc->Doc) -> Element -> Doc
ppElemTypeName :: NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName nx :: NameConverter
nx brack :: Doc -> Doc
brack e :: Element
e@Element{} =
Modifier -> (Doc -> Doc) -> Doc -> Doc
ppTypeModifier (Element -> Modifier
elem_modifier Element
e) Doc -> Doc
brack (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ NameConverter -> XName -> Doc
ppConId NameConverter
nx (Element -> XName
elem_type Element
e)
ppElemTypeName nx :: NameConverter
nx brack :: Doc -> Doc
brack e :: Element
e@OneOf{} =
Doc -> Doc
brack (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Modifier -> (Doc -> Doc) -> Doc -> Doc
ppTypeModifier (Element -> Modifier
liftedElemModifier Element
e) Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "OneOf" Doc -> Doc -> Doc
<> String -> Doc
text (Int -> String
forall a. Show a => a -> String
show ([[Element]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Element -> [[Element]]
elem_oneOf Element
e)))
Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (([Element] -> Doc) -> [[Element]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Element] -> Doc
ppSeq ([Element] -> Doc) -> ([Element] -> [Element]) -> [Element] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> [Element]
cleanChoices) (Element -> [[Element]]
elem_oneOf Element
e))
where
ppSeq :: [Element] -> Doc
ppSeq [] = String -> Doc
text "()"
ppSeq [e :: Element
e] = NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName NameConverter
nx Doc -> Doc
parens Element
e
ppSeq es :: [Element]
es = String -> Doc
text "(" Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text ",")
((Element -> Doc) -> [Element] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName NameConverter
nx Doc -> Doc
parens) [Element]
es))
Doc -> Doc -> Doc
<> String -> Doc
text ")"
ppElemTypeName nx :: NameConverter
nx brack :: Doc -> Doc
brack e :: Element
e@AnyElem{} =
Doc -> Doc
brack (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Modifier -> (Doc -> Doc) -> Doc -> Doc
ppTypeModifier (Element -> Modifier
elem_modifier Element
e) Doc -> Doc
forall a. a -> a
id (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
String -> Doc
text "AnyElement"
ppElemTypeName nx :: NameConverter
nx brack :: Doc -> Doc
brack e :: Element
e@Text{} =
String -> Doc
text "String"
ppFieldAttribute :: NameConverter -> XName -> Attribute -> Doc
ppFieldAttribute :: NameConverter -> XName -> Attribute -> Doc
ppFieldAttribute nx :: NameConverter
nx t :: XName
t a :: Attribute
a = NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t (Attribute -> XName
attr_name Attribute
a) Doc -> Doc -> Doc
<+> String -> Doc
text "::"
Doc -> Doc -> Doc
<+> (if Attribute -> Bool
attr_required Attribute
a then Doc
empty
else String -> Doc
text "Maybe")
Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx (Attribute -> XName
attr_type Attribute
a)
Doc -> Doc -> Doc
$$ CommentPosition -> Comment -> Doc
ppComment CommentPosition
After (Attribute -> Comment
attr_comment Attribute
a)
ppTypeModifier :: Modifier -> (Doc->Doc) -> Doc -> Doc
ppTypeModifier :: Modifier -> (Doc -> Doc) -> Doc -> Doc
ppTypeModifier Single _ d :: Doc
d = Doc
d
ppTypeModifier Optional k :: Doc -> Doc
k d :: Doc
d = Doc -> Doc
k (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Maybe" Doc -> Doc -> Doc
<+> Doc -> Doc
k Doc
d
ppTypeModifier (Range (Occurs Nothing Nothing)) _ d :: Doc
d = Doc
d
ppTypeModifier (Range (Occurs (Just 0) Nothing)) k :: Doc -> Doc
k d :: Doc
d = Doc -> Doc
k (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text "Maybe" Doc -> Doc -> Doc
<+> Doc -> Doc
k Doc
d
ppTypeModifier (Range (Occurs _ _)) _ d :: Doc
d = String -> Doc
text "[" Doc -> Doc -> Doc
<> Doc
d Doc -> Doc -> Doc
<> String -> Doc
text "]"
ppElemModifier :: Modifier -> Doc -> Doc
ppElemModifier :: Modifier -> Doc -> Doc
ppElemModifier Single doc :: Doc
doc = Doc
doc
ppElemModifier Optional doc :: Doc
doc = String -> Doc
text "optional" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range (Occurs Nothing Nothing)) doc :: Doc
doc = Doc
doc
ppElemModifier (Range (Occurs (Just 0) Nothing)) doc :: Doc
doc = String -> Doc
text "optional"
Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range (Occurs (Just 0) (Just n :: Int
n))) doc :: Doc
doc
| Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
forall a. Bounded a => a
maxBound = String -> Doc
text "many" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range (Occurs Nothing (Just n :: Int
n))) doc :: Doc
doc
| Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
forall a. Bounded a => a
maxBound = String -> Doc
text "many1" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range (Occurs (Just 1) (Just n :: Int
n))) doc :: Doc
doc
| Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
forall a. Bounded a => a
maxBound = String -> Doc
text "many1" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range o :: Occurs
o) doc :: Doc
doc = String -> Doc
text "between" Doc -> Doc -> Doc
<+> (Doc -> Doc
parens (String -> Doc
text (Occurs -> String
forall a. Show a => a -> String
show Occurs
o))
Doc -> Doc -> Doc
$$ Doc -> Doc
parens Doc
doc)
xmlElemModifier :: Modifier -> Doc -> Doc
xmlElemModifier :: Modifier -> Doc -> Doc
xmlElemModifier Single doc :: Doc
doc = Doc
doc
xmlElemModifier Optional doc :: Doc
doc = String -> Doc
text "maybe []" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
xmlElemModifier (Range (Occurs Nothing Nothing)) doc :: Doc
doc = Doc
doc
xmlElemModifier (Range (Occurs (Just 0) Nothing)) doc :: Doc
doc = String -> Doc
text "maybe []"
Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
xmlElemModifier (Range (Occurs _ _)) doc :: Doc
doc = String -> Doc
text "concatMap" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
cleanChoices :: [Element] -> [Element]
cleanChoices :: [Element] -> [Element]
cleanChoices [e :: Element
e@Element{}] = (Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
:[]) (Element -> [Element]) -> Element -> [Element]
forall a b. (a -> b) -> a -> b
$
case Element -> Modifier
elem_modifier Element
e of
Range (Occurs (Just 0) Nothing) -> Element
e{elem_modifier :: Modifier
elem_modifier=Modifier
Single}
Range (Occurs (Just 0) max :: Maybe Int
max)-> Element
e{elem_modifier :: Modifier
elem_modifier=Occurs -> Modifier
Range (Maybe Int -> Maybe Int -> Occurs
Occurs (Int -> Maybe Int
forall a. a -> Maybe a
Just 1) Maybe Int
max)}
_ -> Element
e
cleanChoices es :: [Element]
es = [Element]
es
liftedElemModifier :: Element -> Modifier
liftedElemModifier :: Element -> Modifier
liftedElemModifier e :: Element
e@OneOf{} =
case Element -> Modifier
elem_modifier Element
e of
Range (Occurs Nothing Nothing) -> Modifier
newModifier
Single -> Modifier
newModifier
m :: Modifier
m -> Modifier
m
where
newModifier :: Modifier
newModifier = if (Element -> Bool) -> [Element] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\x :: Element
x-> case Element
x of
Text -> Bool
True
_ -> case Element -> Modifier
elem_modifier Element
x of
Range (Occurs (Just 0) _) -> Bool
True
Optional -> Bool
True
_ -> Bool
False)
([[Element]] -> [Element]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Element -> [[Element]]
elem_oneOf Element
e))
then Modifier
Optional
else Modifier
Single
paragraph :: Int -> String -> String
paragraph :: Int -> String -> String
paragraph n :: Int
n s :: String
s = Int -> [String] -> String
go Int
n (String -> [String]
words String
s)
where go :: Int -> [String] -> String
go i :: Int
i [] = []
go i :: Int
i [x :: String
x] | Int
lenInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
i = String
x
| Bool
otherwise = "\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
x
where len :: Int
len = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x
go i :: Int
i (x :: String
x:xs :: [String]
xs) | Int
lenInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
i = String
xString -> String -> String
forall a. [a] -> [a] -> [a]
++" "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> [String] -> String
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) [String]
xs
| Bool
otherwise = "\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xString -> String -> String
forall a. [a] -> [a] -> [a]
++" "String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> [String] -> String
go (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
lenInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) [String]
xs
where len :: Int
len = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x
uniqueify :: [Element] -> [Element]
uniqueify :: [Element] -> [Element]
uniqueify = [String] -> [Element] -> [Element]
go []
where
go :: [String] -> [Element] -> [Element]
go seen :: [String]
seen [] = []
go seen :: [String]
seen (e :: Element
e@Element{}:es :: [Element]
es)
| XName -> String
forall a. Show a => a -> String
show (Element -> XName
elem_name Element
e) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
seen
= let fresh :: XName
fresh = (String -> Bool) -> XName -> XName
new (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem`[String]
seen) (Element -> XName
elem_name Element
e) in
Element
e{elem_name :: XName
elem_name=XName
fresh} Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [String] -> [Element] -> [Element]
go (XName -> String
forall a. Show a => a -> String
show XName
freshString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
seen) [Element]
es
| Bool
otherwise = Element
eElement -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [String] -> [Element] -> [Element]
go (XName -> String
forall a. Show a => a -> String
show (Element -> XName
elem_name Element
e)String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
seen) [Element]
es
go seen :: [String]
seen (e :: Element
e:es :: [Element]
es) = Element
e Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [String] -> [Element] -> [Element]
go [String]
seen [Element]
es
new :: (String -> Bool) -> XName -> XName
new pred :: String -> Bool
pred (XName (N n :: String
n)) = QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ String -> QName
N (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
(String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile String -> Bool
pred [(String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++Integer -> String
forall a. Show a => a -> String
show Integer
i) | Integer
i <- [2..]]
new pred :: String -> Bool
pred (XName (QN ns :: Namespace
ns n :: String
n)) = QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ Namespace -> String -> QName
QN Namespace
ns (String -> QName) -> String -> QName
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
(String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile String -> Bool
pred [(String
nString -> String -> String
forall a. [a] -> [a] -> [a]
++Integer -> String
forall a. Show a => a -> String
show Integer
i) | Integer
i <- [2..]]