packages feed

happstack-data 0.2.1 → 6.0.1

raw patch · 17 files changed

Files

happstack-data.cabal view
@@ -1,5 +1,5 @@ Name:               happstack-data-Version:            0.2.1+Version:            6.0.1 License:            BSD3 License-File:       COPYING Author:             Happstack team, HAppS LLC@@ -22,28 +22,57 @@      * Marshalling Haskell values to and from HTML forms. Tested-With:        GHC==6.6.1, GHC==6.8.2 Build-Type:         Simple-Cabal-Version:      >= 1.2.3+Cabal-Version:      >= 1.6 +source-repository head+    type:     darcs+    subdir:   happstack-data+    location: http://patch-tag.com/r/mae/happstack+ flag base4  Flag tests     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   else     Build-Depends:    base < 4 +-- Saizan said that we need syb-with-class at least 0.6.1 for+-- GHC 6.12.1, but we should use 0.6.0 for GHC 6.10.4.+-- I don't know of a nicer way than explicitly checking+-- the GHC version used.+  if impl(ghc >= 6.12.1)+    Build-Depends:    syb-with-class >= 0.6.1+  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.2.1 && < 0.3, -                      HaXml >= 1.13 && < 1.14,-                      mtl,+                      mtl >= 1.1 && < 2.1,                       pretty,-                      syb-with-class >= 0.5,+                      syb-with-class-instances-text,+                      text >= 0.10 && < 0.12,+                      time >= 1.1.4,                       template-haskell    hs-source-dirs:     src@@ -58,12 +87,18 @@     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:          Happstack.Data.Tests       Happstack.Data.Tests.Xml001@@ -73,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,@@ -81,15 +121,22 @@               TypeSynonymInstances, PatternGuards,               PolymorphicComponents   -- Should also have ", DeriveDataTypeable" but Cabal complains-  GHC-Options: -Wall+  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   GHC-Options: -threaded-  Build-depends: HUnit   hs-source-dirs: tests, src   if flag(tests)     Buildable: True+    Build-depends: HUnit   else     Buildable: False
src/Happstack/Data/Default.hs view
@@ -32,11 +32,14 @@ import qualified Data.ByteString.Char8 as BSC import Data.Generics.SYB.WithClass.Basics import Data.Generics.SYB.WithClass.Instances ()+import Data.Generics.SYB.WithClass.Instances.Text () import Data.Int import Data.Word import qualified Data.Map as M import qualified Data.Set as S import Foreign.ForeignPtr+import Data.Text      as T+import Data.Text.Lazy as L  -- | The 'Default' class provides a 'defaultValue' value, which -- is the default value for that type.@@ -76,7 +79,7 @@ instance Default t => Sat (DefaultD t) where     dict = DefaultD { defaultValueD = defaultValue } -instance Default a => Default [a] where+instance Data DefaultD a => Default [a] where     defaultValue = []  instance Default Int     where defaultValue = 0@@ -114,6 +117,12 @@  instance Default BSC.ByteString where     defaultValue = BSC.pack ""+    +instance Default T.Text where+    defaultValue = T.empty+    +instance Default L.Text where+    defaultValue = L.empty      -- We don't really want this instance, but we need it for the ByteString -- instance
src/Happstack/Data/DeriveAll.hs view
@@ -48,13 +48,23 @@ mkDefaultInstance name  = do info <- reify name       case info of-          TyConI (NewtypeD _ nm tvs _ _) -> return $ deriveDefault True tvs nm-          TyConI (DataD    _ nm tvs _ _) -> return $ deriveDefault True tvs nm+          TyConI (NewtypeD _ nm tvs _ _) -> return $ deriveDefault True (conv tvs) nm+          TyConI (DataD    _ nm tvs _ _) -> return $ deriveDefault True (conv tvs) nm           _ -> fail ("mkDefaultInstance: Bad info: " ++ pprint info)+ where conv = map tyVarBndrToName +#if MIN_VERSION_template_haskell(2,4,0)+tyVarBndrToName :: TyVarBndr -> Name+tyVarBndrToName (PlainTV nm) = nm+tyVarBndrToName (KindedTV nm _) = nm+#else+tyVarBndrToName :: Name -> Name+tyVarBndrToName = id+#endif+ -- | The 'deriveAll' function takes a list of classes to derive and -- a block of declarations. It will additionally derive instances for--- 'Typeable', 'Old.Data' and 'New.Data'.+-- Typeable, Old.Data and New.Data. -- -- Example: --@@ -76,10 +86,10 @@ addDerivedClasses :: Bool -> [Name] -> Dec -> [Dec] addDerivedClasses def cs (DataD ctxt nm tvs cons derivs)     = DataD ctxt nm tvs cons (cs ++ derivs)-    : deriveDefault def tvs nm+    : deriveDefault def (map tyVarBndrToName tvs) nm addDerivedClasses def cs (NewtypeD ctxt nm tvs con derivs)     = NewtypeD ctxt nm tvs con (cs ++ derivs)-    : deriveDefault def tvs nm+    : deriveDefault def (map tyVarBndrToName tvs) nm addDerivedClasses _ _ d = [d]  deriveDefault :: Bool -> [Name] -> Name -> [Dec]@@ -87,8 +97,15 @@ deriveDefault True tvs n = [InstanceD context instanceHead []]     where tvs' = map VarT tvs           mkDef x = ConT ''Default `AppT` x-          context = map mkDef tvs'+          context = map mkCtx tvs'           instanceHead = mkDef $ foldl AppT (ConT n) tvs'++#if MIN_VERSION_template_haskell(2,4,0)+          mkCtx x = ClassP ''Default [x]+#else+          mkCtx = mkDef+#endif+  isDataOrNewtype :: Dec -> Bool isDataOrNewtype (DataD {}) = True
src/Happstack/Data/GOps.hs view
@@ -6,28 +6,47 @@  -- useful generic functions with better names +-- | @gSet x y@ will traveral @x@ and replace +-- any instances of the type @a@ in its structure +-- with @y@. gSet :: (Data b, Typeable a) => a -> b -> b gSet = gReplace . const +-- | @gReplace f b@ will traverse @x@ and will act on+-- any instance of the type @a@ in its structure with+-- the function @f@. gReplace :: (Typeable a, Data b) => (a -> a) -> b -> b gReplace f x = everywhere (mkT f) x +-- | @gFind a@ will extract any elements of type @b@ from+-- @a@'s structure in accordance with the MonadPlus+-- instance, e.g. Maybe Foo will return the first Foo+-- found while [Foo] will return the list of Foos found. gFind :: (MonadPlus m, Data a, Typeable b) => a -> m b gFind = msum . map return . listify (const True) +-- | Acts as gFind but will throw an exception if+-- nothing is found. gFind' :: (Data a, Typeable b) => a -> b gFind' = fromJust . gFind --Monad versions +-- | A generalized modify that will apply the modification+-- function to the structure of the state. gModify :: (MonadState s m,Typeable a,Data s) => (a->a) -> m () gModify = modify . gReplace +-- | A generalized ask that will traverse the+-- stored type of the MonadReader in an attempt to find+-- an @a@ and will then apply the provided function if+-- found. gAsk :: (Data r, Typeable a, MonadReader r m, MonadPlus n) =>         (a -> n b) -> m (n b) gAsk f = do st <- ask             let y = gFind st              return $ maybe mzero f y +-- | The equivalent of 'gAsk' for MonadState gGet :: (Data s, Typeable a, MonadState s m, MonadPlus n) =>         (a -> n b) -> c -> m (n b) gGet f _ = do st <- get
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,14 +1,18 @@-{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GADTs, PatternSignatures,+{-# LANGUAGE CPP, UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GADTs,     GeneralizedNewtypeDeriving, DeriveDataTypeable #-} module Happstack.Data.Serialize     ( Serialize(..), Version(..), Migrate(..), Mode(..), Contained, contain, extension,-      safeGet, safePut, serialize, deserialize, collectVersions,-      Object(objectType), mkObject, deserializeObject, parseObject,+      safeGet, safePut, getSafeGet, getSafePut, serialize, deserialize, collectVersions,+      Object(objectType), mkObject, deserializeObject, parseObject, showQualifiedTypeRep,       module Happstack.Data.Proxy     ) where  import Control.Monad.Identity import Data.Int()+import Data.Ratio ((%), Ratio, denominator, numerator)+import Data.Time (Day(..), DiffTime, LocalTime(..), NominalDiffTime, TimeOfDay(..)+                 ,TimeZone(..), UTCTime(..), UniversalTime(..), ZonedTime(..))+import Data.Time.Clock.TAI (AbsoluteTime, taiEpoch, addAbsoluteTime, diffAbsoluteTime) import Foreign import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as B@@ -17,15 +21,33 @@ import Happstack.Data.Proxy  import Data.Typeable-import qualified Data.Map as M import qualified Data.Map as Map import qualified Data.IntMap as IntMap import qualified Data.Set as Set-+import qualified Data.Text as ST+import qualified Data.Text.Encoding as ST+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT import Data.Binary     as B 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 --------------------------------------------------------------@@ -41,6 +63,10 @@ mkPrevious :: forall a b. (Serialize b, Migrate b a) => Proxy b -> Previous a mkPrevious Proxy = Previous (Proxy :: Proxy b) +-- | Creates a Mode that is a new version of the type carried by the provided proxy+-- and with the provided version number.  Note that since VersionId is an instance of+-- Num that you may use int literals when calling extension, e.g. +-- @extension 1 (Proxy :: Proxy OldState)@ extension :: forall a b. (Serialize b, Migrate b a) => VersionId a -> Proxy b -> Mode a extension vs prox = Versioned vs (Just (mkPrevious prox)) @@ -53,6 +79,11 @@ data Mode a = Primitive -- ^ Data layout won't change. Used for types like Int and Char.             | Versioned (VersionId a) (Maybe (Previous a)) +-- | The Version type class is used to describe whether a type is fundamental+-- or if it is meant to extend another type.  For a user defined type that+-- does not extend any others, one can use the default instance of Version, e.g.+-- @instance Version MyType@ to define it has having a version id of 0 and previous+-- type. class Version a where     mode :: Mode a     mode = Versioned 0 Nothing@@ -104,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@@ -127,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@@ -181,6 +212,17 @@ instance Version Int64 where mode = Primitive instance Serialize Int64 where     getCopy = contain get; putCopy = contain . put+{-+This instance requires base >= 4.2.0.0, which means GHC >= 6.12. We can add this back in when we drop support for GHC 6.10.++instance Version (Fixed a)+instance (Typeable a, HasResolution a) => Serialize (Fixed a) where+    getCopy = contain $ liftM fromRational safeGet ; putCopy = contain . safePut . toRational+-}+instance (Typeable a)  => Version (Ratio a)+instance (Integral a, Serialize a) => Serialize (Ratio a) where+  getCopy = contain $ liftM2 (%) safeGet safeGet+  putCopy r = contain $ safePut (numerator r) >> safePut (denominator r) instance Version () where mode = Primitive instance Serialize () where     getCopy = contain get; putCopy = contain . put@@ -248,8 +290,83 @@ instance (Serialize a) => Serialize (IntMap.IntMap a) where     getCopy = contain $ fmap IntMap.fromAscList safeGet     putCopy = contain . safePut . IntMap.toList+    +instance Version ST.Text+instance Serialize ST.Text where+    putCopy = putCopy . ST.encodeUtf8+    getCopy = contain $ fmap ST.decodeUtf8 safeGet+    +instance Version LT.Text+instance Serialize LT.Text where+    putCopy = putCopy . LT.encodeUtf8+    getCopy = contain $ fmap LT.decodeUtf8 safeGet  +-- Data.Time instances+instance Version Day+instance Serialize Day where+  getCopy = contain $ liftM ModifiedJulianDay get ; putCopy = contain . put . toModifiedJulianDay++instance Version UniversalTime+instance Serialize UniversalTime where+  getCopy = contain $ liftM ModJulianDate get ; putCopy = contain . put . getModJulianDate++instance Version UTCTime+instance Serialize UTCTime where+  getCopy   = contain $ liftM2 UTCTime safeGet safeGet+  putCopy d = contain $ safePut (utctDay d) >> safePut (utctDayTime d)++instance Version TimeZone+instance Serialize TimeZone where+  getCopy   = contain $ do minutes    <- safeGet+                           summerOnly <- safeGet+                           nam        <- safeGet+                           return (TimeZone minutes summerOnly nam)+  putCopy (TimeZone minutes summerOnly nam) =+    contain $ do safePut minutes+                 safePut summerOnly+                 safePut nam++instance Version TimeOfDay+instance Serialize TimeOfDay where+  getCopy = contain $ do h <- safeGet+                         m <- safeGet+                         s <- safeGet+                         return (TimeOfDay h m (fromRational s))+  putCopy (TimeOfDay h m s) =+    contain $ do safePut h+                 safePut m+                 safePut (toRational s)++instance Version ZonedTime+instance Serialize ZonedTime where+  getCopy   = contain $ liftM2 ZonedTime safeGet safeGet+  putCopy (ZonedTime lt tz) = contain $ safePut lt >> safePut tz++instance Version LocalTime+instance Serialize LocalTime where+  getCopy   = contain $ liftM2 LocalTime safeGet safeGet+  putCopy (LocalTime day tod) = contain $ safePut day >> safePut tod++instance Version DiffTime+instance Serialize DiffTime where+  getCopy = contain $ liftM fromRational safeGet ; putCopy = contain . safePut . toRational++instance Version NominalDiffTime+instance Serialize NominalDiffTime where+  getCopy = contain $ liftM fromRational get ; putCopy = contain . put . toRational++instance Version AbsoluteTime+instance Serialize AbsoluteTime where+  getCopy = contain $ liftM toAbsoluteTime safeGet+    where+      toAbsoluteTime :: DiffTime -> AbsoluteTime+      toAbsoluteTime dt = addAbsoluteTime dt taiEpoch+  putCopy = contain . safePut . fromAbsoluteTime+    where+      fromAbsoluteTime :: AbsoluteTime -> DiffTime+      fromAbsoluteTime at = diffAbsoluteTime at taiEpoch+ -------------------------------------------------------------- -- Object serialization --------------------------------------------------------------@@ -264,16 +381,18 @@ 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+-- and the actual data serialized to a byte string. data Object = Object { objectType :: String                      , objectData :: L.ByteString                      }  deriving (Typeable,Show)
src/Happstack/Data/SerializeTH.hs view
@@ -12,12 +12,16 @@  data Class = Tagged [(Name, Int)] Cxt [Name] +-- | Derives an instance of Serialize for the provided type+-- Should work in most cases if the type is already and instance+-- of Version.  +-- Ex: @$(deriveSerialize ''Foo)@ deriveSerialize :: Name -> Q [Dec] deriveSerialize name     = do c <- parseInfo name          case c of            Tagged cons cx keys ->-               do let context = [ mkType ''Serialize [varT key] | key <- keys ] ++ map return cx+               do let context = [ mkCtx ''Serialize [varT key] | key <- keys ] ++ map return cx                   i <- instanceD (sequence context) (mkType ''Serialize [mkType name (map varT keys)])                        [ putCopyFn cons                        , getCopyFn cons@@ -50,7 +54,13 @@                                 [ noBindS [| return $(foldl appE (conE conName) (map varE args)) |] ]                 in funD 'getCopy [clause [] (normalB getCopyBody) []] +#if MIN_VERSION_template_haskell(2,4,0)+          mkCtx = classP+#else+          mkCtx = mkType+#endif +-- | Derives Serialize for a list of types deriveSerializeFor :: [Name] -> Q [Dec] deriveSerializeFor = liftM concat . mapM deriveSerialize @@ -62,10 +72,17 @@ parseInfo name     = do info <- reify name          case info of-           TyConI (DataD cx _ keys cs _)    -> return $ Tagged (map conInfo cs) cx keys-           TyConI (NewtypeD cx _ keys con _)-> return $ Tagged [conInfo con] cx keys+           TyConI (DataD cx _ keys cs _)    -> return $ Tagged (map conInfo cs) cx $ map conv keys+           TyConI (NewtypeD cx _ keys con _)-> return $ Tagged [conInfo con] cx $ map conv keys            _                            -> error "Invalid input"     where conInfo (NormalC n args) = (n, length args)           conInfo (RecC n args) = (n, length args)           conInfo (InfixC _ n _) = (n, 2)           conInfo (ForallC _ _ con) = conInfo con++#if MIN_VERSION_template_haskell(2,4,0)+          conv (PlainTV nm) = nm+          conv (KindedTV nm _) = nm+#else+          conv = id+#endif
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
@@ -3,9 +3,46 @@              ScopedTypeVariables, GADTs,              PolymorphicComponents, FlexibleContexts,              MultiParamTypeClasses, DeriveDataTypeable,-             PatternSignatures, PatternGuards #-}+             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,10 +57,22 @@ import Happstack.Data.DeriveAll import Happstack.Data.Migrate import Happstack.Data.Normalize-import Happstack.Util.TH import Language.Haskell.TH-import qualified Data.Generics as G +-- | 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.     CData d -> Literal string data@@ -184,7 +233,12 @@               do argNames <- replicateM (length vs) (newName "a")                  let args = map varT argNames                      mkXml a = conT ''Xml `appT` a+#if MIN_VERSION_template_haskell(2,4,0)+                     mkXmlPred a = classP ''Xml [a]+                     ctxt = cxt $ map mkXmlPred args+#else                      ctxt = cxt $ map mkXml args+#endif                      instanceHead = mkXml $ foldl appT (conT n) args                      decs = [d|                                 toXml :: Xml a => a -> [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/Instances.hs view
@@ -9,12 +9,10 @@  module Happstack.Data.Xml.Instances where -import Data.Char import Data.List import Happstack.Data.Xml.Base import Data.Generics.SYB.WithClass.Basics import Data.Generics.SYB.WithClass.Instances ()-import Data.Maybe import           Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS
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+
tests/Happstack/Data/Tests/Xml001.hs view
@@ -80,6 +80,13 @@  ,mkFTest [                        Elem "zap" []  ] DefFoo                  @?= (Nothing :: Maybe Res)  ] +-- NOTE: these tests have never passed, they were broken from day one.+-- It is possible that MkMyList is supposed to be treated as+-- Transparent XML, like [] and (,) but it has never been implemented+-- that way.+-- +-- We are disabling these tests until someone convinces us the tests+-- are right and the current implementation is wrong. flexibleManualTests :: Test flexibleManualTests =     "flexibleManualTest" ~:@@ -123,4 +130,4 @@                                | otherwise -> Just v'  xml001 :: Test-xml001 = "xml001" ~: [ flexibleTests, flexibleManualTests, migrationTests ]+xml001 = "xml001" ~: [ flexibleTests, {- flexibleManualTests, -} migrationTests ]
tests/Happstack/Data/Tests/Xml002.hs view
@@ -60,6 +60,13 @@     ,mkRTest [Elem "no"  [], Elem "no"  []] (Just [No,  No])  @?= (Nothing :: Maybe (Maybe [YesNo]))     ] +-- NOTE: these tests have never passed, they were broken from day one.+-- It is possible that MkMyList is supposed to be treated as+-- Transparent XML, like [] and (,) but it has never been implemented+-- that way.+-- +-- We are disabling these tests until someone convinces us the tests+-- are right and the current implementation is wrong. rigidManualTests :: Test rigidManualTests =     "rigidManualTests" ~:@@ -78,4 +85,4 @@                       | otherwise -> Just v'  xml002 :: Test-xml002 = "xml002" ~: [ rigidTests, rigidManualTests ]+xml002 = "xml002" ~: [ rigidTests {-, rigidManualTests -} ]
tests/Happstack/Data/Tests/Xml003.hs view
@@ -20,10 +20,10 @@ instance Default a => Default (Bar a) where     defaultValue = DefBar --- NOTE: I am not possible the test condition is correct, I am just guessing based on what was there+-- NOTE: I am not positive the test condition is correct, I am just guessing based on what was there testPairs :: Test testPairs = let xs = [Foo $ Bar "abc",Foo $ Bar "def"]-                xs' = runIdentity $ fromXml Flexible $ pairsToXml $ xmlToPairs $ concatMap toXml xs+                xs' = runIdentity $ fromXml Flexible $ pairsToXml $ xmlToPairs $ concatMap toPublicXml xs             in "testPairs" ~: xs @=? xs'  xml003 :: Test