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

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

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