content: -- ------------------------------------------------------------
  
  {- |
     Module     : Text.XML.HXT.Arrow.XmlRegex
     Copyright  : Copyright (C) 2008 Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
     Stability  : experimental
     Portability: portable
  
     Regular Expression Matcher working on lists of XmlTrees
  
     It's intended to import this module with an explicit
     import declaration for not spoiling the namespace
     with these somewhat special arrows
  
  -}
  
  -- ------------------------------------------------------------
  
  module Text.XML.HXT.Arrow.XmlRegex
      ( XmlRegex
      , mkZero
      , mkUnit
      , mkPrim
      , mkPrim'
      , mkPrimA
      , mkDot
      , mkStar
      , mkAlt
      , mkAlts
      , mkSeq
      , mkSeqs
      , mkRep
      , mkRng
      , mkOpt
      , mkPerm
      , mkPerms
      , mkMerge
      , nullable
      , delta
      , matchXmlRegex
      , splitXmlRegex
      , scanXmlRegex
      , matchRegexA
      , splitRegexA
      , scanRegexA
      )
  where
  
  import           Control.Arrow.ListArrows
  
  import           Data.Maybe
  
  import           Text.XML.HXT.DOM.Interface
  import           Text.XML.HXT.DOM.ShowXml   (xshow)
  
  -- ------------------------------------------------------------
  -- the exported regex arrows
  
  -- | check whether a sequence of XmlTrees match an Xml regular expression
  --
  -- The arrow for 'matchXmlRegex'.
  --
  -- The expession is build up from simple arrows acting as predicate ('mkPrimA') for
  -- an XmlTree and of the usual cobinators for sequence ('mkSeq'), repetition
  -- ('mkStar', mkRep', 'mkRng') and choice ('mkAlt', 'mkOpt')
  
  matchRegexA             :: XmlRegex -> LA XmlTree XmlTree -> LA XmlTree XmlTrees
  matchRegexA re ts       = ts >>. (\ s -> maybe [s] (const []) . matchXmlRegex re $ s)
  
  -- | split the sequence of trees computed by the filter a into
  --
  -- The arrow for 'splitXmlRegex'.
  --
  -- a first part matching the regex and a rest,
  -- if a prefix of the input sequence does not match the regex, the arrow fails
  -- else the pair containing the result lists is returned
  
  splitRegexA             :: XmlRegex -> LA XmlTree XmlTree -> LA XmlTree (XmlTrees, XmlTrees)
  splitRegexA re ts       = ts >>. (maybeToList . splitXmlRegex re)
  
  -- | scan the input sequence with a regex and give the result as a list of lists of trees back
  -- the regex must at least match one input tree, so the empty sequence should not match the regex
  --
  -- The arrow for 'scanXmlRegex'.
  
  scanRegexA              :: XmlRegex -> LA XmlTree XmlTree -> LA XmlTree XmlTrees
  scanRegexA re ts        = ts >>. (fromMaybe [] . scanXmlRegex re)
  
  -- ------------------------------------------------------------
  
  data XmlRegex   = Zero String
                  | Unit
                  | Sym  (XmlTree -> Bool) String    -- optional external repr. of predicate
                  | Dot
                  | Star  XmlRegex
                  | Alt   XmlRegex XmlRegex
                  | Seq   XmlRegex XmlRegex
                  | Rep   Int      XmlRegex          -- 1 or more repetitions
                  | Rng   Int Int  XmlRegex          -- n..m repetitions
                  | Perm  XmlRegex XmlRegex
                  | Merge XmlRegex XmlRegex
  
  -- ------------------------------------------------------------
  
  {- just for documentation
  
  class Inv a where
      inv         :: a -> Bool
  
  instance Inv XmlRegex where
      inv (Zero _)        = True
      inv Unit            = True
      inv (Sym p _)       = p holds for some XmlTrees
      inv Dot             = True
      inv (Star e)        = inv e
      inv (Alt e1 e2)     = inv e1 &&
                            inv e2
      inv (Seq e1 e2)     = inv e1 &&
                            inv e2
      inv (Rep i e)       = i > 0 && inv e
      inv (Rng i j e)     = (i < j || (i == j && i > 1)) &&
                            inv e
      inv (Perm e1 e2)    = inv e1 &&
                            inv e2
  -}
  -- ------------------------------------------------------------
  --
  -- smart constructors
  
  mkZero          :: String -> XmlRegex
  mkZero          = Zero
  
  mkUnit          :: XmlRegex
  mkUnit          = Unit
  
  mkPrim          :: (XmlTree -> Bool) -> XmlRegex
  mkPrim p        = Sym p ""
  
  mkPrim'         :: (XmlTree -> Bool) -> String -> XmlRegex
  mkPrim'         = Sym
  
  mkPrimA         :: LA XmlTree XmlTree -> XmlRegex
  mkPrimA a       = mkPrim (not . null . runLA a)
  
  mkDot           :: XmlRegex
  mkDot           = Dot
  
  mkStar                  :: XmlRegex -> XmlRegex
  mkStar (Zero _)         = mkUnit                -- {}* == ()
  mkStar e@Unit           = e                     -- ()* == ()
  mkStar e@(Star _e1)     = e                     -- (r*)* == r*
  mkStar (Rep 1 e1)       = mkStar e1             -- (r+)* == r*
  mkStar e@(Alt _ _)      = Star (rmStar e)       -- (a*|b)* == (a|b)*
  mkStar e                = Star e
  
  rmStar  :: XmlRegex -> XmlRegex
  rmStar (Alt e1 e2)      = mkAlt (rmStar e1) (rmStar e2)
  rmStar (Star e1)        = rmStar e1
  rmStar (Rep 1 e1)       = rmStar e1
  rmStar e1               = e1
  
  mkAlt                                   :: XmlRegex -> XmlRegex -> XmlRegex
  mkAlt e1            (Zero _)            = e1                            -- e1 u {} = e1
  mkAlt (Zero _)      e2                  = e2                            -- {} u e2 = e2
  mkAlt e1@(Star Dot) _e2                 = e1                            -- A* u e1 = A*
  mkAlt _e1           e2@(Star Dot)       = e2                            -- e1 u A* = A*
  mkAlt (Sym p1 e1)   (Sym p2 e2)         = mkPrim' (\ x -> p1 x || p2 x)  (e e1 e2) -- melting of predicates
                                            where
                                              e "" x2 = x2
                                              e x1 "" = x1
                                              e x1 x2 = x1 ++ "|" ++ x2
  mkAlt e1            e2@(Sym _ _)        = mkAlt e2 e1                   -- symmetry: predicates always first
  mkAlt e1@(Sym _ _)  (Alt e2@(Sym _ _) e3)
                                          = mkAlt (mkAlt e1 e2) e3        -- prepare melting of predicates
  mkAlt (Alt e1 e2)   e3                  = mkAlt e1 (mkAlt e2 e3)        -- associativity
  mkAlt e1 e2                             = Alt e1 e2
  
  mkAlts                          :: [XmlRegex] -> XmlRegex
  mkAlts                          = foldr mkAlt (mkZero "")
  
  mkSeq                           :: XmlRegex -> XmlRegex -> XmlRegex
  mkSeq e1@(Zero _) _e2           = e1
  mkSeq _e1         e2@(Zero _)   = e2
  mkSeq Unit        e2            = e2
  mkSeq e1          Unit          = e1
  mkSeq (Seq e1 e2) e3            = mkSeq e1 (mkSeq e2 e3)
  mkSeq e1 e2                     = Seq e1 e2
  
  mkSeqs                          :: [XmlRegex] -> XmlRegex
  mkSeqs                          = foldr mkSeq mkUnit
  
  mkRep           :: Int -> XmlRegex -> XmlRegex
  mkRep 0 e                       = mkStar e
  mkRep _ e@(Zero _)              = e
  mkRep _ e@Unit                  = e
  mkRep i e                       = Rep i e
  
  mkRng   :: Int -> Int -> XmlRegex -> XmlRegex
  mkRng 0  0  _e                  = mkUnit
  mkRng 1  1  e                   = e
  mkRng lb ub _e
      | lb > ub                   = Zero $
                                    "illegal range " ++
                                    show lb ++ ".." ++ show ub
  mkRng _l _u e@(Zero _)          = e
  mkRng _l _u e@Unit              = e
  mkRng lb ub e                   = Rng lb ub e
  
  mkOpt   :: XmlRegex -> XmlRegex
  mkOpt   = mkRng 0 1
  
  mkPerm                           :: XmlRegex -> XmlRegex -> XmlRegex
  mkPerm e1@(Zero _) _             = e1
  mkPerm _           e2@(Zero _)   = e2
  mkPerm Unit        e2            = e2
  mkPerm e1          Unit          = e1
  mkPerm e1          e2            = Perm e1 e2
  
  mkPerms                          :: [XmlRegex] -> XmlRegex
  mkPerms                          = foldr mkPerm mkUnit
  
  mkMerge                          :: XmlRegex -> XmlRegex -> XmlRegex
  mkMerge e1@(Zero _) _            = e1
  mkMerge _           e2@(Zero _)  = e2
  mkMerge Unit        e2           = e2
  mkMerge e1          Unit         = e1
  mkMerge e1          e2           = Merge e1 e2
  
  -- ------------------------------------------------------------
  
  instance Show XmlRegex where
      show (Zero s)       = "{err:" ++ s ++ "}"
      show Unit           = "()"
      show (Sym _p "")    = "<pred>"
      show (Sym _p r )    = r
      show Dot            = "."
      show (Star e)       = "(" ++ show e ++ ")*"
      show (Alt e1 e2)    = "(" ++ show e1 ++ "|" ++ show e2 ++ ")"
      show (Seq e1 e2)    = show e1 ++ show e2
      show (Rep 1 e)      = "(" ++ show e ++ ")+"
      show (Rep i e)      = "(" ++ show e ++ "){" ++ show i ++ ",}"
      show (Rng 0 1 e)    = "(" ++ show e ++ ")?"
      show (Rng i j e)    = "(" ++ show e ++ "){" ++ show i ++ "," ++ show j ++ "}"
      show (Perm e1 e2)   = "(" ++ show e1 ++ show e2 ++ "|" ++ show e2 ++ show e1 ++ ")"
      show (Merge e1 e2)  = "(" ++ show e1 ++ "&" ++ show e2 ++ ")"
  
  -- ------------------------------------------------------------
  
  unexpected              :: XmlTree -> String -> String
  unexpected t e          = emsg e ++ (cut 80 . xshow) [t]
      where
        emsg ""           = "unexpected: "
        emsg s            = "expected: " ++ s ++ ", but got: "
        cut n s
            | null rest   = s'
            | otherwise   = s' ++ "..."
            where
              (s', rest)  = splitAt n s
  
  -- ------------------------------------------------------------
  
  nullable        :: XmlRegex -> Bool
  nullable (Zero _)       = False
  nullable Unit           = True
  nullable (Sym _p _)     = False         -- assumption: p holds for at least one tree
  nullable Dot            = False
  nullable (Star _)       = True
  nullable (Alt e1 e2)    = nullable e1 ||
                            nullable e2
  nullable (Seq e1 e2)    = nullable e1 &&
                            nullable e2
  nullable (Rep _i e)     = nullable e
  nullable (Rng i _ e)    = i == 0 ||
                            nullable e
  nullable (Perm e1 e2)   = nullable e1 &&
                            nullable e2
  nullable (Merge e1 e2)  = nullable e1 &&
                            nullable e2
  
  -- ------------------------------------------------------------
  
  delta   :: XmlRegex -> XmlTree -> XmlRegex
  delta e@(Zero _)   _    = e
  delta Unit         c    = mkZero $ unexpected c ""
  delta (Sym p e)    c
      | p c               = mkUnit
      | otherwise         = mkZero $ unexpected c e
  delta Dot          _    = mkUnit
  delta e@(Star e1)  c    = mkSeq (delta e1 c) e
  delta (Alt e1 e2)  c    = mkAlt (delta e1 c) (delta e2 c)
  delta (Seq e1 e2)  c
      | nullable e1       = mkAlt (mkSeq (delta e1 c) e2) (delta e2 c)
      | otherwise         = mkSeq (delta e1 c) e2
  delta (Rep i e)    c    = mkSeq (delta e c) (mkRep (i-1) e)
  delta (Rng i j e)  c    = mkSeq (delta e c) (mkRng ((i-1) `max` 0) (j-1) e)
  delta (Perm e1 e2) c    = case e1' of
                              (Zero _) -> mkPerm e1 (delta e2 c)
                              _        -> mkPerm e1' e2
                            where
                            e1' = delta e1 c
  delta (Merge e1 e2) c   = mkAlt (mkMerge (delta e1 c) e2)
                                  (mkMerge e1 (delta e2 c))
  
  -- ------------------------------------------------------------
  
  delta'          :: XmlRegex -> XmlTrees -> XmlRegex
  delta'          = foldl delta
  
  -- | match a sequence of XML trees with a regular expression over trees
  --
  -- If the input matches, the result is Nothing, else Just an error message is returned
  
  matchXmlRegex           :: XmlRegex -> XmlTrees -> Maybe String
  matchXmlRegex e
      = res . delta' e
      where
      res (Zero er)       = Just er
      res re
          | nullable re   = Nothing       -- o.k.
          | otherwise     = Just $ "input does not match " ++ show e
  
  -- ------------------------------------------------------------
  
  -- | split a sequence of XML trees into a pair of a a matching prefix and a rest
  --
  -- If there is no matching prefix, Nothing is returned
  
  splitXmlRegex           :: XmlRegex -> XmlTrees -> Maybe (XmlTrees, XmlTrees)
  splitXmlRegex re        = splitXmlRegex' re []
  
  splitXmlRegex'          :: XmlRegex -> XmlTrees -> XmlTrees -> Maybe (XmlTrees, XmlTrees)
  splitXmlRegex' re res []
      | nullable re       = Just (reverse res, [])
      | otherwise         = Nothing
  
  splitXmlRegex' (Zero _) _ _
                          = Nothing
  
  splitXmlRegex' re res xs@(x:xs')
      | isJust res'       = res'
      | nullable re       = Just (reverse res, xs)
      | otherwise         = Nothing
      where
      re'  = delta re x
      res' = splitXmlRegex' re' (x:res) xs'
  
  -- ------------------------------------------------------------
  
  -- | scan a sequence of XML trees and split it into parts matching the given regex
  --
  -- If the parts cannot be split because of a missing match, or because of the
  -- empty sequence as match, Nothing is returned
  
  scanXmlRegex                            :: XmlRegex -> XmlTrees -> Maybe [XmlTrees]
  scanXmlRegex re ts                      = scanXmlRegex' re (splitXmlRegex re ts)
  
  scanXmlRegex'                           :: XmlRegex -> Maybe (XmlTrees, XmlTrees) -> Maybe [XmlTrees]
  scanXmlRegex' _  Nothing                = Nothing
  scanXmlRegex' _  (Just (rs, []))        = Just [rs]
  scanXmlRegex' _  (Just ([], _))         = Nothing       -- re is nullable (the empty word matches), nothing split off
                                                          -- would give infinite list of empty lists
  scanXmlRegex' re (Just (rs, rest))
      | isNothing res                     = Nothing
      | otherwise                         = Just (rs : fromJust res)
      where
      res = scanXmlRegex' re (splitXmlRegex re rest)
  
  -- ------------------------------------------------------------
  