RDFNormalize.hs

{- |
   Module     : RDFNormalize 
   Author     : Manuel Ohlendorf  

   Maintainer : Manuel Ohlendorf
   Stability  : experimental
   Portability: portable
   Version    :

Contains all normalisation arrows and exports the main entry point to them
-}

module RDFNormalize  (normalizeRDF)
where
import Char
import Text.XML.HXT.Arrow
import RDFFunctions
import Maybe
import Text.XML.HXT.DOM.Util


-- -------------------------------------------------------------
-- ***** NORMALISATION ****
-- -------------------------------------------------------------

-- | The normalisation arrow. 
-- Creates a normalised RDF\/XML document where several abbreviations have been removed\/normalised.
-- Not every abbreviation is supported right now.
normalizeRDF :: IOSArrow XmlTree XmlTree
normalizeRDF = processChildren $ 
               seqA [changeBase
                    ,mkAbsoluteURIs
                    ,convertToUtf
                    ,processContainer
                    ,processTypedElem
                    ,generateDescElem
                    ,reifyStatement
                    ,generateNodeID
                    ,processChildren (multi isNodeElem)
                    ,deleteDuplicate
                    ,processPropertyAttr -- all Desc ELements must be generated and unfolded befor generating objects
                    ]

-- | removes duplicate node elements, generated by the unfolding
-- every information of this elements is copied to the element above
deleteDuplicate :: (ArrowXml a) => a XmlTree XmlTree
deleteDuplicate 
    = processTopDown (
        (processChildren( (addAttrl (getChildren >>> getAttrl) >>> setChildren []) 
                           `when` 
                          (getChildren >>> isNodeElem))
        )`when` (isNodeElem >>> (deep isNodeElem) ) --`when` (isNodeElem >>> (getChildren>>>getChildren >>> isNodeElem) ))
                     )


-- | Node elements which do not have the name rdf:Description, are extended by the predicate rdf:type and the subject
-- name as value.
processTypedElem ::  (ArrowXml a) => a XmlTree XmlTree
processTypedElem 
  = processTopDown (
      (insertChildrenAt 0 typeElem >>> setElemName rdf_Description)
      `when`  
      ((neg isEmptyElem >>> isTypedNodeElem) `orElse` (isTypedNodeElem >>> nonRDFAttributes)) )
    
    where 
    typeElem 
      = mkElement rdf_type (qattr rdf_resource (getUniversalUri >>> mkText)) none
    
    isTypedNodeElem 
      = isElem  >>> (hasQAttr rdf_nodeID `orElse` hasQAttr rdf_about) >>> neg (hasQName rdf_Description)
    
    nonRDFAttributes = getAttrl >>> neg ( hasQName rdf_about 
                                          `orElse` hasQName rdf_nodeID 
                                          `orElse` hasName "xml:lang"
                                          `orElse` hasQName rdf_ID)

-- | Deals with reification elements. Is not able to process every kind of reification case, yet.
reifyStatement :: IOSArrow XmlTree XmlTree
reifyStatement = processTopDown((catA[this, statement, subject, predicate, object] >>> processChildren (removeQAttr rdf_ID)) 
                                 `when`
                                 (isElem >>> (hasQAttr rdf_about) >>> getChildren >>> hasQAttr rdf_ID))
                                    where
                                    aboutValue = ((getBaseURI >>> arr(++"#")) &&& (getChildren>>>getQAttrValue rdf_ID)) >>> arr(uncurry (++))
                                
                                    statement = generateReifyNode rdf_type rdf_resource (txt (universalUri rdf_Statement ))
                                    subject   = generateReifyNode rdf_subject rdf_resource (getQAttrValue rdf_about >>> mkText)
                                    predicate = generateReifyNode rdf_predicate rdf_resource (getChildren >>>getUniversalUri >>> mkText)
                                    object = ifA (getChildren >>> hasQAttr rdf_resource) 
                                                             (generateReifyNode rdf_object rdf_resource (getChildren >>>getChildren))
                                                             (mkElement rdf_Description (qattr rdf_about (aboutValue >>> mkText)) (mkElement rdf_object none (getChildren>>>getChildren)))

                                    generateReifyNode theType objectType theObj = mkElement rdf_Description (qattr rdf_about (aboutValue >>> mkText)) (mkElement theType (qattr objectType theObj) none) 

-- | Replaces every rdf:li element with a unique number
processContainer :: IOSArrow XmlTree XmlTree
processContainer = processTopDown((arr setElemName $< counterLi)
                                     `when`
                                     (isElem >>> hasQName rdf_li))
                                      where
                                      counterLi = getCounter "li_counter"
                                                  >>> (arr ('_':)) 
                                                  >>> arr((flip mkNsName) $ namespaceRDF)  
 

-- | generates blank node identifiers 
-- furthermore, the fragment identifers are processed here.
generateNodeID :: IOSArrow XmlTree XmlTree
generateNodeID
    = processTopDown (choiceA   [choice1 :-> addAttrl (qattr rdf_nodeID (getCounter "node_id">>>(arr("genid"++)) >>> mkText))   -- id erzeugen und zustand verändern
                                ,(isElem >>> hasQAttr rdf_ID) :-> ((addAttrl (qattr rdf_about attrValue) )>>>removeQAttr rdf_ID) 
                                ,this:-> this
                              ]
                     )
                     where 
                     choice1 = ( isElem >>> hasQName rdf_Description >>> neg ( hasQAttr rdf_nodeID `orElse` hasQAttr rdf_about `orElse` hasQAttr rdf_ID))

                     --creates an absolut from the input                        
                     attrValue = getQAttrValue rdf_ID >>> arr('#':)>>> mkAbsURI >>> mkText

-- | processing of xml:base
changeBase :: IOSArrow XmlTree XmlTree
changeBase
        = processTopDownWithAttrl ( 
            (perform (getAttrValue "xml:base" >>> changeBaseURI)) 
            `when` (isElem >>> hasAttr "xml:base")
            )


-- | generate a simple counter and returns its value as String
getCounter :: String -> IOSArrow b String
getCounter name   
        = arr genNewId                      
     $<
     getParamInt 1 name       -- default start wert 0
   where
   genNewId :: Int -> IOSArrow b String
   genNewId i
        = setParamInt name (i+1)              -- wird hier beim ersten aufruf in den zustand geschrieben
            >>>
            constA (show i)



-- | generates node elements for property-and-node elements.
generateDescElem :: (ArrowXml a) => a XmlTree XmlTree
generateDescElem 
    = processTopDown (replaceChildren (mkElement rdf_Description none getChildren) 
                      `when` hasResourceParseType )


{- generates Property and Object for Property attributes in subject elements-}
processPropertyAttr :: (ArrowXml a) => a XmlTree XmlTree
processPropertyAttr 
    = processTopDown (
            insertChildrenAt 0 propertyElements 
            `when` isNodeElem )

propertyElements :: (ArrowXml a) => a XmlTree XmlTree
propertyElements
    = getAttrl 
      >>> neg ( hasQName rdf_about 
                `orElse` hasQName rdf_nodeID
                `orElse` hasName "xml:lang"
                `orElse` hasQName rdf_ID )
      >>> arr mkqelem $<<< getQName &&& listA none &&& (listA (constA getChildren))


-- | changes every relative URI to the absolute uri.                                            
mkAbsoluteURIs :: IOSArrow XmlTree XmlTree
mkAbsoluteURIs = processChildren (mkAbs `when` isElem)
      where
      mkAbs = mkAbsURIs $< getBaseURI 

mkAbsURIs   :: String -> IOSArrow XmlTree XmlTree
mkAbsURIs base
        = processTopDown editURIs       -- edit all refs in documnt
        where

        -- build the edit filter from the list of element-attribute names
        editURIs = seqA . map mkAbs $ rdfAttrs
      
        -- list of attributes which can have relative uris
        rdfAttrs = [ rdf_about,rdf_datatype,rdf_resource]

        -- change the reference in attribute attrName of element elemName

        mkAbs attrName = processAttrl ( changeAttrValue (mkAbsURIString base)
                `when`
                hasQName attrName
                )

-- | compute an absolute URI, if not possible leave URI unchanged
mkAbsURIString  :: String -> String -> String
mkAbsURIString base uri
    = fromMaybe uri . expandURIString uri $ base



-- | converts every non US-ASCII character to the encoded UNICODE variant
convertToUtf :: (ArrowXml a) => a XmlTree XmlTree
convertToUtf
        = processTopDown editToUtf
      where editToUtf = changeText toUtf `when` isText

toUtf :: [Char] -> [Char]
toUtf = concatMap charToUtf

charToUtf :: Char -> String
charToUtf c
  | ord c < 0x80  = [c]
  | otherwise = "\\u00" ++ charToHexString c

{-hexChar :: Int -> String
hexChar i | i < 0 = hexChar (i + 2^16)
hexChar i =  toHex (i `div` 256) ++ toHex (i `mod` 256)

toHex :: Int -> [Char]
toHex i = [toHexDigit (i `div` 16), toHexDigit (i `mod` 16)]

toHexDigit :: Int -> Char
toHexDigit x
  | x < 10= chr ((ord '0')+x)
  | otherwise= chr ((ord 'A')+x-10)-}