diff --git a/property-list.cabal b/property-list.cabal --- a/property-list.cabal +++ b/property-list.cabal @@ -1,5 +1,5 @@ name: property-list -version: 0.0.0.7 +version: 0.0.1.0 stability: experimental license: PublicDomain @@ -13,90 +13,48 @@ category: Data, Parsing, XML synopsis: XML property list parser description: Parser, data type and formatter for Apple's XML property list 1.0 format. - - The bytestring-0.9.1.5 update on hackage seems to have - cratered the build for many packages, including the last - several versions of this one, so this version will - probably not build properly on the hackage site. - As far as I know, though, that is the only reason - it fails. This version includes a hack to try to make - it build on the site, triggered by the HaXml_1_13 build flag. -flag new-data-object - description: Use the new version of the data-object package (>= 0.0.2) - Which has a "generic object" type in place of the simpler - Object type in previous versions. - default: True - -flag new-template-haskell - description: Template Haskell 2.4 seems to have made the - generated @PropertyListItem OneOfN@ instances break. - So, detect it and deal with it. - flag HaXml_1_13 default: False - description: The Hackage website builder is currently very finicky - and the bytestring-0.9.1.5 update has made me very - frustrated, because the last several versions of this - package have failed to build because of it. - The "preferred-versions" fallback fails too, because - the additional HaXml constraint combined with the - one here becomes unsatisfiable. So, I'm gonna make - this thing work with HaXml 1.13 now. - - And, as an additional hack to make sure it works, - this flag will also trigger dependencies on specific - versions of packages known to have been built against - bytestring-0.9.1.4 on the hackage server. - - Once ghc-6.12 is released, this should no longer be - a problem and I can clean up the mess I've made here. - + description: The Hackage website builder used to be very finicky + and the bytestring-0.9.1.5 update frustrated me, + because several versions of this package failed to + build because of it. HaXml 1.13 support was added as + part of a hack to make it build on the hackage build + server. Hopefully the ghc-6.12 changeover will have + fixed things, so I'm eliminating the build hack that + was used before. HaXml-1.13 support remains, though. Library hs-source-dirs: src + ghc-options: -fwarn-unused-binds -fwarn-unused-imports exposed-modules: Data.PropertyList - other-modules: Data.PropertyList.Xml - Data.PropertyList.Type - Data.PropertyList.Parse + Data.PropertyList.Algebra + Data.PropertyList.Xml + + other-modules: Data.PropertyList.Types Data.PropertyList.PropertyListItem - Data.PropertyList.Object - build-depends: base >= 3 && <5, + Data.PropertyList.KeyPath + Data.PropertyList.Xml.Parse + Data.PropertyList.Xml.Types + build-depends: base >= 4 && <5, bytestring, bytestring-class, + category-extras, containers, dataenc, mtl, old-locale, pretty, + syb, + template-haskell, time, th-fold - if flag(new-template-haskell) - -- wild guess - template-haskell seems to follow the "even-minors" convention, - -- so put 2.6 as upper version bound. - build-depends: template-haskell >=2.4 && <2.6 - cpp-options: -DNEW_TEMPLATE_HASKELL - else - build-depends: template-haskell <2.4 - - - if flag(new-data-object) - build-depends: data-object >= 0.0.2 - cpp-options: -DNEW_DATA_OBJECT - else - build-depends: data-object < 0.0.2 - 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, - bytestring == 0.9.1.4, - bytestring-class == 0.0.0, - data-object == 0.0.2, - - utf8-string == 0.3.5 - -- (transitive dependency brought in by bytestring-class) + build-depends: HaXml >= 1.13 && <1.14 else other-modules: Data.PropertyList.Xml.Dtd diff --git a/src/Data/PropertyList.hs b/src/Data/PropertyList.hs --- a/src/Data/PropertyList.hs +++ b/src/Data/PropertyList.hs @@ -1,25 +1,154 @@ module Data.PropertyList - ( PropertyList - , PropertyList_ + ( -- * The basic property list types + -- |Property lists have several supported representations, but the main + -- one most end users will care about is 'PropertyList'. This is a basic + -- algebraic representation of property lists which can be constructed + -- using the polymorphic constructors described below and pattern-matched + -- using the polymorphic destructors (designed for convenient usage with + -- the ViewPatterns extension) + -- + -- Also provided is the 'PartialPropertyList' representation, which is + -- a property list that is extended by adding a new constructor containing + -- some arbitrary type chosen by the user. It is mostly used as an + -- intermediate represenation for property lists that have been parsed + -- 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. + PropertyList + , PartialPropertyList + , PropertyListS(..) , UnparsedPlistItem(..) + + -- * Constructors and destructors for property lists + -- |The \"pl*\" operations construct 'PropertyList's, 'PartialPropertyList's, + -- or any other types defining an unlifted algebra for the 'PropertyListS' + -- signature. + -- + -- The \"fromPl*\" operations are ViewPattern matching operations for + -- 'PropertyList', 'PartialPropertyList', or any other type defining + -- a 'Maybe'-lifted coalgebra for 'PropertyListS'. + -- + -- The generality of these operations means that they can also be used + -- to directly generate or analyze \"external\" formats such as the XML + -- 'Plist' representation. + , plArray, fromPlArray + , plData, fromPlData + , plDate, fromPlDate + , plDict, fromPlDict + , plReal, fromPlReal + , plInt, fromPlInt + , plString, fromPlString + , plBool, fromPlBool + + -- * The internal algebraic model for property lists + -- | Internally, conversions between various property list representations + -- are all defined in terms of universal algebra, which is basically just + -- fancy math-talk for \"very general interfaces that let you convert between + -- certain kinds of representations easily and efficiently\". + -- + -- Most users do not need to understand this stuff - the class names are + -- only exported because they appear in the types of the constructors and + -- destructors. For more detailed info, see "Data.PropertyList.Algebra". + , PListAlgebra, PListCoalgebra + , InitialPList, TerminalPList + + -- * Parsing and formatting property lists using any supported format + , readPropertyList + , showPropertyList + , readPropertyListFromFile , writePropertyListToFile + -- * Parsing and formatting property lists using the XML format + , readXmlPropertyList + , showXmlPropertyList + + , readXmlPropertyListFromFile + , writeXmlPropertyListToFile + + -- * Manipulating property lists + -- + -- |This module exports a class ('PropertyListItem') and several functions + -- used to manipulate 'PropertyList's and their contents at a high level, + -- viewing and manipulating the data in the tree through ad-hoc + -- transformations. + -- + -- For example, consider the following property list: + -- + -- > myPlist = plDict $ M.fromList + -- > [ ("foo", plInt 4) + -- > , ("bar", plString "qux") + -- > , ("subDict", plDict $ M.fromList + -- > [ ("item 1", plString "This is item 1!") + -- > , ("item B", plBool True) + -- > ]) + -- > ] :: PropertyList + -- + -- Some typical actions you might do with a plist like this (Note that + -- in many cases a 'Just' is added - this is because the key-path operations + -- are defined in terms of 'Maybe' so that operations like 'setItemAtKeyPath' + -- or 'alterItemAtKeyPath' can create new items where none already exist): + -- + -- > getItemAtKeyPath ["subDict", "item B"] (Just myPlist) :: Maybe Bool + -- + -- (returns @Just True@) + -- + -- > getItemAtKeyPath ["subDict"] (Just myPlist) :: M.Map String String + -- + -- (returns @M.fromList [(\"item 1\", \"This is item 1!\"), (\"item B\", \"YES\")]@. + -- Note the stringification of non-string items. In general, 'PropertyListItem' + -- instances are expected to do \"reasonable\" conversions to try and make sense + -- of what the user is asking the system to do.) + -- + -- > setItemAtKeyPath ["omg", "lolwut"] (Just "roflcopter") (Just myPlist) + -- + -- (returns a modified version of @myPlist@ with + -- @plDict $ M.fromList [(\"omg\", plDict $ M.fromList [(\"omg\", + -- plDict $ M.fromList [(\"lolwut\", plString \"roflcopter\")])])]@ + -- added to the root dictionary) + -- + -- > setItemAtKeyPath ["foo"] Nothing (Just myPlist) + -- + -- (returns a modified version of @myPlist@ with the \"foo\" entry in the + -- root dictionary deleted) + -- + -- > setItemAtKeyPath ["foo", "bar", "baz"] (Just "qux") Nothing + -- + -- (returns a new dictionary with @plString \"qux\"@ at the key path foo.bar.baz) + -- + , module Data.PropertyList.PropertyListItem + , module Data.PropertyList.KeyPath ) where -import Data.PropertyList.Type -import Data.PropertyList.Parse +import Data.PropertyList.Algebra +import Data.PropertyList.Types import Data.PropertyList.Xml -import Data.PropertyList.Object ({- ToObject instances -}) import Data.PropertyList.PropertyListItem +import Data.PropertyList.KeyPath -readPropertyListFromFile :: FilePath -> IO (Either String PropertyList) -readPropertyListFromFile file = do - x <- readPlistFromFile file - return (fmap plistToPropertyList x) +-- | 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'. +readPropertyListFromFile :: FilePath -> IO PropertyList +readPropertyListFromFile = readXmlPropertyListFromFile + +-- | Write a property list to a file, using a \"preferred\" property list format. +-- Presently, that is the \"XML1\" format. See also 'writeXmlPropertyListToFile'. writePropertyListToFile :: FilePath -> PropertyList -> IO () -writePropertyListToFile file plist = do - writePlistToFile file (propertyListToPlist unparsedPlistItemToPlistItem plist) +writePropertyListToFile = writeXmlPropertyListToFile diff --git a/src/Data/PropertyList/Algebra.hs b/src/Data/PropertyList/Algebra.hs new file mode 100644 --- /dev/null +++ b/src/Data/PropertyList/Algebra.hs @@ -0,0 +1,265 @@ +{-# LANGUAGE + MultiParamTypeClasses, FunctionalDependencies, + TemplateHaskell, + FlexibleContexts + #-} + +-- |The internal \"algebraic\" interface for working with property-list-like +-- things. The classes defined here are the basis for a very general system +-- supporting transformations between many property-list representations, +-- including both internal and external formats. The transformations are +-- based on algebra and are very well-behaved mathematically. It is possible +-- to \"fuse\" operations so that, for example, reading from XML and writing +-- to a text plist can be done without creating any intermediate +-- representations other than those used by the XML parser and the text +-- renderer. Or, expressions using the \"smart constructors\" can be +-- evaluated to directly synthesize XML-formatted plists, or the view-pattern +-- destructors can be used to directly analyze them. +-- +-- The interface defined in this module is very heavily influenced by +-- category-theoretical constructions. In particular, F-algebras and +-- F-coalgebras, initiality, and terminality. For those not familiar with +-- these concepts, this will probably be quite incomprehensible. Sorry +-- about that. The basic idea, though, is the use of the 'PropertyListS' +-- type as a sort of a central junction point through which all conversions +-- between property-list-like types and property-list-item types are routed. +-- The classes defined here are chosen to minimize the inderdependence of +-- these types and hence maximize the flexibility of the system as a whole. +-- +-- More simply stated, these weird math thingies make the design +-- as flexible as possible (in a well-defined and useful sense). +module Data.PropertyList.Algebra where + +import Control.Applicative +import Control.Monad.Identity +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.Time + +-- * The signature type ('PropertyListS') + +-- |The signature of the base property list algebra. This algebra is +-- \"lifted\" in various ways to support several different but similar +-- representations of property lists as well as projections and +-- injections. All the different representations are 'connected' through +-- this signature. +-- +-- For example, 'PropertyList' is a fixed-point of this signature - that +-- is, a recursive version where @a@ is instantiated as @'PropertyListS' a@. +-- That gives the \"expected\" structure of a basic property list. It is both +-- initial and terminal for this signature in its 'un-lifted' form - which +-- is to say, any other type with an algebra for this signature (such as an +-- XML representation) can be made from a 'PropertyList', and any type with +-- a coalgebra for this signature (such as a 'String', an 'Integer', etc.) +-- can be converted directly to a 'PropertyList'. This also means that any +-- transformation or series of transformations involving the 'PropertyList' +-- type can be fused to \"skip\" generating intermediate property lists, +-- although there are currently no rewrite rules set up to do so. +-- +-- Similarly, 'PartialPropertyList' is a fixed point of an arbitrarily- +-- augmented version of this signature (also known as the free monad +-- generated by the signature). Depending on its type parameter, +-- 'PartialPropertyList' can be terminal among many simple extensions to +-- the signature. Thus many types with a coalgebra for an extension of +-- this signature (such as XML given an appropriate tree destructor, or +-- the 'PropertyList' type itself) can be trivially converted to a +-- 'PartialPropertyList'. +data PropertyListS a + = PLArray [a] + | PLData ByteString + | PLDate UTCTime + | PLDict (M.Map String a) + | PLReal Double + | PLInt Integer + | PLString String + | PLBool Bool + deriving (Eq, Ord, Show, Read) + +-- |Construct a basic non-recursive algebra of property list items. +-- This is equivalent to pattern matching on 'PropertyListS'. +foldPropertyListS :: ([a] -> t) + -> (ByteString -> t) + -> (UTCTime -> t) + -> (M.Map String a -> t) + -> (Double -> t) + -> (Integer -> t) + -> (String -> t) + -> (Bool -> t) + -> PropertyListS a -> t +foldPropertyListS = $(fold ''PropertyListS) + +instance Functor PropertyListS where + fmap f = foldPropertyListS (PLArray . fmap f) PLData PLDate (PLDict . fmap f) PLReal PLInt PLString PLBool + +instance Foldable PropertyListS where + foldMap f = foldPropertyListS (foldMap f) mempty mempty (foldMap f) mempty mempty mempty mempty + +instance Traversable PropertyListS where + sequenceA = foldPropertyListS (fmap PLArray . sequenceA) (pure . PLData) (pure . PLDate) (fmap PLDict . sequenceA) (pure . PLReal) (pure . PLInt) (pure . PLString) (pure . PLBool) + +-- * The algebra and coalgebra classes + +-- |A class for types which can be constructed algebraically from the +-- 'PropertyListS' signature (lifted by @f@) - in other words, types which +-- you can put property lists into. +-- +-- The @f@-lifting is provided to support extending the algebra. The algebra +-- is defined in a class rather than passing around functions because most of +-- the time for any given type there is only one algebra you care about. +-- +-- Typically a renderer for an output format will be implemented as a type +-- with an @instance 'PListAlgebra' 'Identity'@. For example, the XML +-- output system is implemented in the @instance 'PListAlgebra' 'Identity' +-- 'Data.PropertyList.Xml.Types.Plist'@. +class Functor f => PListAlgebra f a where + -- |Build a value of type @a@ from a piece of a property list (using + -- the 'PropertyListS' signature augmented by the \"lifting\" @f@). + plistAlgebra :: f (PropertyListS a) -> a + +-- |An identification of the fact that the type @a@ has an initial plist algebra +-- (under some lifting @f@). Functional dependencies are in use - for any +-- type, only one of its initial algebras (if multiple apply, which they may +-- because the same type may be initial for multiple distinct liftings) +-- can be chosen, and for any lifting only one type's algebra may be chosen. +-- This is to make types decidable in the not-so-uncommon case where the +-- lifting is encapsulated (eg, any time 'foldPList' is partially applied +-- - for example, see the signature of 'fromPlist'). +-- +-- For cases where the lifting either needs to be chosen or needs to be +-- transformed to another lifting, 'fromPlistWith' is provided. It is based +-- on the same definition as the default implementation of 'foldPList' but +-- also inserts a chosen transformation of the lifting. +-- +-- Question for self: Is the PListCoalgebra context reasonable here? +-- Some rough calculations suggest that in the presence of fixed point +-- type operators, it is possible to construct a PListCoalgebra for any +-- InitialPList, which essentially is defined as pattern matching. So, +-- I'm not totally sure but I think this is reasonable - at least, for +-- finitary signatures, which we're using as long as @f@ doesn't go crazy. +class (PListAlgebra f a, PListCoalgebra f a) => InitialPList f a | f -> a, a -> f where + -- |Using some other plist algebra, compute the unique transformation from + -- the type @a@ to that algebra. + -- + -- The default implementation is: + -- + -- > foldPList f = go + -- > where + -- > go = f . fmap (fmap go) . plistCoalgebra + -- + foldPList :: (f (PropertyListS t) -> t) -> a -> t + foldPList f = go + where + go = f . fmap (fmap go) . plistCoalgebra + +-- |Convert from an initial plist to any other plist with the same lifted algebra. +fromPlist :: (InitialPList f pl, PListAlgebra f t) => pl -> t +fromPlist = foldPList plistAlgebra + +-- If the transformation is natural, this is equivalent to 'toPlistWith'. I think. +fromPlistWith :: (PListCoalgebra f pl, PListAlgebra g t) => (f (PropertyListS t) -> g (PropertyListS t)) -> pl -> t +fromPlistWith lift = fold + where + fold = plistAlgebra . lift . fmap (fmap fold) . plistCoalgebra + +-- |A class for types which can be dissected (pattern-matched) into the +-- 'PropertyListS' signature (lifted by @f@) - in other words, types which +-- you can take property lists out of. +-- +-- Typically a property list parser will be implemented as a type with a +-- 'PListCoalgebra' instance, where @f@ is either 'Identity' in the case where +-- the parser guarantees to return a fully well-formed property list +-- (assuming it returns anything at all) or 'Either' @something@ when the +-- parser only guarantees that the structure is sound (but that some elements +-- might be defective, in which case a value of type @something@ would be +-- substituted). The XML parser, for example, is based on the latter +-- approach, where @something@ is 'UnparsedPlistItem'. +class Functor f => PListCoalgebra f a where + -- |Analyze a value of type @a@ by matching it to a constructor in the + -- (lifted by @f@) 'PropertyListS' signature. + plistCoalgebra :: a -> f (PropertyListS a) + +-- |Chosen terminal coalgebra for the given lifting, and chosen lifting +-- for the given type. See also 'InitialPList'. +class (PListCoalgebra f a, PListAlgebra f a) => TerminalPList f a | f -> a, a -> f where + -- |Given some coalgebra for the chosen lifted plist signature, compute + -- the unique extraction/unfolding of that coalgebra into the type @a@. + -- + -- The default implementation is: + -- + -- > unfoldPList f = go + -- > where + -- > go = plistAlgebra . fmap (fmap go) . f + -- + unfoldPList :: (t -> f (PropertyListS t)) -> t -> a + unfoldPList f = go + where + go = plistAlgebra . fmap (fmap go) . f + +-- |Convert from any plist-like thing to a plist which is terminal for a some lifted algebra. +toPlist :: (PListCoalgebra f t, TerminalPList f pl) => t -> pl +toPlist = unfoldPList plistCoalgebra + +-- If the transformation is natural, this is equivalent to 'fromPlistWith'. I think. +toPlistWith :: (PListCoalgebra f t, PListAlgebra g pl) => (f (PropertyListS t) -> g (PropertyListS t)) -> t -> pl +toPlistWith lift = unfold + where + unfold = plistAlgebra . fmap (fmap unfold) . lift . plistCoalgebra + + +-- * \"Smart\" constructors for any 'PListAlgebra'. + +plArray :: (PListAlgebra Identity a) => [a] -> a +plArray x = plistAlgebra (Identity $ PLArray x) + +plData :: (PListAlgebra Identity a) => ByteString -> a +plData x = plistAlgebra (Identity $ PLData x) + +plDate :: (PListAlgebra Identity a) => UTCTime -> a +plDate x = plistAlgebra (Identity $ PLDate x) + +plDict :: (PListAlgebra Identity a) => M.Map String a -> a +plDict x = plistAlgebra (Identity $ PLDict x) + +plReal :: (PListAlgebra Identity a) => Double -> a +plReal x = plistAlgebra (Identity $ PLReal x) + +plInt :: (PListAlgebra Identity a) => Integer -> a +plInt x = plistAlgebra (Identity $ PLInt x) + +plString :: (PListAlgebra Identity a) => String -> a +plString x = plistAlgebra (Identity $ PLString x) + +plBool :: (PListAlgebra Identity a) => Bool -> a +plBool x = plistAlgebra (Identity $ PLBool x) + +-- * \"View pattern\" destructors for any 'PListCoalgebra'. + +fromPlArray :: PListCoalgebra Maybe a => a -> Maybe [a] +fromPlArray pl = do PLArray a <- plistCoalgebra pl; return a + +fromPlData :: PListCoalgebra Maybe a => a -> Maybe ByteString +fromPlData pl = do PLData a <- plistCoalgebra pl; return a + +fromPlDate :: PListCoalgebra Maybe a => a -> Maybe UTCTime +fromPlDate pl = do PLDate a <- plistCoalgebra pl; return a + +fromPlDict :: PListCoalgebra Maybe a => a -> Maybe (M.Map String a) +fromPlDict pl = do PLDict a <- plistCoalgebra pl; return a + +fromPlReal :: PListCoalgebra Maybe a => a -> Maybe Double +fromPlReal pl = do PLReal a <- plistCoalgebra pl; return a + +fromPlInt :: PListCoalgebra Maybe a => a -> Maybe Integer +fromPlInt pl = do PLInt a <- plistCoalgebra pl; return a + +fromPlString :: PListCoalgebra Maybe a => a -> Maybe String +fromPlString pl = do PLString a <- plistCoalgebra pl; return a + +fromPlBool :: PListCoalgebra Maybe a => a -> Maybe Bool +fromPlBool pl = do PLBool a <- plistCoalgebra pl; return a diff --git a/src/Data/PropertyList/KeyPath.hs b/src/Data/PropertyList/KeyPath.hs new file mode 100644 --- /dev/null +++ b/src/Data/PropertyList/KeyPath.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE + ViewPatterns + #-} +module Data.PropertyList.KeyPath + ( alterItemAtKeyPathM, alterItemAtKeyPath + , getItemAtKeyPath, setItemAtKeyPath + ) where + +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 + +-- |Alter a @'Maybe' 'PropertyList'@, viewing it as an instance of 'PropertyListItem' +-- and re-synthesizing it from a (possibly different) instance of 'PropertyListItem'. +-- Input and output are lifted by 'Maybe' in order to support adding or deleting of +-- items (as this function is used inside the key-path based versions) +-- +-- Actually only needs 'Functor', not 'Monad' but since it's not exported +-- and is only used in 'Monad' contexts, I'm using 'Monad' to avoid needing +-- to add 'Functor' to those other contexts. +{-# INLINE alterPropertyListM #-} +alterPropertyListM :: + (Monad m, PropertyListItem i, PropertyListItem i') + => (Maybe i -> m (Maybe i')) + -> Maybe PropertyList -> m (Maybe PropertyList) +alterPropertyListM f = liftM (fmap toPropertyList) . f . (>>= fromPropertyList) + +-- |Alter the contents of a dictionary (represented as a M.Map String), +-- viewing its values through the 'PropertyListItem' class. +-- +-- If the result of the alteration is 'Nothing', and the resulting dictionary +-- is empty, the result of the whole operation is 'Nothing' (causing cascading +-- deletion of empty key paths in 'alterDictionaryEntryM' et al.) +{-# INLINE alterDictionaryEntryM #-} +alterDictionaryEntryM :: + (Monad m, PropertyListItem i, PropertyListItem i') + => String -> (Maybe i -> m (Maybe i')) + -> Maybe (M.Map String PropertyList) -> m (Maybe (M.Map String PropertyList)) +alterDictionaryEntryM k f Nothing = do + i' <- f Nothing + return (fmap (M.singleton k . toPropertyList) i') +alterDictionaryEntryM k f (Just dict) = do + let (dict', i) = case M.splitLookup k dict of + (pre, v, post) -> (M.union pre post, fromPropertyList =<< v) + + i' <- f i + return $ case i' of + Nothing + | M.null dict' -> Nothing + | otherwise -> Just dict' + Just i'' -> Just (M.insert k (toPropertyList i'') dict) + +-- |Attempt to view a 'PropertyList' as a 'M.Map String' and, if successful, +-- modify an entry of the dictionary (by calling 'alterDictionaryEntryM'). +-- If not possible, 'fail's. +-- +-- If the result of the alteration is 'Nothing', and the resulting dictionary +-- is empty, that dictionary is deleted in the result. +{-# SPECIALIZE tryAlterDictionaryEntryM :: (PropertyListItem i, PropertyListItem i') + => String + -> (Maybe i -> Identity (Maybe i')) + -> Maybe PropertyList -> Identity (Maybe PropertyList) + #-} +{-# SPECIALIZE tryAlterDictionaryEntryM :: (PropertyListItem i) + => String + -> (Maybe i -> StateT (Maybe i) Maybe (Maybe i)) + -> Maybe PropertyList -> StateT (Maybe i) Maybe (Maybe PropertyList) + #-} +tryAlterDictionaryEntryM :: + (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." + +-- |@alterItemAtKeyPathM path f@ applies the function @f@ deep inside the +-- 'PropertyList' on the property list item at the given key-path @path@ +-- (if possible). This is the same notion of key path as is used in the +-- Apple plist APIs - each component of the path indicates descending +-- into a dictionary by selecting the element with that key (if any). If a +-- key is not found, it is created. If a key is found but is not a +-- dictionary, the operation fails (with 'fail' from the 'Monad' class). +-- +-- If the result of @f@ is 'Nothing', and the resulting dictionary is empty, +-- that dictionary is deleted in the result (and any empty parent dictionaries). +-- If this is not the behavior you want, you should alter the parent dictionary +-- itself and return an empty one. +{-# SPECIALIZE alterItemAtKeyPathM :: (PropertyListItem i, PropertyListItem i') + => [String] + -> (Maybe i -> Identity (Maybe i')) + -> Maybe PropertyList -> Identity (Maybe PropertyList) + #-} +{-# SPECIALIZE alterItemAtKeyPathM :: (PropertyListItem i) + => [String] + -> (Maybe i -> StateT (Maybe i) Maybe (Maybe i)) + -> Maybe PropertyList -> StateT (Maybe i) Maybe (Maybe PropertyList) + #-} +alterItemAtKeyPathM :: + (Monad m, PropertyListItem i, PropertyListItem i') + => [String] -> (Maybe i -> m (Maybe i')) + -> Maybe PropertyList -> m (Maybe PropertyList) +alterItemAtKeyPathM [] f = alterPropertyListM f +alterItemAtKeyPathM (k:ks) f = tryAlterDictionaryEntryM k (alterItemAtKeyPathM ks f) + +-- |@alterItemAtKeyPath path f@ applies the function @f@ deep inside the +-- 'PropertyList' on the property list item at the given key-path @path@ +-- (if possible). This is the same notion of key path as is used in the +-- Apple plist APIs - namely, each component of the path indicates descending +-- into a dictionary by selecting the element with that key (if any). If a +-- key is not found, it is created. If a key is found but is not a +-- dictionary, the operation fails (with 'error'). +-- +-- If the result of @f@ is 'Nothing', and the resulting dictionary is empty, +-- that dictionary is deleted in the result (and any empty parent dictionaries). +-- If this is not the behavior you want, you should alter the parent dictionary +-- itself and return an empty one. +alterItemAtKeyPath :: + (PropertyListItem i, PropertyListItem i') + => [String] -> (Maybe i -> Maybe i') + -> Maybe PropertyList -> Maybe PropertyList +alterItemAtKeyPath path f = runIdentity . alterItemAtKeyPathM path (Identity . f) + +-- |Gets the item, if any (and if convertible to the required type), +-- at a given key path. If the key path passes through something that +-- is not a dictionary, the operation returns 'Nothing'. +getItemAtKeyPath :: PropertyListItem i => + [String] -> Maybe PropertyList -> Maybe i + -- works by running a StateT (Maybe i) Maybe operation at the keypath. + -- The operation captures the value it is passed and 'put's it into the + -- state. The result is the final state of the operation 'join'ed to + -- the success/failure in the underlying 'Maybe' monad (which is why + -- we use 'StateT' instead of just 'State' - the latter would cause + -- failure by 'error' since it's equivalent to @'StateT' s 'Identity'@). +getItemAtKeyPath path plist = join $ execStateT + (alterItemAtKeyPathM path (\e -> put e >> return e) plist) + Nothing + +-- |Sets the item at a given key-path. If the key path does not exist, it is +-- created. If it exists but passes through something that is not a dictionary, +-- the operation fails (with 'error') +setItemAtKeyPath :: PropertyListItem i => + [String] -> Maybe i -> Maybe PropertyList -> Maybe PropertyList +setItemAtKeyPath path value plist = alterItemAtKeyPath path + (\e -> value `asTypeOf` e) plist + diff --git a/src/Data/PropertyList/Object.hs b/src/Data/PropertyList/Object.hs deleted file mode 100644 --- a/src/Data/PropertyList/Object.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE - FlexibleContexts, UndecidableInstances - #-} -module Data.PropertyList.Object ({- instances only -}) where - -import Data.Object -import Data.PropertyList.Type -import Data.PropertyList.Parse -import Data.PropertyList.Xml -import qualified Data.Map as M -import Control.Monad -import Control.Monad -import Control.Monad.Error - -instance ToScalar UnparsedPlistItem where - toScalar = toScalar . showXml . plistItemToPlist . unparsedPlistItemToPlistItem -instance ToObject UnparsedPlistItem where - toObject = Scalar . toScalar - -instance (ToObject (l a), ToObject (m a)) => ToObject (PropertyListS l m a) where - toObject (PLArray a) = toObject a - toObject (PLData bs) = toObject bs - toObject (PLDate d) = showToObject d - toObject (PLDict d) = toObject d - toObject (PLReal d) = showToObject d - toObject (PLInt i) = showToObject i - toObject (PLString s) = toObject s - toObject (PLBool b) = showToObject b - -instance (ToObject (f (M f a)), ToObject a) => ToObject (M f a) where - toObject (S x) = toObject x - toObject (V a) = toObject a - -instance (ToScalar k, ToObject v) => ToObject (M.Map k v) where - toObject = toObject . M.assocs - -showToObject :: Show a => a -> Object -showToObject = toObject . show - -test :: Object -test = toObject (undefined :: PropertyList) diff --git a/src/Data/PropertyList/Parse.hs b/src/Data/PropertyList/Parse.hs deleted file mode 100644 --- a/src/Data/PropertyList/Parse.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE - TemplateHaskell, CPP - #-} - -module Data.PropertyList.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 -import Text.XML.HaXml.XmlContent -#endif - -import Data.PropertyList.Xml -import Data.PropertyList.Type - -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 - --- |run an incremental parser - a function which takes --- a token type and returns either a subterm (possibly still --- containing unparsed tokens) or an unparseable 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, where the 'variable' sort --- consists of unparsed fragments of the source data. -parseT :: Monad t => (a -> Either (t a) b) -> a -> t b -parseT f = parse - where parse token = - either (>>= parse) return (f token) - -unparsedPlistItemToPlistItem :: UnparsedPlistItem -> PlistItem -unparsedPlistItemToPlistItem = $(fold ''UnparsedPlistItem) - (TwoOf9 . Data ) - (ThreeOf9 . Date ) - (SixOf9 . AInteger) - (FiveOf9 . AReal ) - -plistToPropertyList :: Plist -> PropertyList -plistToPropertyList = parseT parsePlistItem . plistToPlistItem - -plistItemToPropertyList :: PlistItem -> PropertyList -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 diff --git a/src/Data/PropertyList/PropertyListItem.hs b/src/Data/PropertyList/PropertyListItem.hs --- a/src/Data/PropertyList/PropertyListItem.hs +++ b/src/Data/PropertyList/PropertyListItem.hs @@ -1,37 +1,75 @@ {-# LANGUAGE + MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, - GeneralizedNewtypeDeriving, - TemplateHaskell, CPP + TemplateHaskell, CPP, + ViewPatterns #-} -module Data.PropertyList.PropertyListItem where +module Data.PropertyList.PropertyListItem + (PropertyListItem(..)) where import Language.Haskell.TH import Language.Haskell.TH.Syntax import Language.Haskell.TH.Fold -import Data.PropertyList.Type +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.Lazy.Char8 (pack, unpack) import Data.ByteString.Class import Data.Time import Data.Char +import Data.Int +import Data.Word import Text.XML.HaXml.OneOfN import Control.Monad -import Control.Monad.State +import Control.Monad.Identity +import qualified Data.Traversable as Traversable +import Data.Generics -import Data.Object +-- * some local utility functions --- |A class for items which can be converted to and from property lists +-- try to read a string to some other format using the Read instance +-- and failing gracefully +tryRead :: Read a => String -> Maybe a +tryRead s = case reads s of + [(d, "")] -> Just d + _ -> Nothing + +-- try to convert a fractional type to an integral type without loss of precision. +-- in case of loss of precision, the conversion fails. +tryToIntegral :: (RealFrac a, Integral b) => a -> Maybe b +tryToIntegral d = case properFraction d of + (i, 0) -> Just i + _ -> Nothing + +-- +--fmapM f m = fmap M.fromList $ +-- sequence [ do { v <- f v; return (k, v)} +-- | (k, v) <- M.toList m ] + +-- |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 +-- necessary and desirable in the 'PropertyListItem' situation because we are +-- more interested in composable injection/projection operations on than in +-- universal maps. +-- +-- The algebraic interface also cannot work for arrays or dictionaries, +-- because it only allows primitive (co-)recursion - the conversions can only +-- operate on one "layer" of 'PropertyListS' at a time. This could be +-- handled by enlarging the types (from [t] to Either t [t], for example) +-- or by encoding in-band (by taking a singleton list to be an element +-- instead of a list, for example), but both of those \"solutions\" create +-- headaches of their own, and in any case the algebraic interface is probably +-- too bizarre for most users. class PropertyListItem i where - -- |Convert the item to a property list, usually by simply wrapping the - -- value with the appropriate 'PropertyList_' constructor + -- |Construct a 'PropertyList' from the item. toPropertyList :: i -> PropertyList -- |Convert a property list to a property list item if its contents @@ -50,224 +88,103 @@ listToPropertyList = plArray . map toPropertyList listFromPropertyList :: PropertyList -> Maybe [i] - listFromPropertyList (S (PLArray x)) = mapM fromPropertyList x - listFromPropertyList _ = Nothing + listFromPropertyList (fromPlArray -> Just x) = mapM fromPropertyList x + listFromPropertyList _ = Nothing instance PropertyListItem a => PropertyListItem [a] where toPropertyList = listToPropertyList fromPropertyList = listFromPropertyList -{-# SPECIALIZE alterPropertyListM :: Monad m => (Maybe (M.Map String PropertyList) -> m (Maybe (M.Map String PropertyList))) - -> Maybe PropertyList -> m (Maybe PropertyList) #-} -alterPropertyListM :: - (Monad m, PropertyListItem i, PropertyListItem i') - => (Maybe i -> m (Maybe i')) - -> Maybe PropertyList -> m (Maybe PropertyList) -alterPropertyListM f plist = do - i' <- f (plist >>= fromPropertyList) - return (fmap toPropertyList i') - -{-# SPECIALIZE alterDictionaryEntryM :: Monad m => String -> (Maybe PropertyList -> m (Maybe PropertyList)) - -> Maybe (M.Map String PropertyList) -> m (Maybe (M.Map String PropertyList)) #-} -alterDictionaryEntryM :: - (Monad m, PropertyListItem i, PropertyListItem i') - => String -> (Maybe i -> m (Maybe i')) - -> Maybe (M.Map String PropertyList) -> m (Maybe (M.Map String PropertyList)) -alterDictionaryEntryM k f Nothing = do - i' <- f Nothing - return (fmap (M.singleton k . toPropertyList) i') -alterDictionaryEntryM k f (Just dict) = do - let (dict', i) = case M.splitLookup k dict of - (pre, v, post) -> (M.union pre post, fromPropertyList =<< v) - - i' <- f i - return $ case i' of - Nothing - | M.null dict' -> Nothing - | otherwise -> Just dict' - Just i' -> Just (M.insert k (toPropertyList i') dict) - -tryAlterDictionaryEntryM :: - (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 (S (PLDict 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." - -alterItemAtKeyPathM :: - (Monad m, PropertyListItem i, PropertyListItem i') - => [String] -> (Maybe i -> m (Maybe i')) - -> Maybe PropertyList -> m (Maybe PropertyList) -alterItemAtKeyPathM [] f = alterPropertyListM f -alterItemAtKeyPathM (k:ks) f = tryAlterDictionaryEntryM k (alterItemAtKeyPathM ks f) - -alterPropertyList :: - (PropertyListItem i, PropertyListItem i') - => (Maybe i -> Maybe i') - -> Maybe PropertyList -> Maybe PropertyList -alterPropertyList f plist = fmap toPropertyList (f (fromPropertyList =<< plist)) - -alterDictionaryEntry :: - (PropertyListItem i, PropertyListItem i') - => String -> (Maybe i -> Maybe i') - -> Maybe (M.Map String PropertyList) -> Maybe (M.Map String PropertyList) -alterDictionaryEntry k f Nothing = fmap (M.singleton k . toPropertyList) (f Nothing) -alterDictionaryEntry k f (Just dict) = case i' of - Nothing - | M.null dict' -> Nothing - | otherwise -> Just dict' - Just i' -> Just (M.insert k (toPropertyList i') dict) - - where - (dict', i) = case M.splitLookup k dict of - (pre, v, post) -> (M.union pre post, fromPropertyList =<< v) - i' = f i - -tryAlterDictionaryEntry :: - (PropertyListItem i, PropertyListItem i') - => String -> (Maybe i -> Maybe i') - -> Maybe PropertyList -> (Maybe PropertyList, Bool) -tryAlterDictionaryEntry k f Nothing = (fmap plDict (alterDictionaryEntry k f Nothing), True) -tryAlterDictionaryEntry k f (Just (S (PLDict d))) = (fmap plDict (alterDictionaryEntry k f (Just d)), True) -tryAlterDictionaryEntry k f other = (other, False) - --- |TODO: capture the success/failure of the operation? --- (can fail if key path tries to enter something that isn't a dictionary) -alterItemAtKeyPath :: - (PropertyListItem i, PropertyListItem i') - => [String] -> (Maybe i -> Maybe i') - -> Maybe PropertyList -> Maybe PropertyList -alterItemAtKeyPath [] f plist= alterPropertyList f plist -alterItemAtKeyPath (k:ks) f plist = case tryAlterDictionaryEntry k (alterItemAtKeyPath ks f) plist of - (_, False) -> error "Key path tries to pass through non-dictionary thing." - (plist, True) -> plist - -getItemAtKeyPath :: PropertyListItem i => - [String] -> Maybe PropertyList -> Maybe i -getItemAtKeyPath path plist = execState - (alterItemAtKeyPathM path (\e -> put e >> return e) plist) - Nothing - -setItemAtKeyPath :: PropertyListItem i => - [String] -> Maybe i -> Maybe PropertyList -> Maybe PropertyList -setItemAtKeyPath path value plist = alterItemAtKeyPath path - (\e -> value `asTypeOf` e) plist - instance PropertyListItem PropertyList where toPropertyList = id fromPropertyList = Just instance PropertyListItem ByteString where toPropertyList = plData - fromPropertyList (S (PLData x)) = Just x - fromPropertyList (S (PLString x)) = Just (toStrictByteString x) + fromPropertyList (fromPlData -> Just x) = Just x + fromPropertyList (fromPlString -> Just x) = Just (toStrictByteString x) fromPropertyList _ = Nothing instance PropertyListItem Lazy.ByteString where toPropertyList = plData . toStrictByteString - fromPropertyList (S (PLData x)) = Just (toLazyByteString x) - fromPropertyList (S (PLString x)) = Just (toLazyByteString x) + fromPropertyList (fromPlData -> Just x) = Just (toLazyByteString x) + fromPropertyList (fromPlString -> Just x) = Just (toLazyByteString x) fromPropertyList _ = Nothing instance PropertyListItem UTCTime where toPropertyList = plDate - fromPropertyList (S (PLDate x)) = Just x + fromPropertyList (fromPlDate -> Just x) = Just x fromPropertyList _ = Nothing instance PropertyListItem a => PropertyListItem (M.Map String a) where {-# SPECIALIZE instance PropertyListItem (M.Map String PropertyList) #-} toPropertyList = plDict . fmap toPropertyList - fromPropertyList (S (PLDict x)) = fmapM fromPropertyList x - where fmapM f m = fmap M.fromList $ - sequence [ do { v <- f v; return (k, v)} - | (k, v) <- M.toList m ] + fromPropertyList (fromPlDict -> Just x) = Traversable.mapM fromPropertyList x fromPropertyList _ = Nothing instance PropertyListItem Double where toPropertyList = plReal - fromPropertyList (S (PLInt i)) = Just (fromInteger i) - fromPropertyList (S (PLReal d)) = Just d - fromPropertyList (S (PLString s)) = case reads s of - [(d, "")] -> Just d - _ -> Nothing + fromPropertyList (fromPlInt -> Just i) = Just (fromInteger i) + fromPropertyList (fromPlReal -> Just d) = Just d + fromPropertyList (fromPlString -> Just s) = tryRead s fromPropertyList _ = Nothing instance PropertyListItem Float where toPropertyList = toPropertyList . (realToFrac :: Float -> Double) fromPropertyList = fmap (realToFrac :: Double -> Float) . fromPropertyList -instance PropertyListItem Integer where - toPropertyList = plInt - fromPropertyList (S (PLInt i)) = Just i - fromPropertyList (S (PLReal d)) = case properFraction d of - (i, 0) -> Just i - _ -> Nothing - fromPropertyList (S (PLString s)) = case reads s of - [(i, "")] -> Just i - _ -> Nothing - fromPropertyList _ = Nothing - -instance PropertyListItem Int where - toPropertyList = toPropertyList . toInteger - fromPropertyList = fmap fromInteger . fromPropertyList +-- this little bit of Template Haskell replicates the embedded instance +-- to many other integral types (by using SYB generics to replace every +-- occurrence of ''Integer in the declarations' template-haskell representation +-- with each other type's name) +$( do + decls <- [d| + instance PropertyListItem Integer where + toPropertyList = plInt . fromIntegral + fromPropertyList pl = case runIdentity (plistCoalgebra pl) of + PLInt i -> Just (fromIntegral i) + PLReal d -> tryToIntegral d + PLString s -> tryRead s + _ -> Nothing + |] + sequence + [ everywhereM (mkM (return . replace)) dec + | t <- [''Integer, ''Int, + ''Int8, ''Int16, ''Int32, ''Int64, + ''Word8, ''Word16, ''Word32, ''Word64] + , dec <- decls + , let replace name + | name == ''Integer = t + | otherwise = name + ] + ) -- this instance doesnt make much sense by itself, but must be here to support strings instance PropertyListItem Char where toPropertyList c = plString [c] - fromPropertyList (S (PLString [c])) = Just c + fromPropertyList (fromPlString -> Just [c]) = Just c fromPropertyList _ = Nothing listToPropertyList = plString - listFromPropertyList (S (PLString x)) = Just x - listFromPropertyList (S (PLData x)) = Just (fromStrictByteString x) - listFromPropertyList (S (PLBool True)) = Just "YES" - listFromPropertyList (S (PLBool False)) = Just "NO" - listFromPropertyList (S (PLInt i)) = Just (show i) - listFromPropertyList (S (PLReal d)) = Just (show d) + listFromPropertyList (fromPlString -> Just x) = Just 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 Bool where toPropertyList = plBool - fromPropertyList (S (PLBool d)) = Just d - fromPropertyList (S (PLString b)) + fromPropertyList (fromPlBool -> Just d) = Just d + fromPropertyList (fromPlString -> Just b) | map toLower b `elem` ["yes", "true"] = Just True | map toLower b `elem` ["no", "false"] = Just False fromPropertyList _ = Nothing -instance PropertyListItem UnparsedPlistItem where - toPropertyList = plVar - fromPropertyList (V d) = Just d - fromPropertyList _ = Nothing - --- |Note that due to 'Object''s use of 'Lazy.ByteString's, scalars become data, not strings. --- Using @GenObject key String@ instead of 'Object' will cause scalars to be encoded as plist strings. -#ifdef NEW_DATA_OBJECT -instance (PropertyListItem val, LazyByteString key) => PropertyListItem (GenObject key val) where -#else -instance PropertyListItem Object where -#endif - toPropertyList (Mapping m) = toPropertyList (M.fromList [(toStr k, v) | (k,v) <- m]) - where toStr = unpack . toLazyByteString - toPropertyList (Sequence s) = toPropertyList s - toPropertyList (Scalar s) = toPropertyList s - - fromPropertyList plist = msum - [ do - m <- fromPropertyList plist - let fromStr = fromLazyByteString . pack - return (Mapping [(fromStr k, v) | (k,v) <- M.assocs m]) - , fmap Sequence (fromPropertyList plist) - , fmap Scalar (fromPropertyList plist) - ] - -- The following TH generates, for Either and for all OneOfN types -- (N in [2..20]), an instance of the form: -- @@ -294,7 +211,7 @@ tyVars = map varT tyVarNames typeWithVars = foldl appT (conT typeName) tyVars -#ifdef NEW_TEMPLATE_HASKELL +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 612 preds = [classP ''PropertyListItem [tyVar] | tyVar <- tyVars] context = cxt preds #else diff --git a/src/Data/PropertyList/Type.hs b/src/Data/PropertyList/Type.hs deleted file mode 100644 --- a/src/Data/PropertyList/Type.hs +++ /dev/null @@ -1,114 +0,0 @@ -{-# LANGUAGE - TemplateHaskell, - FlexibleContexts, UndecidableInstances, - TypeSynonymInstances, RelaxedPolyRec - #-} - -module Data.PropertyList.Type where - -import Language.Haskell.TH.Fold - -import qualified Data.Map as M -import Data.ByteString as B hiding (map) -import Data.Time - --- |A property list possibly containing unparsed items (only when items fail --- to parse or the user puts them there) -type PropertyList = PropertyList_ UnparsedPlistItem - -data PropertyListS l m a - = PLArray (l a) - | PLData ByteString - | PLDate UTCTime - | PLDict (m a) - | PLReal Double - | PLInt Integer - | PLString String - | PLBool Bool - deriving (Eq, Ord, Show, Read) - -foldPropertyListS :: (l a -> t) - -> (ByteString -> t) - -> (UTCTime -> t) - -> (m a -> t) - -> (Double -> t) - -> (Integer -> t) - -> (String -> t) - -> (Bool -> t) - -> PropertyListS l m a -> t -foldPropertyListS = $(fold ''PropertyListS) - -instance (Functor l, Functor m) => Functor (PropertyListS l m) where - fmap f = foldPropertyListS (PLArray . fmap f) PLData PLDate (PLDict . fmap f) PLReal PLInt PLString PLBool - -data M f a - = S (f (M f a)) - | V a - -foldM :: (f (M f a) -> t) -> (a -> t) -> M f a -> t -foldM = $(fold ''M) - -instance (Eq (f (M f a)), Eq a) => Eq (M f a) where - S x == S y = (x == y) - V a == V b = (a == b) - _ == _ = False -instance (Ord (f (M f a)), Ord a) => Ord (M f a) where - S x `compare` S y = x `compare` y - V a `compare` V b = a `compare` b - S _ `compare` V _ = LT - V _ `compare` S _ = GT - -instance (Show (f (M f a)), Show a) => Show (M f a) where - showsPrec p (S x) = showParen (p > 10) (showString "S " . showsPrec 11 x) - showsPrec p (V x) = showParen (p > 10) (showString "V " . showsPrec 11 x) - --- instance Read... - --- |The property-list term algebra type itself, parameterized over the type of --- \"structural holes\" in the terms. -type PropertyList_ = M (PropertyListS [] (M.Map String)) - -plArray x = S (PLArray x) -plData x = S (PLData x) -plDate x = S (PLDate x) -plDict x = S (PLDict x) -plReal x = S (PLReal x) -plInt x = S (PLInt x) -plString x = S (PLString x) -plBool x = S (PLBool x) -plVar x = V x - -data UnparsedPlistItem - = UnparsedData String - | UnparsedDate String - | UnparsedInt String - | UnparsedReal String - deriving (Eq, Ord, Show, Read) - -instance Functor f => Functor (M f) where - fmap f (S x) = S (fmap (fmap f) x) - fmap f (V x) = V (f x) - -instance Functor f => Monad (M f) where - return = V - (S x) >>= f = S (fmap (>>= f) x) - (V x) >>= f = f x - -foldPropertyList :: (Functor list, Functor map) - => (list a -> a) - -> (ByteString -> a) - -> (UTCTime -> a) - -> (map a -> a) - -> (Double -> a) - -> (Integer -> a) - -> (String -> a) - -> (Bool -> a) - -> (t -> a) - -> M (PropertyListS list map) t -> a -foldPropertyList foldList a b foldMap c d e f g = foldIt - where - foldIt = foldM foldS g - foldS = foldPropertyListS foldArray a b foldDict c d e f - - foldArray branches = foldList (fmap foldIt branches) - foldDict dict = foldMap (fmap foldIt dict) diff --git a/src/Data/PropertyList/Types.hs b/src/Data/PropertyList/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/PropertyList/Types.hs @@ -0,0 +1,198 @@ +{-# LANGUAGE + MultiParamTypeClasses, + FlexibleContexts, FlexibleInstances, IncoherentInstances, + GeneralizedNewtypeDeriving + #-} + +-- |This module implements the 'PropertyList' and 'PartialPropertyList' types +-- and their algebras/coalgebras. These types are the core of the property-list +-- implementation, representing either complete or partial propertylists, +-- respectively, in the most \"universal\" form possible. +module Data.PropertyList.Types where + +import Data.PropertyList.Algebra + +import Control.Functor.Pointed +import Control.Functor.Fix +import Control.Applicative +import Control.Monad.Identity +import Control.Monad.Free +import Data.Foldable (Foldable(foldMap)) +import Data.Traversable (Traversable(..)) +import Data.Void + +import Unsafe.Coerce (unsafeCoerce) {- used _only_ to eliminate fmap traversals for newtype constructors -} + +-- * The 'PropertyList' data type +-- (the universal algebra/coalgebra for the unlifted signature) + +-- |A fully-parsed property list. +newtype PropertyList = PL { unPL :: FixF PropertyListS } +instance Eq PropertyList where + PL (InF x) == PL (InF y) = fmap PL x == fmap PL y +instance Ord PropertyList where + PL (InF x) `compare` PL (InF y) = fmap PL x `compare` fmap PL y + +{-# RULES + -- don't traverse with no-ops! +"fmap PL -> unsafeCoerce" fmap PL = unsafeCoerce +"fmap unPl -> unsafeCoerce" fmap unPL = unsafeCoerce + #-} + +instance Show PropertyList where + show pl = showsPrec 0 pl " :: PropertyList" + showsPrec p (PL x) = showParen (p > 10) $ case outF x of + PLArray arr -> showString "plArray " . showsPrec 11 (fmap PL arr) + PLData bs -> showString "plData " . showsPrec 11 bs + PLDate time -> showString "plDate " . showsPrec 11 time + PLDict dict -> showString "plDict " . showsPrec 11 (fmap PL dict) + PLReal dbl -> showString "plReal " . showsPrec 11 dbl + PLInt int -> showString "plInt " . showsPrec 11 int + PLString str -> showString "plString " . showsPrec 11 str + PLBool bool -> showString "plBool " . showsPrec 11 bool + +instance Copointed f => PListAlgebra f PropertyList where + {-# SPECIALIZE instance PListAlgebra Identity PropertyList #-} + plistAlgebra = PL . InF . fmap unPL . extract + +instance PListCoalgebra Identity a => PListAlgebra (Either a) PropertyList where + plistAlgebra = either toPlist (plistAlgebra . Identity) + +instance InitialPList Identity PropertyList + +instance Pointed f => PListCoalgebra f PropertyList where + {-# SPECIALIZE instance PListCoalgebra Identity PropertyList #-} + plistCoalgebra = point . fmap PL . outF . unPL + +instance TerminalPList Identity PropertyList + +foldPropertyList f (PL pl) = fold pl + where fold (InF x) = f (fmap fold x) + +-- * The 'PartialPropertyList' data type +-- (the universal algebra/coalgebra for the signature extended by +-- introducing new constructors) + +-- |A partially-parsed property-list term algebra, parameterized over the type of +-- \"structural holes\" in the terms. +newtype PartialPropertyList a = PPL {unPPL :: Free PropertyListS a} + deriving (Pointed, Functor, Monad, MonadFree PropertyListS) +{-# RULES + -- don't traverse with no-ops! +"fmap PPL -> unsafeCoerce" fmap PPL = unsafeCoerce +"fmap unPPl -> unsafeCoerce" fmap unPPL = unsafeCoerce + #-} + +instance Applicative PartialPropertyList where + pure = return + (<*>) = ap + +instance Foldable PartialPropertyList where + foldMap f (PPL x) = case runFree x of + Left x -> f x + Right x -> foldMap (foldMap f . PPL) x + +instance Traversable PartialPropertyList where + traverse f (PPL x) = case runFree x of + Left x -> return <$> f x + Right x -> inFree <$> traverse (traverse f . PPL) x + +instance Eq a => Eq (PartialPropertyList a) where + PPL x == PPL y = case (runFree x, runFree y) of + (Left a, Left b) -> a == b + (Right a, Right b) -> fmap PPL a == fmap PPL b + _ -> False + +instance Ord a => Ord (PartialPropertyList a) where + PPL x `compare` PPL y = case (runFree x, runFree y) of + (Left a, Left b) -> a `compare` b + (Left _, Right _) -> Left () `compare` Right () + (Right a, Right b) -> fmap PPL a `compare` fmap PPL b + (Right _, Left _) -> Right () `compare` Left () + +instance Show a => Show (PartialPropertyList a) where + showsPrec p (PPL x) = showParen (p > 10) $ case runFree x of + Left a -> showString "return " . showsPrec 11 a + Right x -> case x of + PLArray arr -> showString "plArray " . showsPrec 11 (fmap PPL arr) + PLData bs -> showString "plData " . showsPrec 11 bs + PLDate time -> showString "plDate " . showsPrec 11 time + PLDict dict -> showString "plDict " . showsPrec 11 (fmap PPL dict) + PLReal dbl -> showString "plReal " . showsPrec 11 dbl + PLInt int -> showString "plInt " . showsPrec 11 int + PLString str -> showString "plString " . showsPrec 11 str + PLBool bool -> showString "plBool " . showsPrec 11 bool + +-- 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 Copointed f => PListAlgebra f (PartialPropertyList a) where + {-# SPECIALIZE instance PListAlgebra Identity (PartialPropertyList a) #-} + plistAlgebra = inFree . extract + +instance PListAlgebra Maybe (PartialPropertyList ()) where + plistAlgebra Nothing = return () + plistAlgebra (Just x) = inFree x + +instance PListAlgebra (Either a) (PartialPropertyList a) where + plistAlgebra (Left x) = return x + plistAlgebra (Right x) = inFree x + +instance InitialPList (Either a) (PartialPropertyList a) where + +instance PListCoalgebra (Either a) (PartialPropertyList a) where + plistCoalgebra (PPL xf) = fmap (fmap PPL) (runFree xf) + +instance TerminalPList (Either a) (PartialPropertyList a) where + +instance PListCoalgebra Maybe (PartialPropertyList a) where + plistCoalgebra (PPL xf) = case runFree xf of + Left _ -> Nothing + Right x -> Just (fmap PPL x) + +-- * Convenient functions for converting from 'PartialPropertyList' to +-- 'PropertyList'. + +-- |Take a 'PartialPropertyList' that has been expunged of all incomplete +-- elements (as witnessed by the 'PListCoalgebra' 'Identity' @a@ context, which +-- states that any value of type @a@ can be unfolded to a complete 'PropertyList') +-- and convert it to a 'PropertyList'. +-- +-- This is just a convenient synonym for 'fromPlist' with the types +-- explicitly specialized. +completePropertyList :: PListCoalgebra Identity a => PartialPropertyList a -> PropertyList +completePropertyList = fromPlist + +-- |Like 'completePropertyList' but also accepting a function that \"attempts\" +-- to complete any incomplete value in the 'PartialPropertyList'. +-- +-- Note that there is a potential type-inference trap here - the @b@ parameter +-- needs to be inferrable from the function used. For example: +-- +-- > completePropertyListBy (\_ -> fail "parse error") +-- +-- will be rejected by the compiler because it doesn't know what @b@ is. +-- +-- Instead, say: +-- +-- > completePropertyListBy (\_ -> fail "parse error" :: IO PropertyList) +-- +-- (@b@ ~ 'Void' works too, or any other choice of @b@ satisfying the type +-- context) +completePropertyListBy :: (Applicative f, PListCoalgebra Identity b) + => (a -> f b) -> PartialPropertyList a -> f PropertyList +completePropertyListBy f = fmap completePropertyList . traverse f + +-- |Exactly the same as 'completePropertyListBy', except using 'Monad' in +-- place of 'Applicative' (for situations where a 'Monad' is missing an +-- 'Applicative' instance and you'd rather not add an orphan, etc.) +completePropertyListByM :: (Monad m, PListCoalgebra Identity b) + => (a -> m b) -> PartialPropertyList a -> m PropertyList +completePropertyListByM f = liftM completePropertyList . unwrapMonad . traverse (WrapMonad . f) + +-- instance for Void to allow it to be used as @a@ in 'completePropertyList': +instance Functor f => PListCoalgebra f Void where + plistCoalgebra = void diff --git a/src/Data/PropertyList/Xml.hs b/src/Data/PropertyList/Xml.hs --- a/src/Data/PropertyList/Xml.hs +++ b/src/Data/PropertyList/Xml.hs @@ -1,102 +1,102 @@ {-# LANGUAGE - TemplateHaskell, CPP + FlexibleContexts #-} - -module Data.PropertyList.Xml 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 +module Data.PropertyList.Xml + ( Plist + , readXmlPlist, showXmlPlist + , readXmlPlistFromFile, writeXmlPlistToFile + + , PlistItem + , plistToPlistItem, plistItemToPlist + + , UnparsedPlistItem(..) + , unparsedPlistItemToPlistItem + + , readXmlPropertyList, readXmlPropertyListFromFile + + , readXmlPartialPropertyList, showXmlPropertyList + , readXmlPartialPropertyListFromFile, writeXmlPropertyListToFile + + ) where -import Language.Haskell.TH.Fold +import Data.PropertyList.Algebra +import Data.PropertyList.Types +import Data.PropertyList.Xml.Parse +import Data.PropertyList.Xml.Types -type PlistItem = OneOf9 Array Data Date Dict AReal AInteger AString X.True X.False +import Control.Monad.Error ({- instance Monad (Either String) -}) -readPlist :: String -> Either String Plist -readPlist = readXml +-- * Reading and writing XML 'Plist's from files -readPlistFromFile :: FilePath -> IO (Either String Plist) -readPlistFromFile path = do +-- |Try to parse a 'Plist' from an XML property-list file. +readXmlPlistFromFile :: FilePath -> IO (Either String Plist) +readXmlPlistFromFile path = do contents <- readFile path - return (readXml contents) + return (readXmlPlist contents) -writePlistToFile :: FilePath -> Plist -> IO () -writePlistToFile path plist = do - writeFile path (showXml plist) +-- |Try to write a 'Plist' to an XML property-list file. +writeXmlPlistToFile :: FilePath -> Plist -> IO () +writeXmlPlistToFile path plist = do + writeFile path (showXmlPlist plist) -#ifdef HaXml_1_13 -readXml :: String -> Either String Plist -readXml xml = case X2H.readXml xml of - Nothing -> Left "readXml: parse failed" - Just plist -> Right plist +-- * Reading and writing XML 'PartialPropertyList's and 'PropertyList's from 'String's -showXml :: Plist -> String -showXml = X2H.showXml +-- |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 -toXml :: Plist -> Document -toXml value = - Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing)) [] Nothing []) - emptyST - ( case (toElem value) of - [CElem e] -> e - ) - [] +-- |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 -#else +--readXmlPropertyList :: String -> PropertyList +--readXmlPropertyList +-- = runIdentity +-- . completePropertyListByM (\_ -> fail "parse error" :: Identity PropertyList) +-- . either error id +-- . (readXmlPartialPropertyList :: String -> Either String (PartialPropertyList UnparsedPlistItem)) --- | 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 - _ -> "" +-- |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, PListAlgebra f PlistItem) => pl -> String +showXmlPropertyList = showXmlPlist . plistItemToPlist . fromPlist -toXml :: Plist -> Document () -toXml value = - Document (Prolog (Just (XMLDecl "1.0" Nothing Nothing)) [] Nothing []) - emptyST - ( case (toContents value) of - [CElem e ()] -> e - ) - [] -#endif +-- * Reading and writing XML 'PartialPropertyList's and 'PropertyList's from files -plistToPlistItem :: Plist -> PlistItem -plistToPlistItem = $(fold ''Plist) - (\attr -> OneOf9 ) - (\attr -> TwoOf9 ) - (\attr -> ThreeOf9) - (\attr -> FourOf9 ) - (\attr -> FiveOf9 ) - (\attr -> SixOf9 ) - (\attr -> SevenOf9) - (\attr -> EightOf9) - (\attr -> NineOf9 ) +-- |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'@). +readXmlPartialPropertyListFromFile + :: (PListCoalgebra f PlistItem, TerminalPList f pl) => + FilePath -> IO (Either String pl) +readXmlPartialPropertyListFromFile file = do + x <- readXmlPlistFromFile file + return (fmap (toPlist . plistToPlistItem) x) -plistItemToPlist = $(fold ''OneOf9) - (PlistArray attr) - (PlistData attr) - (PlistDate attr) - (PlistDict attr) - (PlistAReal attr) - (PlistAInteger attr) - (PlistAString attr) - (PlistTrue attr) - (PlistFalse attr) - where attr = fromAttrs [] +-- |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 + + +-- |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, PListAlgebra f PlistItem) => + FilePath -> pl -> IO () +writeXmlPropertyListToFile file plist = do + writeXmlPlistToFile file (plistItemToPlist (fromPlist plist)) diff --git a/src/Data/PropertyList/Xml/Dtd.hs b/src/Data/PropertyList/Xml/Dtd.hs --- a/src/Data/PropertyList/Xml/Dtd.hs +++ b/src/Data/PropertyList/Xml/Dtd.hs @@ -12,6 +12,11 @@ {-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 diff --git a/src/Data/PropertyList/Xml/Dtd_1_13.hs b/src/Data/PropertyList/Xml/Dtd_1_13.hs --- a/src/Data/PropertyList/Xml/Dtd_1_13.hs +++ b/src/Data/PropertyList/Xml/Dtd_1_13.hs @@ -14,6 +14,11 @@ {-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 diff --git a/src/Data/PropertyList/Xml/Parse.hs b/src/Data/PropertyList/Xml/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/PropertyList/Xml/Parse.hs @@ -0,0 +1,122 @@ +{-# 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 Control.Functor.Pointed +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 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 + ) . extract + +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 ) diff --git a/src/Data/PropertyList/Xml/Types.hs b/src/Data/PropertyList/Xml/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/PropertyList/Xml/Types.hs @@ -0,0 +1,116 @@ +{-# 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