Instances.hs

{-# LANGUAGE TemplateHaskell, FlexibleInstances,
             OverlappingInstances, UndecidableInstances, CPP,
             TypeSynonymInstances, PatternGuards,
             MultiParamTypeClasses #-}
{-# OPTIONS -fno-warn-orphans #-}
-- These are orphaned instances This means the existance of this file causes
-- ghc to visit its .hi every time any file that depends on it in any way is
-- compiled, just to see if this instance is needed

module Happstack.Data.Xml.Instances where

import Data.List
import Happstack.Data.Xml.Base
import Data.Generics.SYB.WithClass.Basics
import Data.Generics.SYB.WithClass.Instances ()
import           Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as BS

import Happstack.Data.Default



instance Xml Element where
    toXml = (:[])


-- The Xml [a] context is a bit scary, but if we don't have it then
-- GHC complains about overlapping instances
instance (Xml a, Xml [a]) => Xml [a] where
    toXml = concatMap toXml
    readXml r = f [] []
        where f acc_xs acc_vs [] = Just (reverse acc_xs, reverse acc_vs)
              f acc_xs acc_vs (x:xs) = case readXml r [x] of
                                           Just ([], v) ->
                                               f acc_xs (v:acc_vs) xs
                                           _ ->
                                               f (x:acc_xs) acc_vs xs


instance Xml Bool where
    toXml True = [CData "1"]
    toXml False = [CData "0"]
    readXml = readXmlWith f
        where f _ (CData "1") = Just True
              f _ (CData "0") = Just False
              f _ (CData "True") = Just True
              f _ (CData "False") = Just False
              f _ (CData "T") = Just True
              f _ (CData "F") = Just False
              f _ _ = Nothing

instance Default Bool where defaultValue= False

instance Xml String where
    toXml x = [CData x]
    readXml = readXmlWith f
        where f _ (CData x) = Just x
              f _ _ = Nothing

instance Xml Char where
    toXml x = [CData [x]]
    readXml = readXmlWith f
        where f _ (CData [x]) = Just x
              f _ _ = Nothing

instance Xml ByteString where
    toXml x = [CData $ BS.unpack x]
    readXml = readXmlWith f
        where f _ (CData x) = Just $ BS.pack x
              f _ _ = Nothing

instance Xml [String] where
    toXml xs = [CData $ concat $ intersperse "," xs]
    readXml = readXmlWith f
        where f _ (CData x) = Just $ words $ noCommas x
              f _ _ = Nothing

$( xmlShowCDatas [''Int, ''Integer, ''Float, ''Double] )
$( xmlCDataLists [''Int, ''Integer, ''Float, ''Double] )


instance Xml a => Xml (Maybe a) where
    toXml = transparentToXml
    -- We can't use transparentReadXml or Nothing would always win, as
    -- it is first in the list of constructors
    readXml r = aConstrFromElements r
              $ map (toConstr xmlProxy) [Just (), Nothing]

$( transparentXml ''Either )
$( transparentXml ''() )
$( transparentXml ''(,) )
$( transparentXml ''(,,) )
$( transparentXml ''(,,,) )