packages feed

happstack-data 0.1 → 0.2.1

raw patch · 48 files changed

+1955/−2161 lines, 48 filesdep ~happstack-utildep ~template-haskell

Dependency ranges changed: happstack-util, template-haskell

Files

happstack-data.cabal view
@@ -1,5 +1,5 @@ Name:               happstack-data-Version:            0.1+Version:            0.2.1 License:            BSD3 License-File:       COPYING Author:             Happstack team, HAppS LLC@@ -28,7 +28,7 @@  Flag tests     Description: Build the testsuite, and include the tests in the library-    Default: True+    Default: False  Library   if flag(base4)@@ -36,47 +36,49 @@   else     Build-Depends:    base < 4 -  Build-Depends:      mtl, template-haskell, syb-with-class >= 0.5, HaXml >= 1.13 && < 1.14,-                      happstack-util, bytestring, pretty, binary, containers+  Build-Depends:      binary,+                      bytestring,+                      containers,+                      happstack-util >= 0.2.1 && < 0.3, +                      HaXml >= 1.13 && < 1.14,+                      mtl,+                      pretty,+                      syb-with-class >= 0.5,+                      template-haskell+   hs-source-dirs:     src   if flag(tests)     hs-source-dirs:    tests   Exposed-modules:-    HAppS.Data-    HAppS.Data.Default-    HAppS.Data.Default.Generic-    HAppS.Data.DeriveAll-    HAppS.Data.HList-    HAppS.Data.Migrate-    HAppS.Data.Normalize-    HAppS.Data.Pairs-    HAppS.Data.Xml-    HAppS.Data.Xml.HaXml-    HAppS.Data.Atom-    HAppS.Data.GOps-    HAppS.Data.Proxy-    HAppS.Data.Serialize-    HAppS.Data.SerializeTH+    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.Xml.HaXml+    Happstack.Data.GOps+    Happstack.Data.Proxy+    Happstack.Data.Serialize+    Happstack.Data.SerializeTH   if flag(tests)     Exposed-modules:   -      HAppS.Data.Tests-      HAppS.Data.Tests.HasT001-      HAppS.Data.Tests.Xml001-      HAppS.Data.Tests.Xml002-      HAppS.Data.Tests.Xml003-      HAppS.Data.Tests.HList001-      HAppS.Data.Tests.HList002+      Happstack.Data.Tests+      Happstack.Data.Tests.Xml001+      Happstack.Data.Tests.Xml002+      Happstack.Data.Tests.Xml003    Other-modules:-    HAppS.Data.HListBase-    HAppS.Data.Xml.Base-    HAppS.Data.Xml.Instances-    HAppS.Data.Xml.PrintParse+    Happstack.Data.Xml.Base+    Happstack.Data.Xml.Instances+    Happstack.Data.Xml.PrintParse   Extensions: TemplateHaskell, FlexibleInstances, UndecidableInstances,               OverlappingInstances, MultiParamTypeClasses, CPP,               FunctionalDependencies, DeriveDataTypeable, FlexibleContexts,               ScopedTypeVariables, GADTs, GeneralizedNewtypeDeriving,-              PatternSignatures, TypeSynonymInstances, PatternGuards,+              TypeSynonymInstances, PatternGuards,               PolymorphicComponents   -- Should also have ", DeriveDataTypeable" but Cabal complains   GHC-Options: -Wall
− src/HAppS/Data.hs 
@@ -1,27 +0,0 @@-module HAppS.Data-   (-    module Data.Typeable-   ,module HAppS.Data.Default-   ,module HAppS.Data.DeriveAll-   ,module HAppS.Data.HList-   ,module HAppS.Data.Migrate-   ,module HAppS.Data.Normalize-   ,module HAppS.Data.Pairs-   ,module HAppS.Data.Xml-   ,module HAppS.Data.GOps-   ,module HAppS.Data.Serialize-   ,module HAppS.Data.SerializeTH-   )-where--import HAppS.Data.GOps-import Data.Typeable-import HAppS.Data.Default-import HAppS.Data.DeriveAll-import HAppS.Data.HList-import HAppS.Data.Migrate-import HAppS.Data.Normalize-import HAppS.Data.Pairs-import HAppS.Data.Xml-import HAppS.Data.Serialize hiding (migrate, Migrate)-import HAppS.Data.SerializeTH
− src/HAppS/Data/Atom.hs 
@@ -1,104 +0,0 @@-{-# LANGUAGE CPP, TemplateHaskell, UndecidableInstances, DeriveDataTypeable #-}-module HAppS.Data.Atom -    (-     Entry(..)-    ,Feed(..)-    ,Author(..)-    ,Contributor(..)-    ,Category(..)-    ,Id(..)-    ,Title(..)-    ,Published(..)-    ,Updated(..)-    ,Summary(..)-    ,Content(..)-    ,Word(..)-    ,Email(..)---)-    where--import HAppS.Data---$( deriveAll [''Ord,''Eq,''Read,''Show,''Default] -   [d|-    data Feed = Feed [Entry]--    data Entry = -        Entry-        [Author]                                                                                                                                              -        [Category]  -        (Maybe Content )-        [Contributor]-        Id-        -        -- Link is a computed value-        (Maybe Published)-        -- ignoring stuff I don't care about-        (Maybe Summary)-        Title-        Updated--       {----        Entry --        --stuff not in the spec but commonly useful for management-        --a -- sometime you want to stick other data in here-        --(Maybe Owner) -- not in spec but useful for actual management-        --(Maybe Refs) -- for use when Entry is actually a comment on another --        Author -- we will have only one author-        [Contributor] -- author can credit contributors-        [Category] -- allow user to select categories-        Id -        -- Link is a computed value-        Title-        Updated -        Maybe Published-        -- (Maybe Rights)-        Maybe Summary -- We choose to always have a summary-        Maybe Content -- We choose to always have content-        --}--    type PersonConstruct = (Name, Maybe Uri, Maybe Email)-    data Author = Author PersonConstruct-    data Contributor = Contributor PersonConstruct-    newtype Name = Name Text --    data Category = Category Term (Maybe Scheme) (Maybe Label) -    newtype Term = Term String -    newtype Scheme = Scheme String -    newtype Label = Label String --    newtype Id = Id Integer --    type DateConstruct = Integer--    data Title = Title TextConstruct -    data Subtitle = Subtitle TextConstruct -    newtype Summary = Summary TextConstruct -    newtype Content = Content TextConstruct --    newtype Uri = Uri String -    newtype Email = Email String -    newtype Updated = Updated DateConstruct-    newtype Published = Published DateConstruct--    type Text = String-    type TextConstruct = Text--    newtype Word = Word String- |] )--#define V(x) instance Version x-V(Uri);V(Email);V(Updated);V(Published);V(Title);V(Subtitle)-V(Summary);V(Content);V(Author);V(Contributor);V(Name);V(Category)-V(Term);V(Scheme);V(Label);V(Id)-$(deriveSerializeFor [''Uri, ''Email, ''Updated, ''Published-                     ,''Title, ''Subtitle, ''Summary, ''Content-                     ,''Author, ''Contributor, ''Name, ''Category-                     ,''Term, ''Scheme, ''Label, ''Id])-
− src/HAppS/Data/Default.hs 
@@ -1,124 +0,0 @@-{-# LANGUAGE OverlappingInstances, UndecidableInstances,-             FlexibleContexts #-}---------------------------------------------------------------------------------- |--- Module      :  HAppS.Data.Default--- Copyright   :  (c) 2007 HAppS LLC--- License     :  BSD3------ Maintainer  :  AlexJacobson@HAppS.org--- Stability   :  experimental--- Portability :  Not portable------ Provides default values for Haskell datatypes.-----------------------------------------------------------------------------------module HAppS.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.Int-import Data.Word-import qualified Data.Map as M-import qualified Data.Set as S-import Foreign.ForeignPtr---- | 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--- "HAppS.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 Default 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 ""---- 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)
− src/HAppS/Data/Default/Generic.hs 
@@ -1,26 +0,0 @@--{-# LANGUAGE OverlappingInstances, UndecidableInstances #-}---------------------------------------------------------------------------------- |--- Module      :  HAppS.Data.Default.Generic--- Copyright   :  (c) 2007 HAppS LLC--- License     :  BSD3------ Maintainer  :  AlexJacobson@HAppS.org--- Stability   :  experimental--- Portability :  Not portable------ Provides a 'Default' instance for all types. 'defaultDefaultValue' is--- used for 'defaultValue'.-----------------------------------------------------------------------------------module HAppS.Data.Default.Generic () where--import HAppS.Data.Default-import Data.Generics.SYB.WithClass.Basics-import Data.Generics.SYB.WithClass.Instances ()--instance Data DefaultD a => Default a-
− src/HAppS/Data/DeriveAll.hs 
@@ -1,90 +0,0 @@--{-# LANGUAGE TemplateHaskell, CPP #-}-{-# OPTIONS_GHC -Wall -Werror #-}---------------------------------------------------------------------------------- |--- Module      :  HAppS.Data.DeriveAll--- Copyright   :  (c) 2007 HAppS LLC--- License     :  BSD3------ Maintainer  :  AlexJacobson@HAppS.org--- 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 HAppS.Data.Default's--- 'Default' class.-----------------------------------------------------------------------------------module HAppS.Data.DeriveAll (deriveAll, deriveNewData, deriveNewDataNoDefault)-    where--import qualified Data.Generics as Old-import Data.Generics.SYB.WithClass.Derive-import Data.List-import HAppS.Data.Default-import Language.Haskell.TH--deriveNewData :: [Name] -> Q [Dec]-deriveNewData names- = do nd <- deriveData names-      defaults <- mapM mkDefaultInstance names-      return (nd ++ concat defaults)--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 tvs nm-          TyConI (DataD    _ nm tvs _ _) -> return $ deriveDefault True tvs nm-          _ -> fail ("mkDefaultInstance: Bad info: " ++ pprint info)---- | 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 tvs nm-addDerivedClasses def cs (NewtypeD ctxt nm tvs con derivs)-    = NewtypeD ctxt nm tvs con (cs ++ derivs)-    : deriveDefault def 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 mkDef tvs'-          instanceHead = mkDef $ foldl AppT (ConT n) tvs'--isDataOrNewtype :: Dec -> Bool-isDataOrNewtype (DataD {}) = True-isDataOrNewtype (NewtypeD {}) = True-isDataOrNewtype _ = False-
− src/HAppS/Data/GOps.hs 
@@ -1,36 +0,0 @@-module HAppS.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 :: (Data b, Typeable a) => a -> b -> b-gSet v = gReplace (const v)--gReplace :: (Typeable a, Data b) => (a -> a) -> b -> b-gReplace f x = everywhere (mkT f) x--gFind :: (MonadPlus m, Data a, Typeable b) => a -> m b-gFind x = msum $ map return $ listify (const True) x--gFind' :: (Data a, Typeable b) => a -> b-gFind' x = fromJust $ gFind x---Monad versions--gModify :: (MonadState s m,Typeable a,Data s) => (a->a) -> m ()-gModify f = modify $ gReplace f--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--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 y-
− src/HAppS/Data/HList.hs 
@@ -1,98 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances,-             UndecidableInstances, OverlappingInstances,-             MultiParamTypeClasses, CPP, FunctionalDependencies #-}--module HAppS.Data.HList (HasT, hlextract, hlupdate, (.&.),-                         (:&:),-                         Couple(..),Nil(..),CoupleClass,hMap,trans) where--- HList useful with generic--import HAppS.Data.Xml-import HAppS.Data.Pairs-import Data.Generics as G-import HAppS.Data.HListBase--infixr 6 .&.-(.&.) :: a -> b -> Couple a b-(.&.) = Couple--type a :&: b = Couple b a----class CoupleClass a where-    toPairs' :: a -> Pairs-    fromPairs' :: Pairs -> Maybe a--instance (Eq a,Xml a, Show a, G.Data a,CoupleClass b) => CoupleClass (Couple a b) where-    toPairs' (Couple a b) = (toPairs a) ++ (toPairs' b)-    fromPairs' = const Nothing --doesn't make sense to unmix to make toPairs' . fromPairs' an identity--instance CoupleClass Nil where-    toPairs' _ = []-    fromPairs' _ = return Nil--instance (Xml a, Xml b) => Xml (Couple a b) where-    toXml (Couple a b) = (toXml a) ++ (toXml b)-    readXml r xml = do-                  (xml', a) <- readXml r xml-                  (xml'', b) <- readXml r xml'-                  return (xml'', Couple a b)--hlextract :: HasT a b => a -> b-hlextract hlist = x hlist--hlupdate :: HasT a b => a -> b -> a-hlupdate hlist val = u hlist val--class HasT a b where-    x :: a -> b-    u :: a -> b -> a--instance HasT (Couple a b) a  where-    x (Couple a _) = a-    u (Couple _ b) a = Couple a b--instance HasT (Couple a b) b where-    x (Couple _ b) = b-    u (Couple a _) b = Couple a b---- Oleg's trick http://www.haskell.org/pipermail/haskell/2004-June/014176.html-class HasT' a b where -    x' :: a -> b-    u' :: a -> b -> a--instance HasT' a b => HasT a b where-    x a = x' a-    u a b = u' a b--instance (HasT c a) => HasT' (Couple b c) a where-    x' (Couple _ b) = x b-    u' (Couple a b) c = Couple a (u b c)--class Trans ft a where-    trans :: ft -> a -> a--instance Trans (a->a) (Couple a b) where-    trans f (Couple a b) = Couple (f a) b--instance Trans (b->b) (Couple a b) where-    trans f (Couple a b) = Couple a (f b) --class Trans' ft a where-    trans' :: ft -> a ->a--instance Trans' ft a => Trans ft a where-    trans f a = trans' f a--instance (Trans ft b) => Trans' ft (Couple a b) where-    trans' f (Couple a b) = Couple a (trans f b)--class HMap a b | a -> b where-    hMap::a->b--instance (HMap b d,CoupleClass b) => HMap (Couple a b) (Couple [a] d) where-    hMap (Couple a b) = Couple [a] $ hMap b --instance HMap (Couple a Nil) (Couple [a] Nil) where-    hMap (Couple a Nil) = Couple [a] Nil
− src/HAppS/Data/HListBase.hs 
@@ -1,17 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances,-             UndecidableInstances, OverlappingInstances,-             MultiParamTypeClasses, CPP, DeriveDataTypeable #-}-module HAppS.Data.HListBase where-import HAppS.Data.DeriveAll-import HAppS.Data.Default-import Data.Typeable--$( deriveAll [''Show,''Default,''Eq,''Read,''Ord]-   [d|-        data Couple a b = Couple a b-        data Nil = Nil-    |]-  )--nil::Nil-nil=Nil
− src/HAppS/Data/Migrate.hs 
@@ -1,6 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-module HAppS.Data.Migrate where--class Migrate a b where-    migrate :: a -> b-
− src/HAppS/Data/Normalize.hs 
@@ -1,83 +0,0 @@-{-# LANGUAGE OverlappingInstances, UndecidableInstances,-             FlexibleContexts, FlexibleInstances #-}---------------------------------------------------------------------------------- |--- Module      :  HAppS.Data.Normalize--- Copyright   :  (c) 2007 HAppS LLC--- License     :  BSD3------ Maintainer  :  AlexJacobson@HAppS.org--- Stability   :  experimental--- Portability :  Not portable------ Normalizing Haskell values.-----------------------------------------------------------------------------------module HAppS.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 x- = normalize $ gmapT normalizeProxy (normalizeRecursivelyD dict) x---- | 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-
− src/HAppS/Data/Pairs.hs 
@@ -1,141 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, UndecidableInstances -- just for example at the bottom-    ,CPP, DeriveDataTypeable, MultiParamTypeClasses-  #-}-module HAppS.Data.Pairs (pairsToXml,xmlToPairs,pairsToHTMLForm,xmlToHTMLForm-                        ,toPairs,toPairsX,fromPairs,toHTMLForm-                        ,Pairs,AsPairs-                        ) where--import Data.Char-import Data.List-import Data.Maybe-----stuff for examples-import HAppS.Data.DeriveAll-import HAppS.Util.Common--import Data.Generics as G-import HAppS.Data.Default -- for pairs-import HAppS.Data.Xml-import Control.Monad.Identity--type Pairs = [(String,String)]--pairsToXml :: Pairs -> [Element]-pairsToXml pairs = fst $ formIntoEls "" $ map slash pairs--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)-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')--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]]--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 x = xmlToPairs $ toPublicXml x-    fromPairs [] = Nothing-    fromPairs pairs = if res == dv && notRigidMatch then Nothing else Just res-        where-        xml = pairsToXml $ mapFst 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) then n-                  else if 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 x = map (\(n,v)->let (_,child)=break (=='/') n in-                            if null child then (n,v) else (tail child,v)) $ toPairs x--toHTMLForm :: (Xml a, Show a, Data a, Eq a) =>-              String -> String -> String -> a -> [Element]-toHTMLForm iden method action = xmlToHTMLForm iden method action ------- example usage and tests here-$( deriveAll [''Show,''Default,''Eq]-   [d|-       data UserInfo = UserInfo User Pass -       newtype User = User String -       newtype Pass = Pass String -    |]- )
− src/HAppS/Data/Proxy.hs 
@@ -1,20 +0,0 @@-{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, DeriveDataTypeable, UndecidableInstances #-}-module HAppS.Data.Proxy where--import HAppS.Data.DeriveAll-import HAppS.Data.Default--$(deriveAll [''Read,''Show,''Default]-  [d| data Proxy t = Proxy |]- )--proxy :: t -> Proxy t-proxy _ = Proxy--unProxy :: Proxy t -> t-unProxy _ = undefined--asProxyType :: t -> Proxy t -> t-asProxyType t _ = t--
− src/HAppS/Data/Serialize.hs 
@@ -1,276 +0,0 @@-{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GADTs,-    GeneralizedNewtypeDeriving, DeriveDataTypeable, PatternSignatures #-}-module HAppS.Data.Serialize-    ( Serialize(..), Version(..), Migrate(..), Mode(..), Contained, contain, extension,-      safeGet, safePut, serialize, deserialize, collectVersions,-      Object(objectType), mkObject, deserializeObject, parseObject,-      module HAppS.Data.Proxy-    ) where--import Control.Monad.Identity-import Data.Int()-import Foreign-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Char8 as B--import HAppS.Data.Migrate-import HAppS.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 Data.Binary     as B-import Data.Binary.Put as B-import Data.Binary.Get as B------------------------------------------------------------------- Core types-----------------------------------------------------------------data Contained a = Contained {unsafeUnPack :: a}--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)--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))--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)---safePut :: forall a. Serialize a => a -> Put-safePut val = do fn <- getSafePut-                 fn val--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))--compareVersions :: VersionId a -> VersionId b -> Ordering-compareVersions v1 v2 = compare (unVersion v1) (unVersion v2)---serialize :: Serialize a => a -> L.ByteString-serialize a = runPut (safePut a)--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-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-------------------------------------------------------------------- Object serialization-------------------------------------------------------------------deserializeObject :: L.ByteString -> (Object, L.ByteString)-deserializeObject = deserialize---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--mkObject :: Serialize a => a -> Object-mkObject obj = Object { objectType = show (typeOf obj)-                      , objectData = serialize obj }--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)
− src/HAppS/Data/SerializeTH.hs 
@@ -1,72 +0,0 @@-{-# LANGUAGE TemplateHaskell, CPP #-}-module HAppS.Data.SerializeTH-    ( deriveSerialize-    , deriveSerializeFor-    ) where--import HAppS.Data.Serialize--import Language.Haskell.TH-import Control.Monad-import Data.Binary--data Class = Tagged [(Name, Int)] Cxt [Name]--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-                  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) []]---deriveSerializeFor :: [Name] -> Q [Dec]-deriveSerializeFor names-    = liftM concat $ mapM deriveSerialize names---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 keys-           TyConI (NewtypeD cx _ keys con _)-> return $ Tagged [conInfo con] cx 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
− src/HAppS/Data/Xml.hs 
@@ -1,9 +0,0 @@--module HAppS.Data.Xml (-    module HAppS.Data.Xml.Base,-    module HAppS.Data.Xml.PrintParse) where--import HAppS.Data.Xml.Base-import HAppS.Data.Xml.PrintParse-import HAppS.Data.Xml.Instances ()-
− src/HAppS/Data/Xml/Base.hs 
@@ -1,452 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances,-             OverlappingInstances, UndecidableInstances, CPP,-             ScopedTypeVariables, GADTs,-             PolymorphicComponents, FlexibleContexts,-             MultiParamTypeClasses, DeriveDataTypeable,-             PatternGuards, PatternSignatures #-}--module HAppS.Data.Xml.Base 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 HAppS.Data.Default-import HAppS.Data.DeriveAll-import HAppS.Data.Migrate-import HAppS.Data.Normalize-import HAppS.Util.TH-import Language.Haskell.TH-import qualified Data.Generics as G--$(deriveAll [''Default, ''Eq,''Read,''Ord] [d|-    data Element = Elem String [Element]-                 | CData String-                 | Attr String String- |])--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--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--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--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 }--xmlProxy :: Proxy XmlD-xmlProxy = error "xmlProxy"--instance Xml t => Sat (XmlD t) where-    dict = XmlD { toXmlD = toXml,-                  readMXmlD = readMXml,-                  readMXmlNoRootDefaultD = readMXmlNoRootDefault }--first :: (a -> a) -> [a] -> [a]-first _ [] = []-first f (x:xs) = f x : xs--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']--transparentToXml :: Xml t => t -> [Element]-transparentToXml x = concat $ gmapQ xmlProxy (toXmlD dict) x--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--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-                     ctxt = cxt $ map mkXml args-                     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--isTheAttr :: String -> Element -> Bool-isTheAttr a (Attr k _) = a == k-isTheAttr _ _          = False--getAttr :: String -> [Element] -> Maybe (String, [Element])-getAttr a es = case break (isTheAttr a) es of-                (prefix, Attr _ v : suffix) -> Just (v, prefix ++ suffix)-                _ -> Nothing--versionAttr :: String-versionAttr = "haskellTypeVersion"--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 = head (reverse 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 :: 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 ]---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)--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]-                 }--getXmls :: Monad m => ReadM m [Element]-getXmls = do st <- get-             return $ xmls st--putXmls :: Monad m => [Element] -> ReadM m ()-putXmls xs = do st <- get-                put $ st { xmls = xs }--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--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]--xmlShowCDatas :: [Name] -> Q [Dec]-xmlShowCDatas = liftM concat . mapM xmlShowCData--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 :: [Name] -> Q [Dec]-xmlCDataLists = liftM concat . mapM xmlCDataList--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]--noCommas :: String -> String-noCommas = map (\x -> if x == ',' then ' ' else x)--typeNotValue :: Xml a => a -> a-typeNotValue t = error ("Type used as value: " ++ typeName)-    where typeName = dataTypeName (dataTypeOf xmlProxy t)-
− src/HAppS/Data/Xml/HaXml.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances,-             OverlappingInstances, UndecidableInstances #-}--module HAppS.Data.Xml.HaXml where--import Data.List-import HAppS.Data.Xml.Base-import qualified Text.XML.HaXml.Types as H--isAttr :: Element -> Bool-isAttr (Attr {}) = True-isAttr _ = False--toHaXmls :: [Element] -> [H.Content]-toHaXmls = map toHaXml--toHaXmlEl :: Element -> H.Element-toHaXmlEl el = let H.CElem el' = toHaXml el in el'---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])--toAttribute :: Element -> H.Attribute-toAttribute (Attr k v) = (k, H.AttValue [Left v])-toAttribute _ = error "toAttribute: Can't happen"--fromHaXmls :: [H.Content] -> [Element]-fromHaXmls = map fromHaXml--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 ""----fromAttributes :: [H.Attribute] -> [Element]-fromAttributes = map fromAttribute--fromAttribute :: H.Attribute -> Element-fromAttribute (k, H.AttValue [Left v]) = Attr k v-fromAttribute _ = error "fromAttribute: Not implemented"----
− src/HAppS/Data/Xml/Instances.hs 
@@ -1,93 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances,-             OverlappingInstances, UndecidableInstances, CPP,-             TypeSynonymInstances, PatternGuards,-             MultiParamTypeClasses #-}--module HAppS.Data.Xml.Instances where--import Data.Char-import Data.List-import HAppS.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--import HAppS.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 ''(,,,) )--
− src/HAppS/Data/Xml/PrintParse.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, CPP,-             OverlappingInstances, UndecidableInstances,-             DeriveDataTypeable, MultiParamTypeClasses #-}--module HAppS.Data.Xml.PrintParse 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 HAppS.Data.Xml.Base-import HAppS.Data.Xml.HaXml-import Data.Generics as G-import HAppS.Data.DeriveAll-import HAppS.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 a = toString $ toXml a---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 = do els <- fromString r x-                        fromXml r els-
+ src/Happstack/Data.hs view
@@ -0,0 +1,26 @@+module 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+
+ src/Happstack/Data/Default.hs view
@@ -0,0 +1,124 @@+{-# 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.Int+import Data.Word+import qualified Data.Map as M+import qualified Data.Set as S+import Foreign.ForeignPtr++-- | 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 Default 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 ""++-- 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)
+ src/Happstack/Data/Default/Generic.hs view
@@ -0,0 +1,30 @@++{-# 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+
+ src/Happstack/Data/DeriveAll.hs view
@@ -0,0 +1,97 @@++{-# 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 tvs nm+          TyConI (DataD    _ nm tvs _ _) -> return $ deriveDefault True tvs nm+          _ -> fail ("mkDefaultInstance: Bad info: " ++ pprint info)++-- | 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 tvs nm+addDerivedClasses def cs (NewtypeD ctxt nm tvs con derivs)+    = NewtypeD ctxt nm tvs con (cs ++ derivs)+    : deriveDefault def 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 mkDef tvs'+          instanceHead = mkDef $ foldl AppT (ConT n) tvs'++isDataOrNewtype :: Dec -> Bool+isDataOrNewtype (DataD {}) = True+isDataOrNewtype (NewtypeD {}) = True+isDataOrNewtype _ = False+
+ src/Happstack/Data/GOps.hs view
@@ -0,0 +1,35 @@+module 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 :: (Data b, Typeable a) => a -> b -> b+gSet = gReplace . const++gReplace :: (Typeable a, Data b) => (a -> a) -> b -> b+gReplace f x = everywhere (mkT f) x++gFind :: (MonadPlus m, Data a, Typeable b) => a -> m b+gFind = msum . map return . listify (const True)++gFind' :: (Data a, Typeable b) => a -> b+gFind' = fromJust . gFind+--Monad versions++gModify :: (MonadState s m,Typeable a,Data s) => (a->a) -> m ()+gModify = modify . gReplace++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++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 y
+ src/Happstack/Data/Migrate.hs view
@@ -0,0 +1,8 @@+{-# 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+
+ src/Happstack/Data/Normalize.hs view
@@ -0,0 +1,82 @@+{-# 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+
+ src/Happstack/Data/Pairs.hs view
@@ -0,0 +1,153 @@+{-# 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 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+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 $ mapFst 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 +    |]+ )
+ src/Happstack/Data/Proxy.hs view
@@ -0,0 +1,24 @@+{-# 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++
+ src/Happstack/Data/Serialize.hs view
@@ -0,0 +1,286 @@+{-# LANGUAGE UndecidableInstances, OverlappingInstances, ScopedTypeVariables, GADTs, PatternSignatures,+    GeneralizedNewtypeDeriving, DeriveDataTypeable #-}+module Happstack.Data.Serialize+    ( Serialize(..), Version(..), Migrate(..), Mode(..), Contained, contain, extension,+      safeGet, safePut, serialize, deserialize, collectVersions,+      Object(objectType), mkObject, deserializeObject, parseObject,+      module Happstack.Data.Proxy+    ) where++import Control.Monad.Identity+import Data.Int()+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 M+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified Data.Set as Set++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)++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))++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+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+++--------------------------------------------------------------+-- 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 }++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)
+ src/Happstack/Data/SerializeTH.hs view
@@ -0,0 +1,71 @@+{-# 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]++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+                  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) []]+++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 keys+           TyConI (NewtypeD cx _ keys con _)-> return $ Tagged [conInfo con] cx 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
+ src/Happstack/Data/Xml.hs view
@@ -0,0 +1,9 @@++module Happstack.Data.Xml (+    module Happstack.Data.Xml.Base,+    module Happstack.Data.Xml.PrintParse) where++import Happstack.Data.Xml.Base+import Happstack.Data.Xml.PrintParse+import Happstack.Data.Xml.Instances ()+
+ src/Happstack/Data/Xml/Base.hs view
@@ -0,0 +1,504 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+             OverlappingInstances, UndecidableInstances, CPP,+             ScopedTypeVariables, GADTs,+             PolymorphicComponents, FlexibleContexts,+             MultiParamTypeClasses, DeriveDataTypeable,+             PatternSignatures, PatternGuards #-}++module Happstack.Data.Xml.Base 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 Happstack.Util.TH+import Language.Haskell.TH+import qualified Data.Generics as G++{-| 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+                     ctxt = cxt $ map mkXml args+                     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)+
+ src/Happstack/Data/Xml/HaXml.hs view
@@ -0,0 +1,70 @@+{-# 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] -> [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
@@ -0,0 +1,97 @@+{-# 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.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++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 ''(,,,) )++
+ src/Happstack/Data/Xml/PrintParse.hs view
@@ -0,0 +1,54 @@+{-# 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+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+                       -- 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/HAppS/Data/Tests.hs 
@@ -1,16 +0,0 @@--- |HUnit tests and QuickQuick properties for HAppS.Util.*-module HAppS.Data.Tests (allTests) where--import HAppS.Data.Tests.HList001 (hlist001)-import HAppS.Data.Tests.HList002 (hlist002)-import HAppS.Data.Tests.Xml001   (xml001)-import HAppS.Data.Tests.Xml002   (xml002)-import HAppS.Data.Tests.Xml003   (xml003)-import HAppS.Data.Tests.HasT001  (hasT001)--import Test.HUnit as HU (Test(..),(~:))---- |All of the tests for happstack-util should be listed here. -allTests :: Test-allTests = -    "happstack-data tests" ~: [hlist001, hlist002, xml001, xml002, xml003, hasT001]
− tests/HAppS/Data/Tests/HList001.hs 
@@ -1,28 +0,0 @@-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,-             FlexibleInstances, MultiParamTypeClasses,-             OverlappingInstances, UndecidableInstances #-}-module HAppS.Data.Tests.HList001 (hlist001, t10, t10_2, t11) where--import Language.Haskell.TH-import HAppS.Data-import Test.HUnit--$( deriveAll [''Show,''Eq, ''Default]-   [d|-       data UserInfo = UserInfo User Pass -       newtype User = User String -       newtype Pass = Pass String -       newtype Age = Age Int-    |]- )--t10, t10_2, t11 :: Test--t10   = "t10"    ~: hlextract (User "alex" .&. "abc") @?= "abc"-t10_2 = "t10_2"  ~: hlextract (User "alex" .&. Pass "pass" .&. "abc") @?= "abc"-t11   = "t11"    ~:-        let hl = User "alex" .&. Pass "pass"-        in Pass "pass2" @?= (hlextract $ hlupdate hl (Pass "pass2"))--hlist001 :: Test-hlist001 = "hlextract" ~: [t10, t10_2, t11]
− tests/HAppS/Data/Tests/HList002.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,-             FlexibleInstances, MultiParamTypeClasses,-             OverlappingInstances, UndecidableInstances #-}-module HAppS.Data.Tests.HList002 (hlist002, t15) where--import Language.Haskell.TH-import HAppS.Data-import Test.HUnit--$( deriveAll [''Show,''Eq, ''Default]-   [d|-       data UserInfo = UserInfo User Pass -       newtype User = User String -       newtype Pass = Pass String -       newtype Age = Age Int-    |]- )-t12 :: Couple User (Couple Pass Age)-t12 = (User "ales" .&. Pass "pass" .&. Age 55 )--t13 :: Pairs-t13 = toPairs t12--t14 :: Maybe (Couple User (Couple Pass Age))-t14 = fromPairs t13 --t15 :: Test-t15 = "t15" ~: (Just t12) @?= t14--hlist002 :: Test-hlist002 = "toPairs/fromPairs" ~: [ t15 ]
− tests/HAppS/Data/Tests/HasT001.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,-             FlexibleInstances, MultiParamTypeClasses,-             OverlappingInstances, UndecidableInstances #-}-module HAppS.Data.Tests.HasT001 (hasT001, t8, t9) where--import Language.Haskell.TH-import HAppS.Data-import Test.HUnit (Test,(@?=), (~:))--$( deriveAll [''Show,''Eq, ''Default]-             [d| newtype User = User String |]- )--tHasT :: HasT hlist y => hlist -> y -> (y, y)-tHasT hlist v = (hlextract hlist, v)--t8 :: Test-t8 = "t8" ~: tHasT (User "alex" .&. "asad") (User "alex2") @?= (User "alex",User "alex2")--t9 :: Test-t9 = "t9" ~: tHasT (User "alex" .&. "asad" ) "abc" @?= ("asad","abc")--hasT001 :: Test-hasT001 = "hasT001" ~: [t8, t9]
− tests/HAppS/Data/Tests/Xml001.hs 
@@ -1,126 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances, DeriveDataTypeable #-}-module HAppS.Data.Tests.Xml001 (xml001, flexibleTests, flexibleManualTests, migrationTests) where--import Control.Monad.Identity-import Data.Generics.SYB.WithClass.Basics-import Data.Maybe-import HAppS.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)- ]--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 ]
− tests/HAppS/Data/Tests/Xml002.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, UndecidableInstances, OverlappingInstances #-}-module HAppS.Data.Tests.Xml002 (xml002, rigidTests, rigidManualTests) where--import Control.Monad.Identity-import Data.Generics.SYB.WithClass.Basics-import Data.Maybe-import HAppS.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]))-    ]--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 ]
− tests/HAppS/Data/Tests/Xml003.hs 
@@ -1,30 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, UndecidableInstances, OverlappingInstances #-}-module HAppS.Data.Tests.Xml003 (xml003, testPairs) where--import Control.Monad.Identity-import Data.Generics.SYB.WithClass.Basics-import Data.Maybe-import HAppS.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 possible 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-            in "testPairs" ~: xs @=? xs'--xml003 :: Test-xml003 = "xml003" ~: [ testPairs ]
+ tests/Happstack/Data/Tests.hs view
@@ -0,0 +1,14 @@+-- |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]+
+ tests/Happstack/Data/Tests/Xml001.hs view
@@ -0,0 +1,126 @@+{-# 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)+ ]++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 ]
+ tests/Happstack/Data/Tests/Xml002.hs view
@@ -0,0 +1,81 @@+{-# 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]))+    ]++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 ]
+ tests/Happstack/Data/Tests/Xml003.hs view
@@ -0,0 +1,30 @@+{-# 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 possible 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+            in "testPairs" ~: xs @=? xs'++xml003 :: Test+xml003 = "xml003" ~: [ testPairs ]
tests/Test.hs view
@@ -1,6 +1,6 @@ module Main where -import HAppS.Data.Tests (allTests)+import Happstack.Data.Tests (allTests) import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT) import System.Exit (exitFailure) import System.IO (hIsTerminalDevice, stdout)