happstack-data-6.0.0/0000755000000000000000000000000011527320403012565 5ustar0000000000000000happstack-data-6.0.0/Setup.hs0000644000000000000000000000013111527320403014214 0ustar0000000000000000 module Main (main) where import Distribution.Simple main :: IO () main = defaultMain happstack-data-6.0.0/happstack-data.cabal0000644000000000000000000000771011527320403016443 0ustar0000000000000000Name: happstack-data Version: 6.0.0 License: BSD3 License-File: COPYING Author: Happstack team, HAppS LLC Maintainer: Happstack team homepage: http://happstack.com Stability: experimental Category: Web, Distributed Computing Synopsis: Happstack data manipulation libraries Description: This package provides libraries for: . * Deriving instances for your datatypes. . * Producing default values of Haskell datatypes. . * Normalizing values of Haskell datatypes. . * Marshalling Haskell values to and from XML. . * Marshalling Haskell values to and from HTML forms. Tested-With: GHC==6.6.1, GHC==6.8.2 Build-Type: Simple 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, mtl >= 1.1 && < 2.1, pretty, syb-with-class-instances-text, text >= 0.10 && < 0.12, time >= 1.1.4, template-haskell hs-source-dirs: src if flag(tests) hs-source-dirs: tests Exposed-modules: Happstack.Data Happstack.Data.Default Happstack.Data.Default.Generic Happstack.Data.DeriveAll Happstack.Data.Migrate Happstack.Data.Normalize Happstack.Data.Pairs Happstack.Data.Xml 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 Happstack.Data.Tests.Xml002 Happstack.Data.Tests.Xml003 Other-modules: Happstack.Data.Xml.Base Happstack.Data.Xml.Instances 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, ScopedTypeVariables, GADTs, GeneralizedNewtypeDeriving, TypeSynonymInstances, PatternGuards, PolymorphicComponents -- Should also have ", DeriveDataTypeable" but Cabal complains 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 hs-source-dirs: tests, src if flag(tests) Buildable: True Build-depends: HUnit else Buildable: False happstack-data-6.0.0/COPYING0000644000000000000000000000267111527320403013626 0ustar0000000000000000Copyright (c) 2006, HAppS.org All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the HAppS.org; nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. happstack-data-6.0.0/src/0000755000000000000000000000000011527320403013354 5ustar0000000000000000happstack-data-6.0.0/src/Happstack/0000755000000000000000000000000011527320403015272 5ustar0000000000000000happstack-data-6.0.0/src/Happstack/Data.hs0000644000000000000000000000126211527320403016500 0ustar0000000000000000module Happstack.Data ( module Data.Typeable ,module Happstack.Data.Default ,module Happstack.Data.DeriveAll ,module Happstack.Data.Migrate ,module Happstack.Data.Normalize ,module Happstack.Data.Pairs ,module Happstack.Data.Xml ,module Happstack.Data.GOps ,module Happstack.Data.Serialize ,module Happstack.Data.SerializeTH ) where import Happstack.Data.GOps import Data.Typeable import Happstack.Data.Default import Happstack.Data.DeriveAll import Happstack.Data.Migrate import Happstack.Data.Normalize import Happstack.Data.Pairs import Happstack.Data.Xml import Happstack.Data.Serialize hiding (migrate, Migrate) import Happstack.Data.SerializeTH happstack-data-6.0.0/src/Happstack/Data/0000755000000000000000000000000011527320403016143 5ustar0000000000000000happstack-data-6.0.0/src/Happstack/Data/DeriveAll.hs0000644000000000000000000000732111527320403020351 0ustar0000000000000000 {-# LANGUAGE TemplateHaskell, CPP #-} {-# OPTIONS_GHC -Wall -Werror #-} ----------------------------------------------------------------------------- -- | -- Module : Happstack.Data.DeriveAll -- Copyright : (c) 2009 Happstack.com; (c) 2007 HAppS LLC -- License : BSD3 -- -- Maintainer : happs@googlegroups.com -- Stability : experimental -- Portability : Not portable -- -- Concisely specify which classes to derive for your datatypes. -- As well as the standard derivable classes, it can also -- derive syb-with-class's 'New.Data' class and Happstack.Data.Default's -- 'Default' class. -- ----------------------------------------------------------------------------- module Happstack.Data.DeriveAll (deriveAll, deriveNewData, deriveNewDataNoDefault) where import qualified Data.Generics as Old import Data.Generics.SYB.WithClass.Derive import Data.List import Happstack.Data.Default import Language.Haskell.TH {- | Derives instances for syb-with-class's Data class and Happstack.Data.Default's Default class. The list of names should be of the form [''Foo,''Bar,..] -} deriveNewData :: [Name] -> Q [Dec] deriveNewData names = do nd <- deriveData names defaults <- mapM mkDefaultInstance names return (nd ++ concat defaults) {- | Derives instances for syb-with-class's Data class only. The list of names should be of the form [''Foo,''Bar,..] -} deriveNewDataNoDefault :: [Name] -> Q [Dec] deriveNewDataNoDefault = deriveData mkDefaultInstance :: Name -> Q [Dec] mkDefaultInstance name = do info <- reify name case info of 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. -- -- Example: -- -- > $( deriveAll [''Show, ''Eq, ''Default] [d| -- > data Foo a = Foo a -- > data Bar = Baz | Quux -- > |] ) deriveAll :: [Name] -> Q [Dec] -> Q [Dec] deriveAll classes0 qdecs = do decs <- qdecs derivedDecs <- deriveDec (filter isDataOrNewtype decs) let (classDefault, classes1) = partition (''Default ==) classes0 classes2 = ''Old.Data : classes1 addDefaultInstance = not $ null classDefault f = addDerivedClasses addDefaultInstance classes2 decs' = concatMap f decs return (decs' ++ derivedDecs) addDerivedClasses :: Bool -> [Name] -> Dec -> [Dec] addDerivedClasses def cs (DataD ctxt nm tvs cons derivs) = DataD ctxt nm tvs cons (cs ++ derivs) : deriveDefault def (map tyVarBndrToName tvs) nm addDerivedClasses def cs (NewtypeD ctxt nm tvs con derivs) = NewtypeD ctxt nm tvs con (cs ++ derivs) : deriveDefault def (map tyVarBndrToName tvs) nm addDerivedClasses _ _ d = [d] deriveDefault :: Bool -> [Name] -> Name -> [Dec] deriveDefault False _ _ = [] deriveDefault True tvs n = [InstanceD context instanceHead []] where tvs' = map VarT tvs mkDef x = ConT ''Default `AppT` x 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 isDataOrNewtype (NewtypeD {}) = True isDataOrNewtype _ = False happstack-data-6.0.0/src/Happstack/Data/Serialize.hs0000644000000000000000000003762311527320403020441 0ustar0000000000000000{-# LANGUAGE 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, 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 import Happstack.Data.Migrate import Happstack.Data.Proxy import Data.Typeable 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 -------------------------------------------------------------- -- Core types -------------------------------------------------------------- data Contained a = Contained {unsafeUnPack :: a} -- | Lifts the provided value into Contained contain :: a -> Contained a contain = Contained data Previous a = forall b. (Serialize b, Migrate b a) => Previous (Proxy b) 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)) newtype VersionId a = VersionId {unVersion :: Int} deriving (Num,Read,Show,Eq) instance Binary (VersionId a) where get = liftM VersionId get put = put . unVersion 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 class (Typeable a, Version a) => Serialize a where getCopy :: Contained (Get a) putCopy :: a -> Contained Put -------------------------------------------------------------- -- Implementation -------------------------------------------------------------- getSafeGet :: forall a. Serialize a => Get (Get a) getSafeGet = case mode :: Mode a of Primitive -> return (unsafeUnPack getCopy) Versioned wantedVersion mbPrevious -> do storedVersion <- get return (safeGetVersioned wantedVersion mbPrevious storedVersion) getSafePut :: forall a. Serialize a => PutM (a -> Put) getSafePut = case mode :: Mode a of Primitive -> return (unsafeUnPack . putCopy) Versioned vs _ -> do B.put vs return (unsafeUnPack . putCopy) -- | Equivalent of Data.Binary.put for instances of Serialize. -- Takes into account versioning of types. safePut :: forall a. Serialize a => a -> Put safePut val = do fn <- getSafePut fn val -- | Equivalent of Data.Binary.get for instances of Serialize -- Takes into account versioning of types. safeGet :: forall a. Serialize a => Get a safeGet = join getSafeGet safeGetVersioned :: forall a b. (Serialize b) => VersionId b -> Maybe (Previous b) -> VersionId a -> B.Get b safeGetVersioned wantedVersion mbPrevious storedVersion = case compareVersions storedVersion wantedVersion of GT -> error $ "Version tag too large: " ++ show (wantedVersion,storedVersion) ++ " (" ++ tStr ++ ")" EQ -> unsafeUnPack getCopy LT -> case mbPrevious of Nothing -> error $ "No previous version (" ++ tStr ++ ")" Just (Previous (_ :: Proxy f) :: Previous b) -> case mode of Primitive -> error $ "Previous version marked as a Primitive (" ++ tStr ++ ")" Versioned wantedVersion' mbPrevious' -> do old <- safeGetVersioned wantedVersion' mbPrevious' storedVersion :: B.Get f return $ migrate old where tStr = show (typeOf (error "huh?" :: b)) -- | Compares the numeric value of the versions compareVersions :: VersionId a -> VersionId b -> Ordering compareVersions v1 v2 = compare (unVersion v1) (unVersion v2) -- | Pure version of 'safePut'. Serializes to a ByteString serialize :: Serialize a => a -> L.ByteString serialize = runPut . safePut -- | Pure version of 'safeGet'. Parses a ByteString into the expected type -- and a remainder. deserialize :: Serialize a => L.ByteString -> (a, L.ByteString) deserialize bs = case runGetState safeGet bs 0 of (val, rest, _offset) -> (val, rest) -- | Version lookups collectVersions :: forall a . (Typeable a, Version a) => Proxy a -> [L.ByteString] collectVersions prox = case mode :: Mode a of Primitive -> [thisType] Versioned _ Nothing -> [thisType] Versioned _ (Just (Previous prev)) -> thisType : (collectVersions prev) where thisType = (L.pack . show . typeOf . unProxy) prox -------------------------------------------------------------- -- Instances -------------------------------------------------------------- instance Version Int where mode = Primitive instance Serialize Int where getCopy = contain get; putCopy = contain . put instance Version Integer where mode = Primitive instance Serialize Integer where getCopy = contain get; putCopy = contain . put instance Version Float where mode = Primitive instance Serialize Float where getCopy = contain get; putCopy = contain . put instance Version Double where mode = Primitive instance Serialize Double where getCopy = contain get; putCopy = contain . put instance Version L.ByteString where mode = Primitive instance Serialize L.ByteString where getCopy = contain get; putCopy = contain . put instance Version B.ByteString where mode = Primitive instance Serialize B.ByteString where getCopy = contain get; putCopy = contain . put instance Version Char where mode = Primitive instance Serialize Char where getCopy = contain get; putCopy = contain . put instance Version Word8 where mode = Primitive instance Serialize Word8 where getCopy = contain get; putCopy = contain . put instance Version Word16 where mode = Primitive instance Serialize Word16 where getCopy = contain get; putCopy = contain . put instance Version Word32 where mode = Primitive instance Serialize Word32 where getCopy = contain get; putCopy = contain . put instance Version Word64 where mode = Primitive instance Serialize Word64 where getCopy = contain get; putCopy = contain . put instance Version Ordering where mode = Primitive instance Serialize Ordering where getCopy = contain get; putCopy = contain . put instance Version Int8 where mode = Primitive instance Serialize Int8 where getCopy = contain get; putCopy = contain . put instance Version Int16 where mode = Primitive instance Serialize Int16 where getCopy = contain get; putCopy = contain . put instance Version Int32 where mode = Primitive instance Serialize Int32 where getCopy = contain get; putCopy = contain . put 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 instance Version Bool where mode = Primitive instance Serialize Bool where getCopy = contain get; putCopy = contain . put instance Version (Either a b) where mode = Primitive instance (Serialize a, Serialize b) => Serialize (Either a b) where getCopy = contain $ do n <- get if n then liftM Right safeGet else liftM Left safeGet putCopy (Right a) = contain $ put True >> safePut a putCopy (Left a) = contain $ put False >> safePut a instance Version (a,b) where mode = Primitive instance (Serialize a, Serialize b) => Serialize (a,b) where getCopy = contain $ liftM2 (,) safeGet safeGet putCopy (a,b) = contain $ safePut a >> safePut b instance Version (a,b,c) where mode = Primitive instance (Serialize a, Serialize b, Serialize c) => Serialize (a,b,c) where getCopy = contain $ liftM3 (,,) safeGet safeGet safeGet putCopy (a,b,c) = contain $ safePut a >> safePut (b,c) instance Version (a,b,c,d) where mode = Primitive instance (Serialize a, Serialize b, Serialize c, Serialize d) => Serialize (a,b,c,d) where getCopy = contain $ liftM4 (,,,) safeGet safeGet safeGet safeGet putCopy (a,b,c,d) = contain $ safePut a >> safePut (b,c,d) instance Version (a,b,c,d,e) where mode = Primitive instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e) => Serialize (a,b,c,d,e) where getCopy = contain $ liftM5 (,,,,) safeGet safeGet safeGet safeGet safeGet putCopy (a,b,c,d,e) = contain $ safePut a >> safePut (b,c,d,e) instance Version (Proxy a) where mode = Primitive instance Typeable a => Serialize (Proxy a) where getCopy = contain $ return Proxy putCopy Proxy = contain $ return () instance Version [a] where mode = Primitive instance Serialize a => Serialize [a] where getCopy = contain $ do n <- get getSafeGet >>= replicateM n putCopy lst = contain $ do put (length lst) getSafePut >>= forM_ lst instance Version (Maybe a) where mode = Primitive instance Serialize a => Serialize (Maybe a) where getCopy = contain $ do n <- get if n then liftM Just safeGet else return Nothing putCopy (Just a) = contain $ put True >> safePut a putCopy Nothing = contain $ put False instance Version (Set.Set a) where mode = Primitive instance (Serialize a, Ord a) => Serialize (Set.Set a) where getCopy = contain $ fmap Set.fromAscList safeGet putCopy = contain . safePut . Set.toList instance Version (Map.Map a b) where mode = Primitive instance (Serialize a,Serialize b, Ord a) => Serialize (Map.Map a b) where getCopy = contain $ fmap Map.fromAscList safeGet putCopy = contain . safePut . Map.toList instance Version (IntMap.IntMap a) where mode = Primitive 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 -------------------------------------------------------------- -- | 'deserialize' specialized to Objects deserializeObject :: L.ByteString -> (Object, L.ByteString) deserializeObject = deserialize -- | Attempts to convert an Object back into its base type. -- If the conversion fails 'error' will be called. parseObject :: Serialize a => Object -> a parseObject (Object objType objData) = let res = runGet safeGet objData resType = show (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) , 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) instance Version Object instance Serialize Object where putCopy (Object objType objData) = contain $ put (objType, objData) getCopy = contain $ do (objType, objData) <- get return (Object objType objData) happstack-data-6.0.0/src/Happstack/Data/Xml.hs0000644000000000000000000000071611527320403017243 0ustar0000000000000000{-# LANGUAGE CPP #-} module Happstack.Data.Xml ( module Happstack.Data.Xml.Base, #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 () happstack-data-6.0.0/src/Happstack/Data/Proxy.hs0000644000000000000000000000121011527320403017612 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, DeriveDataTypeable, UndecidableInstances #-} module Happstack.Data.Proxy where import Happstack.Data.DeriveAll import Happstack.Data.Default -- | Proxy is empty and is used as a transport of a phantom type $(deriveAll [''Read,''Show,''Default] [d| data Proxy t = Proxy |] ) -- | Creates the Proxy with a type matching the argument proxy :: t -> Proxy t proxy _ = Proxy -- | Returns bottom unProxy :: Proxy t -> t unProxy _ = undefined -- | Acts as id except for providing type restrictions asProxyType :: t -> Proxy t -> t asProxyType t _ = t happstack-data-6.0.0/src/Happstack/Data/Default.hs0000644000000000000000000001074111527320403020066 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances, FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Happstack.Data.Default -- Copyright : (c) 2009 Happstack.com; (c) 2007 HAppS LLC -- License : BSD3 -- -- Maintainer : happs@googlegroups.com -- Stability : experimental -- Portability : Not portable -- -- Provides default values for Haskell datatypes. -- ----------------------------------------------------------------------------- module Happstack.Data.Default ( -- * The interface Default(defaultValue), -- * Writing your own instances defaultDefaultValue, -- * Advanced usage DefaultD(..), defaultProxy, ) where 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. -- -- There is no instance for arbitrary types by default, but if you -- declare an instance without providing the value then one will be -- built using the first constructor. 'defaultValue' is used to provide -- values for any arguments of the constructor. -- -- If you want an instance for all types then import -- "Happstack.Data.Default.Generic". class (Data DefaultD a) => Default a where defaultValue :: a defaultValue = defaultDefaultValue -- | This is the 'defaultValue' that is used in an instance if you don't -- specify one. It may be a useful building block when writing your own -- instances. defaultDefaultValue :: (Data DefaultD a,Default a) => a defaultDefaultValue = res where res = case datarep $ dataTypeOf defaultProxy res of AlgRep (c:_) -> fromConstrB defaultProxy (defaultValueD dict) c r -> error ("defaultDefaultValue: Bad DataRep: " ++ show r) -- | When writing your own generic functions for 'Default' you may -- need to access the class method through this datatype rather than -- directly. data DefaultD a = DefaultD { defaultValueD :: a } -- | When writing your own generic functions for 'Default' you may -- need this, the proxy value. defaultProxy :: Proxy DefaultD defaultProxy = error "defaultProxy" instance Default t => Sat (DefaultD t) where dict = DefaultD { defaultValueD = defaultValue } instance Data DefaultD a => Default [a] where defaultValue = [] instance Default Int where defaultValue = 0 instance Default Int8 where defaultValue = 0 instance Default Int16 where defaultValue = 0 instance Default Int32 where defaultValue = 0 instance Default Int64 where defaultValue = 0 instance Default Word where defaultValue = 0 instance Default Word8 where defaultValue = 0 instance Default Word16 where defaultValue = 0 instance Default Word32 where defaultValue = 0 instance Default Word64 where defaultValue = 0 instance Default Integer where defaultValue = 0 instance Default Float where defaultValue = 0 instance Default Double where defaultValue = 0 instance (Default a, Default b) => Default (Either a b) where defaultValue = Left defaultValue instance Default () where defaultValue = () instance (Default a, Default b) => Default (a,b) where defaultValue = (defaultValue, defaultValue) instance (Default a, Default b, Default c) => Default (a,b,c) where defaultValue = (defaultValue, defaultValue, defaultValue) instance (Default a, Default b, Default c, Default d) => Default (a,b,c,d) where defaultValue = (defaultValue, defaultValue, defaultValue, defaultValue) instance Default Char where defaultValue = 'A' instance Default a => Default (Maybe a) where defaultValue = Nothing 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 instance Default a => Default (ForeignPtr a) where defaultValue = error "defaultValue: ForeignPtr" instance (Data DefaultD a, Data DefaultD b, Ord a) => Default (M.Map a b) instance (Data DefaultD a, Ord a) => Default (S.Set a) happstack-data-6.0.0/src/Happstack/Data/GOps.hs0000644000000000000000000000347111527320403017354 0ustar0000000000000000module Happstack.Data.GOps where import Data.Generics hiding (GT) import Control.Monad.Reader import Control.Monad.State import Data.Maybe -- 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 let y = gFind st return $ maybe mzero f yhappstack-data-6.0.0/src/Happstack/Data/SerializeTH.hs0000644000000000000000000000741411527320403020670 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, CPP #-} module Happstack.Data.SerializeTH ( deriveSerialize , deriveSerializeFor ) where import Happstack.Data.Serialize import Language.Haskell.TH import Control.Monad import Data.Binary 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 = [ mkCtx ''Serialize [varT key] | key <- keys ] ++ map return cx i <- instanceD (sequence context) (mkType ''Serialize [mkType name (map varT keys)]) [ putCopyFn cons , getCopyFn cons ] return [i] where putCopyFn cons = do inp <- newName "inp" let putCopyBody = appE (varE 'contain) $ caseE (varE inp) $ [ do args <- replicateM nArgs (newName "arg") let matchCon = conP conName (map varP args) match matchCon (normalB (putCopyWork args i)) [] | ((conName,nArgs), i) <- zip cons [0..]] putCopyWork args i = doE $ [noBindS [| putWord8 $(litE (integerL i)) |]] ++ [ noBindS [| safePut $(varE arg) |] | arg <- args ] funD 'putCopy [clause [varP inp] (normalB putCopyBody) []] getCopyFn cons = let getCopyBody = do c <- newName "c" appE (varE 'contain) $ doE [bindS (varP c) [| getWord8 |] , noBindS $ caseE (varE c) $ [ do args <- replicateM nArgs (newName "arg") match (litP (integerL i)) (normalB $ getCopyWork conName args) [] | ((conName, nArgs), i) <- zip cons [0..]] ++ [match (return WildP) (normalB [|error "Wrong serialization type"|]) []] ] getCopyWork conName args = doE $ [ bindS (varP arg) [| safeGet |] | arg <- args ] ++ [ 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 mkType :: Name -> [TypeQ] -> TypeQ mkType con = foldl appT (conT con) parseInfo :: Name -> Q Class parseInfo name = do info <- reify name case info of 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 #endifhappstack-data-6.0.0/src/Happstack/Data/Migrate.hs0000644000000000000000000000043111527320403020065 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} module Happstack.Data.Migrate where {- | Migrate instances are needed to allow upgrades of MACID state. It should be declared as instance Migrate Old New where migrate = transition_function -} class Migrate a b where migrate :: a -> b happstack-data-6.0.0/src/Happstack/Data/Normalize.hs0000644000000000000000000000557111527320403020447 0ustar0000000000000000{-# LANGUAGE OverlappingInstances, UndecidableInstances, FlexibleContexts, FlexibleInstances #-} ----------------------------------------------------------------------------- -- | -- Module : Happstack.Data.Normalize -- Copyright : (c) Happstack.com 2009; (c) HAppS LLC 2007 -- License : BSD3 -- -- Maintainer : happs@googlegroups.com -- Stability : experimental -- Portability : Not portable -- -- Normalizing Haskell values. -- ----------------------------------------------------------------------------- module Happstack.Data.Normalize ( -- * The interface Normalize(normalize, normalizeRecursively), -- * Writing your own instances defaultNormalize, defaultNormalizeRecursively, -- * Advanced usage NormalizeD(..), normalizeProxy, ) where import Data.Generics.SYB.WithClass.Basics -- | The 'Normalize' class provides a 'normalize' function, which -- is intended to normalize values only at the top-level constructor, -- and a 'normalizeRecursively' function, which is intended to -- normalize all the subvalues and then normalize the top-level -- constructor. -- -- There is a default instance that matches all types, where 'normalize' -- is 'id' and 'normalizeRecursively' applies 'normalizeRecursively' to -- all of its children and then 'normalize' to the result. -- -- If you want to actually do some normalization for a certain type, -- then just define an instance for that type; this will take precedence -- over the default instance. class Data NormalizeD a => Normalize a where normalize :: a -> a normalize = defaultNormalize normalizeRecursively :: a -> a normalizeRecursively = defaultNormalizeRecursively -- | This is the 'normalize' function in the default 'Normalize' -- instance. It may be a useful building block when writing your own -- instances. defaultNormalize :: Normalize a => a -> a defaultNormalize x = x -- | This is the 'normalizeRecursively' function in the default -- 'Normalize' instance. It may be a useful building block when writing -- your own instances. defaultNormalizeRecursively :: Normalize a => a -> a defaultNormalizeRecursively = normalize . gmapT normalizeProxy (normalizeRecursivelyD dict) -- | When writing your own generic functions for 'Normalize' you may -- need to access the class methods through this datatype rather than -- directly. data NormalizeD a = NormalizeD { normalizeD :: a -> a, normalizeRecursivelyD :: a -> a } -- | When writing your own generic functions for 'Normalize' you may -- need this, the proxy value. normalizeProxy :: Proxy NormalizeD normalizeProxy = error "normalizeProxy" instance Normalize t => Sat (NormalizeD t) where dict = NormalizeD { normalizeD = normalize, normalizeRecursivelyD = normalizeRecursively } instance Data NormalizeD a => Normalize a happstack-data-6.0.0/src/Happstack/Data/Pairs.hs0000644000000000000000000001275211527320403017564 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, FlexibleInstances, UndecidableInstances -- just for example at the bottom ,CPP, DeriveDataTypeable, MultiParamTypeClasses #-} module Happstack.Data.Pairs (pairsToXml,xmlToPairs,pairsToHTMLForm,xmlToHTMLForm ,toPairs,toPairsX,fromPairs,toHTMLForm ,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 Data.Generics as G import Happstack.Data.Default -- for pairs import Happstack.Data.Xml import Control.Monad.Identity type Pairs = [(String,String)] -- | Converts lists of string pairs into a list of Elements. -- The basic structure is -- pairsToXml [("foo","bar")] = [Elem "foo" [CData "bar"]] -- pairsToXml [("foo/bar","baz")] = [Elem "foo" [Elem "bar" [CData "baz"]]] pairsToXml :: Pairs -> [Element] pairsToXml = fst . formIntoEls "" . map slash slash :: (String,t) -> (String,t) slash p@('/':_,_) = p slash (n,v) = ('/':n,v) formIntoEls :: String -> Pairs -> ([Element], Pairs) formIntoEls _ [] = ([],[]) formIntoEls ctx pairs@((name,val):rest) | not $ isPrefixOf ctx name = ([],pairs) | isAttr = moreCtx $ Attr elName val | isLeaf = moreCtx $ Elem elName [CData val] | otherwise = let (es,pairs') = formIntoEls ctx' pairs (es',pairs'') = formIntoEls ctx pairs' in (Elem elName es:es',pairs'') where ctx' = ctx ++ "/" ++ top node = tail $ drop (length ctx) name (top,subs) = break (=='/') node elName = takeWhile (/='[') top isLeaf = null subs isAttr = head top == '@' moreCtx el = let (restCtx,restPairs) = formIntoEls ctx rest in (el:restCtx,restPairs) -- | Converts a list of Elements to a list of String pairs. -- xmlToPairs [CData _] = error -- xmlToPairs [Elem "foo" [CData "bar"]] = [("foo","bar")] -- xmlToPairs [Elem "foo" [Elem "bar" [CData "baz"]]] = [("foo/bar","baz")] -- xmlToPairs . pairsToXml = id xmlToPairs :: [Element] -> Pairs xmlToPairs = map (\(x,y)->(tail x,y)) . xmlIntoPairs 0 "" xmlIntoPairs :: Int -> String -> [Element] -> Pairs xmlIntoPairs _ _ [] = [] xmlIntoPairs x ctx (Elem _ []:xs) = xmlIntoPairs x ctx xs xmlIntoPairs x ctx (Attr n v:xs) = (ctx++"/"++n,v):xmlIntoPairs x ctx xs xmlIntoPairs _ ctx (CData v:[]) = [(ctx,v)] xmlIntoPairs _ _ (CData _:_) = [] xmlIntoPairs i ctx ((Elem n xs):xs') = thisElPairs ++ restPairs where --if we have two elements with the same name then we have to add [i] nIndex = n ++ "[" ++ (show i) ++ "]" (iNext,nName) | i/=0 = (i+1,nIndex) | null xs' = (0,n) | next==n = (i+1,nIndex) | otherwise = (0,n) Elem next _ = head xs' thisElPairs = (xmlIntoPairs 0 (ctx++"/"++nName) xs) restPairs = (xmlIntoPairs iNext ctx xs') -- | Creates the Xml structure corresponding to the specification of an HTML -- form. The provided pairs should be the spec of the inputs to the form. pairsToHTMLForm :: String -> String -> String -> Pairs -> [Element] pairsToHTMLForm iden action method pairs = [Elem "form" (Attr "action" action : Attr "id" iden : Attr "method" method : map pToInput pairs ++ [submitButton])] submitButton :: Element submitButton = Elem "input" [Attr "type" "submit"] pToInput :: (String,String) -> Element pToInput (n,v)= Elem "div" [Attr "class" "formEl", Elem "span" [Attr "class" "name" ,CData $ map (\x->if x=='/' then ' ' else x) n] ,Elem "input" [Attr "name" n,Attr "value" v]] -- | Equivalent to pairsToHTMLForm but first converts the Xml instance to list of pairs. xmlToHTMLForm :: (Xml a, Show a, Data a, Eq a) => String -> String -> String -> a -> [Element] xmlToHTMLForm iden method action = pairsToHTMLForm iden method action . toPairsX -- xmlToPairs class (Xml x,Show x, G.Data x) => AsPairs x where toPairs::x->Pairs fromPairs::Pairs -> Maybe x instance (Xml a,Show a,G.Data a,Eq a) => AsPairs a where toPairs = xmlToPairs . toPublicXml fromPairs [] = Nothing fromPairs pairs = if res == dv && notRigidMatch then Nothing else Just res where xml = pairsToXml $ map (A.first clean) pairs res = runIdentity $ fromXml Flexible xml mbRigidMatch = fromXml Rigid xml _ = [mbRigidMatch,Just res] isRigidMatch = isJust mbRigidMatch notRigidMatch = not isRigidMatch dv = defaultValue (cons,_) = break (==' ') $ show dv clean n = if (map toLower parent)==(map toLower cons) || (head n == '/') then n else cons++('/':name) where name = trimSlash n (parent,_) = break (=='/') name trimSlash n = if head n=='/' then tail n else n toPairsX :: (Xml a, Show a, Data a, Eq a) => a -> Pairs toPairsX = map (\(n,v)->let (_,child)=break (=='/') n in if null child then (n,v) else (tail child,v)) . toPairs -- | Equivalent to pairsToHTMLForm but first converts the Xml instance to list of pairs. An alias for xmlToHTMLForm currently. toHTMLForm :: (Xml a, Show a, Data a, Eq a) => String -> String -> String -> a -> [Element] toHTMLForm = xmlToHTMLForm --- example usage and tests here $( deriveAll [''Show,''Default,''Eq] [d| data UserInfo = UserInfo User Pass newtype User = User String newtype Pass = Pass String |] ) happstack-data-6.0.0/src/Happstack/Data/Xml/0000755000000000000000000000000011527320403016703 5ustar0000000000000000happstack-data-6.0.0/src/Happstack/Data/Xml/Base.hs0000644000000000000000000005103611527320403020116 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, FlexibleInstances, OverlappingInstances, UndecidableInstances, CPP, ScopedTypeVariables, GADTs, PolymorphicComponents, FlexibleContexts, MultiParamTypeClasses, DeriveDataTypeable, ScopedTypeVariables, PatternGuards #-} 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 import Data.Char import Data.List 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 import Happstack.Data.Default import Happstack.Data.DeriveAll import Happstack.Data.Migrate import Happstack.Data.Normalize 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. CData d -> Literal string data Attr key val -> Key/Value pair of the element attribute. -} $(deriveAll [''Default, ''Eq,''Read,''Ord] [d| data Element = Elem String [Element] | CData String | Attr String String |]) -- | insEl a b will convert a to xml and insert it into the -- xml of b if b results in an Elem constructor. insEl :: (Data XmlD a, Default a, Data NormalizeD a, Data XmlD b, Default b, Data NormalizeD b) => a -> b -> Element insEl a b = case toXml b of (Elem n xs:_) -> Elem n $ toPublicXml a ++ xs _ -> error "can't insert a into b" -- This is a more readable representation than the default, but is still -- Haskell syntax instance Show Element where show (Elem s es) = "Elem " ++ show s ++ " [" ++ fiddle (unlines (indent (concatMap lines $ comma $ map show es))) ++ "]" where indent = map (" " ++) comma::[String]->[String] comma [] = [] comma (x:xs) = (' ':x):map (',':) xs fiddle "" = "" fiddle xs = '\n' : (if last xs == '\n' then init xs else xs) show (CData s) = "CData " ++ show s show (Attr k v) = "Attr " ++ show k ++ " " ++ show v -- | Wrapper around the Xml class method readXml. -- The Rigidity will determine the behavior in the case of a failed parsing: Rigid will return Nothing and Flexible will return Identity (defaultValue) fromXml :: forall m a . (Monad m, Xml a) => Rigidity m -> [Element] -> m a fromXml r xs = case readXml r xs of Just (_, v) -> return v Nothing -> case r of Rigid -> fail "fromXml XXX" Flexible -> return defaultValue data Other b = forall a . (Migrate a b, Xml a) => Other a | NoOther -- | Identical to toXml from Xml class except that it will remove attributes named haskellType or haskellTypeVersion toPublicXml :: Xml a => a -> [Element] toPublicXml x = clean $ toXml x where clean [] = [] clean ((Elem n xs):rest) = (Elem n $ clean xs): clean rest clean (CData s:rest)=CData s:clean rest clean (Attr n v:rest) = if n `elem` [typeAttr,versionAttr] then clean rest else Attr n v:clean rest -- | Rigidity is used to designate the result of a failed Xml parsing. data Rigidity m where Rigid :: Rigidity Maybe Flexible :: Rigidity Identity instance Show (Rigidity m) where show Rigid = "Rigid" show Flexible = "Flexible" class (Data XmlD a, Default a, -- We'd rather have this only in the Flexible case, -- but bugs in GHC 6.6.1 and problems getting the -- instance for child types in constrFromElements -- mean it's a constraint of the Xml class for now. Normalize a) => Xml a where toXml :: a -> [Element] toXml = defaultToXml -- readXml is like readXml' except it normalises the Elements and -- the result readXml :: Monad m => Rigidity m -> [Element] -> Maybe ([Element], a) readXml = defaultReadXml readXml' :: Monad m => Rigidity m -> [Element] -> Maybe ([Element], a) readXml' = defaultReadXml' normalizeXml :: a{- can't look at this value -} -> [Element] -> [Element] normalizeXml _ = id version :: a{- can't look at this value -} -> Maybe String version _ = Just "0" otherVersion :: a{- can't look at this value -} -> Other a otherVersion _ = NoOther typ :: a{- can't look at this value -} -> String typ _ = dataTypeName (dataTypeOf xmlProxy (undefined :: a)) instance (Data XmlD t, Default t, Normalize t) => Xml t data XmlD a = XmlD { toXmlD :: a -> [Element], readMXmlD :: forall m . Monad m => Rigidity m -> ReadM m a, readMXmlNoRootDefaultD :: forall m . Monad m => Rigidity m -> ReadM Maybe a } -- | Used as a type witness for usage with syb-with-class Data class. xmlProxy :: Proxy XmlD xmlProxy = error "xmlProxy" instance Xml t => Sat (XmlD t) where dict = XmlD { toXmlD = toXml, readMXmlD = readMXml, readMXmlNoRootDefaultD = readMXmlNoRootDefault } -- | Applies function to only first element of the list. Safe on empty lists. first :: (a -> a) -> [a] -> [a] first _ [] = [] first f (x:xs) = f x : xs {- | Converts the argument to an Xml element with the constructor name as the root of the Elem and the additional attributes corresponding to haskellType and haskellTypeVersion added -} defaultToXml :: Xml t => t -> [Element] defaultToXml x = let me = first toLower $ constring $ toConstr xmlProxy x rest = Attr typeAttr (dataTypeName (dataTypeOf xmlProxy x)) : transparentToXml x rest' = case version x of Nothing -> rest Just v -> Attr versionAttr v : rest in [Elem me rest'] -- | Generically traverses an instance of Xml and converts it into a list of elements transparentToXml :: Xml t => t -> [Element] transparentToXml = concat . gmapQ xmlProxy (toXmlD dict) -- | Attempts to parse the set of elements and return the first constructor it -- can successfully parse of the inferred type. transparentReadXml :: forall m t . (Monad m, Xml t) => Rigidity m -> [Element] -> Maybe ([Element], t) transparentReadXml r es = aConstrFromElements r (dataTypeConstrs (dataTypeOf xmlProxy resType)) es where resType :: t resType = typeNotValue resType -- | Create an Xml instance using transparentToXml and transparentReadXml transparentXml :: Name -> Q [Dec] transparentXml n = do i <- reify n case i of TyConI (DataD _ _ vs _ _) -> 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] toXml = transparentToXml readXml :: (Monad m, Xml a) => Rigidity m -> [Element] -> Maybe ([Element], a) readXml = transparentReadXml |] d <- instanceD' ctxt instanceHead decs return [d] _ -> fail ("transparentXml: Not given a type constructor's name: " ++ show n) -- Don't do any defaulting here, as these functions can be implemented -- differently by the user. We do the defaulting elsewhere instead. -- The t' type is thus not used. defaultReadXml :: (Monad m, Xml t) => Rigidity m -> [Element] -> Maybe ([Element], t) defaultReadXml r es = res where res = case readXml' r $ normalizeXml valType es of Nothing -> Nothing Just (es', v) -> Just (es', normalize v) valType = snd $ fromJust res defaultReadXml' :: (Monad m, Xml t) => Rigidity m -> [Element] -> Maybe ([Element], t) defaultReadXml' = readXmlWith readVersionedElement readXmlWith :: Xml t => (Rigidity m -> Element -> Maybe t) -> Rigidity m -> [Element] -> Maybe ([Element], t) readXmlWith f r@Rigid es = case es of e : es' -> case f r e of Just v -> Just (es', v) Nothing -> Nothing [] -> Nothing readXmlWith f r@Flexible es = readXmlWith' [] es where readXmlWith' acc (x:xs) = case f r x of Nothing -> readXmlWith' (x:acc) xs Just v -> Just (reverse acc ++ xs, v) readXmlWith' _ [] = Nothing readVersionedElement :: forall m t . (Monad m, Xml t) => Rigidity m -> Element -> Maybe t readVersionedElement r (Elem n es) = case getAttr typeAttr es of Nothing -> readElement r (Elem n es) Just (t, es') | t == typ resType -> case version resType of Nothing -> readElement r (Elem n es') Just v -> case getAttr versionAttr es' of Nothing -> readElement r (Elem n es') Just (v', es'') | v == v' -> readElement r (Elem n es'') | otherwise -> case otherVersion resType of NoOther -> Nothing Other (_ :: u) -> case readVersionedElement r (Elem n es'') of Just (res :: u) -> Just (migrate res) Nothing -> Nothing | otherwise -> Nothing where resType :: t resType = typeNotValue resType readVersionedElement _ _ = Nothing -- | Matches the provided string to the key of an attribute. Returns False if any other Element constructor is given. isTheAttr :: String -> Element -> Bool isTheAttr a (Attr k _) = a == k isTheAttr _ _ = False -- | Fetch the value of the given attribute if present, if not present will return Nothing getAttr :: String -> [Element] -> Maybe (String, [Element]) getAttr a es = case break (isTheAttr a) es of (prefix, Attr _ v : suffix) -> Just (v, prefix ++ suffix) _ -> Nothing -- | Attribute used for Xml class version information versionAttr :: String versionAttr = "haskellTypeVersion" -- | Attribute used for recording the actual Haskell type in the xml serialization typeAttr :: String typeAttr = "haskellType" readElement :: forall m t . (Monad m, Xml t) => Rigidity m -> Element -> Maybe t readElement r (Elem n es) = res where resType = dataTypeOf xmlProxy (undefined :: t) res = case readConstr resType $ first toUpper n of Just c -> f c Nothing -> if endsWithNum n then readElement r (Elem (noNum n) es) else Nothing f :: Constr -> Maybe t f c = let m :: m ([Element], t) m = constrFromElements r c es in case r of Rigid -> case m of Just ([], x) -> Just x _ -> Nothing Flexible -> case runIdentity m of -- We ignore left over elements (_, x) -> Just x endsWithNum m = (last m) `elem` "0123456789" noNum = reverse . dropWhile (`elem` "012344566789") . reverse readElement _ _ = Nothing -- When just trying all the constructors of a type, if defaulting is -- allowed we would always get the first constructor as all of its -- arguments could be defaulted. Therefore we have the choice of -- * accepting this -- * turning off defaulting for this level only -- * turning off defaulting recursively -- We choose the second option, and thus have to duplicate -- constrFromElements and readXml(D). -- | aConstrFromElements will return the results of the first constructor -- that parses correctly. aConstrFromElements :: forall m t . (Monad m, Xml t) => Rigidity m -> [Constr] -> [Element] -> Maybe ([Element], t) aConstrFromElements r cs es = msum [ constrFromElementsNoRootDefault r c es | c <- cs ] -- | Like constrFromElements but does not allow defaulting in case of -- a parse error. constrFromElementsNoRootDefault :: forall m t . (Monad m, Xml t) => Rigidity m -> Constr -> [Element] -> Maybe ([Element], t) constrFromElementsNoRootDefault r c es = do let st = ReadState { xmls = es } m :: ReadM Maybe t m = fromConstrM xmlProxy (readMXmlNoRootDefaultD dict r) c -- XXX Should we flip the result order? (x, st') <- runStateT m st return (xmls st', x) {- | Attempts to parse the given elements to build the particular type given by the constructor argument. -} constrFromElements :: forall m t . (Monad m, Xml t) => Rigidity m -> Constr -> [Element] -> m ([Element], t) constrFromElements r c es = do let st = ReadState { xmls = es } m :: ReadM m t m = fromConstrM xmlProxy (readMXmlD dict r) c -- XXX Should we flip the result order? (x, st') <- runStateT m st return (xmls st', x) type ReadM m = StateT ReadState m data ReadState = ReadState { xmls :: [Element] } -- | Returns the elements currently in the state getXmls :: Monad m => ReadM m [Element] getXmls = do st <- get return $ xmls st -- | Sets the state of the xml parsing to the given value putXmls :: Monad m => [Element] -> ReadM m () putXmls xs = do st <- get put $ st { xmls = xs } {- | Attempts to parse the current set of elements. If it fails the behavior is dependent on the Rigidity. If it is Rigid, then it will return Nothing but if it is Flexible it will return the defaultValue. If the parsing succeeds, it will return the value and store the remaining XML elements in the parser state. -} readMXml :: (Monad m, Xml a) => Rigidity m -> ReadM m a readMXml r = do xs <- getXmls case readXml r xs of Nothing -> case r of Rigid -> fail "Cannot read value" Flexible -> return defaultValue Just (xs', v) -> do putXmls xs' return v -- | Identical to readMXml except that in the case of a failed parsing it will not use defaultValue. readMXmlNoRootDefault :: (Monad m, Xml a) => Rigidity m -> ReadM Maybe a readMXmlNoRootDefault r = do xs <- getXmls case readXml r xs of Nothing -> fail "Cannot read value" Just (xs', v) -> do putXmls xs' return v xmlAttr :: Name -> Q [Dec] xmlAttr newTypeName = do i <- reify newTypeName case i of TyConI (NewtypeD _ n _ (NormalC c [(_, ConT t)]) _) | t == ''ByteString -> mkDecs n c t _ -> fail "xmlAttr: Didn't get what I wanted" where mkDecs n c t = do let x = mkName "x" f = mkName "f" cstr = stringL $ first toLower $ nameBase c toFun = funD 'toXml [clause [conP c [varP x]] (normalB [| [Attr $(litE cstr) $ BS.unpack $(varE x)] |]) []] readFun = funD 'readXml [clause [] (normalB [| readXmlWith $(varE f) |]) [readHelper]] readHelper = funD f [ clause [conP 'Attr [litP cstr, (varP x)]] (normalB [| Just $ $(conE c) $ BS.pack $(varE x) |]) [], clause [wildP] (normalB [| Nothing |]) [] ] inst <- instanceD (cxt []) ( conT ''Xml `appT` conT n) [toFun, readFun] return [inst] -- | xmlShowCData lifted to act on lists xmlShowCDatas :: [Name] -> Q [Dec] xmlShowCDatas = liftM concat . mapM xmlShowCData {- | automatically creates an Xml definition for a type that is an instance of Show and Read. This will result in an instance that converts the type to and from CData. -} xmlShowCData :: Name -> Q [Dec] xmlShowCData newTypeName = do d <- instanceD' (cxt []) (conT ''Xml `appT` conT newTypeName) [d| toXml :: (Show a, Xml a) => a -> [Element] toXml x = [CData $ show x] readXml :: (Read a, Xml a) => Rigidity m -> [Element] -> Maybe ([Element], a) readXml = readXmlWith f where f _ (CData x) | [(v, "")] <- reads x = Just v f _ _ = Nothing |] return [d] -- | xmlCDataLists lifted to act on lists xmlCDataLists :: [Name] -> Q [Dec] xmlCDataLists = liftM concat . mapM xmlCDataList {- | Creates an instance similar to xmlShowCData except for lists of the provided type -} xmlCDataList :: Name -> Q [Dec] xmlCDataList newTypeName = do d <- instanceD' (cxt []) (conT ''Xml `appT` (listT `appT` conT newTypeName)) [d| toXml :: (Show a, Xml a) => [a] -> [Element] toXml xs = [CData $ concat $ intersperse "," $ map show xs] readXml :: (Read a, Xml a) => Rigidity m -> [Element] -> Maybe ([Element], [a]) readXml = readXmlWith f where f _ (CData x) = let list = words $ noCommas x is = concatMap reads list in if length is == length list then Just $ map fst is else Nothing f _ _ = Nothing |] return [d] -- | Replaces commas in the string with single spaces noCommas :: String -> String noCommas = map (\x -> if x == ',' then ' ' else x) -- | Throws an error when called typeNotValue :: Xml a => a -> a typeNotValue t = error ("Type used as value: " ++ typeName) where typeName = dataTypeName (dataTypeOf xmlProxy t) happstack-data-6.0.0/src/Happstack/Data/Xml/Instances.hs0000644000000000000000000000574211527320403021176 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, FlexibleInstances, OverlappingInstances, UndecidableInstances, CPP, TypeSynonymInstances, PatternGuards, MultiParamTypeClasses #-} {-# OPTIONS -fno-warn-orphans #-} -- These are orphaned instances This means the existance of this file causes -- ghc to visit its .hi every time any file that depends on it in any way is -- compiled, just to see if this instance is needed module Happstack.Data.Xml.Instances where import Data.List import Happstack.Data.Xml.Base import Data.Generics.SYB.WithClass.Basics import Data.Generics.SYB.WithClass.Instances () import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as BS import Happstack.Data.Default instance Xml Element where toXml = (:[]) -- The Xml [a] context is a bit scary, but if we don't have it then -- GHC complains about overlapping instances instance (Xml a, Xml [a]) => Xml [a] where toXml = concatMap toXml readXml r = f [] [] where f acc_xs acc_vs [] = Just (reverse acc_xs, reverse acc_vs) f acc_xs acc_vs (x:xs) = case readXml r [x] of Just ([], v) -> f acc_xs (v:acc_vs) xs _ -> f (x:acc_xs) acc_vs xs instance Xml Bool where toXml True = [CData "1"] toXml False = [CData "0"] readXml = readXmlWith f where f _ (CData "1") = Just True f _ (CData "0") = Just False f _ (CData "True") = Just True f _ (CData "False") = Just False f _ (CData "T") = Just True f _ (CData "F") = Just False f _ _ = Nothing instance Default Bool where defaultValue= False instance Xml String where toXml x = [CData x] readXml = readXmlWith f where f _ (CData x) = Just x f _ _ = Nothing instance Xml Char where toXml x = [CData [x]] readXml = readXmlWith f where f _ (CData [x]) = Just x f _ _ = Nothing instance Xml ByteString where toXml x = [CData $ BS.unpack x] readXml = readXmlWith f where f _ (CData x) = Just $ BS.pack x f _ _ = Nothing instance Xml [String] where toXml xs = [CData $ concat $ intersperse "," xs] readXml = readXmlWith f where f _ (CData x) = Just $ words $ noCommas x f _ _ = Nothing $( xmlShowCDatas [''Int, ''Integer, ''Float, ''Double] ) $( xmlCDataLists [''Int, ''Integer, ''Float, ''Double] ) instance Xml a => Xml (Maybe a) where toXml = transparentToXml -- We can't use transparentReadXml or Nothing would always win, as -- it is first in the list of constructors readXml r = aConstrFromElements r $ map (toConstr xmlProxy) [Just (), Nothing] $( transparentXml ''Either ) $( transparentXml ''() ) $( transparentXml ''(,) ) $( transparentXml ''(,,) ) $( transparentXml ''(,,,) ) happstack-data-6.0.0/src/Happstack/Data/Xml/HaXml13.hs0000644000000000000000000000507611527320403020424 0ustar0000000000000000{-# 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" happstack-data-6.0.0/src/Happstack/Data/Xml/PrintParse.hs0000644000000000000000000000317111527320403021330 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, FlexibleInstances, CPP, OverlappingInstances, UndecidableInstances, DeriveDataTypeable, MultiParamTypeClasses #-} module Happstack.Data.Xml.PrintParse where import Control.Monad import Text.PrettyPrint.HughesPJ 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 import Happstack.Data.Xml.HaXml 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 noPos -- 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 happstack-data-6.0.0/src/Happstack/Data/Xml/HaXml.hs0000644000000000000000000000515011527320403020251 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, FlexibleInstances, OverlappingInstances, UndecidableInstances #-} module Happstack.Data.Xml.HaXml 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 i] -> [Element] fromHaXmls = map fromHaXml -- | Converts a HaXml Content to an Element 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) _) = 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" happstack-data-6.0.0/src/Happstack/Data/Xml/PrintParse13.hs0000644000000000000000000000311111527320403021466 0ustar0000000000000000{-# 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 happstack-data-6.0.0/src/Happstack/Data/Default/0000755000000000000000000000000011527320403017527 5ustar0000000000000000happstack-data-6.0.0/src/Happstack/Data/Default/Generic.hs0000644000000000000000000000176111527320403021444 0ustar0000000000000000 {-# LANGUAGE OverlappingInstances, UndecidableInstances #-} {-# OPTIONS -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Happstack.Data.Default.Generic -- Copyright : (c) 2009 Happstack.com; (c) 2007 HAppS LLC -- License : BSD3 -- -- Maintainer : happs@googlegroups.com -- Stability : experimental -- Portability : Not portable -- -- Provides a 'Default' instance for all types. 'defaultDefaultValue' is -- used for 'defaultValue'. -- ----------------------------------------------------------------------------- module Happstack.Data.Default.Generic () where import Happstack.Data.Default import Data.Generics.SYB.WithClass.Basics import Data.Generics.SYB.WithClass.Instances () -- This is an orphaned instanced. This means the existance of this file causes -- ghc to visit its .hi every time any files that depend on it are compiled, -- just to see if this instance is need instance Data DefaultD a => Default a happstack-data-6.0.0/tests/0000755000000000000000000000000011527320403013727 5ustar0000000000000000happstack-data-6.0.0/tests/Test.hs0000644000000000000000000000120411527320403015177 0ustar0000000000000000module Main where import Happstack.Data.Tests (allTests) import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT) import System.Exit (exitFailure) import System.IO (hIsTerminalDevice, stdout) -- |A simple driver for running the local test suite. main :: IO () main = do c <- do istty <- hIsTerminalDevice stdout if istty then runTestTT allTests else do (c,st) <- runTestText putTextToShowS allTests putStrLn (st "") return c case (failures c) + (errors c) of 0 -> return () n -> exitFailure happstack-data-6.0.0/tests/Happstack/0000755000000000000000000000000011527320403015645 5ustar0000000000000000happstack-data-6.0.0/tests/Happstack/Data/0000755000000000000000000000000011527320403016516 5ustar0000000000000000happstack-data-6.0.0/tests/Happstack/Data/Tests.hs0000644000000000000000000000066611527320403020164 0ustar0000000000000000-- |HUnit tests and QuickQuick properties for Happstack.Data.* module Happstack.Data.Tests (allTests) where import Happstack.Data.Tests.Xml001 (xml001) import Happstack.Data.Tests.Xml002 (xml002) import Happstack.Data.Tests.Xml003 (xml003) import Test.HUnit as HU (Test(..),(~:)) -- |All of the tests for happstack-data should be listed here. allTests :: Test allTests = "happstack-data tests" ~: [xml001, xml002, xml003] happstack-data-6.0.0/tests/Happstack/Data/Tests/0000755000000000000000000000000011527320403017620 5ustar0000000000000000happstack-data-6.0.0/tests/Happstack/Data/Tests/Xml001.hs0000644000000000000000000001221311527320403021134 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances, DeriveDataTypeable #-} module Happstack.Data.Tests.Xml001 (xml001, flexibleTests, flexibleManualTests, migrationTests) where import Control.Monad.Identity import Data.Generics.SYB.WithClass.Basics import Data.Maybe import Happstack.Data import Test.HUnit (Test(..),(@?=),(~:)) $( deriveAll [''Eq, ''Default, ''Show] [d| data Bap = Zip | Zap data Fuzz a = Fo | Fig a |] ) $( deriveAll [''Eq, ''Show] [d| data Foo a = DefFoo | Foo a data Bar a = DefBar | Bar a data New = New Int data Old = Old YesNo data YesNo = Yes | No -- Use our own type as Bool has a -- Xml special instance |] ) newtype MyList a = MkMyList { unMyList :: [a] } deriving (Show, Eq, Typeable) instance (Sat (ctx (MyList a)), Sat (ctx [a]), Data ctx a) => Data ctx (MyList a) where gfoldl _ f z x = z MkMyList `f` unMyList x toConstr _ (MkMyList _) = mkMyListConstr gunfold _ k z c = case constrIndex c of 1 -> k (z MkMyList) _ -> error "gunfold MyList: Can't happen" dataTypeOf _ _ = myListDataType mkMyListConstr :: Constr mkMyListConstr = mkConstr myListDataType "MkMyList" [] Prefix myListDataType :: DataType myListDataType = mkDataType "MyList" [mkMyListConstr] instance Default a => Default (MyList a) where defaultValue = MkMyList defaultValue instance Default New where defaultValue = New 7 instance Default Old where defaultValue = Old Yes instance Xml New where version _ = Just "newver" otherVersion _ = Other (error "Other" :: Old) instance Xml Old where typ _ = "New" instance Migrate Old New where migrate (Old No) = New 8 migrate (Old Yes) = New 9 instance Default YesNo where defaultValue = No instance Default a => Default (Foo a) where defaultValue = DefFoo instance Default a => Default (Bar a) where defaultValue = DefBar flexibleTests :: Test flexibleTests = "flexibleTests" ~: [mkFTest [Elem "foo" [Elem "bar" [Elem "zap" []]]] (Foo $ Just $ Bar Zap) @?= (Nothing :: Maybe Res) ,mkFTest [ Elem "bar" [Elem "zap" []] ] DefFoo @?= (Nothing :: Maybe Res) ,mkFTest [Elem "foo" [ Elem "zap" [] ]] (Foo Nothing) @?= (Nothing :: Maybe Res) ,mkFTest [Elem "foo" [Elem "bar" [ ]]] (Foo $ Just $ Bar Zip) @?= (Nothing :: Maybe Res) ,mkFTest [Elem "foo" [ ]] (Foo Nothing) @?= (Nothing :: Maybe Res) ,mkFTest [ Elem "bar" [] ] DefFoo @?= (Nothing :: Maybe Res) ,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" ~: [mkFTest [] (MkMyList []) @?= (Nothing :: Maybe (MyList YesNo)) ,mkFTest [Elem "yes" []] (MkMyList [Yes]) @?= (Nothing :: Maybe (MyList YesNo)) ,mkFTest [Elem "no" []] (MkMyList [No]) @?= (Nothing :: Maybe (MyList YesNo)) ,mkFTest [Elem "yes" [], Elem "yes" []] (MkMyList [Yes, Yes]) @?= (Nothing :: Maybe (MyList YesNo)) ,mkFTest [Elem "yes" [], Elem "no" []] (MkMyList [Yes, No]) @?= (Nothing :: Maybe (MyList YesNo)) ,mkFTest [Elem "no" [], Elem "yes" []] (MkMyList [No, Yes]) @?= (Nothing :: Maybe (MyList YesNo)) ,mkFTest [Elem "no" [], Elem "no" []] (MkMyList [No, No]) @?= (Nothing :: Maybe (MyList YesNo)) ] migrationTests :: Test migrationTests = "migrationTests" ~: [mkFTest [Elem "new" [testtype, newver, CData "5" ]] (New 5) @?= Nothing ,mkFTest [Elem "old" [testtype, oldver, Elem "yes" []]] (New 9) @?= Nothing ,mkFTest [Elem "old" [testtype, oldver, Elem "no" []]] (New 8) @?= Nothing ,mkFTest [Elem "new" [ CData "5" ]] (New 5) @?= Nothing ,mkFTest [Elem "new" [ Elem "yes" []]] (New 0) @?= Nothing ,mkFTest [Elem "new" [ ]] (New 0) @?= Nothing ,mkFTest [Elem "old" [testtype ]] (New 7) @?= Nothing ,mkFTest [Elem "old" [testtype, oldver ]] (New 8) @?= Nothing ,mkFTest [Elem "old" [ ]] (New 7) @?= Nothing ] newver :: Element newver = Attr versionAttr "newver" oldver :: Element oldver = Attr versionAttr "oldver" testtype :: Element testtype = Attr typeAttr (dataTypeName (dataTypeOf xmlProxy (undefined :: New))) type Res = Foo (Maybe (Bar Bap)) mkFTest :: (Eq a, Xml a) => [Element] -> a -> Maybe a mkFTest es v = case fromXml Flexible es of Identity v' | v == v' -> Nothing | otherwise -> Just v' xml001 :: Test xml001 = "xml001" ~: [ flexibleTests, {- flexibleManualTests, -} migrationTests ]happstack-data-6.0.0/tests/Happstack/Data/Tests/Xml002.hs0000644000000000000000000000732511527320403021145 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, UndecidableInstances, OverlappingInstances #-} module Happstack.Data.Tests.Xml002 (xml002, rigidTests, rigidManualTests) where import Control.Monad.Identity import Data.Generics.SYB.WithClass.Basics import Data.Maybe import Happstack.Data import Test.HUnit(Test(..),(@?=),(~:)) $( deriveAll [''Eq, ''Default, ''Show] [d| data Bap = Zip | Zap data Fuzz a = Fo | Fig a |] ) $( deriveAll [''Eq, ''Show] [d| data Foo a = DefFoo | Foo a data Bar a = DefBar | Bar a data YesNo = Yes | No -- Use our own type as Bool has a -- Xml special instance |] ) newtype MyList a = MkMyList { unMyList :: [a] } deriving (Show, Eq, Typeable) instance (Sat (ctx (MyList a)), Sat (ctx [a]), Data ctx a) => Data ctx (MyList a) where gfoldl _ f z x = z MkMyList `f` unMyList x toConstr _ (MkMyList _) = mkMyListConstr gunfold _ k z c = case constrIndex c of 1 -> k (z MkMyList) dataTypeOf _ _ = myListDataType mkMyListConstr :: Constr mkMyListConstr = mkConstr myListDataType "MkMyList" [] Prefix myListDataType :: DataType myListDataType = mkDataType "MyList" [mkMyListConstr] instance Default a => Default (MyList a) where defaultValue = MkMyList defaultValue instance Default YesNo where defaultValue = No instance Default a => Default (Foo a) where defaultValue = DefFoo instance Default a => Default (Bar a) where defaultValue = DefBar rigidTests :: Test rigidTests = "rigidTests" ~: [mkRTest [] (Just []) @?= (Nothing :: Maybe (Maybe [YesNo])) ,mkRTest [Elem "yes" []] (Just [Yes]) @?= (Nothing :: Maybe (Maybe [YesNo])) ,mkRTest [Elem "no" []] (Just [No]) @?= (Nothing :: Maybe (Maybe [YesNo])) ,mkRTest [Elem "yes" [], Elem "yes" []] (Just [Yes, Yes]) @?= (Nothing :: Maybe (Maybe [YesNo])) ,mkRTest [Elem "yes" [], Elem "no" []] (Just [Yes, No]) @?= (Nothing :: Maybe (Maybe [YesNo])) ,mkRTest [Elem "no" [], Elem "yes" []] (Just [No, Yes]) @?= (Nothing :: Maybe (Maybe [YesNo])) ,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" ~: [mkRTest [] (Just (MkMyList [])) @?= (Nothing :: Maybe (Maybe (MyList YesNo))) ,mkRTest [Elem "yes" []] (Just (MkMyList [Yes])) @?= (Nothing :: Maybe (Maybe (MyList YesNo))) ,mkRTest [Elem "no" []] (Just (MkMyList [No])) @?= (Nothing :: Maybe (Maybe (MyList YesNo))) ,mkRTest [Elem "yes" [], Elem "yes" []] (Just (MkMyList [Yes, Yes])) @?= (Nothing :: Maybe (Maybe (MyList YesNo))) ,mkRTest [Elem "yes" [], Elem "no" []] (Just (MkMyList [Yes, No])) @?= (Nothing :: Maybe (Maybe (MyList YesNo))) ,mkRTest [Elem "no" [], Elem "yes" []] (Just (MkMyList [No, Yes])) @?= (Nothing :: Maybe (Maybe (MyList YesNo))) ,mkRTest [Elem "no" [], Elem "no" []] (Just (MkMyList [No, No])) @?= (Nothing :: Maybe (Maybe (MyList YesNo))) ] mkRTest :: (Eq a, Xml a) => [Element] -> Maybe a -> Maybe (Maybe a) mkRTest es v = case fromXml Rigid es of v' | v == v' -> Nothing | otherwise -> Just v' xml002 :: Test xml002 = "xml002" ~: [ rigidTests {-, rigidManualTests -} ]happstack-data-6.0.0/tests/Happstack/Data/Tests/Xml003.hs0000644000000000000000000000175311527320403021145 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, UndecidableInstances, OverlappingInstances #-} module Happstack.Data.Tests.Xml003 (xml003, testPairs) where import Control.Monad.Identity import Data.Generics.SYB.WithClass.Basics import Data.Maybe import Happstack.Data import Test.HUnit(Test(..),(@=?),(~:), assertFailure) $( deriveAll [''Eq, ''Show] [d| data Foo a = DefFoo | Foo a data Bar a = DefBar | Bar a |] ) instance Default a => Default (Foo a) where defaultValue = DefFoo instance Default a => Default (Bar a) where defaultValue = DefBar -- 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 toPublicXml xs in "testPairs" ~: xs @=? xs' xml003 :: Test xml003 = "xml003" ~: [ testPairs ]