module Data.PropertyList.Xml.Dtd where
import Prelude ((++), ($), return, Eq, Show, String, concatMap)
import Text.XML.HaXml.XmlContent
import Text.XML.HaXml.OneOfN
data Plist = PlistArray Plist_Attrs Array
| PlistData Plist_Attrs Data
| PlistDate Plist_Attrs Date
| PlistDict Plist_Attrs Dict
| PlistAReal Plist_Attrs AReal
| PlistAInteger Plist_Attrs AInteger
| PlistAString Plist_Attrs AString
| PlistTrue Plist_Attrs True
| PlistFalse Plist_Attrs False
deriving (Eq,Show)
data Plist_Attrs = Plist_Attrs
{ plistVersion :: (Defaultable String)
} deriving (Eq,Show)
newtype Array = Array [(OneOf9 Array Data Date Dict AReal AInteger AString True False)] deriving (Eq,Show)
newtype Dict = Dict [Dict_] deriving (Eq,Show)
data Dict_ = Dict_ Key
(OneOf9 Array Data Date Dict AReal AInteger AString True False)
deriving (Eq,Show)
newtype Key = Key String deriving (Eq,Show)
newtype AString = AString String deriving (Eq,Show)
newtype Data = Data String deriving (Eq,Show)
newtype Date = Date String deriving (Eq,Show)
data True = True deriving (Eq,Show)
data False = False deriving (Eq,Show)
newtype AReal = AReal String deriving (Eq,Show)
newtype AInteger = AInteger String deriving (Eq,Show)
instance HTypeable Plist where
toHType x = Defined "plist" [] []
instance XmlContent Plist where
toContents (PlistArray as a) =
[CElem (Elem "plist" (toAttrs as) (toContents a) ) ()]
toContents (PlistData as a) =
[CElem (Elem "plist" (toAttrs as) (toContents a) ) ()]
toContents (PlistDate as a) =
[CElem (Elem "plist" (toAttrs as) (toContents a) ) ()]
toContents (PlistDict as a) =
[CElem (Elem "plist" (toAttrs as) (toContents a) ) ()]
toContents (PlistAReal as a) =
[CElem (Elem "plist" (toAttrs as) (toContents a) ) ()]
toContents (PlistAInteger as a) =
[CElem (Elem "plist" (toAttrs as) (toContents a) ) ()]
toContents (PlistAString as a) =
[CElem (Elem "plist" (toAttrs as) (toContents a) ) ()]
toContents (PlistTrue as a) =
[CElem (Elem "plist" (toAttrs as) (toContents a) ) ()]
toContents (PlistFalse as a) =
[CElem (Elem "plist" (toAttrs as) (toContents a) ) ()]
parseContents = do
{ e@(Elem _ as _) <- element ["plist"]
; interior e $ oneOf
[ return (PlistArray (fromAttrs as)) `apply` parseContents
, return (PlistData (fromAttrs as)) `apply` parseContents
, return (PlistDate (fromAttrs as)) `apply` parseContents
, return (PlistDict (fromAttrs as)) `apply` parseContents
, return (PlistAReal (fromAttrs as)) `apply` parseContents
, return (PlistAInteger (fromAttrs as)) `apply` parseContents
, return (PlistAString (fromAttrs as)) `apply` parseContents
, return (PlistTrue (fromAttrs as)) `apply` parseContents
, return (PlistFalse (fromAttrs as)) `apply` parseContents
] `adjustErr` ("in <plist>, "++)
}
instance XmlAttributes Plist_Attrs where
fromAttrs as =
Plist_Attrs
{ plistVersion = defaultA fromAttrToStr "1.0" "version" as
}
toAttrs v = catMaybes
[ defaultToAttr toAttrFrStr "version" (plistVersion v)
]
instance HTypeable Array where
toHType x = Defined "array" [] []
instance XmlContent Array where
toContents (Array a) =
[CElem (Elem "array" [] (concatMap toContents a)) ()]
parseContents = do
{ e@(Elem _ [] _) <- element ["array"]
; interior e $ return (Array) `apply` many parseContents
} `adjustErr` ("in <array>, "++)
instance HTypeable Dict where
toHType x = Defined "dict" [] []
instance XmlContent Dict where
toContents (Dict a) =
[CElem (Elem "dict" [] (concatMap toContents a)) ()]
parseContents = do
{ e@(Elem _ [] _) <- element ["dict"]
; interior e $ return (Dict) `apply` many parseContents
} `adjustErr` ("in <dict>, "++)
instance HTypeable Dict_ where
toHType x = Defined "dict" [] []
instance XmlContent Dict_ where
toContents (Dict_ a b) =
(toContents a ++ toContents b)
parseContents = return (Dict_) `apply` parseContents
`apply` parseContents
instance HTypeable Key where
toHType x = Defined "key" [] []
instance XmlContent Key where
toContents (Key a) =
[CElem (Elem "key" [] (toText a)) ()]
parseContents = do
{ e@(Elem _ [] _) <- element ["key"]
; interior e $ return (Key) `apply` (text `onFail` return "")
} `adjustErr` ("in <key>, "++)
instance HTypeable AString where
toHType x = Defined "string" [] []
instance XmlContent AString where
toContents (AString a) =
[CElem (Elem "string" [] (toText a)) ()]
parseContents = do
{ e@(Elem _ [] _) <- element ["string"]
; interior e $ return (AString) `apply` (text `onFail` return "")
} `adjustErr` ("in <string>, "++)
instance HTypeable Data where
toHType x = Defined "data" [] []
instance XmlContent Data where
toContents (Data a) =
[CElem (Elem "data" [] (toText a)) ()]
parseContents = do
{ e@(Elem _ [] _) <- element ["data"]
; interior e $ return (Data) `apply` (text `onFail` return "")
} `adjustErr` ("in <data>, "++)
instance HTypeable Date where
toHType x = Defined "date" [] []
instance XmlContent Date where
toContents (Date a) =
[CElem (Elem "date" [] (toText a)) ()]
parseContents = do
{ e@(Elem _ [] _) <- element ["date"]
; interior e $ return (Date) `apply` (text `onFail` return "")
} `adjustErr` ("in <date>, "++)
instance HTypeable True where
toHType x = Defined "true" [] []
instance XmlContent True where
toContents True =
[CElem (Elem "true" [] []) ()]
parseContents = do
{ (Elem _ as []) <- element ["true"]
; return True
} `adjustErr` ("in <true>, "++)
instance HTypeable False where
toHType x = Defined "false" [] []
instance XmlContent False where
toContents False =
[CElem (Elem "false" [] []) ()]
parseContents = do
{ (Elem _ as []) <- element ["false"]
; return False
} `adjustErr` ("in <false>, "++)
instance HTypeable AReal where
toHType x = Defined "real" [] []
instance XmlContent AReal where
toContents (AReal a) =
[CElem (Elem "real" [] (toText a)) ()]
parseContents = do
{ e@(Elem _ [] _) <- element ["real"]
; interior e $ return (AReal) `apply` (text `onFail` return "")
} `adjustErr` ("in <real>, "++)
instance HTypeable AInteger where
toHType x = Defined "integer" [] []
instance XmlContent AInteger where
toContents (AInteger a) =
[CElem (Elem "integer" [] (toText a)) ()]
parseContents = do
{ e@(Elem _ [] _) <- element ["integer"]
; interior e $ return (AInteger) `apply` (text `onFail` return "")
} `adjustErr` ("in <integer>, "++)