CreatePattern.hs

-- |
-- 
-- Creates the 'Pattern' datastructure from a simplified Relax NG schema. 
-- The created datastructure is used in the validation algorithm
-- (see also: "Text.XML.HXT.RelaxNG.Validation")

module Text.XML.HXT.RelaxNG.CreatePattern
  ( createPatternFromXmlTree
  , createNameClass
  , firstChild
  , lastChild
  , module Text.XML.HXT.RelaxNG.PatternFunctions
  )
where

import Control.Arrow.ListArrows

import Text.XML.HXT.DOM.Interface

import Text.XML.HXT.Arrow.XmlArrow

import Text.XML.HXT.RelaxNG.DataTypes
import Text.XML.HXT.RelaxNG.BasicArrows
import Text.XML.HXT.RelaxNG.PatternFunctions

import Data.Maybe
    ( fromMaybe )

import Data.List
    ( isPrefixOf )

-- ------------------------------------------------------------

-- | Creates the 'Pattern' datastructure from a simplified Relax NG schema.

createPatternFromXmlTree :: LA XmlTree Pattern
createPatternFromXmlTree = createPatternFromXml $< createEnv
 where
 -- | Selects all define-pattern and creates an environment list.
 -- Each list entry maps the define name to the children of the define-pattern.
 -- The map is used to replace a ref-pattern with the referenced define-pattern.
 createEnv :: LA XmlTree Env
 createEnv = listA $ deep isRngDefine 
                     >>> 
                     (getRngAttrName &&& getChildren)


-- | Transforms each XML-element to the corresponding pattern

createPatternFromXml :: Env -> LA XmlTree Pattern
createPatternFromXml env
 = choiceA [
     isRoot                            :-> processRoot env,
     isRngEmpty      :-> constA Empty,
     isRngNotAllowed :-> mkNotAllowed,
     isRngText       :-> constA Text,
     isRngChoice     :-> mkRelaxChoice env,
     isRngInterleave :-> mkRelaxInterleave env,
     isRngGroup      :-> mkRelaxGroup env,
     isRngOneOrMore  :-> mkRelaxOneOrMore env,
     isRngList       :-> mkRelaxList env,
     isRngData       :-> mkRelaxData env,
     isRngValue      :-> mkRelaxValue,
     isRngAttribute  :-> mkRelaxAttribute env,
     isRngElement    :-> mkRelaxElement env,
     isRngRef        :-> mkRelaxRef env,
     this                              :-> mkRelaxError ""
   ]

              
processRoot :: Env -> LA XmlTree Pattern
processRoot env
  = getChildren
    >>> 
    choiceA [
      isRngRelaxError :-> (mkRelaxError $< getRngAttrDescr),
      isRngGrammar    :-> (processGrammar env),
      this                              :-> (mkRelaxError "no grammar-pattern in schema")
    ]


processGrammar :: Env -> LA XmlTree Pattern
processGrammar env
  = getChildren
    >>> 
    choiceA [
      isRngDefine     :-> none,
      isRngRelaxError :-> (mkRelaxError $< getAttrValue "desc"),
      isRngStart      :-> (getChildren >>> createPatternFromXml env),
      this            :-> (mkRelaxError "no start-pattern in schema")
    ]


{- |
  Transforms a ref-element.
  The value of the name-attribute is looked up in the environment list
  to find the corresponding define-pattern. 
  Haskells lazy-evaluation is used to transform circular structures.
-}
mkRelaxRef :: Env -> LA XmlTree Pattern
mkRelaxRef e
 = getRngAttrName
   >>>
   arr (\n -> fromMaybe (notAllowed $ "define-pattern with name " ++ n ++ " not found")
              . lookup n $ transformEnv e
       )
 where
 transformEnv :: [(String, XmlTree)] -> [(String, Pattern)]
 transformEnv env = [ (treeName, (transformEnvElem tree env)) | (treeName, tree) <- env]
 transformEnvElem :: XmlTree -> [(String, XmlTree)] -> Pattern
 transformEnvElem tree env = head $ runLA (createPatternFromXml env) tree 


-- | Transforms a notAllowed-element.
mkNotAllowed :: LA XmlTree Pattern
mkNotAllowed = constA $ notAllowed "notAllowed-pattern in Relax NG schema definition"


-- | Creates an error message.
mkRelaxError :: String -> LA XmlTree Pattern
mkRelaxError errStr
 = choiceA [
     isRngRelaxError :-> (getRngAttrDescr >>> arr notAllowed),
     isElem  :-> ( getName
                   >>>
                   arr (\n -> notAllowed $ "Pattern " ++ n ++ 
                                           " is not allowed in Relax NG schema"
                       )
                 ),
     isAttr  :-> ( getName
                   >>>
                   arr (\n -> notAllowed $ "Attribute " ++ n ++ 
                                           " is not allowed in Relax NG schema"
                       )
                 ),
     isError :-> (getErrorMsg >>> arr notAllowed),                          
     this    :-> (arr (\e -> notAllowed $ if errStr /= ""
                                          then errStr
                                          else "Can't create pattern from " ++ show e)
                 )
   ]


-- | Transforms a choice-element.
mkRelaxChoice :: Env -> LA XmlTree Pattern
mkRelaxChoice env
    = ifA ( getChildren >>.
	    ( \ l -> if length l == 1 then l else [] )
	  )
      ( createPatternFromXml env )
      ( getTwoChildrenPattern env >>> arr2 Choice )

-- | Transforms a interleave-element.
mkRelaxInterleave :: Env -> LA XmlTree Pattern
mkRelaxInterleave env
    = getTwoChildrenPattern env
      >>> 
      arr2 Interleave


-- | Transforms a group-element.
mkRelaxGroup :: Env -> LA XmlTree Pattern
mkRelaxGroup env
    = getTwoChildrenPattern env
      >>>
      arr2 Group


-- | Transforms a oneOrMore-element.
mkRelaxOneOrMore :: Env -> LA XmlTree Pattern
mkRelaxOneOrMore env
    = getOneChildPattern env
      >>> 
      arr OneOrMore


-- | Transforms a list-element.
mkRelaxList :: Env -> LA XmlTree Pattern
mkRelaxList env
    = getOneChildPattern env
      >>>
      arr List


-- | Transforms a data- or dataExcept-element.
mkRelaxData :: Env -> LA XmlTree Pattern
mkRelaxData env 
  = ifA (getChildren >>> isRngExcept)
     (processDataExcept >>> arr3 DataExcept)
     (processData >>> arr2 Data)
  where
  processDataExcept :: LA XmlTree (Datatype, (ParamList, Pattern))
  processDataExcept = getDatatype &&& getParamList &&& 
                      ( getChildren
                        >>> 
                        isRngExcept
                        >>> 
                        getChildren
                        >>>
                        createPatternFromXml env
                      )
  processData :: LA XmlTree (Datatype, ParamList)
  processData = getDatatype &&& getParamList
  getParamList :: LA XmlTree ParamList
  getParamList = listA $ getChildren
                         >>>
                         isRngParam
                         >>> 
                         (getRngAttrName &&& (getChildren >>> getText))
         

-- | Transforms a value-element.
mkRelaxValue :: LA XmlTree Pattern         
mkRelaxValue = getDatatype &&& getValue &&& getContext
               >>>
               arr3 Value 
  where
  getContext :: LA XmlTree Context
  getContext = getAttrValue contextBaseAttr &&& getMapping
  getMapping :: LA XmlTree [(Prefix, Uri)]
  getMapping = listA $ getAttrl >>> 
                       ( (getName >>> isA (contextAttributes `isPrefixOf`))
                         `guards`
                         ( (getName >>> arr (drop $ length contextAttributes)) 
                           &&&
                           (getChildren >>> getText)
                         )
                       )
  getValue :: LA XmlTree String
  getValue = (getChildren >>> getText) `orElse` (constA "")


getDatatype :: LA XmlTree Datatype
getDatatype = getRngAttrDatatypeLibrary
              &&&
              getRngAttrType


-- | Transforms a attribute-element.
-- The first child is a 'NameClass', the second (the last) one a pattern.

mkRelaxAttribute :: Env -> LA XmlTree Pattern
mkRelaxAttribute env
    = ( ( firstChild >>> createNameClass )
	&&&
	( lastChild >>> createPatternFromXml env )
      )
      >>>
      arr2 Attribute

-- | Transforms a element-element.
-- The first child is a 'NameClass', the second (the last) one a pattern.
mkRelaxElement :: Env -> LA XmlTree Pattern
mkRelaxElement env
    = ( ( firstChild >>> createNameClass )
	&&&
	( lastChild >>> createPatternFromXml env )
      )
      >>>
      arr2 Element


-- | Creates a 'NameClass' from an \"anyName\"-, \"nsName\"- or  \"name\"-Pattern, 
createNameClass :: LA XmlTree NameClass
createNameClass
    = choiceA
      [ isRngAnyName :-> processAnyName
      , isRngNsName  :-> processNsName
      , isRngName    :-> processName
      , isRngChoice  :-> processChoice
      , this         :-> mkNameClassError
      ]
    where
    processAnyName :: LA XmlTree NameClass
    processAnyName
	= ifA (getChildren >>> isRngExcept)
          ( getChildren
	    >>> getChildren
	    >>> createNameClass
	    >>> arr AnyNameExcept
          )
         ( constA AnyName )

    processNsName :: LA XmlTree NameClass
    processNsName
	= ifA (getChildren >>> isRngExcept)
          ( ( getRngAttrNs 
              &&&
              ( getChildren >>> getChildren >>> createNameClass )
            )
            >>> 
            arr2 NsNameExcept
          )
          ( getRngAttrNs >>> arr NsName ) 

    processName :: LA XmlTree NameClass
    processName
	= (getRngAttrNs &&& (getChildren >>> getText)) >>> arr2 Name

    processChoice :: LA XmlTree NameClass
    processChoice
	= ( ( firstChild >>> createNameClass )
	    &&&
	    ( lastChild  >>> createNameClass )
	  )
          >>>
	  arr2 NameClassChoice
                        
mkNameClassError :: LA XmlTree NameClass
mkNameClassError 
    = choiceA [ isRngRelaxError
                        :-> ( getRngAttrDescr
			      >>>
			      arr NCError
			 )
	      , isElem  :-> ( getName
			      >>>
			      arr (\n -> NCError ("Can't create name class from element " ++ n))
			    )
	      , isAttr  :-> ( getName
			      >>>
			      arr (\n -> NCError ("Can't create name class from attribute: " ++ n))
			    )
	      , isError :-> ( getErrorMsg
			      >>>
			      arr NCError
			    )
	      , this    :-> ( arr (\e ->  NCError $ "Can't create name class from " ++ show e) )      
	      ]


getOneChildPattern :: Env -> LA XmlTree Pattern
getOneChildPattern env
    = firstChild >>> createPatternFromXml env


getTwoChildrenPattern :: Env -> LA XmlTree (Pattern, Pattern)
getTwoChildrenPattern env
    = ( getOneChildPattern env )
	&&&
	( lastChild  >>> createPatternFromXml env )

-- | Simple access arrows

firstChild	:: (ArrowTree a, Tree t) => a (t b) (t b)
firstChild	= single getChildren

lastChild	:: (ArrowTree a, Tree t) => a (t b) (t b)
lastChild	= getChildren >>. (take 1 . reverse)