packages feed

HAppS-Data (empty) → 0.9.2

raw patch · 21 files changed

+1996/−0 lines, 21 filesdep +HAppS-Utildep +HaXmldep +basesetup-changed

Dependencies added: HAppS-Util, HaXml, base, binary, bytestring, containers, mtl, pretty, regex-compat, syb-with-class, template-haskell

Files

+ HAppS-Data.cabal view
@@ -0,0 +1,53 @@+Name:               HAppS-Data+Version:            0.9.2+License:            BSD3+Copyright:          2007 HAppS LLC+Author:             HAppS LLC+Maintainer:         AlexJacobson@HAppS.org+Stability:          experimental+Category:           Web, Distributed Computing+Synopsis:           HAppS data manipulation libraries+Description:+    This package provides libraries for:+    .+     * Deriving instances for your datatypes.+    .+     * Producing default values of Haskell datatypes.+    .+     * Normalizing values of Haskell datatypes.+    .+     * Marshalling Haskell values to and from XML.+    .+     * Marshalling Haskell values to and from HTML forms.+Tested-With:        GHC==6.6.1, GHC==6.8.2+Build-Depends:      base, mtl, template-haskell, syb-with-class >= 0.4, HaXml >= 1.13 && < 1.14,+                    HAppS-Util>=0.9.2, regex-compat, bytestring, pretty, binary, containers+Build-Type:         Simple+hs-source-dirs:     src+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+Other-modules:+    HAppS.Data.HListBase+    HAppS.Data.Xml.Base+    HAppS.Data.Xml.Instances+    HAppS.Data.Xml.PrintParse+Extensions: UndecidableInstances, OverlappingInstances, Rank2Types,+            TemplateHaskell, FlexibleInstances, CPP, MultiParamTypeClasses,+            FunctionalDependencies+-- Should also have ", DeriveDataTypeable" but Cabal complains+GHC-Options: -Wall -fno-warn-orphans+
+ Setup.hs view
@@ -0,0 +1,8 @@++module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain+
+ src/HAppS/Data.hs view
@@ -0,0 +1,27 @@+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+import HAppS.Data.SerializeTH
+ src/HAppS/Data/Atom.hs view
@@ -0,0 +1,113 @@+{-# OPTIONS_GHC -fth -fglasgow-exts -fallow-undecidable-instances -cpp #-}+module HAppS.Data.Atom +    (+     Entry(..)+    ,Feed(..)+    ,Author(..)+    ,Contributor(..)+    ,Category(..)+    ,Id(..)+    ,Title(..)+    ,Published(..)+    ,Updated(..)+    ,Summary(..)+    ,Content(..)+    ,Word(..)+    ,Email(..)+++)+    where++import HAppS.Data+++#ifndef __HADDOCK__+$( 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+        --}++    --data PersonConstruct = PersonConstruct Name (Maybe URI) (Maybe Email)+    type PersonConstruct = (Name, Maybe Uri, Maybe Email)+    data Author = Author PersonConstruct+    data Contributor = Contributor PersonConstruct+    newtype Name = Name Text +    --type MbRefs = Maybe Refs++    --newtype Owner = Owner String++    data Category = Category Term (Maybe Scheme) (Maybe Label) +    newtype Term = Term String +    newtype Scheme = Scheme String +    newtype Label = Label String ++    newtype Id = Id Integer +    --newtype Refs = Refs 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 XHTML = String -- XXX This should really be an XHTML structured type+    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])++#endif+
+ src/HAppS/Data/Default.hs view
@@ -0,0 +1,121 @@++{-# LANGUAGE OverlappingInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -fglasgow-exts #-}++-----------------------------------------------------------------------------+-- |+-- 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 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"+
+ src/HAppS/Data/Default/Generic.hs view
@@ -0,0 +1,26 @@++{-# 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 view
@@ -0,0 +1,92 @@++{-# 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]+#ifndef __HADDOCK__+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+#endif+
+ src/HAppS/Data/GOps.hs view
@@ -0,0 +1,22 @@+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 v = gReplace (const v)+gReplace f x = everywhere (mkT f) x+--gFind1 x = let res = gFind x in if null res then Nothing else head res+gFind x = msum $ map return $ listify (const True) x+--gFindMb x = gFind x::(Typeable a) => Maybe a+gFind' x = fromJust $ gFind x+--Monad versions+gModify f = modify $ gReplace f+gAsk f = do st <- ask+            let y = gFind st +            return $ maybe mzero f y++gGet f x = do st <- get+              let y = gFind st +              return $ maybe mzero f y+
+ src/HAppS/Data/HList.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+             UndecidableInstances, OverlappingInstances,+             MultiParamTypeClasses, CPP, FunctionalDependencies #-}++module HAppS.Data.HList (HasT, hlextract, hlupdate, (.&.),+#ifndef __HADDOCK__+                         -- Euch, current haddock doesn't understand this+                         (:&:),+#endif+                         Couple(..),Nil(..),CoupleClass,hMap,trans) where+-- HList useful with generic++import HAppS.Data.DeriveAll+import Data.Typeable+import HAppS.Data.Xml+import HAppS.Data.Pairs+import HAppS.Data.Default+import Data.Generics as G+import HAppS.Data.HListBase++infixr 6 .&.+(.&.) :: a -> b -> Couple a b+x .&. y = Couple x y+#ifndef __HADDOCK__+type a :&: b = Couple b a+#endif+++--instance Xml (Couple a b) where+--    toXml (Couple a b) = (toXml a) ++ (toXml b)+--    fromXml xml = Couple (fromXml xml) (fromXml xml)++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)++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 TransT ft a b where+    transT :: ft -> a -> b++instance TransT (a->b) (Couple a c) (Couple b c) where+    transT f (Couple a c) = Couple (f a) c++instance TransT (a->b) (Couple c a) (Couple c b) where+    transT f (Couple c a) = Couple c (f a) ++class TransT' ft a b where+    transT' :: ft -> a -> b++instance TransT' ft a b => TransT ft a b where+    transT f a = transT' f a ++instance (TransT (c->d) b' d) => +    TransT' ft (Couple a b) (Couple a b') where+    transT' f (Couple a b) = Couple a (transT 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++-- hMap ("acdd" .&. Just "acd" .&. ("acb","def") .&. Nil)+++    ++
+ src/HAppS/Data/HListBase.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+             UndecidableInstances, OverlappingInstances,+             MultiParamTypeClasses, CPP, DeriveDataTypeable #-}+module HAppS.Data.HListBase where+import HAppS.Data.DeriveAll+import HAppS.Data.Default+import Data.Typeable++#ifndef __HADDOCK__+$( deriveAll [''Show,''Default,''Eq,''Read,''Ord]+   [d|+        data Couple a b = Couple a b+        data Nil = Nil+    |]+  )+#endif++nil::Nil+nil=Nil
+ src/HAppS/Data/Migrate.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module HAppS.Data.Migrate where++class Migrate a b where+    migrate :: a -> b++-- XXX+-- $(mkMigrate [d| ... |])+
+ src/HAppS/Data/Normalize.hs view
@@ -0,0 +1,84 @@++{-# LANGUAGE OverlappingInstances, UndecidableInstances #-}+{-# OPTIONS_GHC -fglasgow-exts #-}++-----------------------------------------------------------------------------+-- |+-- 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 view
@@ -0,0 +1,193 @@+{-# 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.Typeable++import Data.Generics as G+import HAppS.Data.Default -- for pairs+import HAppS.Data.Xml+import Control.Monad.Identity++pairsToXml pairs = fst $ formIntoEls "" $ map slash pairs+slash p@('/':n,v) = p+slash (n,v) = ('/':n,v)+++type Pairs = [(String,String)]+formIntoEls :: String -> Pairs -> ([Element], Pairs)+formIntoEls ctx [] = ([],[])+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 =+    map (\(x,y)->(tail x,y)) .+    xmlIntoPairs 0 ""+--    where stripInitialSlashes = map (\(x,y)->(tail x,y))++xmlIntoPairs x ctx [] = []+xmlIntoPairs x ctx (Elem n []:xs) = xmlIntoPairs x ctx xs+xmlIntoPairs x ctx (Attr n v:xs) = (ctx++"/"++n,v):xmlIntoPairs x ctx xs+xmlIntoPairs x ctx (CData v:[]) = [(ctx,v)]+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 iden action method pairs+ = [Elem "form" (Attr "action" action :+                Attr "id" iden :+                Attr "method" method :+                map pToInput pairs +++                [submitButton])]+submitButton = Elem "input" [Attr "type" "submit"]+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 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 == Just defaultValue then Nothing else res+                      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+        --fromJust $ head [Just defaultValue,res]+        (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,child) = break (=='/') name+        trimSlash n = if head n=='/' then tail n else n+{--+    fromPairs pairs = res+        where+        res = if (map toLower parent)==(map toLower cons)+              then fromXml $ pairsToXml pairs+              else fromPairs $ +                   --(error . ((show (parent,cons,name))++) . show) $ +                   map (\(n,v)-> if head n=='/' then (n,v) +                                 else (cons++('/':trimSlash n),v))+                   pairs+        dv = fromJust $ head [Just defaultValue,res]+        (n,_) = head pairs+        name = trimSlash n++        (parent,child) = break (=='/') name+        (cons,_) = break (==' ') $ show dv+--}+++--    fromPairs ps = fromPairs' ps+--fromPairs' :: (Xml b, Show b) => [([Char], String)] -> Maybe b+++--instance AsPairs Element where+--    toPairs x = xmlToPairs [x]+--    fromPairs = head . pairsToXml++--    fromPairs x = fromXml $ pairsToXml x+++toPairsX x = map (\(n,v)->let (par,child)=break (=='/') n in+                              if null child then (n,v) else (tail child,v)) $ toPairs x+++toHTMLForm iden method action = xmlToHTMLForm iden method action ++++#ifndef __HADDOCK__+--- example usage and tests here+$( deriveAll [''Show,''Default,''Eq]+   [d|+       data UserInfo = UserInfo User Pass +       newtype User = User String +       newtype Pass = Pass String +    |]+ )+#endif++x = toPairs (defaultValue::UserInfo)++--  It would be nice if every Xml type was fromData+--instance FromData UserInfo++v = toHTMLForm "defForm" "GET" "method" $ (defaultValue::UserInfo)++t1 = toPairs $ UserInfo (User "alex") (Pass "pass")++t2pairs = [("userInfo/user","alex"),("userInfo/pass","pass")]+t2 = fromPairs t2pairs ::Maybe UserInfo++t3pairs = [("user","alex"),("pass","pass")]+t3 = fromPairs t3pairs  ::Maybe UserInfo++t4 = toPairsX $ UserInfo (User "alex") (Pass "pass")+t5 = fromPairs t4::Maybe UserInfo++t6pairs = [("/userInfo/user","alex"),("/userInfo/pass","pass")]+t6 = fromPairs t6pairs ::Maybe UserInfo++-- these are nothing because if there is no information in the pairs then +-- it is a defaultValue and that is bogus+t7 = (fromPairs [("/blag","alex"),("hbli","mypass")]::Maybe UserInfo)  ==  Nothing+t8 = (fromPairs [("/blag","alex"),("/hbli","mypass")]::Maybe UserInfo) == Nothing++t9 = (fromPairs [("pass","alex"),("/hbli","mypass")]::Maybe UserInfo) == +     (Just $ UserInfo defaultValue (Pass "alex"))++
+ src/HAppS/Data/Proxy.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE CPP, TemplateHaskell, DeriveDataTypeable #-}+module HAppS.Data.Proxy where++import HAppS.Data.DeriveAll+import HAppS.Data.Xml+import HAppS.Data.Default++#ifndef __HADDOCK__+$(deriveAll [''Read,''Show,''Default]+  [d| data Proxy t = Proxy |]+ )+#else+data Proxy t = Proxy deriving (Read, Show, Typeable)+#endif+++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 view
@@ -0,0 +1,293 @@+{-# OPTIONS -fglasgow-exts -fallow-undecidable-instances -fallow-overlapping-instances #-}+module HAppS.Data.Serialize+    ( Serialize(..), Version(..), Migrate(..), Mode(..), Contained, contain, extension,+      safeGet, safePut, serialize, deserialize,+      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 proxy = Versioned vs (Just (mkPrevious proxy))++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)++++--------------------------------------------------------------+-- Instances+--------------------------------------------------------------+{-+instance (ToString a,FromString a, Typeable a) => Version a+instance (ToString a,FromString a, Typeable a,Version a) => Serialize a where+    getCopy = contain (defaultDecodeXmlStringM =<< get)+    putCopy = contain . put . defaultEncodeXmlString+-}+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)+++--------------------------------------------------------------+-- Xml serialization+--------------------------------------------------------------++{-+defaultEncodeXmlString :: ToString a => a -> String+defaultEncodeXmlString x = toString x++defaultDecodeXmlStringM :: forall a. (FromString a,Typeable a) => String -> Get a+defaultDecodeXmlStringM str+    = case fromString Flexible str of+        Identity v -> return v+{-+        Nothing -> fail ("defaultDecodeXmlStringM: parsing failed "++show (typeOf (undefined::a))++" @ "+++                         show (take 256 str))+        Just v  -> return v+-}+-}
+ src/HAppS/Data/SerializeTH.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE TemplateHaskell #-}+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 cxt keys ->+               do let context = [ mkType ''Serialize [varT key] | key <- keys ] ++ map return cxt+                  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..]]+                                          ]+                    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 con = foldl appT (conT con)++parseInfo :: Name -> Q Class+parseInfo name+    = do info <- reify name+         case info of+           TyConI (DataD cxt _ keys cs _)    -> return $ Tagged (map conInfo cs) cxt keys+           TyConI (NewtypeD cxt _ keys con _)-> return $ Tagged [conInfo con] cxt keys+           _                            -> error "Invalid input"+    where conInfo (NormalC name args) = (name, length args)+          conInfo (RecC name args) = (name, length args)+          conInfo (InfixC _ name _) = (name, 2)+          conInfo (ForallC _ _ con) = conInfo con
+ src/HAppS/Data/Xml.hs view
@@ -0,0 +1,9 @@++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 view
@@ -0,0 +1,472 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances,+             OverlappingInstances, UndecidableInstances, CPP,+             ScopedTypeVariables, PatternSignatures, GADTs,+             PolymorphicComponents, FlexibleContexts,+             MultiParamTypeClasses, DeriveDataTypeable,+             PatternGuards #-}++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++#ifndef __HADDOCK__+$(deriveAll [''Default, ''Eq,''Read,''Ord] [d|+    data Element = Elem String [Element]+                 | CData String+                 | Attr String String+ |])+#endif++insEl a b = case toXml b  of+            (Elem n xs:_) -> Elem n $ toPublicXml a ++ xs+            --(Attr n v:_) -> error $ "attr!" ++ (show a) ++ "" ++ (show b)+            --[] -> error $ "empty" ++ show b+            --(CData s:_) -> error $ "cdata " ++ (show a) ++ " " ++ (show b)+            _ -> 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 . show) es))))+                       ++ 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++#ifndef __HADDOCK__+data Rigidity m where+    Rigid :: Rigidity Maybe+    Flexible :: Rigidity Identity+#else+data Rigidity m = Rigid | Flexible+#endif++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]+#ifndef __HADDOCK__+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)+#endif++-- 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 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 n = head (reverse n) `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]+#ifndef __HADDOCK__+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+                   -- toXml (c x) = [Attr "c" $ BS.unpack x]+                   toFun = funD+                             'toXml+                             [clause+                                 [conP c [varP x]]+                                 (normalB [| [Attr $(litE cstr)+                                                   $ BS.unpack $(varE x)] |])+                                 []]+                   -- readXml = readXmlWith f+                   --     where <readHelper>+                   readFun = funD+                             'readXml+                             [clause+                                 []+                                 (normalB [| readXmlWith $(varE f) |])+                                 [readHelper]]+                   -- f (Attr "c" x) = Just $ c $ BS.pack x+                   -- f _ = Nothing+                   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]+#endif++xmlShowCDatas :: [Name] -> Q [Dec]+xmlShowCDatas = liftM concat . mapM xmlShowCData++xmlShowCData :: Name -> Q [Dec]+#ifndef __HADDOCK__+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]+#endif++xmlCDataLists :: [Name] -> Q [Dec]+xmlCDataLists = liftM concat . mapM xmlCDataList++xmlCDataList :: Name -> Q [Dec]+#ifndef __HADDOCK__+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]++++#endif++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 view
@@ -0,0 +1,61 @@+{-# 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 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.CMisc (H.Comment c)) = CData ""+fromHaXml (H.CMisc (H.PI (targ,string))) = 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 view
@@ -0,0 +1,102 @@+{-# 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+import HAppS.Util.Common++++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+++--data List'  a = Nil' | Cons a (List' a)+++++++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++#ifndef __HADDOCK__+$( xmlShowCDatas [''Int, ''Integer, ''Float, ''Double] )+$( xmlCDataLists [''Int, ''Integer, ''Float, ''Double] )+#endif++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]++#ifndef __HADDOCK__+$( transparentXml ''Either )+$( transparentXml ''() )+$( transparentXml ''(,) )+$( transparentXml ''(,,) )+$( transparentXml ''(,,,) )+#endif+
+ src/HAppS/Data/Xml/PrintParse.hs view
@@ -0,0 +1,59 @@+{-# 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.Instances+import HAppS.Data.Xml.HaXml+import Data.Maybe+import Data.Generics as G+import HAppS.Data.DeriveAll+import HAppS.Data.Default++#ifndef __HADDOCK__+$(deriveAll [''Read,''Show,''Default]+  [d|+      data W = W [K]+      data K = K String+   |]+ )+#endif+++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+