content: {- |
  Module      :  ./CSMOF/Parser.hs
  Description :  CSMOF XMI parser
  Copyright   :  (c) Daniel Calegari Universidad de la Republica, Uruguay 2013
  License     :  GPLv2 or higher, see LICENSE.txt
  Maintainer  :  dcalegar@fing.edu.uy
  Stability   :  provisional
  Portability :  portable
  -}
  
  module CSMOF.Parser where
  
  import CSMOF.As
  import CSMOF.XMLKeywords
  
  import Text.XML.Light
  import qualified Data.Map as Map
  import Data.Maybe (fromMaybe)
  
  parseCSMOF :: Element -> Metamodel
  parseCSMOF el =
    let keyMap = generateKeyMap el
    in if checkXMLStructure el
       then let m = Metamodel {
                     metamodelName = parseStringAttribute el metamodelNameK
                   , element = parseElements el m keyMap
                   , model = parseModels el m keyMap } in m
       else err "Not a CSMOF XMI document"
  
  checkXMLStructure :: Element -> Bool
  checkXMLStructure el =
    case findElement metamodelK el of
      Nothing -> False
      Just _ -> True
  
  
  parseElements :: Element -> Metamodel -> Map.Map String String -> [NamedElement]
  parseElements el metamodel keyMap = foldr ((++) .
     createElement metamodel keyMap) [] (findChildren elementK el)
  
  -- Returns a list of elements, in the case of a class, the class and its properties
  createElement :: Metamodel -> Map.Map String String -> Element -> [NamedElement]
  createElement metamodel keyMap eleme =
    let name = parseStringAttribute eleme elementNameK
        typeAtt = parseStringAttribute eleme elementTypeK
        isAbs = parseBoolAttribute eleme elementIsAbstractK
        super = parseElementSuperClass eleme
    in
     case typeAtt of
       "CSMOF:DataType" -> createDataType metamodel keyMap name
       _ -> createClass metamodel keyMap name isAbs super eleme -- It is a class
  
  
  parseElementSuperClass :: Element -> [String]
  parseElementSuperClass el =
    case lookupAttr elementSuperClassK (elAttribs el) of
      Nothing -> []
      Just subs -> words subs
  
  
  createDataType :: Metamodel -> Map.Map String String -> String -> [NamedElement]
  createDataType metamodel _ name =
    let namedElement_X = NamedElement { namedElementName = name
                                      , namedElementOwner = metamodel
                                      , namedElementSubClasses = TType { getType = type_X }
                                      }
        type_X = Type { typeSuper = namedElement_X
                      , typeSubClasses = DDataType {
                         getDataType = Datatype { classSuper = type_X } }
                      }
    -- there is only one element
    in [namedElement_X]
  
  
  createClass :: Metamodel -> Map.Map String String -> String -> Bool ->
                 [String] -> Element -> [NamedElement]
  createClass metamodel keyMap name abst subs el =
    let namedElement_X = NamedElement { namedElementName = name
                                      , namedElementOwner = metamodel
                                      , namedElementSubClasses = TType {
                                         getType = type_X }
                                      }
        type_X = Type { typeSuper = namedElement_X
                      , typeSubClasses = DClass { getClass = class_X }
                      }
        class_X = Class { classSuperType = type_X
                        , isAbstract = abst
                        , superClass = foldr ((:) . linkClass keyMap metamodel)
                           [] subs
                        , ownedAttribute = ownedAttributes
                        }
        ownedAttributes = foldr ((:) . createProperty metamodel keyMap class_X)
         [] (findChildren ownedAttributeK el)
    -- there is the class and every property inside it
    in namedElement_X : map (typedElementSuper . propertySuper) ownedAttributes
  
  
  createProperty :: Metamodel -> Map.Map String String -> Class -> Element -> Property
  createProperty metamodel keyMap cla el =
    let lowe = parseIntegerAttribute el ownedAttributeLowerK
        uppe = parseIntegerAttribute el ownedAttributeUpperK
        name = parseStringAttribute el ownedAttributeNameK
        typeEl = parsePropertyType keyMap metamodel el
        souName = typeEl
        tarName = classSuperType cla
        opp = parsePropertyOpposite keyMap metamodel el tarName souName
        namedElement = NamedElement { namedElementName = name
                                    , namedElementOwner = metamodel
                                    , namedElementSubClasses = TTypedElement {
                                       getTypeElement = typedElement }
                                    }
        typedElement = TypedElement { typedElementSuper = namedElement
                                    , typedElementType = typeEl
                                    , typedElementSubClasses = property
                                    }
        property = Property { propertySuper = typedElement
                            , multiplicityElement = MultiplicityElement {
                                        lower = lowe
                                      , upper = uppe
                                      , multiplicityElementSubClasses = property }
                                      , opposite = opp
                                     , propertyClass = cla } in property
  
  parsePropertyType :: Map.Map String String -> Metamodel -> Element -> Type
  parsePropertyType keyMap metamodel el =
    case lookupAttr ownedAttributeTypeK (elAttribs el) of
      Nothing -> err "Property type does not exists"
      Just typ -> linkTypeElem keyMap metamodel typ
  
  
  parsePropertyOpposite :: Map.Map String String -> Metamodel -> Element ->
                           Type -> Type -> Maybe Property
  parsePropertyOpposite keyMap metamodel el souTyp tarTyp =
    case lookupAttr ownedAttributeOppositeK (elAttribs el) of
      Nothing -> Nothing
      Just opp -> Just (linkProperty keyMap metamodel opp tarTyp souTyp)
  
  
  -- ------ Model Part
  
  parseModels :: Element -> Metamodel -> Map.Map String String -> [Model]
  parseModels el metamodel keyMap = foldr ((:) . createModel metamodel keyMap)
   [] (findChildren modelK el)
  
  
  createModel :: Metamodel -> Map.Map String String -> Element -> Model
  createModel metamodel keyMap el =
    let mode = Model { modelName = parseStringAttribute el modelNameK
                     , object = parseObjects metamodel mode keyMap el
                     , link = parseLinks metamodel mode keyMap el
                     , modelType = metamodel
                     }
    in mode
  
  
  parseObjects :: Metamodel -> Model -> Map.Map String String -> Element -> [Object]
  parseObjects metamodel mode keyMap el = foldr ((:) .
     createObject metamodel mode keyMap) [] (findChildren objectK el)
  
  createObject :: Metamodel -> Model -> Map.Map String String -> Element -> Object
  createObject metamodel mode keyMap eleme =
    let name = parseStringAttribute eleme objectNameK
        typeAtt = parseStringAttribute eleme objectTypeK
    in Object { objectName = name
              , objectType = linkTypeElem keyMap metamodel typeAtt
              , objectOwner = mode
              }
  
  
  parseLinks :: Metamodel -> Model -> Map.Map String String -> Element -> [Link]
  parseLinks metamodel mode keyMap el = foldr ((:) .
   createLink metamodel mode keyMap) [] (findChildren linkK el)
  
  createLink :: Metamodel -> Model -> Map.Map String String -> Element -> Link
  createLink metamodel mode keyMap eleme =
    let typ = parseStringAttribute eleme linkTypeK
        sour = parseStringAttribute eleme linkSourceK
        targ = parseStringAttribute eleme linkTargetK
        sourObj = linkObject keyMap metamodel sour
        tarObj = linkObject keyMap metamodel targ
        souObjTyp = objectType sourObj
        tarObjTyp = objectType tarObj
    in Link { linkType = linkProperty keyMap metamodel typ souObjTyp tarObjTyp
            , source = sourObj
            , target = tarObj
            , linkOwner = mode
            }
  
  
  parseStringAttribute :: Element -> QName -> String
  parseStringAttribute el key = Data.Maybe.fromMaybe
    (err ("Attribute does not exists: " ++ show key))
    (lookupAttr key (elAttribs el))
  
  parseIntegerAttribute :: Element -> QName -> Integer
  parseIntegerAttribute el key =
    case lookupAttr key (elAttribs el) of
      Nothing -> 1
      Just low -> read low :: Integer
  
  parseBoolAttribute :: Element -> QName -> Bool
  parseBoolAttribute el key =
    case lookupAttr key (elAttribs el) of
      Nothing -> False
      Just abst -> case abst of
                    "true" -> True
                    _ -> False
  
  
  -- --- Functions for linking elements searching on of them using it key
  
  linkClass :: Map.Map String String -> Metamodel -> String -> Class
  linkClass keyMap metamodel key =
    let name = findElementInMap key keyMap
        list = map toClass (filter (equalClassName name) (element metamodel))
    in
     case list of
       [] -> err ("Class not found: " ++ name)
       h : _ -> h
  
  
  linkObject :: Map.Map String String -> Metamodel -> String -> Object
  linkObject keyMap metamodel key =
    let name = findElementInMap key keyMap
        list = filter (equalObjectName name) (object (rightModel keyMap metamodel key))
    in
     case list of
       [] -> err ("Object not found: " ++ name)
       h : _ -> h
  
  
  linkTypeElem :: Map.Map String String -> Metamodel -> String -> Type
  linkTypeElem keyMap metamodel key =
    let name = findElementInMap key keyMap
        list = map toType (filter (equalTypeName name) (element metamodel))
    in
     case list of
       [] -> err ("Type not found: " ++ name)
       h : _ -> h
  
  
  linkProperty :: Map.Map String String -> Metamodel -> String -> Type -> Type -> Property
  linkProperty keyMap metamodel key souTyp tarTyp =
    let prop = findElementInMap key keyMap
        list = map toProperty (filter (sameProperty prop souTyp tarTyp) (element metamodel))
    in
     case list of
       [] -> err ("Property not found: " ++ prop ++ " - " ++ key ++ " - " ++
               namedElementName (typeSuper souTyp) ++ " - " ++
               namedElementName (typeSuper tarTyp))
       h : _ -> h
  
  
  equalClassName :: String -> NamedElement -> Bool
  equalClassName name ne =
    case ne of
      (NamedElement _ _ (TType (Type _ (DClass _)))) -> namedElementName ne == name
      _ -> False
  
  toClass :: NamedElement -> Class
  toClass ne =
    case ne of
      (NamedElement _ _ (TType (Type _ (DClass cl)))) -> cl
      _ -> err ("Wrong cast: " ++ namedElementName ne)
  
  
  equalObjectName :: String -> Object -> Bool
  equalObjectName name ob = objectName ob == name
  
  
  equalTypeName :: String -> NamedElement -> Bool
  equalTypeName name ne =
    case ne of
      (NamedElement _ _ (TType _)) -> namedElementName ne == name
      _ -> False
  
  toType :: NamedElement -> Type
  toType ne =
    case ne of
      (NamedElement _ _ (TType ty)) -> ty
      _ -> err ("Wrong cast: " ++ namedElementName ne)
  
  
  sameProperty :: String -> Type -> Type -> NamedElement -> Bool
  sameProperty name souTyp2 tarTyp2 ne =
    case ne of
      (NamedElement _ _ (TTypedElement (TypedElement _ tarCl prop))) ->
        let tarTyp = namedElementName (typeSuper tarCl)
            souTyp = namedElementName (typeSuper (classSuperType (propertyClass prop)))
            lisSouTyp2 = getSuperTypesNames souTyp2
            lisTarTyp2 = getSuperTypesNames tarTyp2
        in (namedElementName ne == name) &&
           elem souTyp lisSouTyp2 &&
           (null tarTyp || elem tarTyp lisTarTyp2)
      _ -> False
  
  
  getSuperTypesNames :: Type -> [String]
  getSuperTypesNames typ =
    case typ of
      (Type _ (DClass (Class _ _ superClasses _ ))) ->
        let super = foldr ((++) . getSuperTypesNames . classSuperType) []
                     superClasses
        in namedElementName (typeSuper typ) : super
      (Type _ (DDataType (Datatype dt))) -> [namedElementName (typeSuper dt)]
  
  
  equalPropertyName :: String -> NamedElement -> Bool
  equalPropertyName name ne =
    case ne of
      (NamedElement _ _ (TTypedElement (TypedElement {}))) ->
       namedElementName ne == name
      _ -> False
  
  toProperty :: NamedElement -> Property
  toProperty ne =
    case ne of
      (NamedElement _ _ (TTypedElement (TypedElement _ _ pro))) -> pro
      _ -> err ("Wrong cast: " ++ namedElementName ne)
  
  
  -- Search for the right model according to the key
  rightModel :: Map.Map String String -> Metamodel -> String -> Model
  rightModel keyMap metamodel key = head (filter (isModel keyMap key) (model metamodel))
  
  isModel :: Map.Map String String -> String -> Model -> Bool
  isModel keyMap key mode =
    let el = findElementInMap (getModelKey key) keyMap
    in modelName mode == el
  
  getModelKey :: String -> String
  getModelKey = reverse . dropWhile (/= '/') . reverse
  
  
  findElementInMap :: String -> Map.Map String String -> String
  findElementInMap key keyMap =
    let elNam = Map.lookup key keyMap
    in Data.Maybe.fromMaybe (err ("Key not found: " ++ key)) elNam
  
  -- --- Generates a Key Map for processing references between elements
  
  generateKeyMap :: Element -> Map.Map String String
  generateKeyMap el =
    let modelMap = snd (foldr createModelKey (0, Map.empty) (reverse (findChildren modelK el)))
    in snd (foldr createElementKey (0, modelMap) (reverse (findChildren elementK el)))
  
  
  createElementKey :: Element -> (Integer, Map.Map String String) ->
                      (Integer, Map.Map String String)
  createElementKey eleme (pos, mapp) =
    let key = "//@element." ++ show pos
        mapElements = Map.insert key (parseStringAttribute eleme elementNameK) mapp
    in (pos + 1, third (foldr createChildrenKeys (key ++ "/@ownedAttribute.", 0,
        mapElements) (reverse (findChildren ownedAttributeK eleme))))
  
  
  createModelKey :: Element -> (Integer, Map.Map String String) -> (Integer, Map.Map String String)
  createModelKey eleme (pos, mapp) =
    let key = "//@model." ++ show pos
        mapModel = Map.insert (key ++ "/") (parseStringAttribute eleme modelNameK) mapp
    in (pos + 1, third (foldr createChildrenKeys (key ++ "/@object.", 0, mapModel)
       (reverse (findChildren objectK eleme))))
  
  
  createChildrenKeys :: Element -> (String, Integer, Map.Map String String) ->
                        (String, Integer, Map.Map String String)
  createChildrenKeys eleme (keySup, pos, mapp) =
    let key = keySup ++ show pos
    in (keySup, pos + 1, Map.insert key (parseStringAttribute eleme objectNameK) mapp)
  
  
  third :: (String, Integer, Map.Map String String) -> Map.Map String String
  third (_, _, c) = c
  
  
  -- --- Auxiliary Functions
  
  -- | error messages for the parser
  err :: String -> t
  err s = error $ "XML parser: " ++ s
  