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
$(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"
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,
Normalize a)
=> Xml a where
toXml :: a -> [Element]
toXml = defaultToXml
readXml :: Monad m => Rigidity m -> [Element] -> Maybe ([Element], a)
readXml = defaultReadXml
readXml' :: Monad m => Rigidity m -> [Element] -> Maybe ([Element], a)
readXml' = defaultReadXml'
normalizeXml :: a -> [Element] -> [Element]
normalizeXml _ = id
version :: a -> Maybe String
version _ = Just "0"
otherVersion :: a -> Other a
otherVersion _ = NoOther
typ :: a -> 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 = concat . gmapQ xmlProxy (toXmlD dict)
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
#if MIN_VERSION_template_haskell(2,4,0)
mkXmlPred a = classP ''Xml [a]
ctxt = cxt $ map mkXmlPred args
#else
ctxt = cxt $ map mkXml args
#endif
instanceHead = mkXml $ foldl appT (conT n) args
decs = [d|
toXml :: Xml a => a -> [Element]
toXml = transparentToXml
readXml :: (Monad m, Xml a)
=> Rigidity m -> [Element]
-> Maybe ([Element], a)
readXml = transparentReadXml
|]
d <- instanceD' ctxt instanceHead decs
return [d]
_ ->
fail ("transparentXml: Not given a type constructor's name: " ++
show n)
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
(_, x) -> Just x
endsWithNum m = (last m) `elem` "0123456789"
noNum = reverse . dropWhile (`elem` "012344566789") . reverse
readElement _ _ = Nothing
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
(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
(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)