module HAppS.Data.Pairs (pairsToXml,xmlToPairs,pairsToHTMLForm,xmlToHTMLForm
,toPairs,toPairsX,fromPairs,toHTMLForm
,Pairs,AsPairs
) where
import Data.Char
import Data.List
import Data.Maybe
import HAppS.Data.DeriveAll
import HAppS.Util.Common
import Data.Typeable
import Data.Generics as G
import HAppS.Data.Default
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 ""
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
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
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,child) = break (=='/') name
trimSlash n = if head n=='/' then tail n else n
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__
$( deriveAll [''Show,''Default,''Eq]
[d|
data UserInfo = UserInfo User Pass
newtype User = User String
newtype Pass = Pass String
|]
)
#endif
x = toPairs (defaultValue::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
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"))