property-list 0.0.3 → 0.1
raw patch · 19 files changed
+1050/−841 lines, 19 filesdep +base64-bytestringdep +cerealdep +oneOfNdep −HaXmldep −bytestring-classdep −comonad-transformersdep ~base
Dependencies added: base64-bytestring, cereal, oneOfN, text, transformers, vector, xml
Dependencies removed: HaXml, bytestring-class, comonad-transformers, dataenc, mtl, pointed, pretty, th-fold, void
Dependency ranges changed: base
Files
- property-list.cabal +23/−25
- src/Data/PropertyList.hs +34/−22
- src/Data/PropertyList/Algebra.hs +17/−13
- src/Data/PropertyList/Binary.hs +54/−0
- src/Data/PropertyList/Binary/Algebra.hs +71/−0
- src/Data/PropertyList/Binary/Float.hs +86/−0
- src/Data/PropertyList/Binary/Get.hs +211/−0
- src/Data/PropertyList/Binary/Linearize.hs +64/−0
- src/Data/PropertyList/Binary/Put.hs +184/−0
- src/Data/PropertyList/Binary/Types.hs +67/−0
- src/Data/PropertyList/KeyPath.hs +13/−16
- src/Data/PropertyList/PropertyListItem.hs +22/−13
- src/Data/PropertyList/Types.hs +25/−29
- src/Data/PropertyList/Xml.hs +46/−69
- src/Data/PropertyList/Xml/Algebra.hs +133/−0
- src/Data/PropertyList/Xml/Dtd.hs +0/−204
- src/Data/PropertyList/Xml/Dtd_1_13.hs +0/−212
- src/Data/PropertyList/Xml/Parse.hs +0/−122
- src/Data/PropertyList/Xml/Types.hs +0/−116
property-list.cabal view
@@ -1,9 +1,9 @@ name: property-list-version: 0.0.3+version: 0.1 stability: experimental license: PublicDomain -cabal-version: >= 1.2+cabal-version: >= 1.6 build-type: Simple author: James Cook <james.cook@usma.edu>@@ -14,45 +14,43 @@ synopsis: XML property list parser description: Parser, data type and formatter for Apple's XML property list 1.0 format. -flag HaXml_1_13- default: False- description: Compile against HaXml 1.13 rather than the latest.+tested-with: GHC == 6.12.3, GHC == 7.0.4 +source-repository head+ type: git+ location: git://github.com/mokus0/property-list.git+ Library hs-source-dirs: src ghc-options: -fwarn-unused-binds -fwarn-unused-imports exposed-modules: Data.PropertyList Data.PropertyList.Algebra+ Data.PropertyList.Binary Data.PropertyList.Xml other-modules: Data.PropertyList.Types+ Data.PropertyList.Binary.Algebra+ Data.PropertyList.Binary.Linearize+ Data.PropertyList.Binary.Float+ Data.PropertyList.Binary.Get+ Data.PropertyList.Binary.Put+ Data.PropertyList.Binary.Types Data.PropertyList.PropertyListItem Data.PropertyList.KeyPath- Data.PropertyList.Xml.Parse- Data.PropertyList.Xml.Types- build-depends: base >= 4 && <5,+ Data.PropertyList.Xml.Algebra+ build-depends: base >= 3 && <5,+ base64-bytestring, bytestring,- bytestring-class,+ cereal, containers, - comonad-transformers >= 1.8,- dataenc, free >= 1.8,- mtl,+ transformers, old-locale,- pointed >= 1.8,- pretty,+ oneOfN, recursion-schemes >= 1.8, syb, template-haskell,+ text, time,- th-fold,- void-- if flag(HaXml_1_13)- other-modules: Data.PropertyList.Xml.Dtd_1_13- cpp-options: -DHaXml_1_13- build-depends: HaXml >= 1.13 && <1.14- - else- other-modules: Data.PropertyList.Xml.Dtd- build-depends: HaXml >= 1.19+ vector,+ xml >= 1.3.9
src/Data/PropertyList.hs view
@@ -14,14 +14,13 @@ -- into their overall shape but not all elements have been parsed into -- their final format. -- - -- The 'UnparsedPlistItem' type is the type most often used with- -- 'PartialPropertyList', and that is really its only purpose - to- -- represent unparseable items from an XML plist during intermediate- -- stages of translation.+ -- The 'UnparsedXmlPlistItem' and 'UnparsedBPListRecord' types are used+ -- with 'PartialPropertyList', and that is really their only purpose - to+ -- represent unparseable items during intermediate stages of translation. PropertyList , PartialPropertyList- , PropertyListS(..)- , UnparsedPlistItem(..)+ , UnparsedBPListRecord(..)+ , UnparsedXmlPlistItem(..) -- * Constructors and destructors for property lists -- |The \"pl*\" operations construct 'PropertyList's, 'PartialPropertyList's, @@ -57,12 +56,16 @@ , InitialPList, TerminalPList -- * Parsing and formatting property lists using any supported format- , readPropertyList- , showPropertyList- , readPropertyListFromFile , writePropertyListToFile + -- * Parsing and formatting property lists using the Binary format+ , readBinaryPropertyList+ , encodeBinaryPropertyList+ + , readBinaryPropertyListFromFile+ , writeBinaryPropertyListToFile+ -- * Parsing and formatting property lists using the XML format , readXmlPropertyList , showXmlPropertyList@@ -126,28 +129,37 @@ , module Data.PropertyList.KeyPath ) where +import Control.Exception (try, SomeException(..))+ import Data.PropertyList.Algebra+import Data.PropertyList.Binary import Data.PropertyList.Types import Data.PropertyList.Xml import Data.PropertyList.PropertyListItem import Data.PropertyList.KeyPath --- | Read a property list from a 'String', trying all supported property list formats.--- Presently, only the \"XML1\" format is supported. See also 'readXmlPropertyList'.-readPropertyList :: String -> Either String PropertyList-readPropertyList = readXmlPropertyList---- | Write a property list to a 'String', using a \"preferred\" property list format.--- Presently, that is the \"XML1\" format. See also 'showXmlPropertyList'.-showPropertyList :: PropertyList -> String-showPropertyList = showXmlPropertyList- -- | Read a property list from a file, trying all supported property list formats.--- Presently, only the \"XML1\" format is supported. See also--- 'readXmlPropertyListFromFile'.+-- Presently, the \"XML1\" and \"bplist00\" formats are supported. See also+-- 'readXmlPropertyListFromFile' and 'readBinaryPropertyListFromFile'. readPropertyListFromFile :: FilePath -> IO PropertyList-readPropertyListFromFile = readXmlPropertyListFromFile+readPropertyListFromFile file = do+ partial <- readPartial file+ case partial of+ Left xml -> completePropertyListByM barf xml+ Right bin -> completePropertyListByM barf bin+ where+ readPartial :: FilePath -> IO (Either+ (PartialPropertyList UnparsedXmlPlistItem)+ (PartialPropertyList UnparsedBPListRecord))+ readPartial file = do+ mbPartial <- try (readBinaryPartialPropertyListFromFile file)+ case mbPartial of+ Left SomeException{} -> fmap Left (readXmlPartialPropertyListFromFile file)+ Right bin -> return (Right bin)+ + barf :: Show a => a -> IO PropertyList+ barf unparsed = fail ("Unparseable item found: " ++ show unparsed) -- | Write a property list to a file, using a \"preferred\" property list format. -- Presently, that is the \"XML1\" format. See also 'writeXmlPropertyListToFile'.
src/Data/PropertyList/Algebra.hs view
@@ -1,8 +1,6 @@-{-# LANGUAGE - MultiParamTypeClasses, FunctionalDependencies,- TemplateHaskell,- FlexibleContexts- #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleContexts #-} -- |The internal \"algebraic\" interface for working with property-list-like -- things. The classes defined here are the basis for a very general system@@ -31,16 +29,13 @@ module Data.PropertyList.Algebra where import Control.Applicative-import Control.Monad.Identity+import Data.Functor.Identity+import Data.ByteString as B hiding (map) import Data.Foldable (Foldable(foldMap))-import Data.Traversable (Traversable(..))-import Data.Monoid--import Language.Haskell.TH.Fold (fold)- import qualified Data.Map as M-import Data.ByteString as B hiding (map)+import Data.Monoid import Data.Time+import Data.Traversable (Traversable(..)) -- * The signature type ('PropertyListS') @@ -92,7 +87,16 @@ -> (String -> t) -> (Bool -> t) -> PropertyListS a -> t-foldPropertyListS = $(fold ''PropertyListS)+foldPropertyListS plArray plData plDate plDict plReal plInt plString plBool pl =+ case pl of+ PLArray x -> plArray x+ PLData x -> plData x+ PLDate x -> plDate x+ PLDict x -> plDict x+ PLReal x -> plReal x+ PLInt x -> plInt x+ PLString x -> plString x+ PLBool x -> plBool x instance Functor PropertyListS where fmap f = foldPropertyListS (PLArray . fmap f) PLData PLDate (PLDict . fmap f) PLReal PLInt PLString PLBool
+ src/Data/PropertyList/Binary.hs view
@@ -0,0 +1,54 @@+module Data.PropertyList.Binary+ ( BPListHeader(..), BPListTrailer(..)+ , BPListRecord(..), BPListRecords(..)+ , readBPListRecords, putBPList+ + , Abs, Rel+ , linearize, delinearize, absolutize, intern+ + , UnparsedBPListRecord(..)+ , readBinaryPartialPropertyList+ , readBinaryPartialPropertyListFromFile+ + , readBinaryPropertyList+ , readBinaryPropertyListFromFile+ + , encodeBinaryPropertyList+ , writeBinaryPropertyListToFile+ ) where++import Control.Applicative+import Data.Serialize.Put+import qualified Data.ByteString.Lazy as BL+import Data.PropertyList.Types+import Data.PropertyList.Binary.Algebra ({- instances -})+import Data.PropertyList.Binary.Linearize+import Data.PropertyList.Binary.Get+import Data.PropertyList.Binary.Put+import Data.PropertyList.Binary.Types++readBinaryPartialPropertyList :: BL.ByteString -> Either String (PartialPropertyList UnparsedBPListRecord)+readBinaryPartialPropertyList bs = do+ delinearize <$> readBPListRecords bs++readBinaryPropertyList :: BL.ByteString -> Either String PropertyList+readBinaryPropertyList bs = do+ readBinaryPartialPropertyList bs >>= completePropertyListByM barf+ where barf unparsed = Left ("Unparseable item found: " ++ show unparsed) :: Either String PropertyList++readBinaryPropertyListFromFile :: FilePath -> IO PropertyList+readBinaryPropertyListFromFile path = do+ contents <- BL.readFile path+ either fail return (readBinaryPropertyList contents)++readBinaryPartialPropertyListFromFile :: FilePath -> IO (PartialPropertyList UnparsedBPListRecord)+readBinaryPartialPropertyListFromFile file = do+ bs <- BL.readFile file+ either fail return (readBinaryPartialPropertyList bs)++encodeBinaryPropertyList :: PropertyList -> BL.ByteString+encodeBinaryPropertyList = runPutLazy . putBPList . linearize++writeBinaryPropertyListToFile :: FilePath -> PropertyList -> IO ()+writeBinaryPropertyListToFile path = + BL.writeFile path . encodeBinaryPropertyList
+ src/Data/PropertyList/Binary/Algebra.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Data.PropertyList.Binary.Algebra where++import Data.Monoid+import Data.Functor.Identity+import Data.PropertyList.Algebra+import Data.PropertyList.Binary.Types+import Data.Sequence as S ((<|), (><))+import qualified Data.Sequence as S+import qualified Data.Map as M++instance PListAlgebra Identity (BPListRecords Rel) where+ plistAlgebra = BPListRecords 0 . flatten . runIdentity+ where+ indexFrom n [] = []+ indexFrom n (BPListRecords root recs : rest)+ = n + fromIntegral root : indexFrom (n + fromIntegral (S.length recs)) rest+ + flatten (PLArray xss)+ = BPLArray (indexFrom 1 xss)+ <| mconcat (map records xss)+ flatten (PLDict kvs)+ = BPLDict [1..nks] (indexFrom (nks+1) vss)+ <| S.fromList (map BPLString ks)+ >< mconcat (map records vss)+ where+ nks = fromIntegral (M.size kvs)+ ks = M.keys kvs+ vss = M.elems kvs+ flatten (PLData bs) = S.singleton (BPLData bs)+ flatten (PLDate t) = S.singleton (BPLDate t)+ flatten (PLReal r) = S.singleton (BPLReal r)+ flatten (PLInt i) = S.singleton (BPLInt i)+ flatten (PLString s) = S.singleton (BPLString s)+ flatten (PLBool b) = S.singleton (BPLBool b)++instance PListCoalgebra (Either UnparsedBPListRecord) (BPListRecords Abs) where+ plistCoalgebra (BPListRecords root recs) = fmap (fmap (flip BPListRecords recs)) (unpackRec root)+ where+ unpackRec i+ | fromIntegral i >= S.length recs+ = Left (MissingObjectRef i)+ | otherwise+ = case S.index recs (fromIntegral i) of+ BPLNull -> Left UnparsedNull+ BPLFill -> Left UnparsedFill+ BPLSet s -> Left (UnparsedSet s)+ BPLUID s -> Left (UnparsedUID s)+ BPLArray xs -> Right (PLArray xs)+ BPLData x -> Right (PLData x)+ BPLDate x -> Right (PLDate x)+ BPLDict ks vs -> do+ ks <- mapM (unpackStringOr (UnparsedDict ks vs)) ks+ return (PLDict (M.fromList (zip ks vs)))+ BPLReal x -> Right (PLReal x)+ BPLInt x -> Right (PLInt x)+ BPLString x -> Right (PLString x)+ BPLBool x -> Right (PLBool x)+ + unpackStringOr barf k = do+ key <- unpackRec k+ case key of+ PLString s -> Right s+ _ -> Left barf++-- To support smart-deconstructors:+instance PListCoalgebra Maybe (BPListRecords Abs) where+ plistCoalgebra + = either (const Nothing :: UnparsedBPListRecord -> Maybe t) Just+ . plistCoalgebra
+ src/Data/PropertyList/Binary/Float.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.PropertyList.Binary.Float+ ( doubleToWord64+ , word64ToDouble+ + , floatToWord32+ , word32ToFloat+ + , doubleToEquivalentFloat+ ) where++import Foreign+import GHC.Float++-- TODO: create a library or extend an existing one to include a module Data.Float.IEEE+-- which exports types Float32, Float64, etc., with proper IEEE-safe conversions+-- and C union-style conversions to corresponding Word types...++$( do+ let assertFloatProp :: (Monad m, Eq a) => String -> (Float -> a) -> a -> m ()+ assertFloatProp desc p x+ | p (undefined :: Float) == x = return ()+ | otherwise = fail desc+ + assertDoubleProp :: (Monad m, Eq a) => String -> (Double -> a) -> a -> m ()+ assertDoubleProp desc p x+ | p (undefined :: Double) == x = return ()+ | otherwise = fail desc+ + assertFloatProp "Float should ahdere to the IEEE-754 standard" + isIEEE True+ assertFloatProp "Float's size should be 32 bits"+ sizeOf 4+ assertFloatProp "Float should have a base-2 mantissa"+ floatRadix 2+ assertFloatProp "Float should have a 23-bit mantissa"+ floatDigits 24+ assertFloatProp "Float should have an 8-bit exponent"+ floatRange (-125, 128)+ + assertDoubleProp "Double should ahdere to the IEEE-754 standard" + isIEEE True+ assertDoubleProp "Double's size should be 64 bits"+ sizeOf 8+ assertDoubleProp "Double should have a base-2 mantissa"+ floatRadix 2+ assertDoubleProp "Double should have a 52-bit mantissa"+ floatDigits 53+ assertDoubleProp "Double should have an 11-bit exponent"+ floatRange (-1021, 1024)+ + return []+ )+ +{- NOINLINE doubleToWord64 -}+doubleToWord64 :: Double -> Word64+doubleToWord64 = unsafeConvertStorable++{- NOINLINE word64ToDouble -}+word64ToDouble :: Word64 -> Double+word64ToDouble = unsafeConvertStorable++{- NOINLINE floatToWord32 -}+floatToWord32 :: Float -> Word32+floatToWord32 = unsafeConvertStorable++{- NOINLINE word32ToFloat -}+word32ToFloat :: Word32 -> Float+word32ToFloat = unsafeConvertStorable++{-# INLINE unsafeConvertStorable #-}+unsafeConvertStorable :: (Storable a, Storable b) => a -> b+unsafeConvertStorable x = unsafePerformIO $ + alloca $ \p -> do+ poke (castPtr p) x+ peek p++doubleToEquivalentFloat :: Double -> Maybe Float+doubleToEquivalentFloat d+ -- just check strict equality; if d is NaN, don't convert it+ -- (in case the NaN has an important payload)+ | d == d' = Just f+ | otherwise = Nothing+ where+ f = double2Float d+ d' = float2Double f
+ src/Data/PropertyList/Binary/Get.hs view
@@ -0,0 +1,211 @@+module Data.PropertyList.Binary.Get where++import Control.Applicative+import Control.Monad+import Control.Monad.Trans.Error ({- instance Monad (Either a) -})+import Data.Bits+import qualified Data.ByteString.Char8 as BSC8+import qualified Data.ByteString.Lazy as BL+import Data.PropertyList.Binary.Float+import Data.PropertyList.Binary.Types+import Data.Serialize.Get+import qualified Data.Sequence as Seq+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Time+import qualified Data.Vector.Unboxed as V+import Data.Word+import GHC.Float++rawBPList bs = do+ let headerBS = BL.take 8 bs+ header@(BPListHeader version) <- runGetLazy bplistHeader headerBS+ when (version .&. 0xff00 /= 0x3000) $+ Left "Unsupported bplist version"+ + let trailerBS = BL.drop (BL.length bs - bplistTrailerBytes) bs+ trailer <- runGetLazy bplistTrailer trailerBS+ + --TODO: sanity checks+ let nOffsets :: Num a => a+ nOffsets = fromIntegral (numObjects trailer)+ bytesPerOffset = fromIntegral (offsetIntSize trailer)+ offsetsBS+ = BL.take (nOffsets * fromIntegral bytesPerOffset)+ . BL.drop (fromIntegral (offsetTableOffset trailer))+ $ bs+ offsets <- runGetLazy (replicateM nOffsets (sizedInt bytesPerOffset)) offsetsBS+ + return (RawBPList bs header (V.fromList offsets) trailer)++readBPListRecords :: BL.ByteString -> Either String (BPListRecords Abs)+readBPListRecords bs = do+ raw <- rawBPList bs+ let tlr = rawTrailer raw+ ct = numObjects tlr+ root = topObject tlr+ recs <- mapM (getBPListRecord raw) [0 .. ct - 1]+ return (BPListRecords root (Seq.fromList recs))++getBPListRecord (RawBPList bs _hdr offsets tlr) objNum+ | objNum >= 0 && fromIntegral objNum < V.length offsets+ = runGetLazy (bplistRecord objRef) (BL.drop (fromIntegral (offsets V.! fromIntegral objNum)) bs)+ + | otherwise = Left "getBPListRecord: index out of range"+ where+ objRef = sizedInt (fromIntegral (objectRefSize tlr))++asciiString str = do+ let bs = BSC8.pack str+ bs' <- getByteString (BSC8.length bs)+ if (bs == bs') + then return ()+ else fail ("Expecting " ++ show str)++bplistHeaderBytes = 8+bplistHeader = do+ asciiString "bplist"+ BPListHeader <$> getWord16be++bplistTrailerBytes = 32+bplistTrailer =+ const BPListTrailer+ <$> skip 5 -- _unused+ <*> getWord8 -- sortVersion+ <*> getWord8 -- offsetIntSize+ <*> getWord8 -- objectRefSize+ <*> getWord64be -- numObjects+ <*> getWord64be -- topObject+ <*> getWord64be -- offsetTableOffset++bplistRecord ref = msum+ [ const BPLNull <$> bplNull+ , BPLBool <$> bplTrue+ , BPLBool <$> bplFalse+ , const BPLFill <$> bplFill+ , BPLInt <$> bplInt+ , BPLReal <$> bplFloat32+ , BPLReal <$> bplFloat64+ , BPLDate <$> bplDate+ , BPLData <$> bplData+ , BPLString <$> bplASCII+ , BPLString <$> bplUTF16+ , BPLUID <$> bplUID+ , BPLArray <$> bplArray ref+ , BPLSet <$> bplSet ref+ , uncurry BPLDict <$> bplDict ref+ ]++word8 b = do+ b' <- getWord8+ if b == b'+ then return b+ else fail ("expecting " ++ show b)++bplNull = word8 0x00+bplTrue = word8 0x08 >> return False+bplFalse = word8 0x09 >> return True+bplFill = word8 0x0f+bplInt = do+ sz <- shiftL 1 . fromIntegral <$> halfByte 0x1+ i <- sizedInt sz+ return (interpretBPLInt sz i)+bplFloat32 = do+ word8 0x22+ float2Double <$> getFloat32be+bplFloat64 = do+ word8 0x23+ getFloat64be+bplDate = do+ word8 0x33+ interpretBPLDate . word64ToDouble <$> getWord64be+bplData = do+ sz <- markerAndSize 0x4+ getByteString sz+bplASCII = do+ sz <- markerAndSize 0x5+ BSC8.unpack <$> getByteString sz+bplUTF16 = do+ sz <- markerAndSize 0x6+ Text.unpack . Text.decodeUtf16BE <$> getByteString (2*sz)+bplUID = do+ sz <- fmap (1+) (halfByte 0x8)+ sizedInt (fromIntegral sz)+bplArray ref = do+ sz <- markerAndSize 0xA+ replicateM sz ref+bplSet ref = do+ sz <- markerAndSize 0xC+ replicateM sz ref+bplDict ref = do+ sz <- markerAndSize 0xD+ ks <- replicateM sz ref+ vs <- replicateM sz ref+ return (ks, vs)++halfByte x = do+ marker <- getWord8+ if marker `shiftR` 4 == x+ then return (marker .&. 0x0f)+ else fail ("expecting marker " ++ show x)+markerAndSize x = do+ marker <- halfByte x+ case marker of+ 0xf -> do+ intSz <- shiftL 1 . fromIntegral <$> halfByte 0x1+ sizedInt intSz+ _ -> return (fromIntegral marker)++sizedInt :: (Integral i, Bits i) => Word -> Get i+sizedInt 0 = return 0+sizedInt 1 = fromIntegral <$> getWord8+sizedInt 2 = fromIntegral <$> getWord16be+sizedInt 4 = fromIntegral <$> getWord32be+sizedInt 8 = fromIntegral <$> getWord64be+sizedInt n+ | n < 0 = fail ("sizedInt: negative size: " ++ show n)+ | otherwise = do+ let a = n `shiftR` 1; b = n - a+ x <- sizedInt a+ y <- sizedInt b+ return ((x `shiftL` (fromIntegral b * 8)) .|. y)++-- CFBinaryPList.c says:+{-+ // in format version '00', 1, 2, and 4-byte integers have to be interpreted as unsigned,+ // whereas 8-byte integers are signed (and 16-byte when available)+ // negative 1, 2, 4-byte integers are always emitted as 8 bytes in format '00'+ // integers are not required to be in the most compact possible representation, but only the last 64 bits are significant currently+-}+interpretBPLInt :: Word -> Integer -> Integer+interpretBPLInt sz i+ | isSigned && testBit i signBit = i - bit nBits+ | otherwise = i+ where+ isSigned = sz >= 8+ nBits = fromIntegral sz * 8+ signBit = nBits - 1++-- http://developer.apple.com/library/mac/#documentation/CoreFoundation/Reference/CFDateRef/Reference/reference.html +-- says:+{-+ Absolute time is measured in seconds relative to the absolute reference+ date of Jan 1 2001 00:00:00 GMT. A positive value represents a date+ after the reference date, a negative value represents a date before it.+ For example, the absolute time -32940326 is equivalent to December 16th,+ 1999 at 17:54:34.+ -}+interpretBPLDate :: Double -> UTCTime+interpretBPLDate sec = addUTCTime (realToFrac sec) epoch+ where+ epoch = UTCTime (fromGregorian 2001 1 1) 0++getFloat32be :: Get Float+getFloat32be = do+ d <- getWord32be+ return $! word32ToFloat d++getFloat64be :: Get Double+getFloat64be = do+ d <- getWord64be+ return $! word64ToDouble d
+ src/Data/PropertyList/Binary/Linearize.hs view
@@ -0,0 +1,64 @@+module Data.PropertyList.Binary.Linearize+ ( linearize+ , absolutize+ , intern+ , delinearize+ ) where++import qualified Data.Foldable as F+import qualified Data.Map as M+import Data.Maybe+import Data.PropertyList.Types+import Data.PropertyList.Algebra+import Data.PropertyList.Binary.Algebra ({- instances-})+import Data.PropertyList.Binary.Types+import Data.Sequence as S+import Prelude as P++-- |Flatten a 'PropertyList' to a sequence of 'BPListRecords'. The resulting records will+-- use absolute addressing and will not have any duplicates.+linearize :: PropertyList -> BPListRecords Abs+linearize = intern . absolutize . fromPlist++-- |Take some 'BPListRecords' using relative addressing and change them to use absolute addressing+absolutize :: BPListRecords Rel -> BPListRecords Abs+absolutize (BPListRecords root recs) =+ BPListRecords root (S.mapWithIndex shiftRec recs)+ where+ shiftRec i = mapObjRefs (fromIntegral i +)++-- |Take some 'BPListRecords' using absolute addressing and eliminate +-- all duplicate records, compact the table and update all internal+-- references.+--+-- Does not necessarily yield a totally deduplicated table; The process+-- of interning can introduce duplicate records (because it alters arrays,+-- dicts and sets). All other node types will be deduplicated in one pass,+-- though, which is usually sufficient.+intern :: BPListRecords Abs -> BPListRecords Abs+intern (BPListRecords root recs) = BPListRecords (reloc root) recs'+ where+ reloc i'+ | i < 0 || i >= n = error ("intern: reference out of bounds: " ++ show i)+ | otherwise = S.index relocs i+ where i = fromIntegral i'; n = S.length recs+ + (_, relocs, recs') =+ F.foldl updateRec (M.empty, S.empty, S.empty) recs+ + updateRec (index, relocs, recs) x = + case M.lookup x index of+ Nothing -> + let nRecs = fromIntegral (S.length recs)+ in ( M.insert x nRecs index+ , relocs |> nRecs+ , recs |> mapObjRefs reloc x+ )+ Just loc ->+ ( index, relocs |> loc, recs)++-- TODO: check for cycles?+-- |Reconstruct a property list from a collection of 'BPListRecords'+delinearize :: BPListRecords Abs -> PartialPropertyList UnparsedBPListRecord+delinearize = toPlist+
+ src/Data/PropertyList/Binary/Put.hs view
@@ -0,0 +1,184 @@+module Data.PropertyList.Binary.Put where++import Control.Monad+import Data.Serialize.Put+import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC8+import Data.Char+import Data.Foldable (toList)+import Data.PropertyList.Binary.Float+import Data.PropertyList.Binary.Types+import qualified Data.Sequence as Seq+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Data.Time+import Data.Word++withSize putThing = do+ let thing = runPut putThing+ putByteString thing+ return $! (fromIntegral (BS.length thing) :: Word64)++unsnoc [] = error "unsnoc: empty list"+unsnoc [x] = ([], x)+unsnoc (x:xs) = let ~(ys, y) = unsnoc xs in (x:ys, y)++putBPList (BPListRecords root recs) = do+ let header = bplist00hdr+ nObjs = Seq.length recs+ objRefSz = unsignedSz nObjs+ putObjRef = putSizedInt objRefSz+ + putBPListHeader header+ recSizes <- mapM (withSize . putBPListRecord putObjRef) (toList recs)+ + let (offsets, offsetTblLoc) = unsnoc (scanl (+) 8 recSizes)+ offsetSz = unsignedSz (offsetTblLoc)+ putOffset = putSizedInt (fromIntegral offsetSz)+ + trailer = BPListTrailer + { sortVersion = 0+ , offsetIntSize = fromIntegral offsetSz+ , objectRefSize = fromIntegral objRefSz+ , numObjects = fromIntegral nObjs+ , topObject = root+ , offsetTableOffset = offsetTblLoc+ }+ + mapM_ putOffset offsets+ putBPListTrailer trailer+++putBPListHeader (BPListHeader v) = do+ putByteString (BSC8.pack "bplist")+ putWord16be v++putBPListTrailer tlr = do+ replicateM 5 (putWord8 0x00)+ putWord8 (sortVersion tlr)+ putWord8 (offsetIntSize tlr)+ putWord8 (objectRefSize tlr)+ putWord64be (numObjects tlr)+ putWord64be (topObject tlr)+ putWord64be (offsetTableOffset tlr)++putBPListRecord putRef BPLNull = putWord8 0x00+putBPListRecord putRef BPLFill = putWord8 0x0f+putBPListRecord putRef (BPLArray xs) = do+ putMarkerWithSize 0xA (length xs)+ mapM_ putRef xs+putBPListRecord putRef (BPLSet xs) = do+ putMarkerWithSize 0xC (length xs)+ mapM_ putRef xs+putBPListRecord putRef (BPLData x) = do+ putMarkerWithSize 0x4 (BS.length x)+ putByteString x+putBPListRecord putRef (BPLDate x) = do+ putWord8 0x33+ putBPLDate x+putBPListRecord putRef (BPLDict ks vs) + | nks /= nvs = fail "putBPListRecord: BPLDict has different number of keys and values"+ | otherwise = do+ putMarkerWithSize 0xD nks+ mapM_ putRef ks+ mapM_ putRef vs+ where nks = length ks; nvs = length vs+putBPListRecord putRef (BPLReal x) = do+ case doubleToEquivalentFloat x of+ Just f -> do+ putWord8 0x22+ putFloat32be f+ Nothing -> do+ putWord8 0x23+ putFloat64be x+putBPListRecord putRef (BPLInt x) = putInt x+putBPListRecord putRef (BPLString x) = putString x+putBPListRecord putRef (BPLUID x) = putUID x+putBPListRecord putRef (BPLBool False) = putWord8 0x08+putBPListRecord putRef (BPLBool True) = putWord8 0x09++putMarkerWithPayload x payload = putWord8 ((x `shiftL` 4) .|. payload)+putMarkerWithSize x sz+ | sz < 0x0f = do+ putMarkerWithPayload x (fromIntegral sz)+ | otherwise = do+ putMarkerWithPayload x 0x0f+ putInt (fromIntegral sz)++putInt n+ | tag < 0 = fail "putInt: internal error - size is negative"+ | tag <= 0xf = do+ putMarkerWithPayload 0x1 (fromIntegral tag)+ putSizedInt nBytes n+ | otherwise = fail "putInt: Integer too large to encode in a bplist00"+ where (tag, nBytes) = plIntSz n++putSizedInt 0 _ = return ()+putSizedInt 1 i = putWord8 (fromIntegral i)+putSizedInt 2 i = putWord16be (fromIntegral i)+putSizedInt 4 i = putWord32be (fromIntegral i)+putSizedInt 8 i = putWord64be (fromIntegral i)+putSizedInt n i+ | n < 0 = fail "putSizedInt: size is negative"+ | otherwise = do+ let a = n `shiftR` 1; b = n - a+ putSizedInt a (shiftR i (shiftL b 3))+ putSizedInt b i++-- tag and power-of-two number of bytes needed to represent 'n' +-- as an int. If the type is bounded, then this logic works for +-- negative numbers as well (works for positive but not negative +-- 'Integer's)+wordLgSz n = go 0 8 0xff+ where+ go lgSz nBits mask+ | n .&. mask == n = (lgSz, shiftR nBits 3)+ | otherwise = ((go $! lgSz+1) $! shiftL nBits 1) $! (shiftL mask nBits .|. mask)++-- tag and power-of-two number of bytes needed to represent 'n' as a+-- 2s-complement signed int+intLgSz n+ | n >= 0 = wordLgSz (2 * n)+ | otherwise = wordLgSz (2 * negate (n+1))++-- tag and number of bytes needed to represent 'n' as a bplist00 int, +-- which is has 2^tag bytes and is signed iff it has 8 or more bytes.+plIntSz :: Integer -> (Int, Int)+plIntSz n+ | n < 0 = max (3,8) (intLgSz n)+ | n < bit 63 = wordLgSz n+ | otherwise = intLgSz n++putBPLDate utcDate = putFloat64be (realToFrac (diffUTCTime utcDate epoch))+ where+ epoch = UTCTime (fromGregorian 2001 1 1) 0++putString str+ | all isAscii str = do+ putMarkerWithSize 0x5 (length str)+ putByteString (BSC8.pack str)+ | otherwise = do+ let utf16 = Text.encodeUtf16BE (Text.pack str)+ putMarkerWithSize 0x6 (BS.length utf16 `shiftR` 1)+ putByteString utf16+++putUID i + | sz > maxNBytes = fail ("putUID: UID is too large (it would require " ++ show sz ++ " bytes to encode, but the bplist00 format only supports " ++ show maxNBytes ++ ")")+ | otherwise = do+ putMarkerWithSize 0x8 (sz-1)+ putSizedInt sz i+ where+ sz = unsignedSz i+ maxNBytes = 16++-- return the number of bytes required to represent an unsigned value. Always returns at least 1.+unsignedSz n = go 1 0xff+ where+ go nBytes mask+ | n .&. mask == n = nBytes+ | otherwise = (go $! (nBytes + 1)) $! (shiftL mask 8 .|. mask)++putFloat32be x = putWord32be $! floatToWord32 x+putFloat64be x = putWord64be $! doubleToWord64 x
+ src/Data/PropertyList/Binary/Types.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE EmptyDataDecls #-}+module Data.PropertyList.Binary.Types where++import qualified Data.ByteString as BS (ByteString)+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Sequence (Seq)+import Data.Time (UTCTime)+import Data.Vector.Unboxed (Vector)+import Data.Word++data BPListRecord+ = BPLNull+ | BPLFill+ | BPLArray [Word64]+ | BPLSet [Word64]+ | BPLData BS.ByteString+ | BPLDate UTCTime+ | BPLDict [Word64] [Word64]+ | BPLReal Double+ | BPLInt Integer+ | BPLString String+ | BPLUID Integer+ | BPLBool Bool+ deriving (Eq, Ord, Show)++mapObjRefs :: (Word64 -> Word64) -> BPListRecord -> BPListRecord+mapObjRefs f (BPLArray xs) = BPLArray (map f xs)+mapObjRefs f (BPLSet xs) = BPLSet (map f xs)+mapObjRefs f (BPLDict ks vs) = BPLDict (map f ks) (map f vs)+mapObjRefs f other = other++data UnparsedBPListRecord+ = UnparsedNull+ | UnparsedFill+ | MissingObjectRef Word64+ | UnparsedDict [Word64] [Word64]+ | UnparsedSet [Word64]+ | UnparsedUID Integer+ deriving (Eq, Ord, Show)++data Abs+data Rel+data BPListRecords mode = BPListRecords+ { rootObject :: Word64+ , records :: Seq BPListRecord+ } deriving (Eq, Ord, Show)++data RawBPList = RawBPList+ { rawFile :: BL.ByteString+ , rawHeader :: BPListHeader+ , rawOffsets :: Vector Word64+ , rawTrailer :: BPListTrailer+ } deriving (Eq, Ord, Show)++newtype BPListHeader = BPListHeader+ { bplistVersion :: Word16+ } deriving (Eq, Ord, Show)+bplist00hdr = BPListHeader 0x3030++data BPListTrailer = BPListTrailer+ { sortVersion :: !Word8+ , offsetIntSize :: !Word8+ , objectRefSize :: !Word8+ , numObjects :: !Word64+ , topObject :: !Word64+ , offsetTableOffset :: !Word64+ } deriving (Eq, Ord, Show)
src/Data/PropertyList/KeyPath.hs view
@@ -1,19 +1,15 @@-{-# LANGUAGE- ViewPatterns- #-} module Data.PropertyList.KeyPath ( alterItemAtKeyPathM, alterItemAtKeyPath , getItemAtKeyPath, setItemAtKeyPath ) where +import Control.Monad+import Control.Monad.Trans.State+import Data.Functor.Identity+import qualified Data.Map as M import Data.PropertyList.Algebra-import Data.PropertyList.Types (PropertyList) import Data.PropertyList.PropertyListItem--import qualified Data.Map as M--import Control.Monad.Identity-import Control.Monad.State+import Data.PropertyList.Types (PropertyList) -- |Alter a @'Maybe' 'PropertyList'@, viewing it as an instance of 'PropertyListItem' -- and re-synthesizing it from a (possibly different) instance of 'PropertyListItem'.@@ -75,13 +71,14 @@ (Monad m, PropertyListItem i, PropertyListItem i') => String -> (Maybe i -> m (Maybe i')) -> Maybe PropertyList -> m (Maybe PropertyList)-tryAlterDictionaryEntryM k f Nothing = do- d' <- alterDictionaryEntryM k f Nothing- return (fmap plDict d')-tryAlterDictionaryEntryM k f (Just (fromPlDict -> Just d)) = do- d' <- alterDictionaryEntryM k f (Just d)- return (fmap plDict d')-tryAlterDictionaryEntryM k f other = fail "Key path tries to pass through non-dictionary thing."+tryAlterDictionaryEntryM k f mbPl = + case fmap fromPlDict mbPl of+ -- outer 'Maybe' is 'Just' if a plist was provided, + -- inner is 'Just' if that plist is a dictionary.+ Just (Just d) -> alterDict (Just d)+ Nothing -> alterDict Nothing+ Just Nothing -> fail "Key path tries to pass through non-dictionary thing."+ where alterDict = liftM (fmap plDict) . alterDictionaryEntryM k f -- |@alterItemAtKeyPathM path f@ applies the function @f@ deep inside the -- 'PropertyList' on the property list item at the given key-path @path@
src/Data/PropertyList/PropertyListItem.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses,- TypeSynonymInstances, FlexibleInstances, TemplateHaskell, CPP, ViewPatterns@@ -11,24 +10,23 @@ import Language.Haskell.TH import Language.Haskell.TH.Syntax-import Language.Haskell.TH.Fold import Data.PropertyList.Algebra import Data.PropertyList.Types import qualified Data.Map as M-import Data.ByteString (ByteString)-import qualified Data.ByteString.Lazy as Lazy (ByteString)-import Data.ByteString.Class+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL import Data.Time import Data.Char import Data.Int+import qualified Data.Text as Text import Data.Word -import Text.XML.HaXml.OneOfN+import Data.OneOfN import Control.Monad-import Control.Monad.Identity+import Data.Functor.Identity import qualified Data.Traversable as Traversable import Data.Generics @@ -48,6 +46,11 @@ (i, 0) -> Just i _ -> Nothing +toStrictByteString :: BL.ByteString -> BS.ByteString+toStrictByteString = BS.concat . BL.toChunks+toLazyByteString :: BS.ByteString -> BL.ByteString+toLazyByteString = BL.fromChunks . return+ -- |A class for items which can be converted to and from property lists. This -- is more general than 'PListAlgebra' and 'PListCoalgebra', in that it allows -- for transformations that are not primitive-recursive. This relaxation is@@ -94,16 +97,16 @@ toPropertyList = id fromPropertyList = Just -instance PropertyListItem ByteString where+instance PropertyListItem BS.ByteString where toPropertyList = plData fromPropertyList (fromPlData -> Just x) = Just x- fromPropertyList (fromPlString -> Just x) = Just (toStrictByteString x)+-- fromPropertyList (fromPlString -> Just x) = Just (toStrictByteString x) fromPropertyList _ = Nothing -instance PropertyListItem Lazy.ByteString where+instance PropertyListItem BL.ByteString where toPropertyList = plData . toStrictByteString fromPropertyList (fromPlData -> Just x) = Just (toLazyByteString x)- fromPropertyList (fromPlString -> Just x) = Just (toLazyByteString x)+-- fromPropertyList (fromPlString -> Just x) = Just (toLazyByteString x) fromPropertyList _ = Nothing instance PropertyListItem UTCTime where@@ -163,13 +166,17 @@ listToPropertyList = plString listFromPropertyList (fromPlString -> Just x) = Just x- listFromPropertyList (fromPlData -> Just x) = Just (fromStrictByteString x)+-- listFromPropertyList (fromPlData -> Just x) = Just (fromStrictByteString x) listFromPropertyList (fromPlBool -> Just True) = Just "YES" listFromPropertyList (fromPlBool -> Just False) = Just "NO" listFromPropertyList (fromPlInt -> Just i) = Just (show i) listFromPropertyList (fromPlReal -> Just d) = Just (show d) listFromPropertyList other = Nothing +instance PropertyListItem Text.Text where+ toPropertyList = toPropertyList . Text.unpack+ fromPropertyList = fmap Text.pack . fromPropertyList+ instance PropertyListItem Bool where toPropertyList = plBool fromPropertyList (fromPlBool -> Just d) = Just d@@ -184,7 +191,7 @@ -- (N in [2..20]), an instance of the form: -- -- instance (PropertyListItem a, PropertyListItem b, PropertyListItem c) => PropertyListItem (OneOf3 a b c) where--- toPropertyList = $(fold ''OneOf3) toPropertyList toPropertyList toPropertyList+-- toPropertyList = oneOf3 toPropertyList toPropertyList toPropertyList -- fromPropertyList pl = msum [ fmap OneOf3 (fromPropertyList pl) -- , fmap TwoOf3 (fromPropertyList pl) -- , fmap ThreeOf3 (fromPropertyList pl)@@ -220,6 +227,8 @@ , funD 'fromPropertyList [clause [varP pl] (normalB fromPLbody) []] ] + lcFirst (c:cs) = toLower c : cs+ fold = varE . mkName . lcFirst . nameBase toPLbody = appsE (fold typeName : map (const (varE 'toPropertyList)) conNames) fromPLbody = appE (varE 'msum) $ listE [ [| fmap $(conE con) (fromPropertyList $(varE pl)) |]
src/Data/PropertyList/Types.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses,- FlexibleContexts, FlexibleInstances, IncoherentInstances,- GeneralizedNewtypeDeriving+ FlexibleContexts, FlexibleInstances,+ GeneralizedNewtypeDeriving, TypeFamilies #-} -- |This module implements the 'PropertyList' and 'PartialPropertyList' types@@ -30,14 +30,12 @@ import Control.Applicative (Applicative(..)) import Data.Functor.Foldable (Fix(..))-import Data.Pointed (Pointed(..))-import Data.Copointed (Copointed(..))+import qualified Data.Functor.Foldable as RS import Control.Monad (liftM) import Control.Monad.Free (Free(..))-import Control.Monad.Identity (Identity(..))+import Data.Functor.Identity (Identity(..)) import Data.Foldable (Foldable) import Data.Traversable (Traversable(traverse), mapM)-import Data.Void (Void, absurd) import Unsafe.Coerce (unsafeCoerce) {- used _only_ to eliminate fmap traversals for newtype constructors -} @@ -63,19 +61,30 @@ PLString str -> showString "plString " . showsPrec 11 str PLBool bool -> showString "plBool " . showsPrec 11 bool -instance (Functor f, Copointed f) => PListAlgebra f PropertyList where- {-# SPECIALIZE instance PListAlgebra Identity PropertyList #-}- plistAlgebra = PL . Fix . fmap unPL . copoint+type instance RS.Base PropertyList = PropertyListS+instance RS.Foldable PropertyList where+ project = runIdentity . plistCoalgebra+instance RS.Unfoldable PropertyList where+ embed = plistAlgebra . Identity +inPL :: PropertyListS PropertyList -> PropertyList+inPL = PL . Fix . fmap unPL++outPL :: PropertyList -> PropertyListS PropertyList+outPL = fmap PL . outF . unPL+ where outF (Fix x) = x++instance PListAlgebra Identity PropertyList where+ plistAlgebra = inPL . runIdentity+ instance PListCoalgebra Identity a => PListAlgebra (Either a) PropertyList where plistAlgebra = either toPlist (plistAlgebra . Identity) instance InitialPList Identity PropertyList -instance (Functor f, Pointed f) => PListCoalgebra f PropertyList where+instance Applicative f => PListCoalgebra f PropertyList where {-# SPECIALIZE instance PListCoalgebra Identity PropertyList #-}- plistCoalgebra = point . fmap PL . outF . unPL- where outF (Fix x) = x+ plistCoalgebra = pure . outPL instance TerminalPList Identity PropertyList @@ -90,9 +99,6 @@ #-} -instance Pointed PartialPropertyList where- point = PPL . Pure- -- | [internal] 'Free' constructor specialized to 'PartialPropertyList'. -- 'point'/'pure'/'return' is the corresponding 'Pure' constructor. inPPL :: PropertyListS (PartialPropertyList a) -> PartialPropertyList a@@ -114,20 +120,14 @@ -- instance Read... --- this instance overlaps (with incoherence allowed) with all --- others for PartialPropertyList: ensure that you don't define --- an explicit instance for any 'Copointed' functor!-instance (Functor f, Copointed f) => PListAlgebra f (PartialPropertyList a) where- {-# SPECIALIZE instance PListAlgebra Identity (PartialPropertyList a) #-}- plistAlgebra = inPPL . copoint+instance PListAlgebra Identity (PartialPropertyList a) where+ plistAlgebra = inPPL . runIdentity instance PListAlgebra Maybe (PartialPropertyList ()) where- plistAlgebra Nothing = point ()- plistAlgebra (Just x) = inPPL x+ plistAlgebra = maybe (pure ()) inPPL instance PListAlgebra (Either a) (PartialPropertyList a) where- plistAlgebra (Left x) = point x- plistAlgebra (Right x) = inPPL x+ plistAlgebra = either pure inPPL instance InitialPList (Either a) (PartialPropertyList a) where @@ -178,7 +178,3 @@ completePropertyListByM :: (Monad m, PListCoalgebra Identity b) => (a -> m b) -> PartialPropertyList a -> m PropertyList completePropertyListByM f = liftM completePropertyList . Data.Traversable.mapM f---- instance for Void to allow it to be used as @a@ in 'completePropertyList':-instance Functor f => PListCoalgebra f Void where- plistCoalgebra = absurd
src/Data/PropertyList/Xml.hs view
@@ -1,16 +1,7 @@-{-# LANGUAGE- FlexibleContexts- #-}+{-# LANGUAGE FlexibleContexts #-} module Data.PropertyList.Xml- ( Plist- , readXmlPlist, showXmlPlist- , readXmlPlistFromFile, writeXmlPlistToFile- - , PlistItem- , plistToPlistItem, plistItemToPlist- - , UnparsedPlistItem(..)- , unparsedPlistItemToPlistItem+ ( UnparsedXmlPlistItem(..)+ , unparsedXmlPlistItemToElement , readXmlPropertyList, readXmlPropertyListFromFile @@ -19,88 +10,74 @@ ) where -import Data.Copointed+import Control.Monad.Trans.Error ({- instance Monad (Either a) -}) import Data.PropertyList.Algebra import Data.PropertyList.Types-import Data.PropertyList.Xml.Parse-import Data.PropertyList.Xml.Types--import Control.Monad.Error ({- instance Monad (Either String) -})---- * Reading and writing XML 'Plist's from files---- |Try to parse a 'Plist' from an XML property-list file.-readXmlPlistFromFile :: FilePath -> IO (Either String Plist)-readXmlPlistFromFile path = do- contents <- readFile path- return (readXmlPlist contents)---- |Try to write a 'Plist' to an XML property-list file.-writeXmlPlistToFile :: FilePath -> Plist -> IO ()-writeXmlPlistToFile path plist = do- writeFile path (showXmlPlist plist)-+import Data.PropertyList.Xml.Algebra+import Text.XML.Light -- * Reading and writing XML 'PartialPropertyList's and 'PropertyList's from 'String's --- |Read an XML propertylist from a 'String' in the xml1 plist format to a--- propertylist type which is terminal for the liftings supported by--- 'PlistItem' (such as @'PartialPropertyList' 'UnparsedPlistItem'@--- or @'PartialPropertyList' 'PlistItem'@).-readXmlPartialPropertyList :: (PListCoalgebra f PlistItem, TerminalPList f pl) => String -> Either String pl-readXmlPartialPropertyList = fmap (toPlist . plistToPlistItem) . readXmlPlist+-- |Read an XML property list from a 'String' in the xml1 plist format, leaving +-- unparseable elements in the tree.+readXmlPartialPropertyList :: String -> Either String (PartialPropertyList UnparsedXmlPlistItem)+readXmlPartialPropertyList str = case parseXMLDoc str of+ Just e@(Element (QName "plist" _ _) _ content _) ->+ let v = plistVersion e+ in if v == "1.0"+ then case onlyElems content of+ [root] -> Right (toPlist root)+ _ -> Left "plist element must have exactly one child element"+ else Left ("plist version " ++ show v ++ " is not supported")+ Just e -> Right (toPlist e)+ Nothing -> Left "not an XML document"+ where+ plistVersion = maybe "1.0" id . findAttrBy isVersion+ + isVersion (QName "version" _ _) = True+ isVersion _ = False -- |Read a property list from a 'String' in the xml1 format. If parsing -- fails, returns a description of the problem in the 'Left' result.-readXmlPropertyList :: FilePath -> Either String PropertyList-readXmlPropertyList str = do- x <- readXmlPartialPropertyList str :: Either String (PartialPropertyList UnparsedPlistItem)- completePropertyListByM (\unparsed -> Left ("Unparseable item found: " ++ show unparsed) :: Either String PropertyList) x----readXmlPropertyList :: String -> PropertyList---readXmlPropertyList--- = runIdentity--- . completePropertyListByM (\_ -> fail "parse error" :: Identity PropertyList)--- . either error id--- . (readXmlPartialPropertyList :: String -> Either String (PartialPropertyList UnparsedPlistItem))+readXmlPropertyList :: String -> Either String PropertyList+readXmlPropertyList str+ = readXmlPartialPropertyList str + >>= completePropertyListByM barf+ where barf unparsed = Left ("Unparseable item found: " ++ show unparsed) :: Either String PropertyList -- |Render a propertylist to a 'String' in the xml1 plist format from any -- initial propertylist type (which includes 'PropertyList', @'PartialPropertyList' -- 'UnparsedPlistItem'@, and @'PartialPropertyList' 'PlistItem'@).-showXmlPropertyList :: (InitialPList f pl, Functor f, Copointed f) => pl -> String-showXmlPropertyList- = showXmlPlist- . plistItemToPlist- . fromPlist-+showXmlPropertyList :: (InitialPList f pl, PListAlgebra f Element) => pl -> String+showXmlPropertyList = ppTopElement . plist1element . fromPlist+ where+ version1attr = Attr (unqual "version") "1.0"+ plist1element :: Element -> Element+ plist1element root = unode "plist" (version1attr, root)+ -- * Reading and writing XML 'PartialPropertyList's and 'PropertyList's from files -- |Read an XML propertylist from a file in the xml1 plist format to a--- propertylist type which is terminal for the liftings supported by--- 'PlistItem' (such as @'PartialPropertyList' 'UnparsedPlistItem'@--- or @'PartialPropertyList' 'PlistItem'@).+-- partial propertylist which is structurally sound but may contain some +-- unparseable nodes. readXmlPartialPropertyListFromFile- :: (PListCoalgebra f PlistItem, TerminalPList f pl) =>- FilePath -> IO (Either String pl)+ :: FilePath -> IO (PartialPropertyList UnparsedXmlPlistItem) readXmlPartialPropertyListFromFile file = do- x <- readXmlPlistFromFile file- return (fmap (toPlist . plistToPlistItem) x)+ x <- readFile file+ either fail return (readXmlPartialPropertyList x) -- |Read a property list from a file in the xml1 format. If parsing fails, -- calls 'fail'. readXmlPropertyListFromFile :: FilePath -> IO PropertyList readXmlPropertyListFromFile file = do- x <- readXmlPartialPropertyListFromFile file :: IO (Either String (PartialPropertyList UnparsedPlistItem))- y <- either fail return x- completePropertyListByM (\unparsed -> fail ("Unparseable item found: " ++ show unparsed) :: IO PropertyList) y+ x <- readFile file+ either fail return (readXmlPropertyList x) -- |Output a propertylist to a file in the xml1 plist format from any -- initial propertylist type (which includes 'PropertyList', @'PartialPropertyList' -- 'UnparsedPlistItem'@, and @'PartialPropertyList' 'PlistItem'@).-writeXmlPropertyListToFile- :: (InitialPList f pl, Functor f, Copointed f) =>- FilePath -> pl -> IO ()-writeXmlPropertyListToFile file plist = do- writeXmlPlistToFile file (plistItemToPlist (fromPlist plist))+writeXmlPropertyListToFile :: FilePath -> PropertyList -> IO ()+writeXmlPropertyListToFile file plist =+ writeFile file (showXmlPropertyList plist)
+ src/Data/PropertyList/Xml/Algebra.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+module Data.PropertyList.Xml.Algebra+ ( UnparsedXmlPlistItem(..)+ , unparsedXmlPlistItemToElement+ ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC8+import qualified Data.ByteString.Base64 as B64+import Data.Char (isSpace)+import Data.Functor.Identity+import qualified Data.Map as M+import Data.PropertyList.Algebra+import Data.Time+import System.Locale+import Text.XML.Light++-- "%FT%T%QZ" would be better, but apple's plist parser+-- doesn't accept the fractional-seconds part.+dateFormat :: String+dateFormat = "%FT%T%QZ"++b64encode :: BS.ByteString -> String+b64encode = BSC8.unpack . B64.encode++instance PListAlgebra Identity Element where+ plistAlgebra = toElem . runIdentity+ where+ toElem :: PropertyListS Element -> Element+ toElem (PLArray x) = unode "array" x+ toElem (PLData x) = unode "data" (b64encode x)+ toElem (PLDate x) = unode "date" (formatTime defaultTimeLocale dateFormat x)+ toElem (PLDict x) = unode "dict" $ concat+ [ [ unode "key" k, v]+ | (k,v) <- M.toAscList x+ ]+ toElem (PLReal x) = unode "real" (show x)+ toElem (PLInt x) = unode "integer" (show x)+ toElem (PLString x) = unode "string" x+ toElem (PLBool True) = unode "true" ()+ toElem (PLBool False) = unode "false" ()++-- |A representation of values that were structurally sound in the +-- property list file but the contents of which couldn't be interpreted+-- as what they claimed to be. The result of the initial parse phase will+-- typically be a @PartialPropertyList UnparsedXmlPlistItem@, and if+-- the whole plist was parsed properly will contain no actual values +-- of this type.+data UnparsedXmlPlistItem+ = UnparsedData String+ | UnparsedDate String+ | UnparsedInt String+ | UnparsedReal String+ | UnparsedXml Element+ deriving Show++unparsedXmlPlistItemToElement = toElem+ where+ toElem (UnparsedData x) = unode "data" x+ toElem (UnparsedDate x) = unode "date" x+ toElem (UnparsedInt x) = unode "integer" x+ toElem (UnparsedReal x) = unode "real" x+ toElem (UnparsedXml e) = e++b64decode :: String -> Either String BS.ByteString+b64decode = B64.decode . BSC8.pack . filter (not . isSpace)++instance PListAlgebra (Either Element) Element where+ plistAlgebra (Left x) = x+ plistAlgebra (Right x) = plistAlgebra (Identity x)++instance PListAlgebra (Either UnparsedXmlPlistItem) Element where+ plistAlgebra (Left x) = unparsedXmlPlistItemToElement x+ plistAlgebra (Right x) = plistAlgebra (Identity x)++instance PListCoalgebra (Either UnparsedXmlPlistItem) Element where+ -- I can't find any info anywhere about what namespace URI, if any, should+ -- be used for XML property lists. So, ignoring it.+ plistCoalgebra e = coalg e+ where+ coalg (Element (QName name _ _) [] content _) = fromElem name content+ coalg _ = reject UnparsedXml e+ + fromElem "array" content+ = accept PLArray (onlyElems content)+ fromElem "data" content+ = let contentText = text content+ in case b64decode contentText of+ Right xs -> accept PLData xs+ Left _ -> reject UnparsedData contentText+ fromElem "date" content+ = let contentText = text content+ in case parseTime defaultTimeLocale dateFormat contentText of+ Nothing -> reject UnparsedDate contentText+ Just x -> accept PLDate x+ fromElem "dict" content+ = fmap (PLDict . M.fromList) (fromDict (onlyElems content))+ fromElem "real" content+ = tryRead PLReal UnparsedReal (text content)+ fromElem "integer" content+ = tryRead PLInt UnparsedInt (text content)+ fromElem "string" content+ = accept PLString (text content)+ fromElem "true" [] = accept PLBool True+ fromElem "false" [] = accept PLBool False+ fromElem _ _ = reject UnparsedXml e+ + fromDict [] = Right []+ fromDict (key : value : rest)+ = case key of+ Element (QName "key" _ _) [] content _+ -> fmap ((text content, value) :) (fromDict rest)+ _ -> reject UnparsedXml e+ + text = concatMap cdData . onlyText+ + accept :: (a -> c) -> a -> Either b c+ accept con = Right . con+ + reject :: (a -> b) -> a -> Either b c+ reject con = Left . con+ + tryRead :: Read a => (a -> c) -> (String -> b) -> String -> Either b c+ tryRead onGood onBad str =+ case reads str of+ ((result, ""):_) -> accept onGood result+ _ -> reject onBad str++instance PListCoalgebra Maybe Element where+ plistCoalgebra+ = either (const Nothing :: UnparsedXmlPlistItem -> Maybe a) Just+ . plistCoalgebra
− src/Data/PropertyList/Xml/Dtd.hs
@@ -1,204 +0,0 @@-{-- - 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-}---- |DtdToHaskell-generated type representing XML trees that match the PropertyList-1.0 dtd.--- This is an opaque representation of a structurally-sound property list--- which might still contain invalid data. End users should never need to--- use this type, but if they do, it can be manipulated with the constructors--- and deconstructors in "Data.PropertyList.Algebra".-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-}
− src/Data/PropertyList/Xml/Dtd_1_13.hs
@@ -1,212 +0,0 @@-{-- - generated by DtdToHaskell (from HaXml 1.13.3)- - altered to fix ambiguities and build errors- - (why is this the "preferred" HaXml version, anyway?)- -}--module Data.PropertyList.Xml.Dtd_1_13 where--import Text.XML.HaXml.Xml2Haskell-import Text.XML.HaXml.OneOfN-import Data.Char (isSpace)--import Prelude (Eq, Show, String, Maybe(..), all, concatMap, (++))--{-Type decls-}---- |DtdToHaskell-generated type representing XML trees that match the PropertyList-1.0 dtd.--- This is an opaque representation of a structurally-sound property list--- which might still contain invalid data. End users should never need to--- use this type, but if they do, it can be manipulated with the constructors--- and deconstructors in "Data.PropertyList.Algebra".-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 XmlContent Plist where- fromElem (CElem (Elem "plist" as c0):rest) =- case (fromElem c0) of- (Just a,_) -> (Just (PlistArray (fromAttrs as) a), rest)- (_,_) ->- case (fromElem c0) of- (Just a,_) -> (Just (PlistData (fromAttrs as) a), rest)- (_,_) ->- case (fromElem c0) of- (Just a,_) -> (Just (PlistDate (fromAttrs as) a), rest)- (_,_) ->- case (fromElem c0) of- (Just a,_) -> (Just (PlistDict (fromAttrs as) a), rest)- (_,_) ->- case (fromElem c0) of- (Just a,_) -> (Just (PlistAReal (fromAttrs as) a), rest)- (_,_) ->- case (fromElem c0) of- (Just a,_) -> (Just (PlistAInteger (fromAttrs as) a), rest)- (_,_) ->- case (fromElem c0) of- (Just a,_) -> (Just (PlistAString (fromAttrs as) a), rest)- (_,_) ->- case (fromElem c0) of- (Just a,_) -> (Just (PlistTrue (fromAttrs as) a), rest)- (_,_) ->- case (fromElem c0) of- (Just a,_) -> (Just (PlistFalse (fromAttrs as) a), rest)- (_,_) ->- (Nothing, c0)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem (PlistArray as a) = [CElem (Elem "plist" (toAttrs as) (toElem a) )]- toElem (PlistData as a) = [CElem (Elem "plist" (toAttrs as) (toElem a) )]- toElem (PlistDate as a) = [CElem (Elem "plist" (toAttrs as) (toElem a) )]- toElem (PlistDict as a) = [CElem (Elem "plist" (toAttrs as) (toElem a) )]- toElem (PlistAReal as a) = [CElem (Elem "plist" (toAttrs as) (toElem a) )]- toElem (PlistAInteger as a) = [CElem (Elem "plist" (toAttrs as) (toElem a) )]- toElem (PlistAString as a) = [CElem (Elem "plist" (toAttrs as) (toElem a) )]- toElem (PlistTrue as a) = [CElem (Elem "plist" (toAttrs as) (toElem a) )]- toElem (PlistFalse as a) = [CElem (Elem "plist" (toAttrs as) (toElem a) )]-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 XmlContent Array where- fromElem (CElem (Elem "array" [] c0):rest) =- (\(a,ca)->- (Just (Array a), rest))- (many fromElem c0)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem (Array a) =- [CElem (Elem "array" [] (concatMap toElem a))]-instance XmlContent Dict where- fromElem (CElem (Elem "dict" [] c0):rest) =- (\(a,ca)->- (Just (Dict a), rest))- (many fromElem c0)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem (Dict a) =- [CElem (Elem "dict" [] (concatMap toElem a))]-instance XmlContent Dict_ where- fromElem c0 =- case (\(a,ca)->- (\(b,cb)->- (a,b,cb))- (fromElem ca))- (fromElem c0) of- (Just a,Just b,rest) -> (Just (Dict_ a b), rest)- (_,_,_) ->- (Nothing, c0)- toElem (Dict_ a b) =- (toElem a ++ toElem b)-instance XmlContent Key where- fromElem (CElem (Elem "key" [] c0):rest) =- (\(a,ca)->- (Just (Key a), rest))- (definite fromText "text" "key" c0)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem (Key a) =- [CElem (Elem "key" [] (toText a))]-instance XmlContent AString where- fromElem (CElem (Elem "string" [] c0):rest) =- (\(a,ca)->- (Just (AString a), rest))- (definite fromText "text" "string" c0)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem (AString a) =- [CElem (Elem "string" [] (toText a))]-instance XmlContent Data where- fromElem (CElem (Elem "data" [] c0):rest) =- (\(a,ca)->- (Just (Data a), rest))- (definite fromText "text" "data" c0)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem (Data a) =- [CElem (Elem "data" [] (toText a))]-instance XmlContent Date where- fromElem (CElem (Elem "date" [] c0):rest) =- (\(a,ca)->- (Just (Date a), rest))- (definite fromText "text" "date" c0)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem (Date a) =- [CElem (Elem "date" [] (toText a))]-instance XmlContent True where- fromElem (CElem (Elem "true" [] []):rest) =- (Just True, rest)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem True =- [CElem (Elem "true" [] [])]-instance XmlContent False where- fromElem (CElem (Elem "false" [] []):rest) =- (Just False, rest)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem False =- [CElem (Elem "false" [] [])]-instance XmlContent AReal where- fromElem (CElem (Elem "real" [] c0):rest) =- (\(a,ca)->- (Just (AReal a), rest))- (definite fromText "text" "real" c0)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem (AReal a) =- [CElem (Elem "real" [] (toText a))]-instance XmlContent AInteger where- fromElem (CElem (Elem "integer" [] c0):rest) =- (\(a,ca)->- (Just (AInteger a), rest))- (definite fromText "text" "integer" c0)- fromElem (CMisc _:rest) = fromElem rest- fromElem (CString _ s:rest) | all isSpace s = fromElem rest- fromElem rest = (Nothing, rest)- toElem (AInteger a) =- [CElem (Elem "integer" [] (toText a))]---{-Done-}
− src/Data/PropertyList/Xml/Parse.hs
@@ -1,122 +0,0 @@-{-# LANGUAGE - TemplateHaskell, CPP,- MultiParamTypeClasses,- FlexibleContexts, FlexibleInstances, TypeSynonymInstances,- UndecidableInstances, OverlappingInstances, IncoherentInstances- #-}--module Data.PropertyList.Xml.Parse where--import Language.Haskell.TH.Fold--import Prelude as P-#ifdef HaXml_1_13-import Data.PropertyList.Xml.Dtd_1_13 as X-#else-import Data.PropertyList.Xml.Dtd as X-#endif--import Data.PropertyList.Algebra-import Data.PropertyList.Xml.Types--import Data.Copointed-import Control.Arrow ((+++))-import Control.Monad.Identity-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---- |A representation of values that were structurally sound in the --- property list file but the contents of which couldn't be interpreted--- as what they claimed to be. The result of the initial parse phase will--- typically be a @PartialPropertyList UnparsedPlistItem@, and if--- the whole plist was parsed properly will contain no actual values --- of this type.-data UnparsedPlistItem- = UnparsedData String- | UnparsedDate String- | UnparsedInt String- | UnparsedReal String- deriving (Eq, Ord, Show, Read)--dateFormat :: String-dateFormat = "%FT%TZ"---- This instance is not efficient, and should really only be used as a convenience--- to allow direct construction of 'Plist's using the \"smart constructors\"-instance PListAlgebra f PlistItem => PListAlgebra f Plist where- plistAlgebra = plistItemToPlist . plistAlgebra . fmap (fmap plistToPlistItem)--instance (Functor f, Copointed f) => PListAlgebra f PlistItem where- {-# SPECIALIZE instance PListAlgebra Identity PlistItem #-}- plistAlgebra = foldPropertyListS- (\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- ) . copoint--instance PListAlgebra (Either UnparsedPlistItem) PlistItem where- plistAlgebra (Left unparsed) = unparsedPlistItemToPlistItem unparsed- plistAlgebra (Right parsed) = plistAlgebra (Identity parsed)--instance PListAlgebra (Either PlistItem) PlistItem where- plistAlgebra (Left unparsed) = unparsed- plistAlgebra (Right parsed) = plistAlgebra (Identity parsed)--instance PListCoalgebra (Either UnparsedPlistItem) PlistItem where- plistCoalgebra item = case item of- OneOf9 (Array x ) -> accept PLArray 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, 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 -> c) -> a -> Either b c- accept con = Right . con- - reject :: (a -> b) -> a -> Either b c- reject con = Left . con- - tryRead :: Read a => (a -> c) -> (String -> b) -> String -> Either b c- tryRead onGood onBad str =- case reads str of- ((result, ""):_) -> accept onGood result- _ -> reject onBad str--instance PListCoalgebra (Either PlistItem) PlistItem where- plistCoalgebra = (unparsedPlistItemToPlistItem +++ id) . plistCoalgebra--instance PListCoalgebra Maybe PlistItem where- plistCoalgebra = either (const Nothing) Just . (plistCoalgebra :: PlistItem -> Either PlistItem (PropertyListS PlistItem))---- This instance is not efficient, and should really only be used as a convenience--- to allow direct deconstruction of 'Plist's using the \"view deconstructors\"-instance PListCoalgebra f PlistItem => PListCoalgebra f Plist where- plistCoalgebra = fmap (fmap plistItemToPlist) . plistCoalgebra . plistToPlistItem---- |Take the unparsed data from an 'UnparsedPlistItem' and wrap it in--- the appropriate 'PlistItem' constructor.-unparsedPlistItemToPlistItem :: UnparsedPlistItem -> PlistItem-unparsedPlistItemToPlistItem = $(fold ''UnparsedPlistItem)- (TwoOf9 . Data )- (ThreeOf9 . Date )- (SixOf9 . AInteger)- (FiveOf9 . AReal )
− src/Data/PropertyList/Xml/Types.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE- TemplateHaskell, CPP- #-}--module Data.PropertyList.Xml.Types- ( Plist, PlistItem- , plistItemToPlist, plistToPlistItem- , readXmlPlist, showXmlPlist- ) where--import Prelude as P--import Text.XML.HaXml.OneOfN--#ifdef HaXml_1_13-import Data.PropertyList.Xml.Dtd_1_13 as X-import Text.XML.HaXml.Xml2Haskell hiding (showXml, readXml)-import qualified Text.XML.HaXml.Xml2Haskell as X2H-#else-import Data.PropertyList.Xml.Dtd as X-import Text.XML.HaXml.XmlContent- hiding (showXml, toXml)-#endif--import Text.PrettyPrint.HughesPJ (render)-import Text.XML.HaXml.Pretty (document)-import Text.XML.HaXml.Types--import Language.Haskell.TH.Fold---- * The 'PlistItem' type: Xml-parser-independent view of an xml plist--- |'PlistItem' is nearly equivalent to 'Plist' - the difference is that it discards--- information about where in the tree the item is (a 'Plist' represents the whole--- XML tree starting from the root). This is a \"slightly-less-opaque\" type,--- but still isn't really intended for consumption by end users.-type PlistItem = OneOf9 Array Data Date Dict AReal AInteger AString X.True X.False---- |Convert a 'Plist' to a 'PlistItem', discarding the root element and any --- attributes that element may have had.-plistToPlistItem :: Plist -> PlistItem-plistToPlistItem = $(fold ''Plist)- (\attr -> OneOf9 )- (\attr -> TwoOf9 )- (\attr -> ThreeOf9)- (\attr -> FourOf9 )- (\attr -> FiveOf9 )- (\attr -> SixOf9 )- (\attr -> SevenOf9)- (\attr -> EightOf9)- (\attr -> NineOf9 )---- |Convert a 'PlistItem' to a 'Plist', giving it a root element with no --- attributes.-plistItemToPlist :: PlistItem -> Plist-plistItemToPlist = $(fold ''OneOf9)- (PlistArray attr)- (PlistData attr)- (PlistDate attr)- (PlistDict attr)- (PlistAReal attr)- (PlistAInteger attr)- (PlistAString attr)- (PlistTrue attr)- (PlistFalse attr)- where attr = fromAttrs []---- * Parsing and rendering XML 'Plist's from/to 'String's--#ifdef HaXml_1_13---- |Try to parse a string as an XML property list.-readXmlPlist :: String -> Either String Plist-readXmlPlist xml = case X2H.readXml xml of- Nothing -> Left "readXml: parse failed"- Just plist -> Right plist---- |Render a 'Plist' to a 'String' as an XML property list.-showXmlPlist :: Plist -> String-showXmlPlist = X2H.showXml---- |Render a 'Plist' as a 'Document' (HaXml's internal DOM representation, I--- think)-toXml :: Plist -> Document-toXml value =- Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing)) [] Nothing [])- emptyST- ( case (toElem value) of- [CElem e] -> e- )- []--#else---- |Try to parse a string as an XML property list.-readXmlPlist :: String -> Either String Plist-readXmlPlist = readXml---- |Render a 'Plist' to a 'String' as an XML property list.-showXmlPlist :: Plist -> String-showXmlPlist x =- case toContents x of- [CElem _ _] -> (render . document . toXml) x- _ -> ""---- |Render a 'Plist' as a 'Document' (HaXml's internal DOM representation, I--- think)-toXml :: Plist -> Document ()-toXml value =- Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing)) [] Nothing [])- emptyST- ( case (toContents value) of- [CElem e ()] -> e- )- []--#endif