property-list (empty) → 0.0.0.1
raw patch · 5 files changed
+469/−0 lines, 5 filesdep +HaXmldep +basedep +bytestringsetup-changed
Dependencies added: HaXml, base, bytestring, containers, dataenc, old-locale, pretty, th-fold, time
Files
- Setup.lhs +5/−0
- property-list.cabal +30/−0
- src/Data/PropertyList.hs +160/−0
- src/Data/PropertyList/Xml.hs +74/−0
- src/Data/PropertyList/Xml/Dtd.hs +200/−0
+ Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain+
+ property-list.cabal view
@@ -0,0 +1,30 @@+name: property-list+version: 0.0.0.1+stability: experimental+license: PublicDomain++cabal-version: >= 1.2+build-type: Simple++author: James Cook <james.cook@usma.edu>+maintainer: James Cook <james.cook@usma.edu>+homepage: http://code.haskell.org/~mokus/property-list++category: Data, Parsing+synopsis: XML property list parser+description: Parser for Apple's XML property list 1.0 format.++Library+ hs-source-dirs: src+ exposed-modules: Data.PropertyList+ other-modules: Data.PropertyList.Xml+ Data.PropertyList.Xml.Dtd+ build-depends: base >= 3,+ bytestring,+ containers, + dataenc,+ HaXml,+ old-locale,+ pretty,+ time,+ th-fold
+ src/Data/PropertyList.hs view
@@ -0,0 +1,160 @@+{-+ - ``Data/PropertyList''+ - rough cut type/reader/writer for Apple Property List format+ -}+{-# LANGUAGE+ TemplateHaskell+ #-}++module Data.PropertyList where++import Prelude as P+import Data.PropertyList.Xml.Dtd as X+import Data.PropertyList.Xml++import qualified Data.Map as M+import Data.ByteString as B hiding (map)+import Data.Time+import System.Locale+import Codec.Binary.Base64 as B64++import Text.XML.HaXml.OneOfN+import Language.Haskell.TH.Fold++import Text.XML.HaXml.XmlContent++readPropertyListFromFile :: FilePath -> IO (Either String (PropertyList UnparsedPlistItem))+readPropertyListFromFile file = do+ x <- readPlistFromFile file+ return (fmap plistToPropertyList x)++writePropertyListToFile :: FilePath -> PropertyList UnparsedPlistItem -> IO ()+writePropertyListToFile file plist = do+ writePlistToFile file (propertyListToPlist unparsedPlistItemToPlistItem plist)++data PropertyList a+ = PLArray [PropertyList a]+ | PLData ByteString+ | PLDate UTCTime+ | PLDict (M.Map String (PropertyList a))+ | PLReal Double+ | PLInt Integer+ | PLString String+ | PLBool Bool+ + | PLVar a+ deriving (Eq, Ord, Show, Read)++instance Functor PropertyList where+ fmap f x = x >>= (return . f)++instance Monad PropertyList where+ return = PLVar+ x >>= f = foldPropertyList+ PLArray+ PLData+ PLDate+ PLDict+ PLReal+ PLInt+ PLString+ PLBool+ f x++-- TODO: if possible, make 'fold' in th-utils detect the Functor instances for+-- [] and Map k and automagically generate the call to fmap here+foldPropertyList :: ([a] -> a)+ -> (ByteString -> a)+ -> (UTCTime -> a)+ -> (M.Map String a -> a)+ -> (Double -> a)+ -> (Integer -> a)+ -> (String -> a)+ -> (Bool -> a)+ -> (t -> a)+ -> PropertyList t -> a+foldPropertyList foldList a b foldMap c d e f g = foldIt+ where+ foldIt = $(fold ''PropertyList) foldArray a b foldDict c d e f g+ + foldArray branches = foldList (fmap foldIt branches)+ foldDict dict = foldMap (fmap foldIt dict)++data UnparsedPlistItem+ = UnparsedData String+ | UnparsedDate String+ | UnparsedInt String+ | UnparsedReal String+ deriving (Eq, Ord, Show, Read)++unparsedPlistItemToPlistItem :: UnparsedPlistItem -> PlistItem+unparsedPlistItemToPlistItem = $(fold ''UnparsedPlistItem)+ (TwoOf9 . Data )+ (ThreeOf9 . Date )+ (SixOf9 . AInteger)+ (FiveOf9 . AReal )++-- run an incremental parser - a function which takes+-- a token type and returns either a subterm (possibly still+-- containing unparsed tokens) or an unparsed token (possibly+-- a new token, maybe even of a new type). This interpretation+-- of the action of this function is based on a term-algebra+-- view of the monad in question.+parseT :: Monad t => (a -> Either (t a) b) -> a -> t b+parseT f = parse+ where parse token =+ either (>>= parse) return (f token)++plistToPropertyList :: Plist -> PropertyList UnparsedPlistItem+plistToPropertyList = parseT parsePlistItem . plistToPlistItem++plistItemToPropertyList :: PlistItem -> PropertyList UnparsedPlistItem+plistItemToPropertyList = plistToPropertyList . plistItemToPlist++parsePlistItem :: PlistItem -> Either (PropertyList PlistItem) UnparsedPlistItem+parsePlistItem item = case item of+ OneOf9 (Array x ) -> accept PLArray (map return x)+ TwoOf9 (Data x ) -> case decode x of + Just d -> accept PLData (pack d)+ Nothing -> reject UnparsedData x+ ThreeOf9 (Date x ) -> case parseTime defaultTimeLocale dateFormat x of+ Just t -> accept PLDate t+ Nothing -> reject UnparsedDate x+ FourOf9 (Dict x ) -> accept PLDict (M.fromList [ (k, return v) | Dict_ (Key k) v <- x])+ FiveOf9 (AReal x ) -> tryRead PLReal UnparsedReal x+ SixOf9 (AInteger x) -> tryRead PLInt UnparsedInt x+ SevenOf9 (AString x) -> accept PLString x+ EightOf9 (X.True ) -> accept PLBool P.True+ NineOf9 (X.False ) -> accept PLBool P.False+ + where+ accept :: (a -> b) -> a -> Either b c+ accept con = Left . con+ + reject :: (a -> c) -> a -> Either b c+ reject con = Right . con+ + tryRead :: Read a => (a -> b) -> (String -> c) -> String -> Either b c+ tryRead onGood onBad str =+ case reads str of+ ((result, ""):_) -> accept onGood result+ _ -> reject onBad str+ + +dateFormat :: String+dateFormat = "%FT%TZ"++propertyListToPlist :: (a -> PlistItem) -> PropertyList a -> Plist+propertyListToPlist fromOther = plistItemToPlist . propertyListToPlistItem fromOther++propertyListToPlistItem :: (a -> PlistItem) -> PropertyList a -> PlistItem+propertyListToPlistItem fromOther = foldPropertyList+ (\x -> OneOf9 (Array x)+ ) (\x -> TwoOf9 (Data (encode (unpack x)))+ ) (\x -> ThreeOf9 (Date (formatTime defaultTimeLocale dateFormat x))+ ) (\x -> FourOf9 (Dict [Dict_ (Key k) v | (k,v) <- M.toList x])+ ) (\x -> FiveOf9 (AReal (show x))+ ) (\x -> SixOf9 (AInteger (show x))+ ) (\x -> SevenOf9 (AString x)+ ) (\x -> if x then EightOf9 X.True else NineOf9 X.False+ ) fromOther
+ src/Data/PropertyList/Xml.hs view
@@ -0,0 +1,74 @@+{-+ - ``Data/PropertyList/Xml''+ -}+{-# LANGUAGE+ TemplateHaskell+ #-}++module Data.PropertyList.Xml where++import Prelude as P+import Data.PropertyList.Xml.Dtd as X++import Text.XML.HaXml.OneOfN++import Text.XML.HaXml.XmlContent+ hiding (showXml, toXml)++import Text.PrettyPrint.HughesPJ (render)+import Text.XML.HaXml.Pretty (document)+import Text.XML.HaXml.Types++import Language.Haskell.TH.Fold++type PlistItem = OneOf9 Array Data Date Dict AReal AInteger AString X.True X.False++readPlistFromFile :: FilePath -> IO (Either String Plist)+readPlistFromFile path = do+ contents <- readFile path+ return (readXml contents)++writePlistToFile :: FilePath -> Plist -> IO ()+writePlistToFile path plist = do+ writeFile path (showXml plist)++-- | Convert a fully-typed XML document to a string (without DTD).+showXml :: Plist -> String+showXml x =+ case toContents x of+ [CElem _ _] -> (render . document . toXml) x+ _ -> ""+++toXml :: Plist -> Document ()+toXml value =+ Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing)) [] Nothing [])+ emptyST+ ( case (toContents value) of+ [CElem e ()] -> e+ )+ []++plistToPlistItem :: Plist -> PlistItem+plistToPlistItem = $(fold ''Plist)+ (\attr -> OneOf9 )+ (\attr -> TwoOf9 )+ (\attr -> ThreeOf9)+ (\attr -> FourOf9 )+ (\attr -> FiveOf9 )+ (\attr -> SixOf9 )+ (\attr -> SevenOf9)+ (\attr -> EightOf9)+ (\attr -> NineOf9 )++plistItemToPlist = $(fold ''OneOf9)+ (PlistArray attr)+ (PlistData attr)+ (PlistDate attr)+ (PlistDict attr)+ (PlistAReal attr)+ (PlistAInteger attr)+ (PlistAString attr)+ (PlistTrue attr)+ (PlistFalse attr)+ where attr = fromAttrs []
+ src/Data/PropertyList/Xml/Dtd.hs view
@@ -0,0 +1,200 @@+{-+ - ``Data/PropertyList/Xml/Dtd''+ - generated by DtdToHaskell (from HaXml 1.19.4)+ - altered to fix ambiguities (added explicit Prelude imports)+ -}++module Data.PropertyList.Xml.Dtd where++import Prelude ((++), ($), return, Eq, Show, String, concatMap)++import Text.XML.HaXml.XmlContent+import Text.XML.HaXml.OneOfN++{-Type decls-}++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 decls-}++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>, "++)++++{-Done-}