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

{- |
   Module     : Text.XML.HXT.Arrow.Pickle.Schema
   Copyright  : Copyright (C) 2005 Uwe Schmidt
   License    : MIT

   Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
   Stability  : experimental
   Portability: portable
   Version    : $Id$

Datatypes and functions for building a content model
for XML picklers. A schema is part of every pickler
and can be used to derive a corrensponding DTD (or Relax NG schema).
This schema further enables checking the picklers.

-}

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

module Text.XML.HXT.Arrow.Pickle.Schema
where

import Text.XML.HXT.DOM.TypeDefs
import Text.XML.HXT.XMLSchema.DataTypeLibW3CNames

import Data.List
    ( sort )

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

-- | The datatype for modelling the structure of an

data Schema                     = Any
                                | Seq           { sc_l  :: [Schema]
                                                }
                                | Alt           { sc_l  :: [Schema]
                                                }
                                | Rep           { sc_lb :: Int
                                                , sc_ub :: Int
                                                , sc_1  :: Schema
                                                }
                                | Element       { sc_n  :: Name
                                                , sc_1  :: Schema
                                                }
                                | Attribute     { sc_n  :: Name
                                                , sc_1  :: Schema
                                                }
                                | ElemRef       { sc_n  :: Name
                                                }
                                | CharData      { sc_dt :: DataTypeDescr
                                                }
                                  deriving (Eq, Show)

type Name                       = String
type Schemas                    = [Schema]

data DataTypeDescr              = DTDescr { dtLib    :: String
                                          , dtName   :: String
                                          , dtParams :: Attributes
                                          }
                                  deriving (Show)

instance Eq DataTypeDescr where
    x1 == x2 = dtLib x1 == dtLib x2
               &&
               dtName x1 == dtName x2
               &&
               sort (dtParams x1) == sort (dtParams x2)

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

-- | test: is schema a simple XML Schema datatype

isScXsd                 :: (String -> Bool) -> Schema -> Bool

isScXsd p (CharData (DTDescr lib n _ps))
                        = lib == w3cNS
                          &&
                          p n
isScXsd _ _             = False

-- | test: is type a fixed value attribute type

isScFixed               :: Schema -> Bool
isScFixed sc            = isScXsd (== xsd_string) sc
                          &&
                          ((== 1) . length . words . xsdParam xsd_enumeration) sc

isScEnum                :: Schema -> Bool
isScEnum sc             = isScXsd (== xsd_string) sc
                          &&
                          (not . null . xsdParam xsd_enumeration) sc

isScElem                :: Schema -> Bool
isScElem (Element _ _)  = True
isScElem _              = False

isScAttr                :: Schema -> Bool
isScAttr (Attribute _ _)= True
isScAttr _              = False

isScElemRef             :: Schema -> Bool
isScElemRef (ElemRef _) = True
isScElemRef _           = False

isScCharData            :: Schema -> Bool
isScCharData (CharData _)= True
isScCharData _          = False

isScSARE                :: Schema -> Bool
isScSARE (Seq _)        = True
isScSARE (Alt _)        = True
isScSARE (Rep _ _ _)    = True
isScSARE (ElemRef _)    = True
isScSARE _              = False

isScList                :: Schema -> Bool
isScList (Rep 0 (-1) _) = True
isScList _              = False

isScOpt                 :: Schema -> Bool
isScOpt (Rep 0 1 _)     = True
isScOpt _               = False

-- | access an attribute of a descr of an atomic type

xsdParam                :: String -> Schema -> String
xsdParam n (CharData dtd)
                        = lookup1 n (dtParams dtd)
xsdParam _ _            = ""

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

-- smart constructors for Schema datatype

-- ------------------------------------------------------------
--
-- predefined xsd data types for representation of DTD types

scDT            :: String -> String -> Attributes -> Schema
scDT l n rl     = CharData $ DTDescr l n rl

scDTxsd         :: String -> Attributes -> Schema
scDTxsd         = scDT w3cNS

scString        :: Schema
scString        = scDTxsd xsd_string []

scString1       :: Schema
scString1       = scDTxsd xsd_string [(xsd_minLength, "1")]

scFixed         :: String -> Schema
scFixed v       = scDTxsd xsd_string [(xsd_enumeration, v)]

scEnum          :: [String] -> Schema
scEnum vs       = scFixed (unwords vs)

scNmtoken       :: Schema
scNmtoken       = scDTxsd xsd_NCName []

scNmtokens      :: Schema
scNmtokens      = scList scNmtoken

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

scEmpty                         :: Schema
scEmpty                         = Seq []

scSeq                           :: Schema -> Schema -> Schema
scSeq (Seq [])   sc2            = sc2
scSeq sc1        (Seq [])       = sc1
scSeq (Seq scs1) (Seq scs2)     = Seq (scs1 ++ scs2)    -- prevent nested Seq expr
scSeq (Seq scs1) sc2            = Seq (scs1 ++ [sc2])
scSeq sc1        (Seq scs2)     = Seq (sc1  :  scs2)
scSeq sc1        sc2            = Seq [sc1,sc2]

scSeqs                          :: [Schema] -> Schema
scSeqs                          = foldl scSeq scEmpty

scNull                          :: Schema
scNull                          = Alt []

scAlt                           :: Schema -> Schema -> Schema
scAlt (Alt [])   sc2            = sc2
scAlt sc1        (Alt [])       = sc1
scAlt (Alt scs1) (Alt scs2)     = Alt (scs1 ++ scs2)    -- prevent nested Alt expr
scAlt (Alt scs1) sc2            = Alt (scs1 ++ [sc2])
scAlt sc1        (Alt scs2)     = Alt (sc1  :  scs2)
scAlt sc1        sc2            = Alt [sc1,sc2]

scAlts          :: [Schema] -> Schema
scAlts          = foldl scAlt scNull

scOption        :: Schema -> Schema
scOption     (Seq [])           = scEmpty
scOption (Attribute n sc2)      = Attribute n (scOption sc2)
scOption sc1
    | sc1 == scString1          = scString
    | otherwise                 = scOpt sc1

scList          :: Schema -> Schema
scList          = scRep 0 (-1)

scList1         :: Schema -> Schema
scList1         = scRep 1 (-1)

scOpt           :: Schema -> Schema
scOpt           = scRep 0 1

scRep           :: Int -> Int -> Schema -> Schema
scRep l u sc1  = Rep l u sc1

scElem          :: String -> Schema -> Schema
scElem n sc1    = Element n sc1

scAttr          :: String -> Schema -> Schema
scAttr n sc1    = Attribute n sc1

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