{-# LANGUAGE CPP #-}
-- | Pretty-print the internal Haskell model of XSD datatypes to a
--   Haskell hs-boot module containing only stub type declarations.
--   This approach is intended to work around issues of mutually recursive
--   datatype definitions.
module Text.XML.HaXml.Schema.PrettyHsBoot
  ( 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,catMaybes)

-- | Vertically pretty-print a list of things, with open and close brackets,
--   and separators.
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 CommentPosition = Before | After

-- | Generate aligned haddock-style documentation.
--   (but without escapes in comment text yet)
ppComment :: CommentPosition -> Comment -> Doc
ppComment :: CommentPosition -> Comment -> Doc
ppComment _   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)

-- | Pretty-print a Haskell-style name.
ppHName :: HName -> Doc
ppHName :: HName -> Doc
ppHName (HName x :: String
x) = String -> Doc
text String
x

-- | Pretty-print an XML-style name.
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

-- | Some different ways of using a Haskell identifier.
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

-- | Convert a whole document from HaskellTypeModel to Haskell source text.
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
$$ (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 {-++ module_import_only m-}))
    Doc -> Doc -> Doc
$$ String -> Doc
text " "
    Doc -> Doc -> Doc
$$ NameConverter -> [Decl] -> Doc
ppHighLevelDecls NameConverter
nx (Module -> [Decl]
module_decls Module
m)

-- | Generate a fragmentary parser for an attribute.
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 "<- getAttribute \""
                                       Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Attribute -> XName
attr_name Attribute
a)
                                       Doc -> Doc -> Doc
<> String -> Doc
text "\" e pos"
-- | Generate a fragmentary parser for an element.
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
elem_modifier 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 "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]
e)
    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)

-- | Convert multiple HaskellTypeModel Decls to Haskell source text.
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))

-- | Convert a single Haskell Decl into Haskell source text.
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 "instance Eq" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Show" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    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 "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance SimpleType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t

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 "data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Eq" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Eq" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Show" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Show" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs
    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 "instance Extension"  Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
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"))

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
$$ String -> Doc
text "instance Eq" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Show" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Enum" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    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 "instance SimpleType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t

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 "instance Eq" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Show" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t

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
$$ String -> Doc
text "instance Eq" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Show" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t

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 "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 ()]"


ppHighLevelDecl nx :: NameConverter
nx e :: Decl
e@(ElementAbstractOfType n :: XName
n t :: XName
t substgrp :: [(XName, Maybe XName)]
substgrp comm :: Comment
comm)
    | ((XName, Maybe XName) -> Bool) -> [(XName, Maybe XName)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (XName, Maybe XName) -> Bool
forall a a. (a, Maybe a) -> Bool
notInScope [(XName, Maybe XName)]
substgrp
                = (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 "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 ()]"
    | Bool
otherwise = NameConverter -> Decl -> Doc
ppElementAbstractOfType NameConverter
nx Decl
e
  where
    notInScope :: (a, Maybe a) -> Bool
notInScope (_,Just _)  = Bool
True
    notInScope (_,Nothing) = Bool
False

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
$$ String -> Doc
text "instance Eq" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Show" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t

-- 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 :: NameConverter
nx (Group t :: XName
t es :: [Element]
es comm :: Comment
comm) = Doc
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 :: 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 "-- plus different (more restrictive) parser"
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Eq" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text "instance Show" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    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 "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t

{-
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 "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 :: 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) -- && not (isJust fwdReqd)
        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 [] [] [] []
--  $$ if not (null grandsuper)
--     then vcat (map (ppSuperExtension nx t grandsuper) insts)
--                     -- FIXME some instances are missing!
--     else empty

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 {-# SOURCE #-}" 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 {-# SOURCE #-}" 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

--------------------------------------------------------------------------------

-- | 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 :: NameConverter -> Decl -> Doc
ppHighLevelInstances nx :: NameConverter
nx (ElementsAttrsAbstract t :: XName
t insts :: [(XName, Maybe XName)]
insts comm :: Comment
comm) =
    String -> Doc
text "instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t

ppHighLevelInstances nx :: NameConverter
nx e :: Decl
e@(ElementAbstractOfType n :: XName
n t :: XName
t substgrp :: [(XName, Maybe XName)]
substgrp comm :: Comment
comm)
    | ((XName, Maybe XName) -> Bool) -> [(XName, Maybe XName)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (XName, Maybe XName) -> Bool
forall a a. (a, Maybe a) -> Bool
notInScope [(XName, Maybe XName)]
substgrp = NameConverter -> Decl -> Doc
ppElementAbstractOfType NameConverter
nx Decl
e
    | Bool
otherwise = Doc
empty
  where
    notInScope :: (a, Maybe a) -> Bool
notInScope (_,Just _)  = Bool
True
    notInScope (_,Nothing) = Bool
False

ppHighLevelInstances 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) =
    Doc
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 :: 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
ppHighLevelInstances NameConverter
nx (XName -> [(XName, Maybe XName)] -> Comment -> Decl
ElementsAttrsAbstract XName
t [(XName, Maybe XName)]
insts Comment
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 :: NameConverter -> Decl -> Doc
ppElementAbstractOfType nx :: NameConverter
nx (ElementAbstractOfType n :: XName
n t :: XName
t substgrp :: [(XName, Maybe XName)]
substgrp comm :: Comment
comm) =
    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

--------------------------------------------------------------------------------

-- | 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 :: 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

-- | 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 :: NameConverter -> XName -> [XName] -> (XName, Maybe XName) -> Doc
ppSuperExtension nx :: NameConverter
nx super :: XName
super (grandSuper :: XName
grandSuper:_) (t :: XName
t,Just mod :: XName
mod) =  -- fwddecl
    -- FIXME: generate comment for all of the grandSupers.
    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
grandSuper
    Doc -> Doc -> Doc
$$ String -> Doc
text "--   will be declared in module" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
mod
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

-- | Generate named fields from elements and attributes.
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..]

-- | Generate a single named field from an element.
ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldElement 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)
                                        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 -> 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)
                                        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@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)
                                        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 -> 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)
                                        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

-- | What is the name of the type for an Element (or choice of Elements)?
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
elem_modifier 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 -> [[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"

-- | Generate a single named field from an attribute.
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
<+> 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)

-- | Generate a list or maybe type name (possibly parenthesised).
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 "]"

-- | Generate a parser for a list or Maybe value.
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 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)

-- | Split long lines of comment text into a paragraph with a maximum width.
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: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..]]