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

{- |
   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)

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