content: -- ------------------------------------------------------------
  
  {- |
     Module     : Text.XML.HXT.DTDValidation.RE
     Copyright  : Copyright (C) 2008 Uwe Schmidt
     License    : MIT
  
     Maintainer : Uwe Schmidt (uwe@fh-wedel.de)
     Stability  : experimental
     Portability: portable
  
     A module for regular expression matching based on derivatives of regular expressions.
  
     The code was taken from Joe English (<http://www.flightlab.com/~joe/sgml/validate.html>).
     Tested and extended by Martin Schmidt.
  
     Further references for the algorithm:
  
     Janusz A. Brzozowski.
  
          Derivatives of Regular Expressions. Journal of the ACM, Volume 11, Issue 4, 1964.
  
     Mark Hopkins.
  
          Regular Expression Package. Posted to comp.compilers, 1994.
          Available per FTP at <ftp://iecc.com/pub/file/regex.tar.gz>.
  -}
  
  -- ------------------------------------------------------------
  
  module Text.XML.HXT.DTDValidation.RE
      ( RE(..)
  
      , re_unit
      , re_zero
      , re_sym
      , re_rep
      , re_plus
      , re_opt
      , re_seq
      , re_alt
      , re_dot
  
      , checkRE
      , matches
      , nullable
      , printRE
    )
  where
  
  import           Data.List (foldl')
  
  -- |
  -- Data type for regular expressions.
  
  data RE a =
          RE_ZERO String          --' L(0)   = {} (empty set)
          | RE_UNIT               --' L(1)   = { [] } (empty sequence)
          | RE_SYM a              --' L(x)   = { [x] }
          | RE_DOT                --' accept any single symbol
          | RE_REP (RE a)         --' L(e*)  = { [] } `union` L(e+)
          | RE_PLUS (RE a)        --' L(e+)  = { x ++ y | x <- L(e), y <- L(e*) }
          | RE_OPT (RE a)         --' L(e?)  = L(e) `union` { [] }
          | RE_SEQ (RE a) (RE a)  --' L(e,f) = { x ++ y | x <- L(e), y <- L(f) }
          | RE_ALT (RE a) (RE a)  --' L(e|f) = L(e) `union` L(f)
          deriving (Show, Eq, Ord)
  
  
  
  -- ------------------------------------------------------------
  -- Constructor functions to simplify regular expressions when constructing them.
  
  -- |
  -- Constructs a regular expression for an empty set.
  --
  --    * 1.parameter errMsg :  error message
  --
  --    - returns : regular expression for an empty set
  
  re_zero                 :: String -> RE a
  re_zero m               = RE_ZERO m
  
  
  -- |
  -- Constructs a regular expression for an empty sequence.
  --
  --    - returns : regular expression for an empty sequence
  
  re_unit                 :: RE a
  re_unit                 = RE_UNIT
  
  
  -- |
  -- Constructs a regular expression for accepting a symbol
  --
  --    * 1.parameter sym :  the symbol to be accepted
  --
  --    - returns : regular expression for accepting a symbol
  
  re_sym                  :: a -> RE a
  re_sym x                = RE_SYM x
  
  
  -- |
  -- Constructs a regular expression for accepting any singel symbol
  --
  --    - returns : regular expression for accepting any singel symbol
  
  re_dot                  :: RE a
  re_dot                  = RE_DOT
  
  
  -- |
  -- Constructs an optional repetition (*) of a regular expression
  --
  --    * 1.parameter re_a :  regular expression to be repeted
  --
  --    - returns : new regular expression
  
  re_rep                  :: RE a -> RE a
  re_rep RE_UNIT          = RE_UNIT
  re_rep (RE_ZERO _)      = RE_UNIT
  re_rep e@(RE_REP _)     = RE_REP (rem_rep e)            -- remove nested reps
  re_rep e@(RE_ALT _ _)   = RE_REP (rem_rep e)            -- remove nested reps in alternatives
  re_rep e                = RE_REP e
  
  -- |
  -- remove redundant nested *'s in RE
  -- theoretically this is unneccessary,
  -- but without this simplification the runtime can increase exponentally
  -- when computing deltas, e.g. for a** or (a|b*)* which is the same as (a|b)*
  
  rem_rep                     :: RE a -> RE a
  rem_rep (RE_ALT RE_UNIT e2) = e2
  rem_rep (RE_ALT e1 e2)      = RE_ALT (rem_rep e1) (rem_rep e2)
  rem_rep (RE_REP e1)         = rem_rep e1
  rem_rep e1                  = e1
  
  
  -- |
  -- Constructs a repetition (+) of a regular expression
  --
  --    * 1.parameter re_a :  regular expression to be repeted
  --
  --    - returns : new regular expression
  
  re_plus                 :: RE a -> RE a
  re_plus RE_UNIT         = RE_UNIT
  re_plus (RE_ZERO m)     = RE_ZERO m
  re_plus e
      | nullable e        = re_rep e            -- nullable e => e+ == e*
      | otherwise         = re_seq e (re_rep e)
  
  
  -- |
  -- Constructs an option (?) of a regular expression
  --
  --    * 1.parameter re_a :  regular expression to be optional
  --
  --    - returns : new regular expression
  
  re_opt                  :: (Ord a) => RE a -> RE a
  re_opt RE_UNIT          = RE_UNIT
  re_opt (RE_ZERO _)      = RE_UNIT
  re_opt e                = re_alt RE_UNIT e
  
  -- |
  -- Constructs a sequence (,) of two regular expressions
  --
  --    * 1.parameter re_a :  first regular expression in sequence
  --
  --    - 2.parameter re_b :  second regular expression in sequence
  --
  --    - returns : new regular expression
  
  re_seq                                 :: RE a -> RE a -> RE a
  re_seq e1@(RE_ZERO _)   _              = e1                         -- simplification
  re_seq RE_UNIT          e2             = e2                         -- simplification
  re_seq _                e2@(RE_ZERO _) = e2                         -- simplification
  re_seq e1               RE_UNIT        = e1                         -- simplification
  re_seq (RE_SEQ e11 e12) e2             = re_seq e11 (re_seq e12 e2) -- right assoc.
  re_seq e1               e2             = RE_SEQ e1 e2
  
  
  -- |
  -- Constructs an alternative (|) of two regular expressions
  --
  --    * 1.parameter re_a :  first regular expression of alternative
  --
  --    - 2.parameter re_b :  second regular expression of alternative
  --
  --    - returns : new regular expression
  
  re_alt                                      :: (Ord a) => RE a -> RE a -> RE a
  re_alt (RE_ZERO _)      e2                  = e2
  re_alt e1               (RE_ZERO _)         = e1
  re_alt (RE_ALT e11 e12) e2                  = re_alt e11 (re_alt e12 e2)  -- is right assoc
  re_alt e1               e2@(RE_ALT e21 e22)
      | e1 == e21                             = e2             -- duplicates removed, the effective rule
      | e1 >  e21                             = re_alt e21 (re_alt e1 e22)  -- sort alternatives
      | otherwise                             = RE_ALT e1 e2
  re_alt e1               e2
      | e1 == e2                              = e2             -- simplification, the effective rule
      | e1 >  e2                              = re_alt e2 e1   -- sort alts for unique repr.
      | otherwise                             = RE_ALT e1 e2
  
  
  
  -- ------------------------------------------------------------
  
  
  -- |
  -- Checks if a regular expression matches the empty sequence.
  --
  -- nullable e == [] `in` L(e)
  --
  -- This check indicates if a regular expression fits to a sentence or not.
  --
  --    * 1.parameter re :  regular expression to be checked
  --
  --    - returns : true if regular expression matches the empty sequence,
  --                otherwise false
  
  nullable                ::  RE a -> Bool
  nullable (RE_ZERO _)    = False
  nullable RE_UNIT        = True
  nullable (RE_SYM _)     = False
  nullable (RE_REP _)     = True
  nullable (RE_PLUS e)    = nullable e
  nullable (RE_OPT _)     = True
  nullable (RE_SEQ e f)   = nullable e && nullable f
  nullable (RE_ALT e f)   = nullable e || nullable f
  nullable RE_DOT         = False
  
  
  -- |
  -- Derives a regular expression with respect to one symbol.
  --
  -- L(delta e x) = x \ L(e)
  --
  --    * 1.parameter re :  regular expression to be derived
  --
  --    - 2.parameter sym :  the symbol on which the regular expression is applied
  --
  --    - returns : the derived regular expression
  
  delta :: (Ord a, Show a) => RE a -> a -> RE a
  delta re x = case re of
          RE_ZERO _               -> re                                   -- re_zero m
          RE_UNIT                 -> re_zero ("Symbol " ++ show x ++ " unexpected.")
          RE_SYM sym
                  | x == sym      -> re_unit
                  | otherwise     -> re_zero ("Symbol " ++ show sym ++ " expected, but symbol " ++ show x ++ " found.")
          RE_REP  e               -> re_seq (delta e x) re                -- (re_rep e)
          RE_PLUS e               -> re_seq (delta e x) (re_rep e)
          RE_OPT  e               -> delta e x
          RE_SEQ  e f
                  | nullable e    -> re_alt (re_seq (delta e x) f) (delta f x)
                  | otherwise     -> re_seq (delta e x) f
          RE_ALT  e f             -> re_alt (delta e x) (delta f x)
          RE_DOT                  -> re_unit
  
  
  -- |
  -- Derives a regular expression with respect to a sentence.
  --
  --    * 1.parameter re :  regular expression
  --
  --    - 2.parameter s :  sentence to which the regular expression is applied
  --
  --    - returns : the derived regular expression
  
  matches :: (Ord a, Show a) => RE a -> [a] -> RE a
  matches e = foldl' delta e
  
  
  -- |
  -- Checks if an input matched a regular expression. The function should be
  -- called after matches.
  --
  -- Was the sentence used in @matches@ in the language of the regular expression?
  -- -> matches e s == s `in` L(e)?
  --
  --    * 1.parameter re :  the derived regular expression
  --
  --    - returns : empty String if input matched the regular expression, otherwise
  --               an error message is returned
  
  checkRE :: (Eq a, Show a) => RE a -> String
  checkRE (RE_UNIT)       = ""
  checkRE (RE_ZERO m)     = m
  checkRE re
          | nullable re   = ""
          | otherwise     = "Input must match " ++ printRE re
  
  
  
  -- ------------------------------------------------------------
  
  
  
  -- |
  -- Constructs a string representation of a regular expression.
  --
  --    * 1.parameter re :  a regular expression
  --
  --    - returns : the string representation of the regular expression
  
  printRE :: (Eq a, Show a) => RE a -> String
  printRE re'
      = "( " ++ printRE1 re' ++ " )"
        where
        -- printRE1 :: (Eq a, Show a) => RE a -> String
        printRE1 re = case re of
            RE_ZERO m                             -> "ERROR: " ++ m
            RE_UNIT                               -> ""
            RE_SYM sym                            -> show sym
            RE_DOT                                -> "."
            RE_REP e
                | isSingle e                      -> printRE1 e ++ "*"
                | otherwise                       -> "(" ++ printRE1 e ++ ")*"
            RE_PLUS e
                | isSingle e                      -> printRE1 e ++ "+"
                | otherwise                       -> "(" ++ printRE1 e ++ ")+"
            RE_OPT e
                | isSingle e                      -> printRE1 e ++ "?"
                | otherwise                       -> "(" ++ printRE1 e ++ ")?"
            RE_SEQ e1 (RE_REP e2)
                | e1 == e2                        -> printRE1 (RE_PLUS e1)
            RE_SEQ e1 (RE_SEQ (RE_REP e2) e3)
                | e1 == e2                        -> printRE1 (RE_SEQ (RE_PLUS e1) e3)
            RE_SEQ e f
                | isAlt e  && not (isAlt f)       -> "(" ++ printRE1 e ++ ") , " ++ printRE1 f
                | not (isAlt e) && isAlt f        -> printRE1 e ++ " , (" ++ printRE1 f ++ ")"
                | isAlt e  && isAlt f             -> "(" ++ printRE1 e ++ ") , (" ++ printRE1 f ++ ")"
                | otherwise                       -> printRE1 e ++ " , " ++ printRE1 f
            RE_ALT RE_UNIT f                      -> printRE1 (RE_OPT f)
            RE_ALT e f
                | isSeq e  && not (isSeq f)       -> "(" ++ printRE1 e ++ ") | " ++ printRE1 f
                | not (isSeq e) && isSeq f        -> printRE1 e ++ " | (" ++ printRE1 f ++ ")"
                | isSeq e  && isSeq f             -> "(" ++ printRE1 e ++ ") | (" ++ printRE1 f ++ ")"
                | otherwise                       -> printRE1 e ++ " | " ++ printRE1 f
  
  
        isSingle :: RE a -> Bool
        isSingle (RE_ZERO _)    = True
        isSingle RE_UNIT        = True
        isSingle (RE_SYM _)     = True
        isSingle _              = False
  
  
        isSeq :: (Eq a) => RE a -> Bool
        isSeq (RE_SEQ e1 (RE_REP e2))
            | e1 == e2          = False  -- is transformed back into RE_PLUS
        isSeq (RE_SEQ _ _)      = True
        isSeq _                 = False
  
  
        isAlt :: RE a -> Bool
        isAlt (RE_ALT RE_UNIT _)= False  -- is transformed back into a RE_OPT
        isAlt (RE_ALT _ _)      = True
        isAlt _                 = False
  