{-# LANGUAGE CPP #-}
-- | Pretty-print the internal Haskell model of XSD datatypes to a real
--   Haskell module containing type declarations, and instances for parsing
--   (and printing - though not yet implemented) values of those datatypes
--   from(/to) XML.
module Text.XML.HaXml.Schema.PrettyHaskell
  ( ppComment
  , ppModule
  , ppHighLevelDecl
  , ppHighLevelDecls
  , ppvList
  ) where

#if MIN_VERSION_base(4,11,0)
import Prelude hiding ((<>))
#endif

import Text.XML.HaXml.Types (QName(..),Namespace(..))
import Text.XML.HaXml.Schema.HaskellTypeModel
import Text.XML.HaXml.Schema.XSDTypeModel (Occurs(..))
import Text.XML.HaXml.Schema.NameConversion
import Text.PrettyPrint.HughesPJ as PP

import Data.List (intersperse,notElem,inits)
import Data.Maybe (isJust,fromJust,fromMaybe,catMaybes)
import Data.Char (toLower)

-- | Vertically pretty-print a list of things, with open and close brackets,
--   and separators.
ppvList :: String -> String -> String -> (a->Doc) -> [a] -> Doc
ppvList :: forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
open String
sep String
close a -> Doc
pp []     = String -> Doc
text String
open Doc -> Doc -> Doc
<> String -> Doc
text String
close
ppvList String
open String
sep String
close a -> Doc
pp (a
x:[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 (\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 CommentPosition
_   Comment
Nothing  = Doc
empty
ppComment CommentPosition
pos (Just String
s) = case [String]
ps of
  (String
c:[String]
cs) ->
      String -> Doc
text String
"--" Doc -> Doc -> Doc
<+> String -> Doc
text (case CommentPosition
pos of CommentPosition
Before -> String
"|"; CommentPosition
After -> String
"^") 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 (\String
x-> String -> Doc
text String
"--  " Doc -> Doc -> Doc
<+> String -> Doc
text String
x) [String]
cs)
  [] -> Doc
empty
  where
    ps :: [String]
ps = String -> [String]
lines (Int -> String -> String
paragraph Int
60 String
s)

-- | Generate aligned haddock-style docs for choices (where each choice
--   has its own documentation, but haddock cannot place it directly next
--   to the appropriate component.
ppCommentForChoice :: CommentPosition -> Comment -> [[Element]] -> Doc
ppCommentForChoice :: CommentPosition -> Comment -> [[Element]] -> Doc
ppCommentForChoice CommentPosition
pos Comment
outer [[Element]]
nested =
    String -> Doc
text String
"--" Doc -> Doc -> Doc
<+> String -> Doc
text (case CommentPosition
pos of CommentPosition
Before -> String
"|"; CommentPosition
After -> String
"^") 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 (\String
x-> String -> Doc
text String
"--  " 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 (\String
x-> String -> Doc
text String
"--  " Doc -> Doc -> Doc
<+> String -> Doc
text String
x) [String]
bullets)
  where
    (String
c:[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 String
"Choice between:"
                    (\String
s-> Int -> String -> String
paragraph Int
60 String
sString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"\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 (\Integer
n [String]
seq-> case [String]
seq of
                              [String
x]-> String
"\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 -> String
forall a. [a] -> [a] -> [a]
++Int -> String -> String
paragraph Int
56 String
x
                              [String]
_  -> String
"\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
") 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 (\String
s->String
"\n\n  * "
                                                      String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String -> String
paragraph Int
52 String
s)
                                                 [String]
seq)
                        [Integer
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]]
nested
    safeComment :: Element -> String
safeComment Element
Text = String
"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 Element
e           = String -> Comment -> String
forall a. a -> Maybe a -> a
fromMaybe String
"unknown" (Element -> Comment
elem_comment Element
e)
    xname :: XName -> String
xname (XName (N String
x))     = String
x
    xname (XName (QN Namespace
ns String
x)) = Namespace -> String
nsPrefix Namespace
nsString -> String -> String
forall a. [a] -> [a] -> [a]
++String
":"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
x

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

-- | Pretty-print an XML-style name.
ppXName :: XName -> Doc
ppXName :: XName -> Doc
ppXName (XName (N String
x))     = String -> Doc
text String
x
ppXName (XName (QN Namespace
ns String
x)) = String -> Doc
text (Namespace -> String
nsPrefix Namespace
ns) Doc -> Doc -> Doc
<> String -> Doc
text String
":" 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 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 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 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 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 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 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 NameConverter
nx XName
p XName
q = HName -> Doc
ppHName (NameConverter -> XName -> HName
conid NameConverter
nx XName
p) Doc -> Doc -> Doc
<> String -> Doc
text String
"_" Doc -> Doc -> Doc
<> HName -> Doc
ppHName (NameConverter -> XName -> HName
conid NameConverter
nx XName
q)
ppFieldId :: NameConverter -> XName -> XName -> Doc
ppFieldId   NameConverter
nx 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 NameConverter
nx Module
m =
    String -> Doc
text String
"{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"{-# OPTIONS_GHC -fno-warn-duplicate-exports #-}"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"module" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx (Module -> XName
module_name Module
m)
    Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
2 (String -> Doc
text String
"( 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 XName
ex Comment
com)->
                               CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
com
                               Doc -> Doc -> Doc
$$ String -> Doc
text String
", 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 String
") where")
    Doc -> Doc -> Doc
$$ String -> Doc
text String
" "
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"import Text.XML.HaXml.Schema.Schema (SchemaType(..),SimpleType(..),Extension(..),Restricts(..))"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"import Text.XML.HaXml.Schema.Schema as Schema"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"import Text.XML.HaXml.OneOfN"
    Doc -> Doc -> Doc
$$ (case Module -> Maybe XName
module_xsd_ns Module
m of
         Maybe XName
Nothing -> String -> Doc
text String
"import Text.XML.HaXml.Schema.PrimitiveTypes as Xsd"
         Just XName
ns -> String -> Doc
text String
"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 String
" "
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"-- 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 String
" "
    Doc -> Doc -> Doc
$$ NameConverter -> [Decl] -> Doc
ppHighLevelDecls NameConverter
nx (Module -> [Decl]
module_decls Module
m)

  where
    imports :: Decl -> [(XName, Maybe XName)]
imports (ElementsAttrsAbstract XName
_ [(XName, Maybe XName)]
deps Comment
_) = [(XName, Maybe XName)]
deps
    imports (ExtendComplexTypeAbstract XName
_ XName
_ [(XName, Maybe XName)]
deps Maybe XName
_ [XName]
_ Comment
_) = [(XName, Maybe XName)]
deps
    imports Decl
_ = []

    importElems :: Decl -> [(XName, Maybe XName)]
importElems (ElementAbstractOfType XName
_ XName
_ [(XName, Maybe XName)]
deps Comment
_) = [(XName, Maybe XName)]
deps
    importElems Decl
_ = []

    ppFwdDecl :: (XName, Maybe XName) -> Doc
ppFwdDecl (XName
_,   Maybe XName
Nothing)  = Doc
empty
    ppFwdDecl (XName
name,Just XName
mod) = String -> Doc
text String
"import {-# SOURCE #-}" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
mod
                                Doc -> Doc -> Doc
<+> String -> Doc
text String
"(" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
name Doc -> Doc -> Doc
<+> String -> Doc
text String
")"

    ppFwdElem :: (XName, Maybe XName) -> Doc
ppFwdElem (XName
_,   Maybe XName
Nothing)  = Doc
empty
    ppFwdElem (XName
name,Just XName
mod) = String -> Doc
text String
"import {-# SOURCE #-}" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
mod
                                Doc -> Doc -> Doc
<+> String -> Doc
text String
"("
                                    Doc -> Doc -> Doc
<+> (String -> Doc
text String
"element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
name)
                                    Doc -> Doc -> Doc
<> (String -> Doc
text String
", elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
name)
                                Doc -> Doc -> Doc
<+> String -> Doc
text String
")"


-- | Generate a fragmentary parser for an attribute.
ppAttr :: Attribute -> Int -> Doc
ppAttr :: Attribute -> Int -> Doc
ppAttr Attribute
a Int
n = (String -> Doc
text String
"a"Doc -> Doc -> Doc
<>String -> Doc
text (Int -> String
forall a. Show a => a -> String
show Int
n)) Doc -> Doc -> Doc
<+> String -> Doc
text String
"<-"
                                       Doc -> Doc -> Doc
<+> (if Attribute -> Bool
attr_required Attribute
a then Doc
empty
                                                 else String -> Doc
text String
"optional $")
                                       Doc -> Doc -> Doc
<+> String -> Doc
text String
"getAttribute \""
                                       Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Attribute -> XName
attr_name Attribute
a)
                                       Doc -> Doc -> Doc
<> String -> Doc
text String
"\" e pos"

-- | Generate a fragmentary toXML for an attribute.
toXmlAttr :: Attribute -> Doc
toXmlAttr :: Attribute -> Doc
toXmlAttr Attribute
a = (if Attribute -> Bool
attr_required Attribute
a then Doc -> Doc
forall a. a -> a
id
                                  else (\Doc
d-> String -> Doc
text String
"maybe []" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
d))
              (String -> Doc
text String
"toXMLAttribute \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Attribute -> XName
attr_name Attribute
a) Doc -> Doc -> Doc
<> String -> Doc
text String
"\"")

-- | Generate a fragmentary parser for an element.
ppElem :: NameConverter -> Element -> Doc
ppElem :: NameConverter -> Element -> Doc
ppElem 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 String
"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 String
"parseSchemaType \""
                                        Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Element -> XName
elem_name Element
e)
                                        Doc -> Doc -> Doc
<> String -> Doc
text String
"\"")
ppElem NameConverter
nx e :: Element
e@AnyElem{} = Modifier -> Doc -> Doc
ppElemModifier (Element -> Modifier
elem_modifier Element
e)
                          (String -> Doc
text String
"parseAnyElement")
ppElem NameConverter
nx e :: Element
e@Text{}    = String -> Doc
text String
"parseText"
ppElem NameConverter
nx e :: Element
e@OneOf{}   = Modifier -> Doc -> Doc
ppElemModifier (Element -> Modifier
liftedElemModifier Element
e)
                          (String -> Doc
text String
"oneOf'" Doc -> Doc -> Doc
<+> String
-> String
-> String
-> (([Element], Int) -> Doc)
-> [([Element], Int)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"[" String
"," String
"]"
                                                    (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) [Int
1..Int
n]))
  where
    n :: Int
n = [[Element]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Element -> [[Element]]
elem_oneOf Element
e)
    ppOneOf :: a -> ([Element], Int) -> Doc
ppOneOf a
n ([Element]
e,Int
i) = String -> Doc
text String
"(\"" 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 String
"\","
                      Doc -> Doc -> Doc
<+> String -> Doc
text String
"fmap" Doc -> Doc -> Doc
<+> String -> Doc
text (Int -> String
ordinal Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++String
"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 String
")"
    ordinal :: Int -> String
ordinal Int
i | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
20   = [String]
ordinals[String] -> Int -> String
forall a. HasCallStack => [a] -> Int -> a
!!Int
i
              | Bool
otherwise = String
"Choice" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
    ordinals :: [String]
ordinals = [String
"Zero",String
"One",String
"Two",String
"Three",String
"Four",String
"Five",String
"Six",String
"Seven",String
"Eight"
               ,String
"Nine",String
"Ten",String
"Eleven",String
"Twelve",String
"Thirteen",String
"Fourteen",String
"Fifteen"
               ,String
"Sixteen",String
"Seventeen",String
"Eighteen",String
"Nineteen",String
"Twenty"]
    ppSeqElem :: [Element] -> Doc
ppSeqElem []  = Doc
PP.empty
    ppSeqElem [Element
e] = NameConverter -> Element -> Doc
ppElem NameConverter
nx Element
e
    ppSeqElem [Element]
es  = String -> Doc
text (String
"return ("String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> Char -> String
forall a. Int -> a -> [a]
replicate ([Element] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
esInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Char
','String -> String -> String
forall a. [a] -> [a] -> [a]
++String
")")
                    Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat ((Element -> Doc) -> [Element] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\Element
e-> String -> Doc
text String
"`apply`" Doc -> Doc -> Doc
<+> NameConverter -> Element -> Doc
ppElem NameConverter
nx Element
e) [Element]
es)

-- | Generate a fragmentary toXML for an element.  Fragment must still be
--   applied to an actual element value.
toXmlElem :: NameConverter -> Element -> Doc
toXmlElem :: NameConverter -> Element -> Doc
toXmlElem 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 String
"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 String
"schemaTypeToXML \""
                                        Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Element -> XName
elem_name Element
e)
                                        Doc -> Doc -> Doc
<> String -> Doc
text String
"\"")
toXmlElem NameConverter
nx e :: Element
e@AnyElem{} = Modifier -> Doc -> Doc
xmlElemModifier (Element -> Modifier
elem_modifier Element
e)
                                           (String -> Doc
text String
"toXMLAnyElement")
toXmlElem NameConverter
nx e :: Element
e@Text{}    = String -> Doc
text String
"toXMLText"
toXmlElem NameConverter
nx e :: Element
e@OneOf{}   = Modifier -> Doc -> Doc
xmlElemModifier (Element -> Modifier
liftedElemModifier Element
e)
                           (String -> Doc
text String
"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 String
"" String
"" String
"" [Element] -> Doc
xmlOneOf (Element -> [[Element]]
elem_oneOf Element
e))
  where
    n :: Int
n = [[Element]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Element -> [[Element]]
elem_oneOf Element
e)
    xmlOneOf :: [Element] -> Doc
xmlOneOf [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 [Element
e] = NameConverter -> Element -> Doc
toXmlElem NameConverter
nx Element
e
    xmlSeqElem [Element]
es  = String -> Doc
text String
"\\ (" Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
",") [Doc]
vars)
                     Doc -> Doc -> Doc
<> String -> Doc
text String
") -> concat"
                     Doc -> Doc -> Doc
<+> String
-> String
-> String
-> ((Element, Doc) -> Doc)
-> [(Element, Doc)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"[" String
"," String
"]" (\(Element
e,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 a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Element]
es) (String -> [Doc]) -> String -> [Doc]
forall a b. (a -> b) -> a -> b
$ [Char
'a'..Char
'z']

-- | Convert multiple HaskellTypeModel Decls to Haskell source text.
ppHighLevelDecls :: NameConverter -> [Decl] -> Doc
ppHighLevelDecls :: NameConverter -> [Decl] -> Doc
ppHighLevelDecls NameConverter
nx [Decl]
hs = [Doc] -> Doc
vcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
" ")
                                           ((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 NameConverter
nx (NamedSimpleType XName
t XName
s Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"type" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
s
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"-- No instances required: synonym is isomorphic to the original."

ppHighLevelDecl NameConverter
nx (RestrictSimpleType XName
t XName
s [Restrict]
r Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"newtype" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
                      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 String
"deriving (Eq,Show)"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"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 String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"restricts (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"x) = x")
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"parseSchemaType s = do"
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"e <- element [s]"
                           Doc -> Doc -> Doc
$$ String -> Doc
text String
"commit $ interior e $ parseSimpleType")
                  )
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"schemaTypeToXML s ("Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"x) = "
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"toXMLElement s [] [toXMLText (simpleTypeText x)]")
                  )
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"instance SimpleType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"acceptingParser = fmap" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
                                                 Doc -> Doc -> Doc
<+> String -> Doc
text String
"acceptingParser"
                   -- XXX should enforce the restrictions somehow.  (?)
                   Doc -> Doc -> Doc
$$ String -> Doc
text String
"-- XXX should enforce the restrictions somehow?"
                   Doc -> Doc -> Doc
$$ String -> Doc
text String
"-- The restrictions are:"
                   Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((Restrict -> Doc) -> [Restrict] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> Doc
text String
"--     " 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 Int
4 (String -> Doc
text String
"simpleTypeText (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
                                          Doc -> Doc -> Doc
<+> String -> Doc
text String
"x) = simpleTypeText x")
  where
    ppRestrict :: Restrict -> Doc
ppRestrict (RangeR Occurs
occ Comment
comm)     = String -> Doc
text String
"(RangeR"
                                         Doc -> Doc -> Doc
<+> Occurs -> Doc
ppOccurs Occurs
occ Doc -> Doc -> Doc
<>  String -> Doc
text String
")"
    ppRestrict (Pattern String
regexp Comment
comm) = String -> Doc
text (String
"(Pattern "String -> String -> String
forall a. [a] -> [a] -> [a]
++String
regexpString -> String -> String
forall a. [a] -> [a] -> [a]
++String
")")
    ppRestrict (Enumeration [(String, Comment)]
items)   = String -> Doc
text String
"(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 String
")"
    ppRestrict (StrLength Occurs
occ Comment
comm)  = String -> Doc
text String
"(StrLength"
                                         Doc -> Doc -> Doc
<+> Occurs -> Doc
ppOccurs Occurs
occ Doc -> Doc -> Doc
<>  String -> Doc
text String
")"
    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 NameConverter
nx (ExtendSimpleType XName
t XName
s [Attribute]
as Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
                                    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 String
"deriving (Eq,Show)"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (NameConverter -> XName -> [Element] -> [Attribute] -> Doc
ppFields NameConverter
nx XName
t_attrs [] [Attribute]
as
                  Doc -> Doc -> Doc
$$ String -> Doc
text String
"deriving (Eq,Show)")
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"parseSchemaType s = do"
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"(pos,e) <- posnElement [s]"
                            Doc -> Doc -> Doc
$$ String -> Doc
text String
"commit $ do"
                            Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
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 [Int
0..])
                                  Doc -> Doc -> Doc
$$ String -> Doc
text String
"reparse [CElem e pos]"
                                  Doc -> Doc -> Doc
$$ String -> Doc
text String
"v <- parseSchemaType s"
                                  Doc -> Doc -> Doc
$$ String -> Doc
text String
"return $" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
                                                     Doc -> Doc -> Doc
<+> String -> Doc
text String
"v"
                                                     Doc -> Doc -> Doc
<+> [Attribute] -> Doc
forall {a}. [a] -> Doc
attrsValue [Attribute]
as)
                            )
                  )
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"schemaTypeToXML s ("Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
                                             Doc -> Doc -> Doc
<+> String -> Doc
text String
"bt at) ="
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"addXMLAttributes"
                             Doc -> Doc -> Doc
<+> String
-> String -> String -> (Attribute -> Doc) -> [Attribute] -> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"[" String
"," String
"]"
                                     (\Attribute
a-> Attribute -> Doc
toXmlAttr Attribute
a Doc -> Doc -> Doc
<+> String -> Doc
text String
"$"
                                         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 String
"at")
                                     [Attribute]
as
                             Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"$ schemaTypeToXML s bt"))
                  )
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"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 String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"supertype (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text String
" s _) = s")
  where
    t_attrs :: XName
t_attrs = let (XName (N String
t_base)) = XName
t in QName -> XName
XName (String -> QName
N (String
t_baseString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"Attributes"))

    attrsValue :: [a] -> Doc
attrsValue [] = NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs
    attrsValue [a]
as = Doc -> Doc
parens (NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t_attrs Doc -> Doc -> Doc
<+>
                            [Doc] -> Doc
hsep [String -> Doc
text (String
"a"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
n) | Int
n <- [Int
0..[a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
asInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]])

    -- do element [s]
    --    blah <- attribute foo
    --    interior e $ do
    --        simple <- parseText acceptingParser
    --        return (T simple blah)

ppHighLevelDecl NameConverter
nx (UnionSimpleTypes XName
t [XName]
sts Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"-- Placeholder for a Union type, not yet implemented."

ppHighLevelDecl NameConverter
nx (EnumSimpleType XName
t [] Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
ppHighLevelDecl NameConverter
nx (EnumSimpleType XName
t [(XName, Comment)]
is Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 ( String
-> String
-> String
-> ((XName, Comment) -> Doc)
-> [(XName, Comment)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"=" String
"|" String
"deriving (Eq,Show,Enum)" (XName, Comment) -> Doc
item [(XName, Comment)]
is )
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"parseSchemaType s = do"
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"e <- element [s]"
                           Doc -> Doc -> Doc
$$ String -> Doc
text String
"commit $ interior e $ parseSimpleType")
                  )
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"schemaTypeToXML s x = "
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"toXMLElement s [] [toXMLText (simpleTypeText x)]")
                  )
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"instance SimpleType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"acceptingParser ="
                        Doc -> Doc -> Doc
<+> String
-> String
-> String
-> ((XName, Comment) -> Doc)
-> [(XName, Comment)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"" String
"`onFail`" String
"" (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 (XName
i,Comment
c) = (NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text String
"_" 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 (XName
i,b
_) = String -> Doc
text String
"do literal \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
i Doc -> Doc -> Doc
<> String -> Doc
text String
"\"; return"
                           Doc -> Doc -> Doc
<+> (NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text String
"_" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
i)
    enumText :: (XName, b) -> Doc
enumText  (XName
i,b
_) = String -> Doc
text String
"simpleTypeText"
                           Doc -> Doc -> Doc
<+> (NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text String
"_" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
i)
                           Doc -> Doc -> Doc
<+> String -> Doc
text String
"= \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
i Doc -> Doc -> Doc
<> String -> Doc
text String
"\""

ppHighLevelDecl NameConverter
nx (ElementsAttrs XName
t [Element]
es [Attribute]
as Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
8 (NameConverter -> XName -> [Element] -> [Attribute] -> Doc
ppFields NameConverter
nx XName
t ([Element] -> [Element]
uniqueify [Element]
es) [Attribute]
as
                  Doc -> Doc -> Doc
$$ String -> Doc
text String
"deriving (Eq,Show)")
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"parseSchemaType s = do"
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"(pos,e) <- posnElement [s]"
                       --   $$ text "commit $ do"
                       --   $$ nest 2
                            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 [Int
0..])
                                  Doc -> Doc -> Doc
$$ String -> Doc
text String
"commit $ interior e $ return"
                                      Doc -> Doc -> Doc
<+> [Attribute] -> Doc
forall {a}. [a] -> Doc
returnValue [Attribute]
as
                                      Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
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 Int
4 (String -> Doc
text String
"schemaTypeToXML s x@"Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<> String -> Doc
text String
"{} ="
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"toXMLElement s"
                             Doc -> Doc -> Doc
<+> String
-> String -> String -> (Attribute -> Doc) -> [Attribute] -> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"[" String
"," String
"]"
                                         (\Attribute
a-> Attribute -> Doc
toXmlAttr Attribute
a Doc -> Doc -> Doc
<+> String -> Doc
text String
"$"
                                               Doc -> Doc -> Doc
<+> NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t (Attribute -> XName
attr_name Attribute
a)
                                               Doc -> Doc -> Doc
<+> String -> Doc
text String
"x")
                                         [Attribute]
as
                             Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String
-> String
-> String
-> ((Element, Int) -> Doc)
-> [(Element, Int)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"[" String
"," String
"]"
                                           (\ (Element
e,Int
i)-> NameConverter -> Element -> Doc
toXmlElem NameConverter
nx Element
e
                                                      Doc -> Doc -> Doc
<+> String -> Doc
text String
"$"
                                                      Doc -> Doc -> Doc
<+> NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
                                                      Doc -> Doc -> Doc
<+> String -> Doc
text String
"x")
                                           ([Element] -> [Int] -> [(Element, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Element]
es [Int
0..]))
                            )
                  )
  where
    returnValue :: [a] -> Doc
returnValue [] = NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    returnValue [a]
as = Doc -> Doc
parens (NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+>
                             [Doc] -> Doc
hsep [String -> Doc
text (String
"a"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
n) | Int
n <- [Int
0..[a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
asInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]])
    ppApplyElem :: Element -> Doc
ppApplyElem Element
e = String -> Doc
text String
"`apply`" Doc -> Doc -> Doc
<+> NameConverter -> Element -> Doc
ppElem NameConverter
nx Element
e

ppHighLevelDecl NameConverter
nx (ElementsAttrsAbstract XName
t [] Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"--  (There are no subtypes defined for this abstract type.)"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"=" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
                   Doc -> Doc -> Doc
<+> String -> Doc
text String
"deriving (Eq,Show)"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"parseSchemaType s = fail" Doc -> Doc -> Doc
<+> Doc
errmsg)
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"schemaTypeToXML s _ = toXMLElement s [] []")
  where
    errmsg :: Doc
errmsg = String -> Doc
text String
"\"Parse failed when expecting an extension type of"
             Doc -> Doc -> Doc
<+> XName -> Doc
ppXName XName
t Doc -> Doc -> Doc
<> String -> Doc
text String
":\\n  No extension types are known.\""
ppHighLevelDecl NameConverter
nx (ElementsAttrsAbstract XName
t [(XName, Maybe XName)]
insts Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
8 (String
-> String
-> String
-> ((XName, Maybe XName) -> Doc)
-> [(XName, Maybe XName)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"=" String
"|" String
"" (XName, Maybe XName) -> Doc
forall {a}. (XName, Maybe a) -> Doc
ppAbstrCons [(XName, Maybe XName)]
insts
                  Doc -> Doc -> Doc
$$ String -> Doc
text String
"deriving (Eq,Show)")
--  $$ text "-- instance SchemaType" <+> ppUnqConId nx t
--      <+> text "(declared in Instance module)"
--  *** Declare instance here
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"parseSchemaType s = do"
                  Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 ([Doc] -> Doc
vcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
"`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 String
"`onFail` fail" Doc -> Doc -> Doc
<+> Doc
errmsg])))
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
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))
--  $$ text ""
--  $$ vcat (map ppFwdDecl $ filter (isJust . snd) insts)
  where
    ppAbstrCons :: (XName, Maybe a) -> Doc
ppAbstrCons (XName
name,Maybe a
Nothing)  = XName -> Doc
con XName
name Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
name
    ppAbstrCons (XName
name,Just a
mod) = XName -> Doc
con XName
name Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
name
--  *** Declare FwdDecl type here (proxy for type declared in later module)
--  ppAbstrCons (name,Just mod) = text "forall q . (FwdDecl" <+>
--                                fwd name <+> text "q," <+>
--                                text "SchemaType q) =>" <+>
--                                con name <+>
--                                text "("<>fwd name<>text"->q)" <+> fwd name
    ppParse :: (XName, Maybe a) -> Doc
ppParse (XName
name,Maybe a
Nothing) = String -> Doc
text String
"(fmap" Doc -> Doc -> Doc
<+> XName -> Doc
con XName
name Doc -> Doc -> Doc
<+>
                             String -> Doc
text String
"$ parseSchemaType s)"
    ppParse (XName
name,Just a
_)  = (XName, Maybe a) -> Doc
ppParse (XName
name,Maybe a
forall a. Maybe a
Nothing)
--  ppParse (name,Just _)  = text "(return" <+> con name <+>
--                           text "`apply` (fmap const $ parseSchemaType s)" <+>
--                           text "`apply` return" <+> fwd name <> text ")"
--  ppFwdDecl (name,Just mod)
--         = text "-- | Proxy:" <+> ppConId nx name
--               <+> text "declared later in" <+> ppModId nx mod
--           $$ text "data" <+> fwd name <+> text "=" <+> fwd name
    errmsg :: Doc
errmsg = String -> Doc
text String
"\"Parse failed when expecting an extension type of"
             Doc -> Doc -> Doc
<+> XName -> Doc
ppXName XName
t Doc -> Doc -> Doc
<> String -> Doc
text String
",\\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 String
",")
                                  (((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 String
"\""
--  fwd name = ppFwdConId nx name
    con :: XName -> Doc
con XName
name = NameConverter -> XName -> XName -> Doc
ppJoinConId NameConverter
nx XName
t XName
name
    -- This is probably an unportable hack, but because an abstract type never
    -- has an element in its own name, we need to guess at the name of the
    -- possible subtype elements that could substitute for it.
    toXML :: (XName, b) -> Doc
toXML (XName
name,b
_) = String -> Doc
text String
"schemaTypeToXML _s ("
                     Doc -> Doc -> Doc
<> XName -> Doc
con XName
name Doc -> Doc -> Doc
<+> String -> Doc
text String
"x) = schemaTypeToXML \""
                     Doc -> Doc -> Doc
<> XName -> Doc
ppXName (XName -> XName
initLower XName
name) Doc -> Doc -> Doc
<> String -> Doc
text String
"\" x"
    initLower :: XName -> XName
initLower (XName (N (Char
c: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 Namespace
ns (Char
c: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 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 String
"element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e)) Doc -> Doc -> Doc
<+> String -> Doc
text String
"::"
        Doc -> Doc -> Doc
<+> String -> Doc
text String
"XMLParser" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx (Element -> XName
elem_type Element
e)
    Doc -> Doc -> Doc
$$ (String -> Doc
text String
"element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e)) Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
        Doc -> Doc -> Doc
<+> (String -> Doc
text String
"parseSchemaType \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Element -> XName
elem_name Element
e)  Doc -> Doc -> Doc
<> String -> Doc
text String
"\"")
    Doc -> Doc -> Doc
$$ (String -> Doc
text String
"elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e)) Doc -> Doc -> Doc
<+> String -> Doc
text String
"::"
        Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx (Element -> XName
elem_type Element
e) Doc -> Doc -> Doc
<+> String -> Doc
text String
"-> [Content ()]"
    Doc -> Doc -> Doc
$$ (String -> Doc
text String
"elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx (Element -> XName
elem_name Element
e)) Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
        Doc -> Doc -> Doc
<+> (String -> Doc
text String
"schemaTypeToXML \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName (Element -> XName
elem_name Element
e)  Doc -> Doc -> Doc
<> String -> Doc
text String
"\"")

ppHighLevelDecl NameConverter
nx e :: Decl
e@(ElementAbstractOfType XName
n XName
t [] Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"--  (There are no elements in any substitution group for this element.)"
    Doc -> Doc -> Doc
$$ (String -> Doc
text String
"element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"::"
        Doc -> Doc -> Doc
<+> String -> Doc
text String
"XMLParser" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
$$ (String -> Doc
text String
"element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
        Doc -> Doc -> Doc
<+> String -> Doc
text String
"fail" Doc -> Doc -> Doc
<+> Doc
errmsg
    Doc -> Doc -> Doc
$$ (String -> Doc
text String
"elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"::"
        Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"-> [Content ()]"
    Doc -> Doc -> Doc
$$ (String -> Doc
text String
"elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
        Doc -> Doc -> Doc
<+> (String -> Doc
text String
"schemaTypeToXML \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\"")
  where
    errmsg :: Doc
errmsg = String -> Doc
text String
"\"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 String
">,\\n\\\n\\  There are no substitutable elements.\""
ppHighLevelDecl NameConverter
nx e :: Decl
e@(ElementAbstractOfType XName
n XName
t [(XName, Maybe XName)]
substgrp Comment
comm)
--  | any notInScope substgrp
--              = (text "-- element" <> ppUnqConId nx n) <+> text "::"
--                    <+> text "XMLParser" <+> ppConId nx t
--              $$ text "--     declared in Instances module"
{-  | otherwise-} = CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
                Doc -> Doc -> Doc
$$ (String -> Doc
text String
"element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"::"
                    Doc -> Doc -> Doc
<+> String -> Doc
text String
"XMLParser" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t
                Doc -> Doc -> Doc
$$ (String -> Doc
text String
"element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
                   Doc -> Doc -> Doc
<+> [Doc] -> Doc
vcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
"`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 String
"`onFail` fail" Doc -> Doc -> Doc
<+> Doc
errmsg])
                Doc -> Doc -> Doc
$$ (String -> Doc
text String
"elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"::"
                    Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"-> [Content ()]"
                Doc -> Doc -> Doc
$$ (String -> Doc
text String
"elementToXML" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
n) Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
                    Doc -> Doc -> Doc
<+> (String -> Doc
text String
"schemaTypeToXML \"" Doc -> Doc -> Doc
<> XName -> Doc
ppXName XName
n Doc -> Doc -> Doc
<> String -> Doc
text String
"\"")
            --  $$ vcat (map elementToXML substgrp)
--  | otherwise = ppElementAbstractOfType nx e
  where
    notInScope :: (a, Maybe a) -> Bool
notInScope (a
_,Just a
_)  = Bool
True
    notInScope (a
_,Maybe a
Nothing) = Bool
False
    ppOne :: (XName, Maybe a) -> Doc
ppOne (XName
c,Maybe a
Nothing) = String -> Doc
text String
"fmap" Doc -> Doc -> Doc
<+> String -> Doc
text String
"supertype" -- ppJoinConId nx t c
                        Doc -> Doc -> Doc
<+> (String -> Doc
text String
"element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
c)
    ppOne (XName
c,Just a
_)  = String -> Doc
text String
"fmap" Doc -> Doc -> Doc
<+> String -> Doc
text String
"supertype" -- ppJoinConId nx t c
                        Doc -> Doc -> Doc
<+> (String -> Doc
text String
"element" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
c)
                        Doc -> Doc -> Doc
<+> String -> Doc
text String
"-- FIXME: element is forward-declared"
    errmsg :: Doc
errmsg = String -> Doc
text String
"\"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 String
">,\\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 String
">, <")
                                  (((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 String
">\""
--  elementToXML (c,_) = (text "elementToXML" <> ppUnqConId nx n)
--                       <+> text "(" <> ppJoinConId nx t c
--                       <+> text " x) = elementToXML" <> ppUnqConId nx c
--                       <+> text "x"


ppHighLevelDecl NameConverter
nx (Choice XName
t [Element]
es Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"data" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
        Doc -> Doc -> Doc
<+> Int -> Doc -> Doc
nest Int
4 ( String
-> String
-> String
-> ((Element, Integer) -> Doc)
-> [(Element, Integer)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"=" String
"|" String
"" (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 [Integer
1..])
                   Doc -> Doc -> Doc
$$ String -> Doc
text String
"deriving (Eq,Show)" )
  where
    choices :: (Element, a) -> Doc
choices (Element
e,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)

-- 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 NameConverter
nx (Group XName
t [Element]
es 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 NameConverter
nx (RestrictComplexType XName
t XName
s Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
Before Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"newtype" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
                                       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 String
"deriving (Eq,Show)"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"-- plus different (more restrictive) parser"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"-- (parsing restrictions currently unimplemented)"
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"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 String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"restricts (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"x) = x")
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"instance SchemaType" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"parseSchemaType = fmap " Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+>
                   String -> Doc
text String
". parseSchemaType")
                -- XXX should enforce the restriction.
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"schemaTypeToXML s (" Doc -> Doc -> Doc
<> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t Doc -> Doc -> Doc
<+> String -> Doc
text String
"x)")
                   Doc -> Doc -> Doc
<+> String -> Doc
text String
"= schemaTypeToXML s x"

{-
ppHighLevelDecl nx (ExtendComplexType t s es as _ comm)
    | length es + length as = 1 =
    ppComment Before comm
    $$ text "data" <+> ppConId nx t <+> text "="
                                    <+> ppConId nx t <+> ppConId nx s
                                    <+> ppFields nx t es as
                                    <+> text "deriving (Eq,Show)"
    $$ text "instance Extension" <+> ppConId nx t <+> ppConId nx s
                                 <+> ppAuxConId nx t <+> text "where"
        $$ nest 4 (text "supertype (" <> ppConId nx t <> text " s e) = s"
                   $$ text "extension (" <> ppConId nx t <> text " s e) = e")
-}

ppHighLevelDecl NameConverter
nx (ExtendComplexType XName
t XName
s [Element]
oes [Attribute]
oas [Element]
es [Attribute]
as
                                      Maybe XName
fwdReqd Bool
absSup [XName]
grandsuper 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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [XName]
grandsuper) -- && not (isJust fwdReqd) -- && 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 NameConverter
nx (ExtendComplexTypeAbstract XName
t XName
s [(XName, Maybe XName)]
insts
                                              Maybe XName
fwdReqd [XName]
grandsuper 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 NameConverter
nx (XSDInclude XName
m Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
After Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"import" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppModId NameConverter
nx XName
m

ppHighLevelDecl NameConverter
nx (XSDImport XName
m Maybe XName
ma Comment
comm) =
    CommentPosition -> Comment -> Doc
ppComment CommentPosition
After Comment
comm
    Doc -> Doc -> Doc
$$ String -> Doc
text String
"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 (\XName
a->String -> Doc
text String
"as"Doc -> Doc -> Doc
<+>NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
a) Maybe XName
ma

ppHighLevelDecl NameConverter
nx (XSDComment 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 nx (ElementsAttrsAbstract t insts comm) =
    text "instance SchemaType" <+> ppUnqConId nx t <+> text "where"
        $$ nest 4 (text "parseSchemaType s = do"
                  $$ nest 4 (vcat (intersperse (text "`onFail`")
                                               (map ppParse insts)
                                   ++ [text "`onFail` fail" <+> errmsg])))
  where
    ppParse (name,Nothing) = text "(fmap" <+> con name <+>
                             text "$ parseSchemaType s)"
    ppParse (name,Just _)  = text "(return" <+> con name <+>
                             text "`apply` (fmap const $ parseSchemaType s)" <+>
                             text "`apply` return" <+> fwd name <> text ")"
    errmsg = text "\"Parse failed when expecting an extension type of"
             <+> ppXName t <> text ",\\n\\\n\\  namely one of:\\n\\\n\\"
             <> hcat (intersperse (text ",")
                                  (map (ppXName . fst) insts))
             <> text "\""
    fwd name = ppFwdConId nx name
    con name = ppJoinConId nx t name

ppHighLevelInstances nx e@(ElementAbstractOfType n t substgrp comm)
    | any notInScope substgrp = ppElementAbstractOfType nx e
    | otherwise = empty
  where
    notInScope (_,Just _)  = True
    notInScope (_,Nothing) = False

ppHighLevelInstances nx (ExtendComplexType t s oes oas es as
                                      fwdReqd absSup grandsuper comm) =
    empty
--  ppExtension nx t s fwdReqd absSup oes oas es as
--  $$ (if not (null grandsuper) && isJust fwdReqd
--      then ppSuperExtension nx s grandsuper (t,Nothing)
--      else empty)

ppHighLevelInstances nx (ExtendComplexTypeAbstract t s insts
                                                   fwdReqd grandsuper comm) =
    ppHighLevelInstances nx (ElementsAttrsAbstract t insts comm)
--  $$ ppExtension nx t s fwdReqd True [] [] [] []
--  $$ if not (null grandsuper)
--     then vcat (map (ppSuperExtension nx t grandsuper) insts)
--                     -- FIXME some instances are missing!
--     else empty


ppElementAbstractOfType nx (ElementAbstractOfType n t substgrp comm) =
    ppComment Before comm
    $$ (text "element" <> ppUnqConId nx n) <+> text "::"
        <+> text "XMLParser" <+> ppConId nx t
    $$ (text "element" <> ppUnqConId nx n) <+> text "="
       <+> vcat (intersperse (text "`onFail`") (map ppOne substgrp)
                 ++ [text "`onFail` fail" <+> errmsg])
  where
    ppOne (c,Nothing) = text "fmap" <+> text "supertype" -- ppJoinConId nx t c
                        <+> (text "element" <> ppConId nx c)
    ppOne (c,Just _)  = text "fmap" <+> text "supertype" -- ppJoinConId nx t c
                        <+> (text "element" <> ppConId nx c)
                        <+> text "-- FIXME: element is forward-declared"
    errmsg = text "\"Parse failed when expecting an element in the substitution group for\\n\\\n\\    <"
             <> ppXName n <> text ">,\\n\\\n\\  namely one of:\\n\\\n\\<"
             <> hcat (intersperse (text ">, <")
                                  (map (ppXName . fst) substgrp))
             <> text ">\""

----------------------------------------------------------------------------- -}

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

-- | Generate an instance of the Extension class for a subtype/supertype pair.
ppExtension :: NameConverter -> XName -> XName -> Maybe XName -> Bool ->
               [Element] -> [Attribute] -> [Element] -> [Attribute] -> Doc
ppExtension :: NameConverter
-> XName
-> XName
-> Maybe XName
-> Bool
-> [Element]
-> [Attribute]
-> [Element]
-> [Attribute]
-> Doc
ppExtension NameConverter
nx XName
t XName
s Maybe XName
fwdReqd Bool
abstractSuper [Element]
oes [Attribute]
oas [Element]
es [Attribute]
as =
    String -> Doc
text String
"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 String
"where"
       Doc -> Doc -> Doc
$$ (if Bool
abstractSuper then
           Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"supertype v" Doc -> Doc -> Doc
<+> String -> Doc
text String
"="
                                      Doc -> Doc -> Doc
<+> NameConverter -> XName -> XName -> Doc
ppJoinConId NameConverter
nx XName
s XName
t Doc -> Doc -> Doc
<+>
                                 --   (if isJust fwdReqd
                                 --    then text "(\\_-> v)" <+> ppFwdConId nx t
                                 --    else text "v")
                                      String -> Doc
text String
"v")
           else
           Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"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 String
") ="
                                      Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
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) ))
--  $$ (if isJust fwdReqd then
--     -- text "data" <+> fwd t <+> text "=" <+> fwd t $$  -- already defined
--        text ""
--        $$ text "-- | Proxy" <+> fwd t <+> text "was declared earlier in"
--                   <+> ppModId nx (fromJust fwdReqd)
--        $$ text "instance FwdDecl" <+> fwd t <+> ppConId nx t
--      else empty)
  where
    fwd :: XName -> Doc
fwd XName
name = NameConverter -> XName -> Doc
ppFwdConId NameConverter
nx XName
name
    ppType :: XName -> t a -> t a -> Doc
ppType XName
t t a
es 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 a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
as) [String -> Doc
text (Char
'a'Char -> String -> String
forall a. a -> [a] -> [a]
:Integer -> String
forall a. Show a => a -> String
show Integer
n) | Integer
n<-[Integer
0..]])
                     Doc -> Doc -> Doc
<+> [Doc] -> Doc
hsep (Int -> [Doc] -> [Doc]
forall a. Int -> [a] -> [a]
take (t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
es) [String -> Doc
text (Char
'e'Char -> String -> String
forall a. a -> [a] -> [a]
:Integer -> String
forall a. Show a => a -> String
show Integer
n) | Integer
n<-[Integer
0..]])

-- | Generate an instance of the Extension class for a type and its
--   "grand"-supertype, that is, the supertype of its supertype.
ppSuperExtension :: NameConverter -> XName -> [XName]
                    -> (XName,Maybe XName) -> Doc
{-
ppSuperExtension nx super (grandSuper:_) (t,Nothing) =
    text "instance Extension" <+> ppUnqConId nx t <+> ppConId nx grandSuper
                              <+> text "where"
    $$ nest 4 (text "supertype = (supertype ::"
                                           <+> ppUnqConId nx super
                                           <+> text "->"
                                           <+> ppConId nx grandSuper <> text ")"
              $$ nest 12 (text ". (supertype ::"
                                           <+> ppUnqConId nx t
                                           <+> text "->"
                                           <+> ppConId nx super <> text ")"))
-}
ppSuperExtension :: NameConverter -> XName -> [XName] -> (XName, Maybe XName) -> Doc
ppSuperExtension NameConverter
nx XName
super [XName]
grandSupers (XName
t,Just XName
mod) =  -- fwddecl
    String -> Doc
text String
"-- Note that" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
t
    Doc -> Doc -> Doc
<+> String -> Doc
text String
"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 NameConverter
nx XName
super [XName]
grandSupers (XName
t,Maybe XName
Nothing) =
    [Doc] -> Doc
vcat (([XName] -> Doc) -> [[XName]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (XName -> [XName] -> Doc
ppSuper XName
t ([XName] -> Doc) -> ([XName] -> [XName]) -> [XName] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [XName] -> [XName]
forall a. [a] -> [a]
reverse) (Int -> [[XName]] -> [[XName]]
forall a. Int -> [a] -> [a]
drop Int
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 XName
t gss :: [XName]
gss@(XName
gs:[XName]
_) =
        String -> Doc
text String
"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 String
"where"
        Doc -> Doc -> Doc
$$ Int -> Doc -> Doc
nest Int
4 (String -> Doc
text String
"supertype" Doc -> Doc -> Doc
<+>
                      String
-> String
-> String
-> ((XName, XName) -> Doc)
-> [(XName, XName)]
-> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"=" String
"." String
"" (XName, XName) -> Doc
coerce ([XName] -> [XName] -> [(XName, XName)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([XName] -> [XName]
forall a. HasCallStack => [a] -> [a]
tail [XName]
gss[XName] -> [XName] -> [XName]
forall a. [a] -> [a] -> [a]
++[XName
t]) [XName]
gss))
    coerce :: (XName, XName) -> Doc
coerce (XName
a,XName
b) = String -> Doc
text String
"(supertype ::" Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppUnqConId NameConverter
nx XName
a
                                        Doc -> Doc -> Doc
<+> String -> Doc
text String
"->"
                                        Doc -> Doc -> Doc
<+> NameConverter -> XName -> Doc
ppConId NameConverter
nx XName
b Doc -> Doc -> Doc
<> String -> Doc
text String
")"

-- | Generate named fields from elements and attributes.
ppFields :: NameConverter -> XName -> [Element] -> [Attribute] -> Doc
ppFields :: NameConverter -> XName -> [Element] -> [Attribute] -> Doc
ppFields NameConverter
nx XName
t [Element]
es [Attribute]
as | [Element] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
es Bool -> Bool -> Bool
&& [Attribute] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Attribute]
as = Doc
empty
ppFields NameConverter
nx XName
t [Element]
es [Attribute]
as =  String -> String -> String -> (Doc -> Doc) -> [Doc] -> Doc
forall a. String -> String -> String -> (a -> Doc) -> [a] -> Doc
ppvList String
"{" String
"," String
"}" 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 [Int
0..]

-- | Generate a single named field (including type sig) from an element.
ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldElement :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldElement NameConverter
nx XName
t e :: Element
e@Element{} Int
i = NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
                                    Doc -> Doc -> Doc
<+> String -> Doc
text String
"::" 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 NameConverter
nx XName
t e :: Element
e@OneOf{}   Int
i = NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
                                    Doc -> Doc -> Doc
<+> String -> Doc
text String
"::" 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 NameConverter
nx XName
t e :: Element
e@AnyElem{} Int
i = NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
                                    Doc -> Doc -> Doc
<+> String -> Doc
text String
"::" 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 NameConverter
nx XName
t e :: Element
e@Text{}    Int
i = NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t Element
e Int
i
                                    Doc -> Doc -> Doc
<+> String -> Doc
text String
"::" Doc -> Doc -> Doc
<+> NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName NameConverter
nx Doc -> Doc
forall a. a -> a
id Element
e

-- | Generate a single named field (no type sig) from an element.
ppFieldName :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldName :: NameConverter -> XName -> Element -> Int -> Doc
ppFieldName NameConverter
nx XName
t e :: Element
e@Element{} Int
_ = NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t (Element -> XName
elem_name Element
e)
ppFieldName NameConverter
nx XName
t e :: Element
e@OneOf{}   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
$ String
"choice"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i)
ppFieldName NameConverter
nx XName
t e :: Element
e@AnyElem{} 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
$ String
"any"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i)
ppFieldName NameConverter
nx XName
t e :: Element
e@Text{}    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
$ String
"text"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
show Int
i)

-- | 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 NameConverter
nx 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 NameConverter
nx 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 String
"OneOf" Doc -> Doc -> Doc
<> String -> Doc
text (Int -> String
forall a. Show a => a -> String
show ([[Element]] -> Int
forall a. [a] -> 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 String
"()"
    ppSeq [Element
e] = NameConverter -> (Doc -> Doc) -> Element -> Doc
ppElemTypeName NameConverter
nx Doc -> Doc
parens Element
e
    ppSeq [Element]
es  = String -> Doc
text String
"(" Doc -> Doc -> Doc
<> [Doc] -> Doc
hcat (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
intersperse (String -> Doc
text String
",")
                                     ((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 String
")"
ppElemTypeName NameConverter
nx 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 String
"AnyElement"
ppElemTypeName NameConverter
nx Doc -> Doc
brack e :: Element
e@Text{} =
    String -> Doc
text String
"String"

-- | Generate a single named field from an attribute.
ppFieldAttribute :: NameConverter -> XName -> Attribute -> Doc
ppFieldAttribute :: NameConverter -> XName -> Attribute -> Doc
ppFieldAttribute NameConverter
nx XName
t Attribute
a = NameConverter -> XName -> XName -> Doc
ppFieldId NameConverter
nx XName
t (Attribute -> XName
attr_name Attribute
a) Doc -> Doc -> Doc
<+> String -> Doc
text String
"::"
                                   Doc -> Doc -> Doc
<+> (if Attribute -> Bool
attr_required Attribute
a then Doc
empty
                                           else String -> Doc
text String
"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)

-- | Generate a list or maybe type name (possibly parenthesised).
ppTypeModifier :: Modifier -> (Doc->Doc) -> Doc -> Doc
ppTypeModifier :: Modifier -> (Doc -> Doc) -> Doc -> Doc
ppTypeModifier Modifier
Single   Doc -> Doc
_ Doc
d  = Doc
d
ppTypeModifier Modifier
Optional Doc -> Doc
k Doc
d  = Doc -> Doc
k (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Maybe" Doc -> Doc -> Doc
<+> Doc -> Doc
k Doc
d
ppTypeModifier (Range (Occurs Maybe Int
Nothing Maybe Int
Nothing))  Doc -> Doc
_ Doc
d = Doc
d
ppTypeModifier (Range (Occurs (Just Int
0) Maybe Int
Nothing)) Doc -> Doc
k Doc
d = Doc -> Doc
k (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"Maybe" Doc -> Doc -> Doc
<+> Doc -> Doc
k Doc
d
ppTypeModifier (Range (Occurs Maybe Int
_ Maybe Int
_))              Doc -> Doc
_ Doc
d = String -> Doc
text String
"[" Doc -> Doc -> Doc
<> Doc
d Doc -> Doc -> Doc
<> String -> Doc
text String
"]"

-- | Generate a parser for a list or Maybe value.
ppElemModifier :: Modifier -> Doc -> Doc
ppElemModifier :: Modifier -> Doc -> Doc
ppElemModifier Modifier
Single    Doc
doc = Doc
doc
ppElemModifier Modifier
Optional  Doc
doc = String -> Doc
text String
"optional" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range (Occurs Maybe Int
Nothing Maybe Int
Nothing))  Doc
doc = Doc
doc
ppElemModifier (Range (Occurs (Just Int
0) Maybe Int
Nothing)) Doc
doc = String -> Doc
text String
"optional"
                                                       Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range (Occurs (Just Int
0) (Just Int
n))) Doc
doc
               | Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
forall a. Bounded a => a
maxBound = String -> Doc
text String
"many" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range (Occurs Maybe Int
Nothing  (Just Int
n))) Doc
doc
               | Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
forall a. Bounded a => a
maxBound = String -> Doc
text String
"many1" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range (Occurs (Just Int
1) (Just Int
n))) Doc
doc
               | Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
forall a. Bounded a => a
maxBound = String -> Doc
text String
"many1" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
ppElemModifier (Range Occurs
o) Doc
doc = String -> Doc
text String
"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)

-- | Generate a toXML for a list or Maybe value.
xmlElemModifier :: Modifier -> Doc -> Doc
xmlElemModifier :: Modifier -> Doc -> Doc
xmlElemModifier Modifier
Single    Doc
doc = Doc
doc
xmlElemModifier Modifier
Optional  Doc
doc = String -> Doc
text String
"maybe []" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
xmlElemModifier (Range (Occurs Maybe Int
Nothing Maybe Int
Nothing))  Doc
doc = Doc
doc
xmlElemModifier (Range (Occurs (Just Int
0) Maybe Int
Nothing)) Doc
doc = String -> Doc
text String
"maybe []"
                                                        Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc
xmlElemModifier (Range (Occurs Maybe Int
_ Maybe Int
_)) Doc
doc = String -> Doc
text String
"concatMap" Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
doc

-- | Eliminate a Maybe type modifier, when it occurs directly inside a
--   choice construct (since a parsed Nothing would always be preferred over
--   a real value later in the choice).  Likewise, empty lists must
--   be disallowed inside choice.
cleanChoices :: [Element] -> [Element]
cleanChoices :: [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 Int
0) Maybe Int
Nothing) -> Element
e{elem_modifier=Single}
      Range (Occurs (Just Int
0) Maybe Int
max)-> Element
e{elem_modifier=Range (Occurs (Just 1) max)}
      Modifier
_ -> Element
e
cleanChoices [Element]
es = [Element]
es

-- | Sometimes, a choice without a type modifier contains element sequences,
--   all of which have the same modifier. In that case, it makes sense to lift
--   the modifier (typically Maybe) to the outer layer.
liftedElemModifier :: Element -> Modifier
liftedElemModifier :: Element -> Modifier
liftedElemModifier e :: Element
e@OneOf{} =
    case Element -> Modifier
elem_modifier Element
e of
      Range (Occurs Maybe Int
Nothing Maybe Int
Nothing) -> Modifier
newModifier
      Modifier
Single -> Modifier
newModifier
      Modifier
m -> Modifier
m
  where
    newModifier :: Modifier
newModifier = if (Element -> Bool) -> [Element] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Element
x-> case Element
x of
                                 Element
Text -> Bool
True
                                 Element
_ -> case Element -> Modifier
elem_modifier Element
x of
                                        Range (Occurs (Just Int
0) Maybe Int
_) -> Bool
True
                                        Modifier
Optional                  -> Bool
True
                                        Modifier
_                         -> 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

-- | Split long lines of comment text into a paragraph with a maximum width.
paragraph :: Int -> String -> String
paragraph :: Int -> String -> String
paragraph Int
n String
s = Int -> [String] -> String
go Int
n (String -> [String]
words String
s)
    where go :: Int -> [String] -> String
go Int
i []     = []
          go Int
i [String
x]    | Int
lenInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
i     =       String
x
                      | Bool
otherwise = String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
x
              where len :: Int
len = String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
x
          go Int
i (String
x:[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 -> 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
-Int
1) [String]
xs
                      | Bool
otherwise = String
"\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
xString -> String -> String
forall a. [a] -> [a] -> [a]
++String
" "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
-Int
1) [String]
xs
              where len :: Int
len = String -> Int
forall a. [a] -> 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 [String]
seen [] = []
    go [String]
seen (e :: Element
e@Element{}:[Element]
es)
        | XName -> String
forall a. Show a => a -> String
show (Element -> XName
elem_name Element
e) String -> [String] -> Bool
forall a. Eq a => a -> [a] -> 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 a. Eq a => a -> [a] -> 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=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 [String]
seen (Element
e:[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 String -> Bool
pred (XName (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. HasCallStack => [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 <- [Integer
2..]]
    new String -> Bool
pred (XName (QN Namespace
ns 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. HasCallStack => [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 <- [Integer
2..]]