/Xmlable/Text/XML/Xmlable/Xmlable.hs

{-# OPTIONS_GHC -XNoMonomorphismRestriction #-}

module Text.XML.Xmlable.Xmlable where



import Control.Monad.Identity

import Control.Monad.Error

import Control.Monad.ErrorMonoid

import Control.Monad.State

import Control.Monad.Reader

import Data.Maybe

import GHC.Real(Ratio)

import Control.Arrow((***), (&&&), first, second)

import Data.Char(toUpper, isDigit)

import Data.Function(on)

import Data.Monoid

import Data.List

-- import GHC.Exts(the)

import qualified Data.Map as Map

--import Debug.Trace



type XName = String

data Xml =

    ElemB XName Namespaces  |

    ElemE                   |

    Attr XName String       |

    Val String

    deriving (Eq, Show, Read)



data XmlDesc = XtVal | XtAttr String | XtElem String deriving (Eq, Show)

xdName (XtAttr s) = s; xdName (XtElem s) = s; xdName _ = ""

isAttr (XtAttr _) = True; isAttr _ = False

isElem (XtElem _) = True; isElem _ = False

isVal XtVal = True; isVal _ = False



newtype Errors = Errors { errors :: [(Int, String)] } deriving Eq

instance Monoid Errors where

    mempty = Errors []

    mappend a b = case on compare (map fst . take 1 . errors) a b of

        EQ -> Errors $ nub $ on (++) errors a b

        GT -> a

        LT -> b

instance Error Errors where

    noMsg = mempty

    strMsg = (\(a,b) -> Errors [(read a, b)]) . span isDigit

instance Show Errors where

    show = unlines . map snd . errors



data XmlDescCons = XdcVal | XdcAttr String | XdcElem String [XmlDesc] deriving (Eq, Show)

    --  (XmlDesc, [XmlDesc])

xdcName (XdcAttr s) = s; xdcName (XdcElem s _) = s; xdcName _ = ""

xdcFields (XdcElem _ xs) = xs

xdcFields _ = []

   

type XmlDescConsM = Maybe XmlDescCons

type Namespaces = Map.Map String String

type XmlEnv = (XmlDescConsM, Namespaces)

type ParserXml = ReaderT XmlEnv (StateT [(Int, Xml)] (ErrorMonoidT Errors Identity))





xd2xdc (XtElem n) = XdcElem n []; xd2xdc (XtAttr n) = XdcAttr n; xd2xdc XtVal = XdcVal

xdc2xd (XdcElem n _) = XtElem n; xdc2xd (XdcAttr n) = XtAttr n; xdc2xd XdcVal = XtVal

-- xdc2xd x = error $ "Invalid param in xdc2xd " ++ show x



-- changeNames :: (String -> String) -> XmlDescCons

-- changeNames f = second $ map (\x -> x { xdName = f $ xdName x} )

rename m x = Map.findWithDefault x x m



changeXmlDescNameBy :: (String -> String) -> XmlDesc -> XmlDesc

changeXmlDescNameBy f (XtAttr n) = XtAttr $ f n

changeXmlDescNameBy f (XtElem n) = XtElem $ f n

changeXmlDescNameBy _ XtVal = XtVal



changeXmlDescConsNameBy :: (String->String) -> XmlDescCons -> XmlDescCons

changeXmlDescConsNameBy f (XdcAttr n) = XdcAttr $ f n

changeXmlDescConsNameBy f (XdcElem n fs) = XdcElem (f n) fs

changeXmlDescConsNameBy _ x = x



changeXmlDescName :: Map.Map String String -> XmlDesc -> XmlDesc

changeXmlDescName = changeXmlDescNameBy . rename



changeFieldNamesBy :: (String -> String) -> XmlEnv -> XmlEnv

changeFieldNamesBy = first . liftM . chf

    where

        chf f (XdcElem n fs) = XdcElem n $ map (changeXmlDescNameBy f) fs

        chf f x = x



changeFieldNames :: Map.Map String String -> XmlEnv -> XmlEnv

changeFieldNames = changeFieldNamesBy . rename



changeNamesBy :: (String -> String) -> XmlEnv -> XmlEnv

changeNamesBy = first . liftM . changeXmlDescConsNameBy



changeNames :: Map.Map String String -> XmlEnv -> XmlEnv

changeNames = changeNamesBy . rename



setNewTypeField :: String -> XmlDesc -> XmlEnv -> XmlEnv

setNewTypeField sc d = first $ liftM (\x -> case x of 

        XdcElem n fs 

            | n == sc -> XdcElem n [d]

            | otherwise -> x

        _ -> x

    )



throwErrorX s = get >>= \xs -> throwError $ Errors $ case xs of

        [] -> [(-1, "There is not enough xml data")]

        ((n,x):_) -> [(n, s ++ " at " ++ show (map snd $ takeWhile ((==n) . fst) xs) ++ ". Position = " ++ show n)]

bindX m s = m `catchError` (throwError . Errors . map (second $ (s++) . (" -> "++)) . errors)



parseListChar = parseSimple id

parseListSimple = modify (uncurry (++) . (concatMap getList . take 1 &&& drop 1)) >> liftM2 (:) parse parseSafe

    where

        getList (k, x) = map ((,) k) $ case x of

            Attr n v -> map (Attr n) $ words v

            Val v -> map Val $ words v

parseListElem = liftM (take 1) get >>= \xml -> liftM2 (:) parse (local (first $ Just . fromMaybe (getEnv xml)) parseSafe)

    where

        getEnv [(_, Attr n _)] = XdcAttr n; getEnv [(_, Val _)] = XdcVal; getEnv [(_, ElemB n _)] = XdcElem n []

        getEnv x =  error $ "Error in list parsing (getEnv). Param: " ++ show x



class Xmlable a where

    parse :: ParserXml a

    parseZero :: ParserXml a

    parseZero = parseZeroS ""

    parseZeroS :: String -> ParserXml a

    parseZeroS = throwErrorX . ("There is no parseZero for the type " ++)

    parseSafe :: ParserXml a

    parseSafe = parse `mplus` parseZero

    parseList :: ParserXml [a]

    parseList = parseListElem



    toXml :: (Maybe XmlDesc) -> a -> [Xml]

    toXml = undefined

    -- isChar, fromChar - ????????? ???????, ????? ???????? ?????? ?? ??????? (??? ? HaXml)

    isChar :: a -> Bool

    isChar = const False

    xFromChar :: Char -> a

    xFromChar = undefined

    xToChar :: a -> Char

    xToChar = undefined



prefName = (\(a, b) -> if null b then ([], a) else (a, drop 1 b)) . break (==':')    



compWithPrefix x = comp (prefName x) . prefName

    where

        comp (pa,a) (pb, b) = ask >>= \(_, nss) -> return (a == b && Map.lookup pa nss == Map.lookup pb nss)



-- check :: ParserXml [(Int,Xml)]

check = ask >>= \(d, _) -> get >>= \xmls -> -- traceShow (xmls, d) (

        case (xmls, d) of

            (_ : _, Nothing) -> return xmls

            ((_, ElemB n ns) : _, Just (XdcElem n' _)) -> setLocalNS n ns $ checkEA xmls n n' True

            ((_, Attr n _) : _, Just (XdcAttr n')) -> checkEA xmls n n' False

            ((_, Val _) : _, Just XdcVal) -> return xmls

            ([], _) -> throwErrorX "Check error: empty xml data "

            (x, Just y) -> throwErrorX $ "Check error for " ++ show y

    -- )

    where

        checkEA xmls n n' isE = bindX (compWithPrefix n n' >>= 

                guard 

                -- \b-> ask >>= \(_,ns) -> traceShow (n,n',b,ns) (guard b)

                >> return xmls) $

                "Check error (" ++ (if isE then "ElemB " else "Attr ") ++ n ++ " instead of " ++ n' ++ ")"



instance Xmlable Char where

    parse = {- traceShow 1 -} check >>= \xmls -> case xmls of

            (k, Val (z:zs)) : xs -> parse' z zs xs $ (k, Val zs) : xs

            (k, Attr n (z:zs)) : xs -> parse' z zs xs $ (k, Attr n zs) : xs

            (k1, ElemB n ns) : (k2, Val (z:zs)) : (k3, ElemE) : xs -> parse' z zs xs $ (k1, ElemB n ns) : (k2, Val zs) : (k3, ElemE) : xs

            x:xs               -> throwErrorX "Wrong char parsing"

        where

            parse' z zs xs next = put (if null zs then xs else next) >> return z

    parseZero = parseZeroS "Char"

    parseList = parseListChar

    toXml = toXmlSimple (:[])

    isChar = const True

    xFromChar = id

    xToChar = id



parseSimple :: (Show a, Read a) => (String -> String) -> ParserXml a

parseSimple f = {- traceShow 2 -} check >>= \xmls -> case xmls of

            (_, Val v) : xs    -> make v xs

            (_, Attr _ v) : xs -> make v xs

            (_, ElemB _ _) : (_, Val v) : (_, ElemE) : xs -> make v xs

            _               -> throwErrorX "Unknown pattern in parseSimple"

    where

        make v xs = calc (readList ("[" ++ f v ++ "]")) >>= \r -> put xs >> return r

        calc [(ns, s)]

            | null ns || not (null $ tail ns) || not (null s) = throwErrorX $ "Error in parseSimple.calc " ++ show [(ns, s)]

            | otherwise = return $ head ns

        calc x = throwErrorX $ "Error in parseSimple.calc. Not a singleton " ++ show x



toXmlSimple :: (a -> String) -> (Maybe XmlDesc) -> a -> [Xml]

toXmlSimple f (Just d) = case d of

    XtVal -> (:[]) . Val . f

    XtAttr n -> (:[]) . Attr n . f

    XtElem n -> (\s -> [ElemB n mempty, Val s, ElemE]) . f

toXmlSimple f Nothing = toXmlSimple f $ Just XtVal



instance Xmlable Int where

    parse = parseSimple id

    parseZero = parseZeroS "Int"

    parseList = parseListSimple

    toXml = toXmlSimple show

instance Xmlable Integer where

    parse = parseSimple id

    parseZero = parseZeroS "Integer"

    parseList = parseListSimple

    toXml = toXmlSimple show

instance Xmlable Double where

    parse = parseSimple id

    parseZero = parseZeroS "Double"

    parseList = parseListSimple

    toXml = toXmlSimple show

instance Xmlable Float where

    parse = parseSimple id

    parseZero = parseZeroS "Float"

    parseList = parseListSimple

    toXml = toXmlSimple show

instance Xmlable Bool where

    parse = parseSimple initCap

        where

            initCap [] =[]

            initCap (x : xs) = toUpper x : xs

    parseZero = parseZeroS "Bool"

    parseList = parseListSimple

    toXml = toXmlSimple (\b -> if b then "true" else "false")



instance (Read a, Integral a) => Xmlable (GHC.Real.Ratio a) where

    parseZero = parseZeroS "Ratio"

    parse = parseSimple id

    parseList = parseListSimple

    toXml = toXmlSimple show



instance (Xmlable a) => Xmlable [a] where

    {-

    parse = parseList

    -}

    parse = get >>= \xmls -> return (getEnv $ take 1 $ xmls) >>= \desc -> mods xmls (liftM2 (:) parse $ local (first $ Just . fromMaybe desc) parseSafe)

        where

            lm _ _ [] = const (modify (drop 1) >> return [])

            lm k f v = liftM (\r -> if isChar (head r) then map xFromChar v else r) . (modify ((map (\c -> (k, f c)) (words v) ++) . tail) >>)

            

            getEnv [(_, Attr n _)] = XdcAttr n; getEnv [(_, Val _)] = XdcVal; getEnv [(_, ElemB n _)] = XdcElem n []

            getEnv x =  error $ "Error in list parsing (getEnv). Param: " ++ show x

            

            mods ((k, Attr n v):_) = lm k (Attr n) v; mods ((k, Val v):_) = lm k Val v; mods ((_, ElemB _ _):_) = id 

            mods x = const $ throwErrorX "Error in list parsing."

    parseZero = return []

    toXml Nothing xs = toXml (Just XtVal) xs

    toXml jd@(Just d) xs

        | any isChar xs = toXmlSimple (map xToChar) jd xs

        | otherwise = case d of

                XtVal -> (:[]) . Val . drop 1 . concatMap (\(~(Val s)) -> ' ' : s)

                XtAttr n -> (:[]) . Attr n . drop 1 . concatMap (\(~(Attr _ s)) -> ' ' : s)

                XtElem n -> id

            . concatMap (toXml jd) $ xs



noEnv = local $ first $ const Nothing

parseDef = noEnv parse



instance (Xmlable a, Xmlable b) => Xmlable (a,b) where

    parse = liftM2 (,) parseDef parseDef -- (noEnv parse) (noEnv parse)

    toXml _ (a0,a1) = toXml Nothing a0 ++ toXml Nothing a1



instance (Xmlable a, Xmlable b, Xmlable c) => Xmlable (a,b,c) where

    parse = liftM3 (,,) parseDef parseDef parseDef -- (noEnv parse) (noEnv parse) (noEnv parse)

    toXml _ (a0,a1,a2) = toXml Nothing a0 ++ toXml Nothing a1 ++ toXml Nothing a2



instance (Xmlable a) => Xmlable (Maybe a) where

    parse = liftM Just parse

    parseZero = return Nothing

    toXml d = concat . maybeToList . liftM (toXml d)



setEnv' :: XmlEnv -> ParserXml a -> ParserXml a

setEnv' (Just env, ns') = local ((

        let n = xdcName env in 

            Just . (\d -> case d of 

                    XdcAttr "" -> XdcAttr n

                    XdcElem n0 _ 

                        | null n0 -> XdcElem n $ xdcFields env 

                        | otherwise -> XdcElem n0 $ xdcFields env 

                    dd -> dd 

                ) . fromMaybe env

    ) *** Map.union ns')

    

setLocalNS n ns = local (second $ setDefaultNS n . Map.union ns)

    where

        setDefaultNS n m = (\(a,b) -> if null a then m else fromMaybe m $ liftM (\x-> Map.insert "" x m) $ Map.lookup a m) $ prefName n

        

parseElem fp fc = check >>= \xmls -> case xmls of

        (_, ElemB n ns):xs    -> 

            -- trace ("  parseElem!  " ++ show (head xmls)) $ 

            setLocalNS n ns $ drop1 >> fp fc >>= \res -> get >>= \s -> case s of

                (_, ElemE):_ -> drop1 >> return res

                x -> throwErrorX $ se ++ "There is no ElemE. Instead we have " ++ show x

                    -- ???????????? - ?????????? ???, ???? ?? ????? ElemE

        _ -> fp fc

    where

        se = "Error in element parsing (parseElem). "

        drop1 = modify (drop 1)



-- utils



run p e = runIdentity . runErrorT . runErrorMonoidT . runStateT (runReaderT p e) . zip [0..]



eitherParse p e = (\res -> case res of

        Left w -> (Left $ show w, [])

        Right (a,b) -> (Right a, map snd b)

    ) . run p (second Map.fromList e)



run' p e = (\res -> case res of

        Left w -> Left $ show w

        Right (a,b) -> Right a

    ) . run p (second Map.fromList e)



run'' p e = (\res -> case res of

        Left w -> Left w

        Right (a,b) -> Right a

    ) . run p (second Map.fromList e)



run''' p e = (\res -> case res of

        Left w -> Left mempty

        Right (a,b) -> Right a

    ) . run p (second Map.fromList e)