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

    {- |
       Module     : Text.XML.HXT.RelaxNG.XmlSchema.Regex
       Copyright  : Copyright (C) 2005 Uwe Schmidt
       License    : MIT

       Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
       Stability  : experimental
       Portability: portable

       W3C XML Schema Regular Expression Matcher

       Grammar can be found under <http://www.w3.org/TR/xmlschema11-2/#regexs>

    -}

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

    module Text.XML.HXT.RelaxNG.XmlSchema.Regex
        ( Regex
        , chars
        , charRngs
        , mkZero
        , mkUnit
        , mkSym
        , mkSym1
        , mkSymRng
        , mkDot
        , mkStar
        , mkAlt
        , mkSeq
        , mkRep
        , mkRng
        , mkOpt
        , mkDif
        , mkCompl
        , isZero
        , nullable
        , delta
        , matchWithRE
        , (<&&>)
        , (<||>)
        )
    where

    import Data.List        ( foldl' )

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

    data Regex      = Zero String
                    | Unit
                    | Sym (Char -> Bool)
                    | Dot
                    | Star Regex
                    | Alt Regex Regex
                    | Seq Regex Regex
                    | Rep Int Regex         -- 1 or more repetitions
                    | Rng Int Int Regex     -- n..m repetitions
                    | Dif Regex Regex       -- r1 - r2

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

    {- just for documentation

    class Inv a where
        inv         :: a -> Bool

    instance Inv Regex where
        inv (Zero _)        = True
        inv Unit            = True
        inv (Sym p)         = not . null . chars $ p
        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 (Dif e1 e2)     = inv e1 &&
                              inv e2
    -}

    -- ------------------------------------------------------------
    -- | enumerate all chars specified by a predicate
    --
    -- this function is expensive, it should only be used for testing

    chars                           :: (Char -> Bool) -> [Char]
    chars p                         = filter p $ [minBound .. maxBound]

    charRngs                        :: [Char] -> [(Char, Char)]
    charRngs []                     = []
    charRngs (x:xs)                 = charRng x xs
                                    where
                                    charRng y []            = (x,y) : []
                                    charRng y xs'@(x1:xs1)
                                        | x1 == succ y      = charRng x1 xs1
                                        | otherwise         = (x,y) : charRngs xs'

    -- ------------------------------------------------------------
    --
    -- smart constructors

    mkZero                          :: String -> Regex
    mkZero                          = Zero
    {-# INLINE mkZero #-}

    mkUnit                          :: Regex
    mkUnit                          = Unit
    {-# INLINE mkUnit #-}

    mkSym                           :: (Char -> Bool) -> Regex
    mkSym                           = Sym
    {-# INLINE mkSym #-}

    mkSym1                          :: Char -> Regex
    mkSym1  c                       = mkSym (==c)

    mkSymRng                        :: Char -> Char -> Regex
    mkSymRng c1 c2
        | c1 == minBound &&
          c2 == maxBound            = mkDot
        | c1 <= c2                  = mkSym  $ (>= c1) <&&> (<= c2)
        | otherwise                 = mkZero $ "empty char range"

    mkDot                           :: Regex
    mkDot                           = Dot
    {-# INLINE mkDot #-}

    mkStar                          :: Regex -> Regex
    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                          :: Regex -> Regex
    rmStar (Alt e1 e2)              = mkAlt (rmStar e1) (rmStar e2)
    rmStar (Star e1)                = rmStar e1
    rmStar (Rep 1 e1)               = rmStar e1
    rmStar e1                       = e1

    mkAlt                                   :: Regex -> Regex -> Regex
    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)            = mkSym $ p1 <||> p2            -- 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                           :: Regex -> Regex -> Regex
    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 -> Regex -> Regex
    mkRep 0 e                       = mkStar e
    mkRep _ e@(Zero _)              = e
    mkRep _ e@Unit                  = e
    mkRep i e                       = Rep i e

    mkRng   :: Int -> Int -> Regex -> Regex
    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                           :: Regex -> Regex
    mkOpt                           = mkRng 0 1

    mkDif   :: Regex -> Regex -> Regex
    mkDif e1@(Zero _) _e2           = e1
    mkDif e1          (Zero _)      = e1
    mkDif _e1         (Star Dot)    = mkZero "empty set in difference expr"
    mkDif Dot         (Sym p)       = mkSym (not . p)
    mkDif (Sym _)     Dot           = mkZero "empty set of chars in difference expr"
    mkDif (Sym p1)    (Sym p2)
        | null . chars $ (\ x -> p1 x && not (p2 x))
                                    = mkZero "empty set of chars in difference expr"
    mkDif e1          e2            = Dif e1 e2

    mkCompl                         :: Regex -> Regex
    mkCompl                         = mkDif mkDot

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

    instance Show Regex where
        show (Zero s)       = "{err:" ++ s ++ "}"
        show Unit           = "()"
        show (Sym p)
            | null (tail cs) &&
              rng1 (head cs)
                            = escRng . head $ cs
            | otherwise     = "[" ++ concat cs' ++ "]"
                              where
                              rng1 (x,y)    = x == y
                              cs            = charRngs . chars $ p
                              cs'           = map escRng cs
                              escRng (x, y)
                                  | x == y  = esc x
                                  | succ x == y
                                            = esc x        ++ esc y
                                  | otherwise
                                            = esc x ++ "-" ++ esc y
                              esc x
                                  | x `elem` "\\-[]{}()*+?.^"
                                            = '\\':x:""
                                  | x >= ' ' && x <= '~'
                                            = x:""
                                  | otherwise
                                            = "&#" ++ show (fromEnum x) ++ ";"
        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 (Dif e1 e2)    = "(" ++ show e1 ++ "-" ++ show e2 ++ ")"

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

    isZero                  :: Regex -> Bool
    isZero (Zero _)         = True
    isZero _                = False
    {-# INLINE isZero #-}

    nullable                :: Regex -> Bool
    nullable (Zero _)       = False
    nullable Unit           = True
    nullable (Sym _p)       = False         -- assumption: p holds for at least one char
    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 (Dif e1 e2)    = nullable e1 &&
                              not (nullable e2)

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

    delta   :: Regex -> Char -> Regex
    delta e@(Zero _)  _     = e
    delta Unit        c     = mkZero $
                              "unexpected char " ++ show c
    delta (Sym p)     c
        | p c               = mkUnit
        | otherwise         = mkZero $
                              "unexpected char " ++ show c ++ ", expected: " ++ oneof ++ chars'
                              where
                              (cs, ds) = splitAt 40 (chars p)
                              oneof
                                  | null (tail cs) = ""
                                  | otherwise      = "one of "
                              chars'
                                  | null (tail cs) = "'" ++ cs ++ "'"
                                  | null ds   = "[" ++ cs ++ "]"
                                  | otherwise = "[" ++ cs ++ "...]"

    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 (Dif e1 e2) c     = mkDif (delta e1 c) (delta e2 c)

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

    delta'          :: Regex -> String -> Regex
    delta'          = foldl' delta

    matchWithRE             :: Regex -> String -> Maybe String
    matchWithRE e
        = res . delta' e
        where
        res (Zero err)      = Just err
        res re
            | nullable re   = Nothing       -- o.k.
            | otherwise     = Just $ "input does not match " ++ show e

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

    (<&&>)          :: (Char -> Bool) -> (Char -> Bool) -> (Char -> Bool)
    f <&&> g        = \ x -> f x && g x             -- liftA2 (&&)

    {-# INLINE (<&&>) #-}

    (<||>)          :: (Char -> Bool) -> (Char -> Bool) -> (Char -> Bool)
    f <||> g        = \ x -> f x || g x             -- liftA2 (||)

    {-# INLINE (<||>) #-}

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