content: {- |
  Module      :  ./Static/XSimplePath.hs
  Description :  Simplification of XPath-Structure
  Copyright   :  (c) Simon Ulbricht, DFKI GmbH 2011
  License     :  GPLv2 or higher, see LICENSE.txt
  Maintainer  :  tekknix@informatik.uni-bremen.de
  Stability   :  provisional
  Portability :  non-portable (DevGraph)
  
  break down Common.XPath.Expr into a simpler path description and transfer
  into cursor movement.
  -}
  
  module Static.XSimplePath where
  
  import Common.ToXml (mkText)
  import Common.XPath hiding (Text)
  import Common.XUpdate
  import Common.Utils
  
  import Control.Monad
  import qualified Control.Monad.Fail as Fail
  
  import Data.List
  import Data.Maybe
  import qualified Data.Map as Map
  import qualified Data.Set as Set
  
  import Static.DgUtils
  import Static.XGraph
  
  import Text.XML.Light hiding (findChild)
  import Text.XML.Light.Cursor
  
  data SimplePath = SimplePath { steps :: [Finder]
                               , changeData :: ChangeData }
  
  {- | Finder stores predicate list to locate the element and an index, in case
  multiple elements comply with the predicate -}
  data Finder = FindBy QName [Attr] Int
  
  -- change to be applied at the end of a path plus (maybe) attr-selection
  data ChangeData = ChangeData ChangeSel (Maybe String)
  
  -- | convert PathExpr into more simple Finder stucture
  exprToSimplePath :: Fail.MonadFail m => Change -> m SimplePath
  exprToSimplePath (Change csel e) = case e of
    PathExpr Nothing (Path True stps) -> do
      (fs, atS) <- foldM (\ (fs', atS') stp -> case stp of
          Step Child (NameTest n) exps -> do
            finder <- mkFinder (FindBy (unqual n) [] 1) exps
            return (finder : fs', atS')
          -- should be last step only. return path so-far plus attribute selector
          Step Attribute (NameTest n) [] -> return (fs', Just n)
          _ -> Fail.fail $ "unexpected step: " ++ show stp) ([], Nothing) stps
      return $ SimplePath (reverse fs) $ ChangeData csel atS
    _ -> Fail.fail $ "not a valid path description: " ++ show e
  
  {- | built Finder by recursively following Expr-structure and adding data to
  an initially empty Finder along the way -}
  mkFinder :: Fail.MonadFail m => Finder -> [Expr] -> m Finder
  mkFinder = foldM mkFinderAux
  
  mkFinderAux :: Fail.MonadFail m => Finder -> Expr -> m Finder
  mkFinderAux f@(FindBy qn attrs i) e = case e of
      GenExpr True "and" es -> mkFinder f es
      GenExpr True "=" es -> do
        att <- mkAttr es
        return $ FindBy qn (att : attrs) i
      PrimExpr Number i' -> do
        v <- maybeF ("illegal number: " ++ i') $ readMaybe i'
        when (i /= 1) $ Fail.fail "XPATH number already set differently"
        return $ FindBy qn attrs v
      _ -> Fail.fail "unexpected (2)"
  
  {- | create attribute to locate the element with from expr-data. Note: this
  method will fail for many illegal expr-types! -}
  mkAttr :: Fail.MonadFail m => [Expr] -> m Attr
  mkAttr l = case l of
    [ PathExpr Nothing (Path False [Step Attribute (NameTest nm) []])
      , PrimExpr Literal val] -> return $ Attr (unqual nm) val
    _ -> Fail.fail $ "XPATH unexpected attr: " ++ show l
  
  -- | Describes the minimal change-effect of a .diff upon a DGraph.
  data ChangeList = ChangeList
    { deleteNodes :: Set.Set NodeName
    , deleteLinks :: Set.Set XLink -- ^ stores additional information
    , changeNodes :: Map.Map NodeName ChangeAction
    , changeLinks :: Map.Map EdgeId ChangeAction } deriving (Eq, Show)
  
  data ChangeAction = MkUpdate NodeMod | MkInsert deriving (Eq, Show)
  
  updateNodeChange :: ChangeAction -> NodeName -> ChangeList -> ChangeList
  updateNodeChange chA nm chL = chL { changeNodes =
    Map.insertWith mergeChA nm chA $ changeNodes chL }
  
  retrieveNodeChange :: NodeName -> ChangeList
                     -> Maybe (ChangeAction, ChangeList)
  retrieveNodeChange nm chL = do
    nmod <- Map.lookup nm $ changeNodes chL
    return (nmod, chL { changeNodes = Map.delete nm $ changeNodes chL })
  
  updateLinkChange :: ChangeAction -> EdgeId -> ChangeList -> ChangeList
  updateLinkChange chA ei chL = chL { changeLinks =
    Map.insertWith mergeChA ei chA $ changeLinks chL }
  
  retrieveLinkChange :: EdgeId -> ChangeList -> Maybe (ChangeAction, ChangeList)
  retrieveLinkChange ei chL = do
    nmod <- Map.lookup ei $ changeLinks chL
    return (nmod, chL { changeLinks = Map.delete ei $ changeLinks chL })
  
  mergeChA :: ChangeAction -> ChangeAction -> ChangeAction
  mergeChA (MkUpdate md1) (MkUpdate md2) = MkUpdate $ mergeNodeMod md1 md2
  mergeChA _ _ = MkInsert
  
  emptyChangeList :: ChangeList
  emptyChangeList =
    ChangeList Set.empty Set.empty Map.empty Map.empty
  
  -- | iterate Xml in multiple directions
  data Direction = Vertical
                 | Horizontal
                 | TopElem
  
  changeXml :: Fail.MonadFail m => Element -> String -> m (Element, ChangeList)
  changeXml el input = case parseXMLDoc input of
      Nothing -> Fail.fail "changeXml: cannot parse xupdate file"
      Just diff -> changeXmlMod (cleanUpElem el) diff
  
  {- | apply a diff to an xml-document. returns the result xml and a list of
  changes that affect the original DGraph -}
  changeXmlMod :: Fail.MonadFail m => Element -> Element -> m (Element, ChangeList)
  changeXmlMod el diff = let cr = fromElement el in do
    cs <- anaMods diff
    pths <- mapM exprToSimplePath cs
    (cr', chL) <- iterateXml TopElem pths cr emptyChangeList
    case current cr' of
       Elem e -> return (e, chL)
       _ -> Fail.fail "unexpected content within top element"
  
  {- | follow the Xml-structure and apply Changes. The Change is only applied
  after the recursive call to simulate parallel application. Resulting DgChanges
  are collected along the way. -}
  iterateXml :: Fail.MonadFail m => Direction -> [SimplePath] -> Cursor
             -> ChangeList -> m (Cursor, ChangeList)
  iterateXml _ [] cr chL = return (cr, chL)
  iterateXml dir pths cr0 chL = do
    -- initially, the cursor movement has to be applied
    cr1 <- moveDown dir cr0
    (curChg, toRight, toChildren) <- propagatePaths cr1 pths
    (cr2, chL') <- iterateXml Vertical toChildren cr1 chL
    (cr3, chL'') <- iterateXml Horizontal toRight cr2 chL'
    -- after the call to children and rights, the current cursor is modified
    applyChanges curChg cr3 dir chL''
  
  -- Remove-changes must be treated differently
  data ChangeRes = ChangeCr Cursor
                 | RemoveCr
  
  {- | a list of Changes is applied to a current Cursor. The resulting DgUpdates
  are added to the ChangeList. -}
  applyChanges :: Fail.MonadFail m => [ChangeData] -> Cursor -> Direction -> ChangeList
               -> m (Cursor, ChangeList)
  applyChanges changes cr dir chL = do
    -- to know the resulting DgUpdates, the Changes need not to be applied
    chL' <- foldM (updateChangeList cr) chL changes
    -- because cursor position will change, certain addChanges are appended
    let (chAppend, chNow) = partition (\ cd -> case cd of
            ChangeData (Add Before _) _ -> True
            _ -> False ) changes
    cres1 <- foldM applyChange (ChangeCr cr) chNow
    cres2 <- foldM applyChange cres1 chAppend
    -- after application of the changes, the Cursor movement takes place
    cr' <- case cres2 of
        ChangeCr cr' -> moveUp dir cr'
        RemoveCr -> case dir of
          Vertical -> maybeF "missing parent (Remove)" $ removeGoUp cr
          Horizontal -> maybeF "missing left sibling (Remove)"
            $ removeFindLeft isElem cr
          TopElem -> Fail.fail "Top Element cannot be removed!"
    return (cr', chL')
  
  removeFindLeft :: (Cursor -> Bool) -> Cursor -> Maybe Cursor
  removeFindLeft p = maybe Nothing (\ cr ->
    if p cr then Just cr else findLeft p cr) . removeGoLeft
  
  moveDown :: Fail.MonadFail m => Direction -> Cursor -> m Cursor
  moveDown dir cr = case dir of
      Vertical -> maybeF "no more children" $ findChild isElem cr
      Horizontal -> maybeF "no more right siblings" $ findRight isElem cr
      TopElem -> return cr
  
  moveUp :: Fail.MonadFail m => Direction -> Cursor -> m Cursor
  moveUp dir cr = case dir of
      Vertical -> maybeF "missing parent" $ parent cr
      Horizontal -> maybeF "missing left sibling" $ findLeft isElem cr
      TopElem -> return cr
  
  -- help function for movement; filter out (Text CData)-Contents
  isElem :: Cursor -> Bool
  isElem cr = case current cr of
    Elem _ -> True
    _ -> False
  
  -- | sequentially built up resulting Cursor one Change at a time
  applyChange :: Fail.MonadFail m => ChangeRes -> ChangeData -> m ChangeRes
  applyChange (RemoveCr) _ = return RemoveCr
  applyChange (ChangeCr cr) (ChangeData csel attrSel) = case (csel, attrSel) of
    -- Case#1: full element removal
    (Remove, Nothing) -> return RemoveCr
    -- Case#2: attribute removal
    (Remove, Just atS) -> removeOrChangeAttr Nothing cr atS
    -- Case#3: addChanges, either attr-/ or element-insertion
    (Add pos addCs, _) -> liftM ChangeCr $ foldM (applyAddOp pos) cr addCs
    -- Case#4: set attribute value
    (Update s, Just atS) -> removeOrChangeAttr (Just s) cr atS
    -- Case#5: update text-content
    (Update s, Nothing) -> changeText s cr
    -- OTHER CASES ARE NOT IMPLEMENTED!
    _ -> Fail.fail $ "no implementation for :" ++ show csel
  
  -- | change the text-content of an element
  changeText :: Fail.MonadFail m => String -> Cursor -> m ChangeRes
  changeText t cr = case current cr of
    Elem e | null $ onlyElems $ elContent e -> return $ ChangeCr cr
      { current = Elem $ e
        { elContent = [mkText t] }}
    _ -> Fail.fail "current cursor is no element with text only"
  
  -- | change or remove one of the elements attributes
  removeOrChangeAttr :: Fail.MonadFail m => Maybe String -- ^ optional update value
    -> Cursor -> String -- ^ attribute key
    -> m ChangeRes
  removeOrChangeAttr csel cr atS =
    let failMsg msg = Fail.fail $ "removeOrChangeAttr '" ++ atS ++ "': " ++ msg
    in case current cr of
    Elem e ->
      let (match, restAts) =
            partition ((== atS) . qName . attrKey) $ elAttribs e
      in case match of
        [at] -> return $ ChangeCr cr { current = Elem $ e
            { elAttribs = maybe [] (\ s -> [at { attrVal = s }]) csel
                ++ restAts } }
        [] -> failMsg "attribute not found"
        _ -> failMsg "ambiguous attribute"
    _ -> failMsg "current cursor is no element"
  
  -- | add new elements or attributes
  applyAddOp :: Fail.MonadFail m => Insert -> Cursor -> AddChange -> m Cursor
  applyAddOp pos cr addCh = case (pos, addCh) of
          (Before, AddElem e) -> return $ insertGoLeft (Elem e) cr
          (After, AddElem e) -> return $ insertRight (Elem e) cr
          (Append, AddElem e) -> case current cr of
              Elem e' -> return cr { current = Elem $ e' {
                           elContent = elContent e' ++ [Elem e] } }
              _ -> Fail.fail "applyAddOp: unexpected content(1)"
          (Append, AddAttr at) -> case current cr of
              Elem e -> return cr { current = Elem $ add_attr at e }
              _ -> Fail.fail "applyAddOp: unexpected content(2)"
          _ -> Fail.fail "applyAddOp: illegal addChange-data!"
  
  {- | given the remaining PathElements, determine for which Paths the current
  Cursor is relevant (else -> toRight) and then gather from those the changes
  regarding the current object (PathEnds; else -> toChildren). -}
  propagatePaths :: Fail.MonadFail m => Cursor -> [SimplePath]
                 -> m ([ChangeData], [SimplePath], [SimplePath])
  propagatePaths cr pths = case current cr of
    Elem e -> let
      checkAttr at = maybe False (== attrVal at) $ findAttr (attrKey at) e
      maybeDecrease sp = case steps sp of
            FindBy nm atL i : r | elName e == nm && all checkAttr atL
                -> sp { steps = FindBy nm atL (i - 1) : r }
            _ -> sp
      (cur, toRight) = partition isAtZero $ map maybeDecrease pths
              where isAtZero (SimplePath (FindBy _ _ 0 : _) _) = True
                    isAtZero _ = False
      in do
        -- crop current heads and extract immediate changes
        (changes, toChildren) <- foldM (\ (r1, r2) sp -> case sp of
            SimplePath [_] cd -> return (cd : r1, r2)
            SimplePath (_ : r) cd -> return (r1, SimplePath r cd : r2)
            _ -> Fail.fail "propagatePaths: unexpected PathEnd!") ([], []) cur
        return (changes, toRight, toChildren)
    c -> Fail.fail $ "propagatePaths: unexpected Cursor Content: " ++ show c
  
  {- | determine the required DgUpdates from a Change operation.
  NOTE: some changes (like most attribute changes) will be ignored! -}
  updateChangeList :: Fail.MonadFail m => Cursor -> ChangeList -> ChangeData
                   -> m ChangeList
  updateChangeList cr chL (ChangeData csel atS) = case csel of
    Add _ addCs -> foldM (mkAddChange cr) chL addCs
    Remove | isNothing atS -> mkRemoveChange chL cr
    Update _ | isNothing atS -> case current cr of
      Elem e | isSentenceType e -> mkUpdateChange senMod chL cr
      Elem e | isSymbolType e -> mkUpdateChange symMod chL cr
      {- TODO: cases above have been considered and tested.
      Cases below will only receive update-information for reasons of fault-
      resistancy. They might be refined or even removed! -}
      _ -> mkUpdateChange symMod chL cr
    _ -> mkUpdateChange symMod chL cr
  
  {- | split a list of AddChanges and write all Node and Link insertions into the
  ChangeList. -}
  mkAddChange :: Fail.MonadFail m => Cursor -> ChangeList -> AddChange -> m ChangeList
  mkAddChange cr chL addCh = case addCh of
      AddElem e | isDgNodeElem e -> do
        nm <- extractNodeName e
        return $ updateNodeChange MkInsert nm chL
      AddElem e | isDgLinkElem e -> do
        ei <- extractEdgeId e
        return $ updateLinkChange MkInsert ei chL
      AddElem e | isSymbolType e -> mkUpdateChange addSymMod chL cr
      AddElem e | isSentenceType e -> mkUpdateChange addSenMod chL cr
      -- other cases as the above will be ignored
      _ -> return chL
  
  -- | go upwards until an updatable element is found
  mkUpdateChange :: Fail.MonadFail m => NodeMod -> ChangeList -> Cursor -> m ChangeList
  mkUpdateChange nmod chL cr = case current cr of
    Elem e | isDgNodeElem e -> do
        nm <- extractNodeName e
        return $ updateNodeChange (MkUpdate nmod) nm chL
    Elem e | isDgLinkElem e -> do
        ei <- extractEdgeId e
        return $ updateLinkChange (MkUpdate nmod) ei chL
    -- if no updateable element is found, the change is ignored
    _ -> maybe (return chL) (mkUpdateChange nmod chL) $ parent cr
  
  {- | if node or link is removed, add this to ChangeList. otherwise create
  update-change -}
  mkRemoveChange :: Fail.MonadFail m => ChangeList -> Cursor -> m ChangeList
  mkRemoveChange chL cr = case current cr of
    Elem e | isDgNodeElem e -> do
        nm <- extractNodeName e
        return chL { deleteNodes = Set.insert nm $ deleteNodes chL }
    Elem e | isDgLinkElem e -> do
        xl <- mkXLink e
        return chL { deleteLinks = Set.insert xl $ deleteLinks chL }
    Elem e | isSymbolType e -> mkUpdateChange delSymMod chL cr
    Elem e | isAxiomType e -> mkUpdateChange delAxMod chL cr
    Elem e | isTheoremType e -> mkUpdateChange delThMod chL cr
    -- other cases as the above will be ignored
    _ -> return chL
  
  nameStringIs :: String -> Element -> Bool
  nameStringIs s = (== s) . qName . elName
  
  isSymbolType :: Element -> Bool
  isSymbolType e = nameStringIs "Symbol" e || nameStringIs "Declarations" e
    || nameStringIs "Hidden" e
  
  isSentenceType :: Element -> Bool
  isSentenceType e = isAxiomType e || isTheoremType e
  
  isAxiomType :: Element -> Bool
  isAxiomType e = nameStringIs "Axiom" e || nameStringIs "Axioms" e
  
  isTheoremType :: Element -> Bool
  isTheoremType e = nameStringIs "Theorem" e || nameStringIs "Theorems" e
  
  isDgNodeElem :: Element -> Bool
  isDgNodeElem = nameStringIs "DGNode"
  
  isDgLinkElem :: Element -> Bool
  isDgLinkElem = nameStringIs "DGLink"
  