Xml2Type.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Language.XML.Xml2Type
-- Copyright   :  (c) 2011 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Multifocal:
-- Bidirectional Two-level Transformation of XML Schemas
-- 
-- Translation from XML documents to haskell values.
--
-----------------------------------------------------------------------------

module Language.XML.Xml2Type where

import Data.Type
import Data.Spine
import Data.Equal
import Generics.Pointless.Functors hiding (rep)
import Generics.Pointless.RecursionPatterns
import Generics.Pointless.Combinators hiding (and)
import Language.XML.Xsd2Type
import Language.XML.HaXmlAliases

import Text.XML.HaXml.Types
import Text.XML.HaXml.Pretty
import Text.XML.HaXml.Posn
import Text.PrettyPrint.HughesPJ

import Control.Monad
import Data.List as List
import Data.Char

xml2value :: MonadPlus m => Type b -> Document Posn -> m b
xml2value a (Document _ _ e _) = topelement2value a e

topelement2value :: MonadPlus m => Type b -> Element Posn -> m b
topelement2value t (Elem n atts cts) = --trace "topelement2value" $
	do let atts' = filter (not . rootatt) atts
	   element2value t (Elem n atts' cts)
    where rootatt :: Attribute -> Bool
          rootatt (qname -> n,_) = isPrefixOf "xmlns" n || isPrefixOf "xsi" n

element2value :: MonadPlus m => Type b -> Element Posn -> m b
element2value (Either a b) e = --trace "element2value" $
	(element2value a e >>= return . Left)
	`mplus`
	(element2value b e >>= return . Right)
element2value (Prod a b) e = --trace "element2value" $
	do { x <- element2value a e; y <- empty2value b; return (x,y) }
	`mplus`
	do { x <- empty2value a; y <- element2value b e; return (x,y) }
element2value (listT -> Just (List a)) e = --trace "element2value" $
	element2value a e >>= return . (:[])
element2value (Data s f) e = element2value (NewData s f) e >>= return . (\v -> nu (vnn v) v)
element2value d@(NewData s f) (Elem n atts cts) | nodename s == qname n = --trace ("element2value " ++ show d) $
	do let ctsSpace = filter (not . whitespace) cts
	   (x,[],[]) <- attscts2value (rep f d) (atts,ctsSpace)
	   return (inn x)
element2value d@(NewData s f) (Elem n atts cts) | isAtt d && nodename s == "@"++qname n = --trace ("element2value " ++ show d) $
        do let ctsSpace = filter (not . whitespace) cts
	   (x,atts',cts') <- attscts2value (rep f d) (atts,ctsSpace)
	   --trace ("element:" ++ s ++ " " ++ show atts' ++ show (map content cts')) $
	   guard $ (null atts') && (null cts')
	   return (inn x)
element2value Dynamic e = --trace "element2value" $
	return $ Dyn (List Char) (render $ element e)
element2value t (Elem n atts ctts) = --trace "element2value" $
	--trace ("type " ++ show t ++ " not an element " ++ show n)
	mzero

attscts2value :: MonadPlus m => Type b -> ([Attribute],[Content Posn]) -> m (b,[Attribute],[Content Posn])
attscts2value One (atts,cts) = --trace ("attscts2value " ++ show One) $
	return (_L,atts,cts)
attscts2value t@(Either a b) (atts,cts) = --trace ("attscts2value " ++ show t) $
	do { (x,atts',cts') <- attscts2value a (atts,cts); return (Left x,atts',cts') }
	`mplus`
	do { (y,atts',cts') <- attscts2value b (atts,cts); return (Right y,atts',cts') }
attscts2value t@(Prod a b) (atts,cts) = --trace ("attscts2value " ++ show t) $
        do (x,atts',cts') <- attscts2value a (atts,cts)
	   (y,atts'',cts'') <- attscts2value b (atts',cts')
	   return ((x,y),atts'',cts'')
attscts2value t@(listT -> Just (List a)) (atts,[]) = --trace ("attscts2value " ++ show t) $
	return ([],atts,[])
attscts2value t@(listT -> Just (List a)) (atts,ct:cts) = --trace ("attscts2value " ++ show t) $
	do { x <- content2value a ct; (xs,atts',cts') <- attscts2value (List a) (atts,cts); return (x:xs,atts',cts') }
	`mplus`
	return ([],atts,ct:cts)
attscts2value d@(dataName -> Just n) (atts,cts) | isAtt d = --trace ("attscts2value " ++ show d) $
	do { guard (not $ null atts); x <- attribute2value d (head atts); return (x,tail atts,cts) }
	`mplus`
	do { x <- empty2value d; return (x,atts,cts) }
attscts2value d@(dataName -> Just n) (atts,cts) | isData d = --trace ("attscts2value " ++ show d) $
	do { guard (not $ null cts); x <- content2value d (head cts); return (x,atts,tail cts) }
	`mplus`
	do { x <- empty2value d; return (x,atts,cts) }
attscts2value t (atts,ct:cts) | isBasic t = --trace ("attscts2value " ++ show t) $
	do { x <- content2value t ct; return (x,atts,cts) }
attscts2value t (atts,cts) = error $ "attscts2value: " ++ show t ++ " " ++ show atts ++ " " ++ show (map content cts)

content2value :: MonadPlus m => Type b -> Content Posn -> m b
content2value t (CElem el _) = --trace "content2value" $
	element2value t el
content2value (listT -> Just (List a)) (CString _ str _) | isBasic a = --trace "content2value" $
	mapM (basic2value a) $ words str
content2value t (CString _ str _) | isBasic t = --trace "content2value" $
	basic2value t str	
content2value t (CRef _ _) = error "content: references unsupported"
content2value t (CMisc _ i) = error "content: misc unsupported"

empty2value :: MonadPlus m => Type b -> m b
empty2value One = return _L
empty2value (listT -> Just (List a)) = return []
empty2value (Prod a b) = do { x <- empty2value a; y <- empty2value b; return (x,y) }
empty2value (Either a b) = (empty2value a >>= return . Left) `mplus` (empty2value b >>= return . Right)
empty2value d@(Data _ f) = empty2value (rep f d) >>= return . inn
empty2value d@(NewData _ f) = empty2value (rep f d) >>= return . inn
empty2value t = --trace ("empty2value: " ++ show t)
	mzero

attribute2value :: MonadPlus m => Type b -> Attribute -> m b
attribute2value d@(Data s f) (n,AttValue l) | isAtt d && nodename s == "@"++(qname n) = --trace "attribute2value" $
	do { x <- attvalue2value (rep f d) l; return (inn x) }
attribute2value d@(NewData s f) (n,AttValue l) | isAtt d && nodename s == "@"++(qname n) = --trace "attribute2value" $
	do { x <- attvalue2value (rep f d) l; return (inn x) }
attribute2value t (n,AttValue l) = error $ "attribute: " ++ show t ++ " " ++ " " ++ show n ++ " " ++ show l

attvalue2value :: MonadPlus m => Type b -> [Either String Reference] -> m b
attvalue2value (List a) l | isBasic a = mapM (basic2value a) (dropRefs l)
	where dropRefs = map (\(Left x) -> x) . filter isLeft
attvalue2value a [Left str] | isBasic a = basic2value a str
attvalue2value t l = error $ "attvalue2value: " ++ show t

basic2value :: MonadPlus m => Type b -> String -> m b
basic2value (List Char) s = return s
basic2value d@(Data "Nat" _) s = do { Eq <- teq d nat; basic2value Int s >>= return . intNat }
basic2value Int s = return $ fromEnum (read s :: Int)
basic2value Bool s
	| map toLower s == "true" = return True
	| map toLower s == "false" = return False
basic2value t s = --trace ("basic2value: " ++ show t ++ " " ++ show s)
	mzero

isLeft :: Either a b -> Bool
isLeft (Left _) = True
isLeft (Right _) = False

-- Alternative pattern matching for lists, to avoid matching strings
listT :: Type a -> Maybe (Type a)
listT (List Char) = Nothing
listT (List a) = Just (List a)
listT _ = Nothing

whitespace :: Content Posn -> Bool
whitespace (CString _ s _) = and (map isSpace s)
whitespace _ = False