-- | A type model for Haskell datatypes that bears a reasonable correspondence
--   to the XSD type model.
module Text.XML.HaXml.Schema.HaskellTypeModel
  ( module Text.XML.HaXml.Schema.HaskellTypeModel
  ) where

import Text.XML.HaXml.Schema.NameConversion
import Text.XML.HaXml.Schema.XSDTypeModel (Schema(..),Occurs)
import Text.XML.HaXml.Schema.Parse (lookupBy)
import Text.XML.HaXml.Types (QName(..),Namespace(..))
import Data.List (partition)

-- | Comments can be attached to most things, but not all of them will exist.
type Comment   = Maybe String

-- | The whole Haskell module.
data Module    = Module
                 { Module -> XName
module_name        :: XName   -- the name of this module
                 , Module -> Maybe XName
module_xsd_ns      :: Maybe XName -- xmlns:prefix for XSD
                 , Module -> [Decl]
module_re_exports  :: [Decl]  -- modules imported + exported
                 , Module -> [Decl]
module_import_only :: [Decl]  -- module + alias
                 , Module -> [Decl]
module_decls       :: [Decl]  -- the body of the module
                 }

-- | There are essentially simple types, and complex types, each of which
--   can be either restricted or extended.  There are four kinds of complex
--   type: choices, sequences, named groups, or a simple element with content.
data Decl
                 -- becomes type T = S
               = NamedSimpleType     XName XName Comment

                 -- becomes newtype T = T S
                 --       + instance Restricts T S where restricts ...
               | RestrictSimpleType  XName XName [Restrict] Comment

                 -- becomes data T  = T  S Tf
                 --       + data Tf = Tf {fields}
                 --       + instance Extension T S Tf where ...
               | ExtendSimpleType    XName XName [Attribute] Comment

                 -- becomes data T = Ta S0 | Tb S1 | Tc S2 | ...
               | UnionSimpleTypes    XName [XName] Comment

                 -- becomes data T = T_C0 | T_C1 | T_C2 | ...
               | EnumSimpleType      XName [(XName,Comment)] Comment

                 -- becomes data T  = T { singleattr, fields }
                 --   or    data T  = T { manyattr, singlefield }
                 --   or    data T  = T { t_attrs :: Ta, fields }
                 --       + data Ta = Ta { attributes }
               | ElementsAttrs XName [Element] [Attribute] Comment

                 -- or if T is abstract, it becomes
                 --         data T = T_A  A
                 --                | T_B  B
                 --                | FwdDecl fc c => T_C (fc->c) fc
                 --                | ...
                 --         data FwdC = FwdC -- because C is not yet in scope
                 --         instance FwdDecl FwdC C  -- later, at defn of C
                 --
                 -- In fact, it is better to move the declaration of type C
                 -- here, rather than use a FwdDecl proxy.  This will require
                 -- some patching later where C was originally declared.
                 --         data T = T_A  A
                 --                | T_B  B
                 --                | T_C  C -- but C not yet declared
                 --                | ...
                 --         data C = ... -- because C is not yet in scope
                 --         -- later, at true defn site of C, omit its decl.
                 --
                 -- An earlier solution was
                 --         class T a where parseT :: String -> XMLParser a
                 --         instance T A
                 --         instance T B
                 --         instance T C
                 -- but this is incorrect because the choice between A|B|C
                 -- rests with the input doc, not with the caller of the parser.
               | ElementsAttrsAbstract {-typename-}XName
                                       {-subtypes-}[(XName,Maybe XName)]
                                --  ^ [(type name, module where declared later)]
                                       Comment

                 -- becomes function
                 --    elementE :: Parser T
                 --    elementE = parseSchemaType "E"
               | ElementOfType Element
                 -- or, if E is abstract, with substitutionGroup {Foo,Bar},
                 --    elementE = fmap T_Foo elementFoo `onFail`
                 --               fmap T_Bar elementBar `onFail` ...
               | ElementAbstractOfType {-element name-}XName
                                       {-abstract type name-}XName
                                       {-substitute elems and fwddecls-}
                                           [(XName,Maybe XName)]
                                       Comment

                 -- becomes (global) data T = E0 e0 | E1 e1 | E2 e2 | E3 e3
                 -- becomes (local)  OneOfN e0 e1 e2 e3
               | Choice XName [Element] Comment

                 -- becomes data GroupT = GT e0 e1 e2 e3
               | Group  XName [Element] Comment

      {-         -- becomes data GroupT = GT e0 e1 e2 e3
               | GroupAttrs XName [Attribute] Comment
      -}
                 -- becomes newtype T = T S
                 --       + different (more restrictive) parser
               | RestrictComplexType  XName XName Comment

                 -- becomes data T  = T  {fields}
                 --       + instance Extension T S where ...
                 -- or when T extends an _abstract_ XSDtype S, defined in an
                 -- earlier module, it additionally has
                 --        instance FwdDecl FwdT T
               | ExtendComplexType XName XName [Element] [Attribute]
                                               [Element] [Attribute]
                                               {-FwdDecl req'd-}(Maybe XName)
                                               {-supertype abstract?-}Bool
                                               {-grandsupertypes-}[XName]
                                               Comment
                 -- or when T is itself abstract, extending an abstract type S
                 --        class T a where parseT :: String -> XMLParser a
                 --        instance (T a) => S a where parseS = parseT
               | ExtendComplexTypeAbstract XName XName
                                       {-subtypes-}[(XName,Maybe XName)]
                                       {-FwdDecl instnc req'd-}(Maybe XName)
                                       {-grandsupertypes-}[XName]
                                       Comment

                 -- becomes an import and re-export
               | XSDInclude XName Comment
                 -- becomes an import only
               | XSDImport  XName (Maybe XName) Comment
                 -- a top-level annotation
               | XSDComment Comment
                 deriving (Decl -> Decl -> Bool
(Decl -> Decl -> Bool) -> (Decl -> Decl -> Bool) -> Eq Decl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Decl -> Decl -> Bool
$c/= :: Decl -> Decl -> Bool
== :: Decl -> Decl -> Bool
$c== :: Decl -> Decl -> Bool
Eq,Int -> Decl -> ShowS
[Decl] -> ShowS
Decl -> String
(Int -> Decl -> ShowS)
-> (Decl -> String) -> ([Decl] -> ShowS) -> Show Decl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Decl] -> ShowS
$cshowList :: [Decl] -> ShowS
show :: Decl -> String
$cshow :: Decl -> String
showsPrec :: Int -> Decl -> ShowS
$cshowsPrec :: Int -> Decl -> ShowS
Show)

data Element   = Element { Element -> XName
elem_name     :: XName
                         , Element -> XName
elem_type     :: XName
                         , Element -> Modifier
elem_modifier :: Modifier
                         , Element -> Bool
elem_byRef    :: Bool
                         , Element -> [Decl]
elem_locals   :: [Decl]
                      -- , elem_abstract :: Bool
                         , Element -> Maybe [XName]
elem_substs   :: Maybe [XName] -- substitutable elems
                         , Element -> Comment
elem_comment  :: Comment
                         }
               | OneOf   { Element -> [[Element]]
elem_oneOf    :: [[Element]]
                         , elem_modifier :: Modifier
                         , elem_comment  :: Comment
                         }
               | AnyElem { elem_modifier :: Modifier
                         , elem_comment  :: Comment
                         }
               | Text -- for mixed content
                 deriving (Element -> Element -> Bool
(Element -> Element -> Bool)
-> (Element -> Element -> Bool) -> Eq Element
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Element -> Element -> Bool
$c/= :: Element -> Element -> Bool
== :: Element -> Element -> Bool
$c== :: Element -> Element -> Bool
Eq,Int -> Element -> ShowS
[Element] -> ShowS
Element -> String
(Int -> Element -> ShowS)
-> (Element -> String) -> ([Element] -> ShowS) -> Show Element
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Element] -> ShowS
$cshowList :: [Element] -> ShowS
show :: Element -> String
$cshow :: Element -> String
showsPrec :: Int -> Element -> ShowS
$cshowsPrec :: Int -> Element -> ShowS
Show)
data Attribute = Attribute { Attribute -> XName
attr_name    :: XName
                           , Attribute -> XName
attr_type    :: XName
                           , Attribute -> Bool
attr_required:: Bool
                           , Attribute -> Comment
attr_comment :: Comment
                           }
                 deriving (Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c== :: Attribute -> Attribute -> Bool
Eq,Int -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
(Int -> Attribute -> ShowS)
-> (Attribute -> String)
-> ([Attribute] -> ShowS)
-> Show Attribute
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attribute] -> ShowS
$cshowList :: [Attribute] -> ShowS
show :: Attribute -> String
$cshow :: Attribute -> String
showsPrec :: Int -> Attribute -> ShowS
$cshowsPrec :: Int -> Attribute -> ShowS
Show)

data Modifier  = Single
               | Optional
               | Range Occurs
                 deriving (Modifier -> Modifier -> Bool
(Modifier -> Modifier -> Bool)
-> (Modifier -> Modifier -> Bool) -> Eq Modifier
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Modifier -> Modifier -> Bool
$c/= :: Modifier -> Modifier -> Bool
== :: Modifier -> Modifier -> Bool
$c== :: Modifier -> Modifier -> Bool
Eq,Int -> Modifier -> ShowS
[Modifier] -> ShowS
Modifier -> String
(Int -> Modifier -> ShowS)
-> (Modifier -> String) -> ([Modifier] -> ShowS) -> Show Modifier
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Modifier] -> ShowS
$cshowList :: [Modifier] -> ShowS
show :: Modifier -> String
$cshow :: Modifier -> String
showsPrec :: Int -> Modifier -> ShowS
$cshowsPrec :: Int -> Modifier -> ShowS
Show)

-- | Restrictions on simpleType
data Restrict  = RangeR Occurs Comment
               | Pattern String{-really Regexp-} Comment
               | Enumeration [(String,Comment)]
               | StrLength Occurs Comment
                 deriving (Restrict -> Restrict -> Bool
(Restrict -> Restrict -> Bool)
-> (Restrict -> Restrict -> Bool) -> Eq Restrict
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Restrict -> Restrict -> Bool
$c/= :: Restrict -> Restrict -> Bool
== :: Restrict -> Restrict -> Bool
$c== :: Restrict -> Restrict -> Bool
Eq,Int -> Restrict -> ShowS
[Restrict] -> ShowS
Restrict -> String
(Int -> Restrict -> ShowS)
-> (Restrict -> String) -> ([Restrict] -> ShowS) -> Show Restrict
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Restrict] -> ShowS
$cshowList :: [Restrict] -> ShowS
show :: Restrict -> String
$cshow :: Restrict -> String
showsPrec :: Int -> Restrict -> ShowS
$cshowsPrec :: Int -> Restrict -> ShowS
Show)


-- | A helper for building the formal Module structure.
mkModule :: String -> Schema -> [Decl] -> Module
mkModule :: String -> Schema -> [Decl] -> Module
mkModule String
name Schema
schema [Decl]
decls =
                      Module :: XName -> Maybe XName -> [Decl] -> [Decl] -> [Decl] -> Module
Module { module_name :: XName
module_name        = QName -> XName
XName (QName -> XName) -> QName -> XName
forall a b. (a -> b) -> a -> b
$ String -> QName
N String
name
                             , module_xsd_ns :: Maybe XName
module_xsd_ns      = [Namespace] -> Maybe XName
xsdQualification
                                                      (Schema -> [Namespace]
schema_namespaces Schema
schema)
                             , module_re_exports :: [Decl]
module_re_exports  = [Decl]
reexports
                             , module_import_only :: [Decl]
module_import_only = [Decl]
imports
                             , module_decls :: [Decl]
module_decls       = [Decl]
theRest
                             }
    where ([Decl]
reexports,[Decl]
other)   = (Decl -> Bool) -> [Decl] -> ([Decl], [Decl])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Decl -> Bool
xsdinclude [Decl]
decls
          ([Decl]
imports,  [Decl]
theRest) = (Decl -> Bool) -> [Decl] -> ([Decl], [Decl])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Decl -> Bool
xsdimport  [Decl]
other
          xsdinclude :: Decl -> Bool
xsdinclude (XSDInclude XName
_ Comment
_)  = Bool
True
          xsdinclude Decl
_                 = Bool
False
          xsdimport :: Decl -> Bool
xsdimport  (XSDImport XName
_ Maybe XName
_ Comment
_) = Bool
True
          xsdimport  Decl
_                 = Bool
False
          xsdQualification :: [Namespace] -> Maybe XName
xsdQualification [Namespace]
nss = (Namespace -> XName) -> Maybe Namespace -> Maybe XName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QName -> XName
XName (QName -> XName) -> (Namespace -> QName) -> Namespace -> XName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> QName
N (String -> QName) -> (Namespace -> String) -> Namespace -> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> String
nsPrefix) (Maybe Namespace -> Maybe XName) -> Maybe Namespace -> Maybe XName
forall a b. (a -> b) -> a -> b
$
                                      (Namespace -> Bool) -> [Namespace] -> Maybe Namespace
forall a. (a -> Bool) -> [a] -> Maybe a
lookupBy ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
xsd)(String -> Bool) -> (Namespace -> String) -> Namespace -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Namespace -> String
nsURI) [Namespace]
nss
              where xsd :: String
xsd = String
"http://www.w3.org/2001/XMLSchema"