1-- ------------------------------------------------------------ 2 3{- | 4 Module : Text.XML.HXT.Arrow.Pickle.Schema 5 Copyright : Copyright (C) 2005 Uwe Schmidt 6 License : MIT 7 8 Maintainer : Uwe Schmidt (uwe@fh-wedel.de) 9 Stability : experimental 10 Portability: portable 11 Version : $Id$ 12 13Datatypes and functions for building a content model 14for XML picklers. A schema is part of every pickler 15and can be used to derive a corrensponding DTD (or Relax NG schema). 16This schema further enables checking the picklers. 17 18-} 19 20-- ------------------------------------------------------------ 21 22module Text.XML.HXT.Arrow.Pickle.Schema 23where 24 25import Text.XML.HXT.DOM.TypeDefs 26import Text.XML.HXT.XMLSchema.DataTypeLibW3CNames 27 28import Data.List 29 ( sort ) 30 31-- ------------------------------------------------------------ 32 33-- | The datatype for modelling the structure of an 34 35data Schema = Any 36 | Seq { sc_l :: [Schema] 37 } 38 | Alt { sc_l :: [Schema] 39 } 40 | Rep { sc_lb :: Int 41 , sc_ub :: Int 42 , sc_1 :: Schema 43 } 44 | Element { sc_n :: Name 45 , sc_1 :: Schema 46 } 47 | Attribute { sc_n :: Name 48 , sc_1 :: Schema 49 } 50 | ElemRef { sc_n :: Name 51 } 52 | CharData { sc_dt :: DataTypeDescr 53 } 54 deriving (Eq, Show) 55 56type Name = String 57type Schemas = [Schema] 58 59data DataTypeDescr = DTDescr { dtLib :: String 60 , dtName :: String 61 , dtParams :: Attributes 62 } 63 deriving (Show) 64 65instance Eq DataTypeDescr where 66 x1 == x2 = dtLib x1 == dtLib x2 67 && 68 dtName x1 == dtName x2 69 && 70 sort (dtParams x1) == sort (dtParams x2) 71 72-- ------------------------------------------------------------ 73 74-- | test: is schema a simple XML Schema datatype 75 76isScXsd :: (String -> Bool) -> Schema -> Bool 77 78isScXsd p (CharData (DTDescr lib n _ps)) 79 = lib == w3cNS 80 && 81 p n 82isScXsd _ _ = False 83 84-- | test: is type a fixed value attribute type 85 86isScFixed :: Schema -> Bool 87isScFixed sc = isScXsd (== xsd_string) sc 88 && 89 ((== 1) . length . words . xsdParam xsd_enumeration) sc 90 91isScEnum :: Schema -> Bool 92isScEnum sc = isScXsd (== xsd_string) sc 93 && 94 (not . null . xsdParam xsd_enumeration) sc 95 96isScElem :: Schema -> Bool 97isScElem (Element _ _) = True 98isScElem _ = False 99 100isScAttr :: Schema -> Bool 101isScAttr (Attribute _ _)= True 102isScAttr _ = False 103 104isScElemRef :: Schema -> Bool 105isScElemRef (ElemRef _) = True 106isScElemRef _ = False 107 108isScCharData :: Schema -> Bool 109isScCharData (CharData _)= True 110isScCharData _ = False 111 112isScSARE :: Schema -> Bool 113isScSARE (Seq _) = True 114isScSARE (Alt _) = True 115isScSARE (Rep _ _ _) = True 116isScSARE (ElemRef _) = True 117isScSARE _ = False 118 119isScList :: Schema -> Bool 120isScList (Rep 0 (-1) _) = True 121isScList _ = False 122 123isScOpt :: Schema -> Bool 124isScOpt (Rep 0 1 _) = True 125isScOpt _ = False 126 127-- | access an attribute of a descr of an atomic type 128 129xsdParam :: String -> Schema -> String 130xsdParam n (CharData dtd) 131 = lookup1 n (dtParams dtd) 132xsdParam _ _ = "" 133 134-- ------------------------------------------------------------ 135 136-- smart constructors for Schema datatype 137 138-- ------------------------------------------------------------ 139-- 140-- predefined xsd data types for representation of DTD types 141 142scDT :: String -> String -> Attributes -> Schema 143scDT l n rl = CharData $ DTDescr l n rl 144 145scDTxsd :: String -> Attributes -> Schema 146scDTxsd = scDT w3cNS 147 148scString :: Schema 149scString = scDTxsd xsd_string [] 150 151scString1 :: Schema 152scString1 = scDTxsd xsd_string [(xsd_minLength, "1")] 153 154scFixed :: String -> Schema 155scFixed v = scDTxsd xsd_string [(xsd_enumeration, v)] 156 157scEnum :: [String] -> Schema 158scEnum vs = scFixed (unwords vs) 159 160scNmtoken :: Schema 161scNmtoken = scDTxsd xsd_NCName [] 162 163scNmtokens :: Schema 164scNmtokens = scList scNmtoken 165 166-- ------------------------------------------------------------ 167 168scEmpty :: Schema 169scEmpty = Seq [] 170 171scSeq :: Schema -> Schema -> Schema 172scSeq (Seq []) sc2 = sc2 173scSeq sc1 (Seq []) = sc1 174scSeq (Seq scs1) (Seq scs2) = Seq (scs1 ++ scs2) -- prevent nested Seq expr 175scSeq (Seq scs1) sc2 = Seq (scs1 ++ [sc2]) 176scSeq sc1 (Seq scs2) = Seq (sc1 : scs2) 177scSeq sc1 sc2 = Seq [sc1,sc2] 178 179scSeqs :: [Schema] -> Schema 180scSeqs = foldl scSeq scEmpty 181 182scNull :: Schema 183scNull = Alt [] 184 185scAlt :: Schema -> Schema -> Schema 186scAlt (Alt []) sc2 = sc2 187scAlt sc1 (Alt []) = sc1 188scAlt (Alt scs1) (Alt scs2) = Alt (scs1 ++ scs2) -- prevent nested Alt expr 189scAlt (Alt scs1) sc2 = Alt (scs1 ++ [sc2]) 190scAlt sc1 (Alt scs2) = Alt (sc1 : scs2) 191scAlt sc1 sc2 = Alt [sc1,sc2] 192 193scAlts :: [Schema] -> Schema 194scAlts = foldl scAlt scNull 195 196scOption :: Schema -> Schema 197scOption (Seq []) = scEmpty 198scOption (Attribute n sc2) = Attribute n (scOption sc2) 199scOption sc1 200 | sc1 == scString1 = scString 201 | otherwise = scOpt sc1 202 203scList :: Schema -> Schema 204scList = scRep 0 (-1) 205 206scList1 :: Schema -> Schema 207scList1 = scRep 1 (-1) 208 209scOpt :: Schema -> Schema 210scOpt = scRep 0 1 211 212scRep :: Int -> Int -> Schema -> Schema 213scRep l u sc1 = Rep l u sc1 214 215scElem :: String -> Schema -> Schema 216scElem n sc1 = Element n sc1 217 218scAttr :: String -> Schema -> Schema 219scAttr n sc1 = Attribute n sc1 220 221-- ------------------------------------------------------------ 222