content: {-# LANGUAGE GADTs #-}
  module ValidateXML where
  
  -- based on a Haskell module generated by the BNF converter
  
  import AbsXML
  import PrintXML
  import ParXML
  import LexXML
  
  import ErrM
  
  import Data.List
  
  type Result = Err String
  
  failure :: Show a => a -> Result
  failure x = Bad $ "Undefined case: " ++ show x
  
  ---- TODO: better printer in ToXML
  printXML :: Print a => a -> String
  printXML = unspace . printTree where
    unspace s = case s of
      '<':' ':cs -> '<':unspace cs
      '<':'/':' ':cs -> '<':'/':unspace cs
      ' ':'>':cs -> '>':'\n':unspace cs
      ' ':'/':'>':cs -> '/':'>':'\n':unspace cs
      c      :cs -> c  :unspace cs
      _ -> s
  
  getXML :: FilePath -> IO Document
  getXML f = do
    s <- readFile f
    let ex = parseDocument s >>= validateDocument
    case ex of
      Ok x -> return x
      Bad s -> putStrLn s >> return (DXML HNone DTDNone (EEmpty (ETEmpty (Ident "x") [])))
  
  parseDocument = pDocument . myLexer
  
  validateDocument :: Document -> Err Document
  validateDocument d@(DXML header dtd element) = do
    syntaxCheckElement element
    case dtd of
      DTDNone -> return ()
      _ -> validate dtd element
    return d
  
  syntaxCheckElement :: Element -> Err ()
  syntaxCheckElement t = case t of
    ETag starttag elements endtag -> do
      case (starttag,endtag) of
        (STTag i _, ETTag j) | i /= j -> fail $ "syntax check error: element " ++ printXML starttag ++ " ends with " ++ printXML endtag
        _ -> mapM_ syntaxCheckElement elements
    _ -> return ()
  
  validate :: DTD -> Element -> Err ()
  validate dtd@(DTDDecl i defs) = check i
   where
     check t el = do
       let te = typeElement el
       checkErr (t == te) ("validation error: element type expected " ++ printXML t ++ " found " ++ printXML te)
       atts <- getAttlist defs t
       checkAttlist atts el
       rhs <- getRHS defs t
       let els = contentsElement el
       rest <- checkContents rhs els
       checkErr (null rest) ("validation error at:\n" ++ unlines (map printXML (take 3 rest)))
       
     checkContents rhs els = case rhs of
       REmpty   -> return els
       RPCData  -> return []
       RIdent i -> case els of
         e:es -> case check i e of
           Ok _ -> return es
           Bad s -> fail s
         _ -> fail $ "validation error: expected " ++ printXML i ++ " found nothing"
       RSeq r1 r2 -> do
         els2 <- checkContents r1 els
         checkContents r2 els2
       RAlt r1 r2 -> case checkContents r1 els of
         Ok els2 -> return els2  ---- priority union ??
         _ -> checkContents r2 els
       RStar r -> case checkContents r els of
         Ok els2 -> checkContents rhs els2 ---- longest match ??
         _ -> return els ---- TODO if Bad s, show s if RStar is the last item in an element
       RPlus r -> checkContents (RSeq r (RStar r)) els
       ROpt r -> checkContents (RAlt r REmpty) els
       
     checkAttlist atts el = do
       let required = [a | AAttr a _ ReqRequired <- atts]
       let found = map fst (attributesElement el)
       let notfound = [a | a <- required, notElem a found]
       checkErr (null notfound) ("validation error: required attributes " ++ unwords (map printXML notfound) ++ " not found in:\n" ++ printXML el)
       ---- TODO: check ID and IDREF
       ---- check IMPLIED ??
  
  checkErr :: Bool -> String -> Err ()
  checkErr cond msg = if cond then return () else fail msg
  
  getRHS :: [Definition] -> Ident -> Err RHS
  getRHS definitions t = case lookup t [(i,rhs) | DElement i rhs <- definitions] of
     Just r -> return r
     _ -> fail $ "validation error: DTD has no element type " ++ printXML t
  
  getAttlist :: [Definition] -> Ident -> Err [Attribute]
  getAttlist definitions t = case lookup t [(i,atts) | DAttlist i atts <- definitions] of
     Just a -> return a
     _ -> return []
  
  typeElement :: Element -> Ident
  typeElement t = case t of
    ETag (STTag i _) _ _ -> i -- end tag already syntax checked
    EEmpty (ETEmpty i _) -> i
    EData _ -> pcdataIdent
  
  contentsElement :: Element -> [Element]
  contentsElement t = case t of
    ETag _ els _ -> els
    EEmpty _ -> []
    EData _ -> [] ---- [t] ??
  
  attributesElement :: Element -> [(Ident,String)]
  attributesElement el = case el of
    ETag (STTag _ ats) _ _ -> [(a,s) | AValue a s <- ats]
    EEmpty (ETEmpty _ ats) -> [(a,s) | AValue a s <- ats]
    _ -> []
  
  pcdataIdent = Ident "#PCData"
  
  