{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-|

Module      :  Text.Regex.Base.Context
Copyright   :  (c) Chris Kuklewicz 2006
License     :  BSD-style (see the file LICENSE)

Maintainer  :  libraries@haskell.org, textregexlazy@personal.mightyreason.com
Stability   :  experimental
Portability :  non-portable (MPTC+FD)

This is a module of instances of 'RegexContext' (defined in
Text.Regex.Base.RegexLike).  Nothing else is exported.  This is
usually imported via the Text.Regex.Base convenience package which
itself is re-exported from newer Text.Regex.XXX modules provided by
the different regex-xxx backends.

These instances work for all the supported types and backends
interchangably.  These instances provide the different results that
can be gotten from a match or matchM operation (often via the @=~@ and
@=~~@ operators with combine @makeRegex@ with @match@ and @matchM@
respectively).  This module name is Context because they operators are
context dependent: use them in a context that expects an Int and you
get a count of matches, use them in a Bool context and get True if
there is a match, etc.

@RegexContext a b c@ takes a regular expression suppied in a type 'a'
generated by 'RegexMaker' and a target text supplied in type 'b' to a
result type 'c' using the 'match' class function.  The 'matchM' class
function works like 'match' unless there is no match found, in which
case it calls 'fail' in the (arbitrary) monad context.

There are a few type synonyms from RegexLike that are used here:

@ 
-- | 0 based index from start of source, or (-1) for unused
type MatchOffset = Int
-- | non-negative length of a match
type MatchLength = Int
type MatchArray = Array Int (MatchOffset, MatchLength)
type MatchText source = Array Int (source, (MatchOffset, MatchLength))
@

There are also a few newtypes that used to prevent any possible
overlap of types, which were not needed for GHC's late overlap
detection but are needed for use in Hugs.

@
newtype AllSubmatches f b = AllSubmatches {getAllSubmatches :: (f b)}
newtype AllTextSubmatches f b = AllTextSubmatches {getAllTextSubmatches :: (f b)}
newtype AllMatches f b = AllMatches {getAllMatches :: (f b)}
newtype AllTextMatches f b = AllTextMatches {getAllTextMatches :: (f b) }
@

The newtypes' @f@ parameters are the containers, usually @[]@ or
@Array Int@, (where the arrays all have lower bound 0).

The two *Submatches newtypes return only information on the first
match.  The other two newtypes return information on all the
non-overlapping matches.  The two *Text* newtypes are used to mark
result types that contain the same type as the target text.

Where provided, noncaptured submatches will have a @MatchOffset@ of
(-1) and non-negative otherwise.  The semantics of submatches depend
on the backend and its compile and execution options.  Where provided,
@MatchLength@ will always be non-negative.  Arrays with no elements
are returned with bounds of (1,0).  Arrays with elements will have a
lower bound of 0.

XXX THIS HADDOCK DOCUMENTATION IS OUT OF DATE XXX

These are for finding the first match in the target text:


@ RegexContext a b Bool @ :
  Whether there is any match or not.


@ RegexContext a b () @ :
  Useful as a guard with @matchM@ or @=~~@ in a monad, since failure to match calls 'fail'.


@ RegexContext a b b @ :
  This returns the text of the whole match.
  It will return 'empty' from the 'Extract' type class if there is no match.
  These are defined in each backend module, but documented here for convenience.


@ RegexContext a b (MatchOffset,MatchLength) @ :
  This returns the initial index and length of the whole match.
  MatchLength will always be non-negative, and 0 for a failed match.


@ RegexContext a b (MatchResult b) @ : The
  'MatchResult' structure with details for the match.  This is the
  structure copied from the old @JRegex@ pacakge.


@ RegexContext a b (b, b, b) @ :
  The text before the match, the text of the match, the text after the match


@ RegexContext a b (b, MatchText b, b) @ :
  The text before the match, the details of the match, and the text after the match


@ RegexContext a b (b, b, b, [b]) @ : 
  The text before the match, the text of the match, the text after the
  match, and a list of the text of the 1st and higher sub-parts of the
  match.  This is the same return value as used in the old
  @Text.Regex@ API.

Two containers of the submatch offset information:


@ RegexContext a b MatchArray @ :
  Array of @(MatchOffset,MatchLength)@ for all the sub matches.
  The whole match is at the intial 0th index.
  Noncaptured submatches will have a @MatchOffset@ of (-1)
  The array will have no elements and bounds (1,0) if there is no match.


@ RegexContext a b (AllSubmatches [] (MatchOffset,MatchLength) @ :
  List of @(MatchOffset,MatchLength)@
  The whole match is the first element, the rest are the submatches (if any) in order.
  The list is empty if there is no match.

Two containers of the submatch text and offset information:

@ RegexContext a b (AllTextSubmatches (Array Int) (b, (MatchOffset, MatchLength))) @

@ RegexContext a b (AllTextSubmatches [] (b, (MatchOffset, MatchLength)))  @

Two containers of the submatch text information:

@ RegexContext a b (AllTextSubmatches [] b) @

@ RegexContext a b (AllTextSubmatches (Array Int) b) @

These instances are for all the matches (non-overlapping).  Note that
backends are supposed to supply 'RegexLike' instances for which the
default 'matchAll' and 'matchAllText' stop searching after returning
any successful but empty match.


@ RegexContext a b Int @ :
  The number of matches, non-negative.

Two containers for locations of all matches:

@ RegexContext a b (AllMatches [] (MatchOffset, MatchLength)) @

@ RegexContext a b (AllMatches (Array Int) (MatchOffset,MatchLength)) @

Two containers for the locations of all matches and their submatches:

@ RegexContext a b [MatchArray] @ :

@ RegexContext a b (AllMatches (Array Int) MatchArray) @

Two containers for the text and locations of all matches and their submatches:

@ RegexContext a b [MatchText b] @

@ RegexContext a b (AllTextMatches (Array Int) (MatchText b)) @

Two containers for text of all matches:
@ RegexContext a b (AllTextMatches [] b) @

@ RegexContext a b (AllTextMatches (Array Int) b) @

Four containers for text of all matches and their submatches:

@ RegexContext a b [[b]] @

@ RegexContext a b (AllTextMatches (Array Int) [b]) @

@ RegexContext a b (AllTextMatches [] (Array Int b)) @

@ RegexContext a b (AllTextMatches (Array Int) (Array Int b)) @

Unused matches are 'empty' (defined via 'Extract')

-}

module Text.Regex.Base.Context() where

import Control.Monad(liftM)
import Data.Array(Array,(!),elems,listArray)
--  import Data.Maybe(maybe)
import Text.Regex.Base.RegexLike(RegexLike(..),RegexContext(..)
  ,AllSubmatches(..),AllTextSubmatches(..),AllMatches(..),AllTextMatches(..)
  ,MatchResult(..),Extract(empty),MatchOffset,MatchLength,MatchArray,MatchText)


{-
-- Get the ByteString type for mood/doom
import Data.ByteString(ByteString)
-- Get the Regex types for the mood/doom workaround
import qualified Text.Regex.Lib.WrapPosix as R1(Regex)
import qualified Text.Regex.Lib.WrapPCRE as R2(Regex)
import qualified Text.Regex.Lib.WrapLazy as R3(Regex)
import qualified Text.Regex.Lib.WrapDFAEngine as R4(Regex)
-- Get the RegexLike instances
import Text.Regex.Lib.StringPosix()
import Text.Regex.Lib.StringPCRE()
import Text.Regex.Lib.StringLazy()
import Text.Regex.Lib.StringDFAEngine()
import Text.Regex.Lib.ByteStringPosix()
import Text.Regex.Lib.ByteStringPCRE()
import Text.Regex.Lib.ByteStringLazy()
import Text.Regex.Lib.ByteStringDFAEngine()
-}
{-

mood :: (RegexLike a b) => a -> b -> b
{-# INLINE mood #-}
mood r s = case matchOnceText r s of
    Nothing -> empty
    Just (_,ma,_) -> fst (ma!0)

doom :: (RegexLike a b,Monad m) => a -> b -> m b
{-# INLINE doom #-}
doom =  actOn (\(_,ma,_)->fst (ma!0))

{- These run afoul of various restrictions if I say
   "instance RegexContext a b b where"
   so I am listing these cases explicitly
-}

instance RegexContext R1.Regex String String where match = mood; matchM = doom
instance RegexContext R2.Regex String String where match = mood; matchM = doom
instance RegexContext R3.Regex String String where match = mood; matchM = doom
instance RegexContext R4.Regex String String where match = mood; matchM = doom
instance RegexContext R1.Regex ByteString ByteString where match = mood; matchM = doom
instance RegexContext R2.Regex ByteString ByteString where match = mood; matchM = doom
instance RegexContext R3.Regex ByteString ByteString where match = mood; matchM = doom
instance RegexContext R4.Regex ByteString ByteString where match = mood; matchM = doom
-}


nullArray :: Array Int a
{-# INLINE nullArray #-}
nullArray = listArray (1,0) []

nullFail :: (RegexContext regex source (AllMatches [] target),Monad m) => regex -> source -> m (AllMatches [] target)
{-# INLINE nullFail #-}
nullFail r s = case match r s of
                 (AllMatches []) -> regexFailed
                 xs -> return xs

nullFailText :: (RegexContext regex source (AllTextMatches [] target),Monad m) => regex -> source -> m (AllTextMatches [] target)
{-# INLINE nullFailText #-}
nullFailText r s = case match r s of
                     (AllTextMatches []) -> regexFailed
                     xs -> return xs

nullFail' :: (RegexContext regex source ([] target),Monad m) => regex -> source -> m ([] target)
{-# INLINE nullFail' #-}
nullFail' r s = case match r s of
                 ([]) -> regexFailed
                 xs -> return xs

regexFailed :: (Monad m) => m b
{-# INLINE regexFailed #-}
regexFailed =  fail $ "regex failed to match"

actOn :: (RegexLike r s,Monad m) => ((s,MatchText s,s)->t) -> r -> s -> m t
{-# INLINE actOn #-}
actOn f r s = case matchOnceText r s of
    Nothing -> regexFailed
    Just preMApost -> return (f preMApost)

-- ** Instances based on matchTest ()

instance (RegexLike a b) => RegexContext a b Bool where
  match = matchTest
  matchM r s = case match r s of
                 False -> regexFailed
                 True -> return True

instance (RegexLike a b) => RegexContext a b () where
  match _ _ = ()
  matchM r s = case matchTest r s of
                 False -> regexFailed
                 True -> return ()

-- ** Instance based on matchCount

instance (RegexLike a b) => RegexContext a b Int where
  match = matchCount
  matchM r s = case match r s of
                 0 -> regexFailed
                 x -> return x

-- ** Instances based on matchOnce,matchOnceText

instance (RegexLike a b) => RegexContext a b (MatchOffset,MatchLength) where
  match r s = maybe (-1,0) (!0) (matchOnce r s)
  matchM r s = maybe regexFailed (return.(!0)) (matchOnce r s)

instance (RegexLike a b) => RegexContext a b (MatchResult b) where
  match r s = maybe (MR {mrBefore = s,mrMatch = empty,mrAfter = empty
                        ,mrSubs = nullArray,mrSubList = []}) id (matchM r s)
  matchM = actOn (\(pre,ma,post) ->
     let ((whole,_):subs) = elems ma
     in MR { mrBefore = pre
           , mrMatch = whole
           , mrAfter = post
           , mrSubs = fmap fst ma
           , mrSubList = map fst subs })

instance (RegexLike a b) => RegexContext a b (b,MatchText b,b) where
  match r s = maybe (s,nullArray,empty) id (matchOnceText r s)
  matchM r s = maybe regexFailed return (matchOnceText r s)

instance (RegexLike a b) => RegexContext a b (b,b,b) where
  match r s = maybe (s,empty,empty) id (matchM r s)
  matchM = actOn (\(pre,ma,post) -> let ((whole,_):_) = elems ma
                                    in (pre,whole,post))

instance (RegexLike a b) => RegexContext a b (b,b,b,[b]) where
  match r s = maybe (s,empty,empty,[]) id (matchM r s)
  matchM = actOn (\(pre,ma,post) -> let ((whole,_):subs) = elems ma
                                    in (pre,whole,post,map fst subs))

-- now AllSubmatches wrapper
instance (RegexLike a b) => RegexContext a b MatchArray where
  match r s = maybe nullArray id (matchOnce r s)
  matchM r s = maybe regexFailed return (matchOnce r s)
instance (RegexLike a b) => RegexContext a b (AllSubmatches [] (MatchOffset,MatchLength)) where
  match r s = maybe (AllSubmatches []) id (matchM r s)
  matchM r s = case matchOnce r s of
                 Nothing -> regexFailed
                 Just ma -> return (AllSubmatches (elems ma))

-- essentially AllSubmatches applied to (MatchText b)
instance (RegexLike a b) => RegexContext a b (AllTextSubmatches (Array Int) (b, (MatchOffset, MatchLength))) where
  match r s = maybe (AllTextSubmatches nullArray) id (matchM r s)
  matchM r s = actOn (\(_,ma,_) -> AllTextSubmatches ma) r s
instance (RegexLike a b) => RegexContext a b (AllTextSubmatches [] (b, (MatchOffset, MatchLength))) where
  match r s = maybe (AllTextSubmatches []) id (matchM r s)
  matchM r s = actOn (\(_,ma,_) -> AllTextSubmatches (elems ma)) r s

instance (RegexLike a b) => RegexContext a b (AllTextSubmatches [] b) where
  match r s = maybe (AllTextSubmatches []) id (matchM r s)
  matchM r s = liftM AllTextSubmatches $ actOn (\(_,ma,_) -> map fst . elems $ ma) r s
instance (RegexLike a b) => RegexContext a b (AllTextSubmatches (Array Int) b) where
  match r s = maybe (AllTextSubmatches nullArray) id (matchM r s)
  matchM r s = liftM AllTextSubmatches $ actOn (\(_,ma,_) -> fmap fst ma) r s

-- ** Instances based on matchAll,matchAllText

instance (RegexLike a b) => RegexContext a b (AllMatches [] (MatchOffset,MatchLength)) where
  match r s = AllMatches [ ma!0 | ma <- matchAll r s ]
  matchM r s = nullFail r s
instance (RegexLike a b) => RegexContext a b (AllMatches (Array Int) (MatchOffset,MatchLength)) where
  match r s = maybe (AllMatches nullArray) id (matchM r s)
  matchM r s = case match r s of
                 (AllMatches []) -> regexFailed
                 (AllMatches pairs) -> return . AllMatches . listArray (0,pred $ length pairs) $ pairs

-- No AllMatches wrapper
instance (RegexLike a b) => RegexContext a b [MatchArray] where
  match = matchAll
  matchM = nullFail'
instance (RegexLike a b) => RegexContext a b (AllMatches (Array Int) MatchArray) where
  match r s = maybe (AllMatches nullArray) id (matchM r s)
  matchM r s = case match r s of
                 [] -> regexFailed
                 mas -> return . AllMatches . listArray (0,pred $ length mas) $ mas

-- No AllTextMatches wrapper
instance (RegexLike a b) => RegexContext a b [MatchText b] where
  match = matchAllText
  matchM = nullFail'
instance (RegexLike a b) => RegexContext a b (AllTextMatches (Array Int) (MatchText b)) where
  match r s = maybe (AllTextMatches nullArray) id (matchM r s)
  matchM r s = case match r s of
                 ([]) -> regexFailed
                 (mts) -> return . AllTextMatches . listArray (0,pred $ length mts) $ mts

instance (RegexLike a b) => RegexContext a b (AllTextMatches [] b) where
  match r s = AllTextMatches [ fst (ma!0) | ma <- matchAllText r s ]
  matchM r s = nullFailText r s
instance (RegexLike a b) => RegexContext a b (AllTextMatches (Array Int) b) where
  match r s = maybe (AllTextMatches nullArray) id (matchM r s)
  matchM r s = case match r s of
                 (AllTextMatches []) -> regexFailed
                 (AllTextMatches bs) -> return . AllTextMatches . listArray (0,pred $ length bs) $ bs

-- No AllTextMatches wrapper
instance (RegexLike a b) => RegexContext a b [[b]] where
  match r s = [ map fst (elems ma) | ma <- matchAllText r s ]
  matchM r s = nullFail' r s
instance (RegexLike a b) => RegexContext a b (AllTextMatches (Array Int) [b]) where
  match r s = maybe (AllTextMatches nullArray) id (matchM r s)
  matchM r s = case match r s of
                 ([]) -> regexFailed
                 (ls) -> return . AllTextMatches . listArray (0,pred $ length ls) $ ls
instance (RegexLike a b) => RegexContext a b (AllTextMatches [] (Array Int b)) where
  match r s = AllTextMatches [ fmap fst ma | ma <- matchAllText r s ]
  matchM r s = nullFailText r s
instance (RegexLike a b) => RegexContext a b (AllTextMatches (Array Int) (Array Int b)) where
  match r s = maybe (AllTextMatches nullArray) id (matchM r s)
  matchM r s = case match r s of
                 (AllTextMatches []) -> regexFailed
                 (AllTextMatches as) -> return . AllTextMatches . listArray (0,pred $ length as) $ as