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

    {- |
       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 intendet 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
        , mkPrimA
        , mkDot
        , mkStar
        , mkAlt
        , mkSeq
        , mkRep
        , mkRng
        , mkOpt
        , nullable
        , delta
        , matchXmlRegex
        , splitXmlRegex
        , scanXmlRegex
        , matchRegexA
        , splitRegexA
        , scanRegexA
        )
    where

    import Control.Arrow.ListArrows

    import Data.Maybe

    import Text.XML.HXT.DOM.Interface

    -- ------------------------------------------------------------
    -- 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 [] (const [s]) . 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)
                    | Dot
                    | Star XmlRegex
                    | Alt XmlRegex XmlRegex
                    | Seq XmlRegex XmlRegex
                    | Rep Int XmlRegex              -- 1 or more repetitions
                    | Rng Int Int XmlRegex  -- n..m repetitions

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

    {- 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
    -}
    -- ------------------------------------------------------------
    --
    -- smart constructors

    mkZero          :: String -> XmlRegex
    mkZero          = Zero

    mkUnit          :: XmlRegex
    mkUnit          = Unit

    mkPrim          :: (XmlTree -> Bool) -> 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)      (Sym p2)            = mkPrim $ \ x -> p1 x || p2 x  -- melting of predicates
    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

    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

    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

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

    instance Show XmlRegex where
        show (Zero s)       = "{err:" ++ s ++ "}"
        show Unit           = "()"
        show (Sym _p)       = "{single tree pred}"
        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 ++ "}"

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

    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

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

    delta   :: XmlRegex -> XmlTree -> XmlRegex
    delta e@(Zero _)  _     = e
    delta Unit        c     = mkZero $
                              "unexpected char " ++ show c
    delta (Sym p)     c
        | p c               = mkUnit
        | otherwise         = mkZero $
                              "unexpected tree " ++ show c
    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'          :: 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)

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