happstack-data 0.5.0.3 → 6.0.1
raw patch · 9 files changed
Files
- happstack-data.cabal +37/−9
- src/Happstack/Data/Pairs.hs +2/−3
- src/Happstack/Data/Serialize.hs +22/−6
- src/Happstack/Data/Xml.hs +11/−2
- src/Happstack/Data/Xml/Base.hs +52/−2
- src/Happstack/Data/Xml/HaXml.hs +19/−19
- src/Happstack/Data/Xml/HaXml13.hs +70/−0
- src/Happstack/Data/Xml/PrintParse.hs +3/−2
- src/Happstack/Data/Xml/PrintParse13.hs +54/−0
happstack-data.cabal view
@@ -1,5 +1,5 @@ Name: happstack-data-Version: 0.5.0.3+Version: 6.0.1 License: BSD3 License-File: COPYING Author: Happstack team, HAppS LLC@@ -27,7 +27,7 @@ source-repository head type: darcs subdir: happstack-data- location: http://patch-tag.com/r/mae/happstack/pullrepo+ location: http://patch-tag.com/r/mae/happstack flag base4 @@ -35,6 +35,14 @@ Description: Build the testsuite, and include the tests in the library Default: False +Flag old-haxml+ Description: Build against HaXml => 1.13 && < 1.14+ Default: False++Flag new-haxml+ Description: Build against new HaXml+ Default: False+ Library if flag(base4) Build-Depends: base >=4 && < 5, syb@@ -50,17 +58,20 @@ else Build-Depends: syb-with-class < 0.6.1 + if flag(old-haxml)+ Build-Depends: HaXml >= 1.13 && < 1.14 + if flag(new-haxml)+ Build-Depends: HaXml >= 1.20 && < 1.21++ Build-Depends: binary, bytestring, containers,- happstack-util >= 0.5 && < 0.6, - HaXml >= 1.13 && < 1.14, mtl >= 1.1 && < 2.1, pretty,- syb-with-class >= 0.5, syb-with-class-instances-text,- text >= 0.7.1,+ text >= 0.10 && < 0.12, time >= 1.1.4, template-haskell @@ -76,11 +87,16 @@ Happstack.Data.Normalize Happstack.Data.Pairs Happstack.Data.Xml- Happstack.Data.Xml.HaXml Happstack.Data.GOps Happstack.Data.Proxy Happstack.Data.Serialize Happstack.Data.SerializeTH+ if flag(old-haxml)+ Exposed-modules: + Happstack.Data.Xml.HaXml13+ if flag(new-haxml)+ Exposed-modules: + Happstack.Data.Xml.HaXml if flag(tests) Build-depends: HUnit Exposed-modules: @@ -92,7 +108,12 @@ Other-modules: Happstack.Data.Xml.Base Happstack.Data.Xml.Instances- Happstack.Data.Xml.PrintParse+ if flag(old-haxml)+ Other-modules:+ Happstack.Data.Xml.PrintParse13+ if flag(new-haxml)+ Other-modules:+ Happstack.Data.Xml.PrintParse Extensions: TemplateHaskell, FlexibleInstances, UndecidableInstances, OverlappingInstances, MultiParamTypeClasses, CPP, FunctionalDependencies, DeriveDataTypeable, FlexibleContexts,@@ -100,7 +121,14 @@ TypeSynonymInstances, PatternGuards, PolymorphicComponents -- Should also have ", DeriveDataTypeable" but Cabal complains- GHC-Options: -Wall -O0+ if impl(ghc >= 7.0)+ ghc-options: -Wall -fno-warn-unused-do-bind+ else {+ if impl(ghc >= 6.12)+ ghc-options: -Wall -fno-warn-unused-do-bind -O0+ else+ ghc-options: -Wall -O0+ } Executable happstack-data-tests Main-Is: Test.hs
src/Happstack/Data/Pairs.hs view
@@ -6,14 +6,13 @@ ,Pairs,AsPairs ) where +import qualified Control.Arrow as A import Data.Char import Data.List import Data.Maybe ---stuff for examples import Happstack.Data.DeriveAll-import Happstack.Util.Common- import Data.Generics as G import Happstack.Data.Default -- for pairs import Happstack.Data.Xml@@ -118,7 +117,7 @@ fromPairs [] = Nothing fromPairs pairs = if res == dv && notRigidMatch then Nothing else Just res where- xml = pairsToXml $ mapFst clean pairs+ xml = pairsToXml $ map (A.first clean) pairs res = runIdentity $ fromXml Flexible xml mbRigidMatch = fromXml Rigid xml _ = [mbRigidMatch,Just res]
src/Happstack/Data/Serialize.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GADTs,+{-# LANGUAGE CPP, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GADTs, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Happstack.Data.Serialize ( Serialize(..), Version(..), Migrate(..), Mode(..), Contained, contain, extension, safeGet, safePut, getSafeGet, getSafePut, serialize, deserialize, collectVersions,- Object(objectType), mkObject, deserializeObject, parseObject,+ Object(objectType), mkObject, deserializeObject, parseObject, showQualifiedTypeRep, module Happstack.Data.Proxy ) where @@ -32,6 +32,22 @@ import Data.Binary.Put as B import Data.Binary.Get as B +#if MIN_VERSION_base(4,4,0)+-- in base >= 4.4 the Show instance for TypeRep no longer provides a+-- fully qualified name. But we have old data around that expects the+-- FQN. So we will recreate the old naming system for newer versions+-- of base. We could do something better, but happstack-state is+-- end-of-life anyway.+import Data.Typeable.Internal+showQualifiedTypeRep :: TypeRep -> String+showQualifiedTypeRep tr =+ let (TypeRep _f con _rep) = tr+ in tyConModule con ++ "." ++ show tr+#else+showQualifiedTypeRep :: TypeRep -> String+showQualifiedTypeRep tr = show tr+#endif+ -------------------------------------------------------------- -- Core types --------------------------------------------------------------@@ -119,7 +135,7 @@ Versioned wantedVersion' mbPrevious' -> do old <- safeGetVersioned wantedVersion' mbPrevious' storedVersion :: B.Get f return $ migrate old- where tStr = show (typeOf (error "huh?" :: b))+ where tStr = showQualifiedTypeRep (typeOf (error "huh?" :: b)) -- | Compares the numeric value of the versions compareVersions :: VersionId a -> VersionId b -> Ordering@@ -142,7 +158,7 @@ Primitive -> [thisType] Versioned _ Nothing -> [thisType] Versioned _ (Just (Previous prev)) -> thisType : (collectVersions prev)- where thisType = (L.pack . show . typeOf . unProxy) prox+ where thisType = (L.pack . showQualifiedTypeRep . typeOf . unProxy) prox -------------------------------------------------------------- -- Instances@@ -365,14 +381,14 @@ parseObject :: Serialize a => Object -> a parseObject (Object objType objData) = let res = runGet safeGet objData- resType = show (typeOf res)+ resType = showQualifiedTypeRep (typeOf res) in if objType /= resType then error $ "Failed to parse object of type '" ++ objType ++ "'. Expected type '" ++ resType ++ "'" else res -- | Serializes data and stores it along with its type name in an Object mkObject :: Serialize a => a -> Object-mkObject obj = Object { objectType = show (typeOf obj)+mkObject obj = Object { objectType = showQualifiedTypeRep (typeOf obj) , objectData = serialize obj } -- | Uniform container for any serialized data. It contains a string rep of the type
src/Happstack/Data/Xml.hs view
@@ -1,9 +1,18 @@-+{-# LANGUAGE CPP #-} module Happstack.Data.Xml ( module Happstack.Data.Xml.Base,- module Happstack.Data.Xml.PrintParse) where+#if defined (MIN_VERSION_haxml)+ module Happstack.Data.Xml.PrintParse+#endif+ ) where import Happstack.Data.Xml.Base+#if defined (MIN_VERSION_haxml)+#if MIN_VERSION_haxml(1,20,0) import Happstack.Data.Xml.PrintParse+#else+import Happstack.Data.Xml.PrintParse13 as Happstack.Data.Xml.PrintParse+#endif+#endif import Happstack.Data.Xml.Instances ()
src/Happstack/Data/Xml/Base.hs view
@@ -5,7 +5,44 @@ MultiParamTypeClasses, DeriveDataTypeable, ScopedTypeVariables, PatternGuards #-} -module Happstack.Data.Xml.Base where+module Happstack.Data.Xml.Base + ( Element(..)+ , insEl+ , fromXml+ , Other(..)+ , toPublicXml+ , Rigidity(..)+ , XmlD(..)+ , Xml(..)+ , xmlProxy+ , defaultToXml+ , transparentToXml+ , transparentReadXml+ , transparentXml+ , defaultReadXml+ , defaultReadXml'+ , readXmlWith+ , readVersionedElement+ , isTheAttr+ , getAttr+ , versionAttr+ , typeAttr+ , readElement+ , aConstrFromElements+ , constrFromElementsNoRootDefault+ , constrFromElements+ , getXmls+ , putXmls+ , readMXml+ , readMXmlNoRootDefault+ , xmlAttr+ , xmlShowCDatas+ , xmlShowCData+ , xmlCDataLists+ , xmlCDataList+ , noCommas+ , typeNotValue+ ) where import Control.Monad.Identity import Control.Monad.State@@ -20,8 +57,21 @@ import Happstack.Data.DeriveAll import Happstack.Data.Migrate import Happstack.Data.Normalize-import Happstack.Util.TH import Language.Haskell.TH++-- | Version of 'instanceD' that takes in a Q [Dec] instead of a [Q Dec]+-- and filters out signatures from the list of declarations+instanceD' :: CxtQ -> TypeQ -> Q [Dec] -> DecQ+instanceD' ctxt ty decs =+ do decs' <- decs+ let decs'' = filter (not . isSigD) decs'+ instanceD ctxt ty (map return decs'')++-- | Returns true if the Dec matches a SigD constructor+isSigD :: Dec -> Bool+isSigD (SigD _ _) = True+isSigD _ = False+ {-| Element recursively represents XML data. Elem n elems -> XML element with name n and described by elems. Note that elems contains sub-elements as well as the attributes or literal data of the element.
src/Happstack/Data/Xml/HaXml.hs view
@@ -13,20 +13,20 @@ isAttr _ = False -- | Lifts toHaXml to act on lists of Elements -toHaXmls :: [Element] -> [H.Content]+toHaXmls :: [Element] -> [H.Content ()] toHaXmls = map toHaXml -- | Converts the Element to HaXml Element if the Element is of the form -- Elem _ _ -toHaXmlEl :: Element -> H.Element-toHaXmlEl el = let H.CElem el' = toHaXml el in el'+toHaXmlEl :: Element -> H.Element ()+toHaXmlEl el = let (H.CElem el' _)= toHaXml el in el' -- | Conversion function between the Happstack Element and HaXml Content types-toHaXml :: Element -> H.Content+toHaXml :: Element -> H.Content () toHaXml (Elem n es) = case partition isAttr es of (as, xs) ->- H.CElem (H.Elem n (map toAttribute as) (toHaXmls xs))-toHaXml (CData x) = H.CString True x+ H.CElem (H.Elem n (map toAttribute as) (toHaXmls xs)) ()+toHaXml (CData x) = H.CString True x () -- We can't do better than wrap an attribute up in a fake element. -- This shouldn't be happening in the real world anyway. toHaXml a@(Attr {}) = toHaXml (Elem "JustAnAttr" [a])@@ -39,25 +39,25 @@ -- Is this function really necessary? -- | Lifts fromHaXml to operate on lists-fromHaXmls :: [H.Content] -> [Element]+fromHaXmls :: [H.Content i] -> [Element] fromHaXmls = map fromHaXml -- | Converts a HaXml Content to an Element-fromHaXml :: H.Content -> Element-fromHaXml (H.CElem (H.Elem n as xs))+fromHaXml :: H.Content i -> Element+fromHaXml (H.CElem (H.Elem n as xs) _) = Elem n (fromAttributes as ++ fromHaXmls xs)-fromHaXml (H.CString _ x) = CData x-fromHaXml (H.CRef (H.RefEntity "amp")) = CData "&"-fromHaXml (H.CRef (H.RefEntity "lt")) = CData "<"-fromHaXml (H.CRef (H.RefEntity "gt")) = CData ">"-fromHaXml (H.CRef (H.RefEntity "apos")) = CData "'"-fromHaXml (H.CRef (H.RefEntity "quot")) = CData "\""-fromHaXml (H.CRef (H.RefEntity x)) = +fromHaXml (H.CString _ x _) = CData x+fromHaXml (H.CRef (H.RefEntity "amp") _) = CData "&"+fromHaXml (H.CRef (H.RefEntity "lt") _) = CData "<"+fromHaXml (H.CRef (H.RefEntity "gt") _) = CData ">"+fromHaXml (H.CRef (H.RefEntity "apos") _) = CData "'"+fromHaXml (H.CRef (H.RefEntity "quot") _) = CData "\""+fromHaXml (H.CRef (H.RefEntity x) _) = error $ "fromHaXml: Not implemented ref:" ++ x-fromHaXml (H.CRef (H.RefChar x)) = +fromHaXml (H.CRef (H.RefChar x) _) = error $ "fromHaXml: Not implemented ref:" ++ (show x)-fromHaXml (H.CMisc (H.Comment _)) = CData ""-fromHaXml (H.CMisc (H.PI (_,_))) = CData ""+fromHaXml (H.CMisc (H.Comment _) _) = CData ""+fromHaXml (H.CMisc (H.PI (_,_)) _) = CData "" -- | Lifts fromAttribute to act on lists fromAttributes :: [H.Attribute] -> [Element]
+ src/Happstack/Data/Xml/HaXml13.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+ OverlappingInstances, UndecidableInstances #-}++module Happstack.Data.Xml.HaXml13 where++import Data.List+import Happstack.Data.Xml.Base+import qualified Text.XML.HaXml.Types as H++-- | +isAttr :: Element -> Bool+isAttr (Attr {}) = True+isAttr _ = False++-- | Lifts toHaXml to act on lists of Elements +toHaXmls :: [Element] -> [H.Content]+toHaXmls = map toHaXml++-- | Converts the Element to HaXml Element if the Element is of the form+-- Elem _ _ +toHaXmlEl :: Element -> H.Element+toHaXmlEl el = let H.CElem el' = toHaXml el in el'++-- | Conversion function between the Happstack Element and HaXml Content types+toHaXml :: Element -> H.Content+toHaXml (Elem n es) = case partition isAttr es of+ (as, xs) ->+ H.CElem (H.Elem n (map toAttribute as) (toHaXmls xs))+toHaXml (CData x) = H.CString True x+-- We can't do better than wrap an attribute up in a fake element.+-- This shouldn't be happening in the real world anyway.+toHaXml a@(Attr {}) = toHaXml (Elem "JustAnAttr" [a])++-- | Converts an Element that is an Attr into a HaXml Attribute. Will throw+-- an error if provided the wrong constructor.+toAttribute :: Element -> H.Attribute+toAttribute (Attr k v) = (k, H.AttValue [Left v])+toAttribute _ = error "toAttribute: Can't happen"++-- Is this function really necessary?+-- | Lifts fromHaXml to operate on lists+fromHaXmls :: [H.Content] -> [Element]+fromHaXmls = map fromHaXml++-- | Converts a HaXml Content to an Element+fromHaXml :: H.Content -> Element+fromHaXml (H.CElem (H.Elem n as xs))+ = Elem n (fromAttributes as ++ fromHaXmls xs)+fromHaXml (H.CString _ x) = CData x+fromHaXml (H.CRef (H.RefEntity "amp")) = CData "&"+fromHaXml (H.CRef (H.RefEntity "lt")) = CData "<"+fromHaXml (H.CRef (H.RefEntity "gt")) = CData ">"+fromHaXml (H.CRef (H.RefEntity "apos")) = CData "'"+fromHaXml (H.CRef (H.RefEntity "quot")) = CData "\""+fromHaXml (H.CRef (H.RefEntity x)) = + error $ "fromHaXml: Not implemented ref:" ++ x+fromHaXml (H.CRef (H.RefChar x)) = + error $ "fromHaXml: Not implemented ref:" ++ (show x)+fromHaXml (H.CMisc (H.Comment _)) = CData ""+fromHaXml (H.CMisc (H.PI (_,_))) = CData ""++-- | Lifts fromAttribute to act on lists+fromAttributes :: [H.Attribute] -> [Element]+fromAttributes = map fromAttribute++-- | Will convert a HaXml attribute that is of the form [Left _] to a+-- Happstack Element. Otherwise, will throw an error.+fromAttribute :: H.Attribute -> Element+fromAttribute (k, H.AttValue [Left v]) = Attr k v+fromAttribute _ = error "fromAttribute: Not implemented"
src/Happstack/Data/Xml/PrintParse.hs view
@@ -6,7 +6,8 @@ import Control.Monad import Text.PrettyPrint.HughesPJ-import Text.XML.HaXml.Parse+import Text.XML.HaXml.Parse (xmlParse)+import Text.XML.HaXml.Posn (noPos) import Text.XML.HaXml.Pretty import Text.XML.HaXml.Types (Document(Document), Content(CElem)) import Happstack.Data.Xml.Base@@ -40,7 +41,7 @@ instance FromString Element where fromString _ s = case xmlParse "NoFile" s of Document _ _ e _ ->- return $ fromHaXml $ CElem e+ return $ fromHaXml $ CElem e noPos -- XXX Currently we assume this always succeeds, -- but we should be allowing for the possibility of -- failure
+ src/Happstack/Data/Xml/PrintParse13.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, CPP,+ OverlappingInstances, UndecidableInstances,+ DeriveDataTypeable, MultiParamTypeClasses #-}++module Happstack.Data.Xml.PrintParse13 where++import Control.Monad+import Text.PrettyPrint.HughesPJ+import Text.XML.HaXml.Parse+import Text.XML.HaXml.Pretty+import Text.XML.HaXml.Types (Document(Document), Content(CElem))+import Happstack.Data.Xml.Base+import Happstack.Data.Xml.HaXml13+import Data.Generics as G+import Happstack.Data.DeriveAll+import Happstack.Data.Default++$(deriveAll [''Read,''Show,''Default]+ [d|+ data W = W [K]+ data K = K String+ |]+ )+++class ToString a where toString::a->String+instance ToString [Element] where+ toString = render . vcat . map (content . toHaXml)++instance ToString Element where+ toString = render . content . toHaXml++instance (Xml a,G.Data a) => ToString a where + toString = toString . toXml+++class FromString a where+ fromString :: Monad m => Rigidity m -> String -> m a++instance FromString Element where+ fromString _ s = case xmlParse "NoFile" s of+ Document _ _ e _ ->+ return $ fromHaXml $ CElem e+ -- XXX Currently we assume this always succeeds,+ -- but we should be allowing for the possibility of+ -- failure+ -- _ -> Nothing++instance FromString [Element] where+ fromString r s = liftM (: []) $ fromString r s++instance (Xml a,G.Data a) => FromString a where+ fromString r x = fromString r x >>= fromXml r+