{-# LANGUAGE CPP #-}
module Text.Regex.TDFA.RunMutState(TagEngine(..),newTagEngine,newTagEngine2
                                  ,newScratch,tagsToGroupsST
                                  ,toInstructions,compareWith,resetScratch
                                  ,SScratch(..),MScratch,WScratch) where

import Control.Monad(forM_,liftM,liftM2,liftM3,foldM)
--import Control.Monad.ST.Strict as S (ST)
--import qualified Control.Monad.ST.Lazy as L (ST)
import Control.Monad.State(MonadState(..),execState)

import Data.Array.Base(unsafeRead,unsafeWrite,STUArray(..))
#ifdef __GLASGOW_HASKELL__
import GHC.Arr(STArray(..))
import GHC.ST(ST(..))
import GHC.Prim(MutableByteArray#,RealWorld,Int#,sizeofMutableByteArray#,unsafeCoerce#)
#else
import Control.Monad(when)
import Control.Monad.ST(ST)
import Data.Array.ST(STArray)
#endif

import Data.Array.MArray(MArray(..),newListArray,unsafeFreeze)
import Data.Array.IArray(Array,(!),bounds,assocs)

import Data.IntMap(IntMap)
import qualified Data.IntMap as IMap(null,toList,insert,insertWith,insertWithKey,delete,lookup,keys)
import Data.Ix(Ix(..))
import Data.Monoid(Monoid(..))
import Data.Sequence as S((|>),viewl,ViewL(..))
import Data.STRef(newSTRef,readSTRef,writeSTRef,STRef)

import Text.Regex.Base(MatchArray,MatchOffset,MatchLength)
import Text.Regex.TDFA.Common

-- import Debug.Trace

{- By Chris Kuklewicz, 2007. BSD License, see the LICENSE file. -}

err :: String -> a
err s = common_error "Text.Regex.TDFA.RunMutState"  s

data TagEngine s t p = TagEngine
  !(MScratch s -> Position -> IntMap (IntMap (t,Instructions)) -> ST s ())
  !(MScratch s -> p -> Maybe (WScratch s,p) -> IntMap Instructions -> ST s (Maybe (WScratch s,p)))
  !(MScratch s -> MScratch s -> Position -> IntMap (IntMap (DoPa,Instructions)) -> ST s ())

{-# INLINE newTagEngine #-}
newTagEngine :: Regex -> ST s (TagEngine s t (Position,Char,xxx))
newTagEngine regexIn = do
  (which,count) <- newBoard regexIn
  let comp = makeTagComparer (regex_tags regexIn)
  let findTrans s1 off trans = {-# SCC "findTrans" #-} (mapM_ findTrans' (IMap.toList trans)) where
        findTrans' (destIndex,sources) | IMap.null sources =
          unsafeWrite which destIndex ((-1,undefined),undefined,undefined)
                                       | otherwise =  {-# SCC "findTrans'" #-} do
          let (first:rest) = IMap.toList sources
              {-# INLINE prep #-}
              prep (sourceIndex,(_,instructions)) = {-# SCC "prep" #-} do
                p <- maybe (error "findtrans") return =<< unsafeRead (m_pos s1) sourceIndex
                o <- unsafeRead (m_orbit s1) sourceIndex
                let o' = maybe o (\x -> x off o) (newOrbits instructions)
                return ((sourceIndex,instructions),p,o')
              challenge x1 y1 = {-# SCC "challenge" #-} do
                x2 <- prep y1
                check <- comp off x1 (newPos . snd . fst3 $ x1) x2 (newPos . snd . fst3 $ x2)
        {-
                debug1 <- getAssocs (snd3 x1)
                debug2 <- getAssocs (snd3 x2)
                () <- trace ("findTrans comp, pos="++show off'++", check="++show check
                             ++"\n"++show (debug1,fst3 x1,o1)
                             ++ "\n"++show (debug2,fst3 x2,o2)) (return ())
        -}
                if check==LT then return x2 else return x1
          x1 <- prep first
          x@((sourceIndex',_instructions'),_,_orbit') <- foldM challenge x1 rest
          unsafeWrite which destIndex x -- (sourceIndex',instructions',orbit')
          unsafeRead count sourceIndex' >>= (unsafeWrite count sourceIndex') . succ

  let {-# INLINE updateWinner #-}
      updateWinner s1 (off,prev,input) winning sources | IMap.null sources = return winning
                                                       | otherwise = {-# SCC "updateWinner" #-} do
        let (first:rest) = IMap.toList sources
            {-# INLINE prep #-}
            prep x@(sourceIndex,instructions) = do
              p <- maybe (error "updateWinner") return =<< unsafeRead (m_pos s1) sourceIndex
              o <- unsafeRead (m_orbit s1) sourceIndex
              let o' = maybe o (\f -> f off o) (newOrbits instructions)
              return (x,p,o')
            challenge x1 y1 = do
              x2 <- prep y1
              check <- comp off x1 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x1)
                                x2 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x2)
      {-
                     debug1 <- getAssocs (snd3 x1)
                     debug2 <- getAssocs (snd3 x2)
                     () <- trace ("updateWinner comp, pos="++show off++", check="++show check
                                  ++"\n"++show (debug1,fst3 x1,thd3 x1)
                                  ++ "\n"++show (debug2,fst3 x2,thd3 x2)) (return ())
      -}
              if check==LT then return x2 else return x1
        x1 <- prep first
        ((sourceIndex',instructions'),_,o') <- foldM challenge x1 rest
        n <- unsafeRead count sourceIndex'
        w <- updateWinning s1 (sourceIndex',instructions',o') off n (fmap fst winning)
        return (Just (w,(off,prev,input)))

  let performTrans s1 s2 off dtrans | IMap.null dtrans = return ()
                                    | otherwise = {-# SCC "performTrans" #-} do
        mapM_ performTrans' (IMap.keys dtrans)
          where performTrans' destIndex =  {-# SCC "performTrans'" #-} do
                  i1@((sourceIndex,_instructions),_,_orbit) <- unsafeRead which destIndex
                  if sourceIndex == (-1) then return () else do
                  n <- unsafeRead count sourceIndex
                  unsafeWrite count sourceIndex (pred n)
                  if n==1 then updateSwap s1 i1 off s2 destIndex
                          else updateCopy s1 i1 off s2 destIndex
-- findTrans :: forall s. ({-Dest-}Index,IntMap {-Source-} (DoPa,Instructions)) -> ST s ()
-- updateWinner :: IntMap {- Source -} Instructions -> ST s (Maybe (WScratch s,(Position,Char,String)))
-- performTrans :: IntMap {-Dest-} (IntMap {-Source-} (DoPa,Instructions)) -> ST s ()
  return (TagEngine findTrans updateWinner performTrans)

{-# INLINE newTagEngine2 #-}
newTagEngine2 :: Regex -> ST s (TagEngine s t Position)
newTagEngine2 regexIn = do
  (which,count) <- newBoard regexIn
  let comp = makeTagComparer (regex_tags regexIn)
  let findTrans s1 off trans = {-# SCC "findTrans" #-} (mapM_ findTrans' (IMap.toList trans)) where
        findTrans' (destIndex,sources) | IMap.null sources =
          unsafeWrite which destIndex ((-1,undefined),undefined,undefined)
                                       | otherwise =  {-# SCC "findTrans'" #-} do
          let (first:rest) = IMap.toList sources
              {-# INLINE prep #-}
              prep (sourceIndex,(_,instructions)) = {-# SCC "prep" #-} do
                p <- maybe (error "findtrans") return =<< unsafeRead (m_pos s1) sourceIndex
                o <- unsafeRead (m_orbit s1) sourceIndex
                let o' = maybe o (\x -> x off o) (newOrbits instructions)
                return ((sourceIndex,instructions),p,o')
              challenge x1 y1 = {-# SCC "challenge" #-} do
                x2 <- prep y1
                check <- comp off x1 (newPos . snd . fst3 $ x1) x2 (newPos . snd . fst3 $ x2)
        {-
                debug1 <- getAssocs (snd3 x1)
                debug2 <- getAssocs (snd3 x2)
                () <- trace ("findTrans comp, pos="++show off'++", check="++show check
                             ++"\n"++show (debug1,fst3 x1,o1)
                             ++ "\n"++show (debug2,fst3 x2,o2)) (return ())
        -}
                if check==LT then return x2 else return x1
          x1 <- prep first
          x@((sourceIndex',_instructions'),_,_orbit') <- foldM challenge x1 rest
          unsafeWrite which destIndex x -- (sourceIndex',instructions',orbit')
          unsafeRead count sourceIndex' >>= (unsafeWrite count sourceIndex') . succ

  let {-# INLINE updateWinner #-}
      updateWinner s1 off winning sources | IMap.null sources = return winning
                                          | otherwise = {-# SCC "updateWinner" #-} do
        let (first:rest) = IMap.toList sources
            {-# INLINE prep #-}
            prep x@(sourceIndex,instructions) = do
              p <- maybe (error "updateWinner") return =<< unsafeRead (m_pos s1) sourceIndex
              o <- unsafeRead (m_orbit s1) sourceIndex
              let o' = maybe o (\f -> f off o) (newOrbits instructions)
              return (x,p,o')
            challenge x1 y1 = do
              x2 <- prep y1
              check <- comp off x1 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x1)
                                x2 (dropWhile ((1>=).fst) . newPos . snd . fst3 $ x2)
      {-
                     debug1 <- getAssocs (snd3 x1)
                     debug2 <- getAssocs (snd3 x2)
                     () <- trace ("updateWinner comp, pos="++show off++", check="++show check
                                  ++"\n"++show (debug1,fst3 x1,thd3 x1)
                                  ++ "\n"++show (debug2,fst3 x2,thd3 x2)) (return ())
      -}
              if check==LT then return x2 else return x1
        x1 <- prep first
        ((sourceIndex',instructions'),_,o') <- foldM challenge x1 rest
        n <- unsafeRead count sourceIndex'
        w <- updateWinning s1 (sourceIndex',instructions',o') off n (fmap fst winning)
        return (Just (w,off))

  let performTrans s1 s2 off dtrans | IMap.null dtrans = return ()
                                    | otherwise = {-# SCC "performTrans" #-} do
        mapM_ performTrans' (IMap.keys dtrans)
          where performTrans' destIndex =  {-# SCC "performTrans'" #-} do
                  i1@((sourceIndex,_instructions),_,_orbit) <- unsafeRead which destIndex
                  if sourceIndex == (-1) then return () else do
                  n <- unsafeRead count sourceIndex
                  unsafeWrite count sourceIndex (pred n)
                  if n==1 then updateSwap s1 i1 off s2 destIndex
                          else updateCopy s1 i1 off s2 destIndex
-- findTrans :: forall s. ({-Dest-}Index,IntMap {-Source-} (DoPa,Instructions)) -> ST s ()
-- updateWinner :: IntMap {- Source -} Instructions -> ST s (Maybe (WScratch s,(Position,Char,String)))
-- performTrans :: IntMap {-Dest-} (IntMap {-Source-} (DoPa,Instructions)) -> ST s ()
  return (TagEngine findTrans updateWinner performTrans)

-- XXX change first element type to store winning orbit' and such?
newBoard :: Regex -> ST s (STArray s Index ((Index,Instructions),a,OrbitLog)
                          ,STUArray s Index Int)
newBoard regexIn = do
  let bWhich = (0,regex_init regexIn) -- (-1) index is winning state
      bCount = (0,regex_init regexIn)
  liftM2 (,) (newListArray bWhich (replicate (rangeSize bWhich) ((-1,undefined),undefined,undefined)))
             (newArray bCount 0)

{-
newA' :: (MArray (STArray s) e (ST s)) => (Tag,Tag) -> e -> ST s (STArray s Tag e)
newA' b_tags initial = -- traceNew ("> newA' "++show b_tags) $
                       newArray b_tags initial

newA'_ :: (MArray (STArray s) e (ST s)) => (Tag,Tag) -> ST s (STArray s Tag e)
newA'_ b_tags = -- traceNew ("> newA'_ "++show b_tags) $
                newArray_ b_tags
-}

newA :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> e -> ST s (STUArray s Tag e)
newA b_tags initial = -- traceNew ("> newA "++show b_tags) $
                      newArray b_tags initial

newA_ :: (MArray (STUArray s) e (ST s)) => (Tag,Tag) -> ST s (STUArray s Tag e)
newA_ b_tags = -- traceNew ("> newA_ "++show b_tags) $
               newArray_ b_tags

data MScratch s = MScratch { m_pos :: !(STArray s Index (Maybe (STUArray s Tag Position)))
                           , m_flag :: !(STArray s Index (Maybe (STUArray s Tag Bool)))
                           , m_orbit :: !(STArray s Index OrbitLog) -- Fixed!
                           }
data SScratch s= SScratch { s_1 :: !(MScratch s)
                          , s_2 :: !(MScratch s) -- XXX
                          , w_blank :: !(WScratch s)
                          }
data WScratch s = WScratch { w_pos :: !(STRef s (STUArray s Tag Position))
                           , w_flag :: !(STRef s (STUArray s Tag Bool))
                           , w_orbit :: !(STRef s OrbitLog)
                           }

newWScratch :: (Tag,Tag) -> ST s (WScratch s)
newWScratch b_tags =  liftM3 WScratch (newSTRef =<< newA b_tags (-1))
                                      (newSTRef =<< newA b_tags False)
                                      (newSTRef mempty)

newWScratch_ :: (Tag,Tag) -> ST s (WScratch s)
newWScratch_ b_tags = liftM3 WScratch (newSTRef =<< newA_ b_tags)
                                      (newSTRef =<< newA_ b_tags)
                                      (newSTRef mempty)

resetScratch :: Regex -> Position -> MScratch s -> WScratch s -> ST s ()
resetScratch regexIn startPos s1 w0 = do
  let i = regex_init regexIn
      b_tags = bounds (regex_tags regexIn)

  oldPos <- unsafeRead (m_pos s1) i
  initialPos <- case oldPos of
                  Nothing -> newA b_tags (-1)
                  Just pos -> do blank <- readSTRef (w_pos w0)
                                 copySTU blank pos
                                 return pos
  unsafeWrite initialPos 0 startPos
  unsafeWrite (m_pos s1) i (Just initialPos)

  oldFlags <- unsafeRead (m_flag s1) i
  initFlags <- case oldFlags of
                 Nothing -> newA b_tags False
                 Just flags -> do
                   blank <- readSTRef (w_flag w0)
                   copySTU blank flags
                   return flags
  unsafeWrite initFlags 0 True
  unsafeWrite (m_flag s1) i (Just initFlags)

  unsafeWrite (m_orbit s1) i mempty

newScratch :: Regex -> Position -> ST s (SScratch s)
newScratch regexIn startPos = do
  let i = regex_init regexIn
      b_index = (0,i)
      b_tags = bounds (regex_tags regexIn)
--  trace ("\n> newScratch: "++show (b_index,b_tags,i,startPos)) $ do
  s@(SScratch {s_1=s1,w_blank=w0}) <- newSScratch b_index b_tags
  resetScratch regexIn startPos s1 w0
  return s

newSScratch :: (Index, Index) -> (Tag, Tag) -> ST s (SScratch s)
newSScratch b_index b_tags = do
  s1 <- newMScratch b_index
  s2 <- newMScratch b_index
  w0 <- newWScratch b_tags
  return (SScratch s1 s2 w0)

newMScratch :: (Index,Index) -> ST s (MScratch s)
newMScratch b_index = do
  let n = rangeSize b_index
  pos <- newListArray b_index (replicate n Nothing)
  flag <- newListArray b_index (replicate n Nothing)
  orbit <- newListArray b_index (replicate n mempty)
  return (MScratch pos flag orbit)

{-# INLINE copyUpdateTags #-}
copyUpdateTags :: (MArray (STUArray s) Position (ST s))
                  => STUArray s Tag Position   -- source
                    -> [(Tag,Bool)]            -- updates
                    -> Position -> Position
                    -> STUArray s Tag Position   -- destination
                    -> (ST s) ()
copyUpdateTags a1 changes pFalse pTrue a2 = do
  copySTU a1 a2
  mapM_ (\(tag,v) -> if v then unsafeWrite a2 tag pTrue
                          else unsafeWrite a2 tag pFalse) changes

{-# INLINE copyUpdateFlags #-}
copyUpdateFlags :: (MArray (STUArray s) Bool (ST s))
                   => STUArray s Tag Bool   -- source
                     -> [(Tag,Bool)]          -- updates
                     -> STUArray s Tag Bool   -- destination
                     -> (ST s) ()
copyUpdateFlags a1 changes a2 = do
  copySTU a1 a2
  mapM_ (\(tag,v) -> unsafeWrite a2 tag v) changes

{-# INLINE updateWinning #-}
updateWinning :: MScratch s         -- source 
  -> ({-Source -} Index,Instructions,OrbitLog)
  -> Position
  -> Int
  -> Maybe (WScratch s)              -- destination
  -> ST s (WScratch s)
updateWinning s1 (i1,ins,o) preTag n mw = do
  (Just pos1) <- unsafeRead (m_pos s1) i1
  (Just flag1) <- unsafeRead (m_flag s1) i1
  let val x = if x then postTag else preTag
      postTag = succ preTag
  if n==0
    then do
      mapM_ (\(tag,v) -> unsafeWrite pos1 tag (val v)) (newPos ins)
      mapM_ (\(tag,f) -> unsafeWrite flag1 tag (f)) (newFlags ins)
      case mw of
        Nothing -> liftM3 WScratch (newSTRef pos1) (newSTRef flag1) (newSTRef o)
        Just w -> do writeSTRef (w_pos w) pos1
                     writeSTRef (w_flag w) flag1
                     writeSTRef (w_orbit w) o
                     return w
    else do
      w <- case mw of
             Nothing -> getBounds pos1 >>= newWScratch_
             Just w -> return w
      pos2 <- readSTRef (w_pos w)
      flag2 <- readSTRef (w_flag w)
      copyUpdateTags pos1 (newPos ins) preTag postTag pos2
      copyUpdateFlags flag1 (newFlags ins) flag2
      writeSTRef (w_orbit w) o
      return w

{-# INLINE updateSwap #-}
updateSwap :: MScratch s         -- source 
           -> (({-Source -} Index,Instructions),STUArray s Tag Position,OrbitLog)
           -> Position
           -> MScratch s -> Index        -- destination
           -> ST s ()
updateSwap s1 ((i1,ins),_,o) preTag s2 i2 = do
  -- obtain source
  pos1'@(Just pos1) <- unsafeRead (m_pos s1) i1
  flag1'@(Just flag1) <- unsafeRead (m_flag s1) i1
  -- preserve allocated storage in detination rather than cycle through GC
  unsafeWrite (m_pos s1) i1 =<< unsafeRead (m_pos s2) i2
  unsafeWrite (m_flag s1) i1 =<< unsafeRead (m_flag s2) i2
  -- put source in destination
  unsafeWrite (m_pos s2) i2 pos1'
  unsafeWrite (m_flag s2) i2 flag1'
  unsafeWrite (m_orbit s2) i2 o           --- XXX ???
  let val x = if x then postTag else preTag where postTag = succ preTag
  mapM_ (\(tag,v) -> unsafeWrite pos1 tag (val v)) (newPos ins)
  mapM_ (\(tag,f) -> unsafeWrite flag1 tag (f)) (newFlags ins)

{-# INLINE updateCopy #-}
updateCopy :: MScratch s         -- source 
           -> (({-Source -} Index,Instructions),STUArray s Tag Position,OrbitLog)
           -> Position
           -> MScratch s -> Index        -- destination
           -> ST s ()
updateCopy s1 ((i1,ins),_,o) preTag s2 i2 = do
  pos1 <- maybe (err $ "forceUpdate : m_pos s1 is Nothing" ++ show (i1,ins,preTag)) return =<< unsafeRead (m_pos s1) i1
  flag1 <- maybe (err $ "forceUpdate : m_flag s1 is Nothing" ++ show (i1,ins,preTag)) return =<< unsafeRead (m_flag s1) i1
  b_tags <- getBounds pos1
  pos2 <- maybe (do a <- newA_ b_tags
                    unsafeWrite (m_pos s2) i2 (Just a)
                    return a) return =<< unsafeRead (m_pos s2) i2
  flag2 <- maybe (do a <- newA_ b_tags
                     unsafeWrite (m_flag s2) i2 (Just a)
                     return a) return =<< unsafeRead (m_flag s2) i2
  copyUpdateTags pos1 (newPos ins) preTag (succ preTag) pos2
  copyUpdateFlags flag1 (newFlags ins) flag2
  unsafeWrite (m_orbit s2) i2 o

makeTagComparer :: Array Tag OP
                -> Position
		-> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)
		-> [(Int, Bool)]
		-> ((Int, Instructions), STUArray s Tag Position, IntMap Orbits)
		-> [(Int, Bool)]
		-> ST s Ordering
makeTagComparer aTagOP = foldr ($) end (map chooseBranch
                                            (dropWhile ((1>=).fst)
                                                       (assocs aTagOP)))
  where chooseBranch (tag,Maximize) = challenge_Max tag
        chooseBranch (tag,Minimize) = challenge_Min tag
        chooseBranch (tag,Orbit) = challenge_Orb tag
        end _ _ _ _ _ = return EQ

        challenge_Orb tag next preTag x1@(_state1,_,orbit1') np1 x2@(_state2,_,orbit2') np2 = 
          let s1 = IMap.lookup tag orbit1'
              s2 = IMap.lookup tag orbit2'
          in case (s1,s2) of
               (Nothing,Nothing) -> next preTag x1 np1 x2 np2
               (Just o1,Just o2) | inOrbit o1 == inOrbit o2 ->
                  case comparePos (viewl (getOrbits o1)) (viewl (getOrbits o2)) of
                    EQ -> next preTag x1 np1 x2 np2
                    answer -> return answer
               _ -> err $ "challenge_Orb is too stupid to handle mismatched orbit data :"
                          ++ show(tag,preTag,np1,np2)
          where comparePos :: (ViewL Position) -> (ViewL Position) -> Ordering
                comparePos EmptyL EmptyL = EQ
                comparePos EmptyL _      = GT
                comparePos _      EmptyL = LT
                comparePos (p1 :< ps1) (p2 :< ps2) = 
                  compare p1 p2 `mappend` comparePos (viewl ps1) (viewl ps2)
         

        -- challenge_pos takes the current winner and a challenger, each with instructions.
        -- But the orbits are already modified.
        challenge_Max tag next preTag x1@(_state1,pos1,_) np1 x2@(_state2,pos2,_) np2 = do
          (np1',p1) <- case np1 of
                         ((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)
                         _ -> liftM ((,) np1) (unsafeRead pos1 tag)
          (np2',p2) <- case np2 of
                         ((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)
                         _ -> liftM ((,) np2) (unsafeRead pos2 tag)
          case (p1,p2) of
            (-1,-1) -> next preTag x1 np1' x2 np2'
            (_ ,-1) -> return GT
            (-1, _) -> return LT
            _ -> let answer = compare p1 p2
                 in if answer == EQ then next preTag x1 np1' x2 np2'
                                    else return answer

        -- challenge_pos takes the current winner and a challenger, each with instructions.
        -- But the orbits are already modified.
        challenge_Min tag next preTag x1@(_state1,pos1,_) np1 x2@(_state2,pos2,_) np2 = do
          (np1',p1) <- case np1 of
                         ((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)
                         _ -> liftM ((,) np1) (unsafeRead pos1 tag)
          (np2',p2) <- case np2 of
                         ((t,p):rest) | t==tag -> return (rest,if p then succ preTag else preTag)
                         _ -> liftM ((,) np2) (unsafeRead pos2 tag)
          case (p1,p2) of
            (-1,-1) -> next preTag x1 np1' x2 np2'
            (_ ,-1) -> return LT
            (-1, _) -> return GT
            _ -> let answer = compare p2 p1
                 in if answer == EQ then next preTag x1 np1' x2 np2'
                                    else return answer

compareWith :: (Ord x,Monoid a) => (Maybe (x,b) -> Maybe (x,c) -> a) -> [(x,b)] -> [(x,c)] -> a
compareWith comp = cw where
  cw [] [] = comp Nothing Nothing
  cw xx@(x:xs) yy@(y:ys) =
    case compare (fst x) (fst y) of
      GT -> comp Nothing  (Just y) `mappend` cw xx ys
      EQ -> comp (Just x) (Just y) `mappend` cw xs ys
      LT -> comp (Just x) Nothing  `mappend` cw xs yy
  cw xx [] = foldr (\x rest -> comp (Just x) Nothing  `mappend` rest) mempty xx
  cw [] yy = foldr (\y rest -> comp Nothing  (Just y) `mappend` rest) mempty yy

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

modifyPos :: Bool -> Tag -> CompileInstructions ()
modifyPos todo tag = do
  (a,b,c) <- get
  let a' = IMap.insert tag todo a
      b' = IMap.insert tag True b
  put (a',b',c)

setPreTag :: Tag -> CompileInstructions ()
setPreTag = modifyPos False

setPostTag :: Tag -> CompileInstructions ()
setPostTag = modifyPos True

resetTag :: Tag -> CompileInstructions ()
resetTag tag = do
  (a,b,c) <- get
  let b' = IMap.insert tag False b
  put (a,b',c)

modifyOrbit :: (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()
modifyOrbit f = do
  (a,b,c) <- get
  let c' = f c
  put (a,b,c')

modifyFlagOrbit :: Tag -> Bool -> (IntMap AlterOrbit -> IntMap AlterOrbit) -> CompileInstructions ()
modifyFlagOrbit tag flag f = do
  (a,b,c) <- get
  let b' = IMap.insert tag flag b
      c' = f c
  put (a,b',c')

resetOrbit :: Tag -> CompileInstructions ()
resetOrbit tag = modifyFlagOrbit tag False (IMap.insert tag AlterReset)

leaveOrbit :: Tag -> CompileInstructions ()
leaveOrbit tag = modifyOrbit escapeOrbit where
  escapeOrbit = IMap.insertWith setInOrbitFalse tag AlterLeave where
    setInOrbitFalse _ x@(AlterModify {}) = x {newInOrbit = False}
    setInOrbitFalse _ x = x

enterOrbit :: Tag -> CompileInstructions ()
enterOrbit tag = modifyFlagOrbit tag True changeOrbit where
  changeOrbit = IMap.insertWith overwriteOrbit tag appendNewOrbit

  appendNewOrbit = AlterModify {newInOrbit = True, freshOrbit = False} -- try to append
  startNewOrbit  = AlterModify {newInOrbit = True, freshOrbit = True}   -- will start a new series

  overwriteOrbit _ AlterReset = startNewOrbit
  overwriteOrbit _ AlterLeave = startNewOrbit
  overwriteOrbit _ (AlterModify {newInOrbit = False}) = startNewOrbit
  overwriteOrbit _ (AlterModify {newInOrbit = True}) =
    err $ "enterOrbit: Cannot enterOrbit twice in a row: " ++ show tag

alterOrbits :: [(Tag,AlterOrbit)] -> (Position -> OrbitTransformer)
alterOrbits x = let items = map alterOrbit x
                in (\pos m -> foldl (flip ($)) m (map ($ pos) items))

alterOrbit :: (Tag,AlterOrbit) -> (Position -> OrbitTransformer)
alterOrbit (tag,AlterModify {newInOrbit = inOrbit',freshOrbit = True}) =
  (\_ m -> IMap.insert tag (Orbits {inOrbit = inOrbit', getOrbits = mempty}) m)
alterOrbit (tag,AlterModify {newInOrbit = inOrbit',freshOrbit = False}) =
  (\pos m -> IMap.insertWithKey (updateOrbit pos) tag newOrbit m) where
  newOrbit = Orbits {inOrbit = inOrbit', getOrbits = mempty}
  updateOrbit pos _tag new old =
    let answer = case old of
                   Orbits True prev -> Orbits {inOrbit = inOrbit', getOrbits = prev |> pos }
                   Orbits False _   -> new
    in answer
alterOrbit (tag,AlterReset) = (\_ m -> IMap.delete tag m)
alterOrbit (tag,AlterLeave) = (\_ m -> 
    let old = IMap.lookup tag m
        answer = case old of
                   Nothing -> m
                   Just x -> IMap.insert tag (escapeOrbit x) m
    in answer)
  where escapeOrbit x = x {inOrbit = False}

assemble :: TagList -> CompileInstructions ()
assemble spec = sequence_ . map helper $ spec where
  helper (tag,command) =
    case command of
      PreUpdate TagTask -> setPreTag tag
      PreUpdate ResetGroupStopTask -> resetTag tag
      PreUpdate ResetOrbitTask -> resetOrbit tag
      PreUpdate EnterOrbitTask -> enterOrbit tag
      PreUpdate LeaveOrbitTask -> leaveOrbit tag
      PostUpdate TagTask -> setPostTag tag
      PostUpdate ResetGroupStopTask -> resetTag tag
      _ -> err ("assemble : Weird orbit command: "++show (tag,spec))

toInstructions :: TagList -> Instructions
toInstructions spec =
  let todo = assemble spec
      initalState = (mempty,mempty,mempty)
      (a,b,c) = execState todo initalState
  in Instructions {newPos = IMap.toList a
                  ,newFlags = IMap.toList b
                  ,newOrbits = if IMap.null c then Nothing else Just $ alterOrbits (IMap.toList c)}

tagsToGroupsST :: forall s. Array GroupIndex [GroupInfo] -> WScratch s -> ST s MatchArray
tagsToGroupsST aGroups (WScratch {w_pos=pRef,w_flag=fRef})= do
  let b_max = snd (bounds (aGroups))
  ma <- newArray (0,b_max) (-1,0) :: ST s (STArray s Int (MatchOffset,MatchLength))
  p <- readSTRef pRef
  f <- readSTRef fRef
  startPos0 <- unsafeRead p 0
  stopPos0 <- unsafeRead p 1
  unsafeWrite ma 0 (startPos0,stopPos0-startPos0)
  let act _this_index [] = return ()
      act this_index ((GroupInfo _ parent start stop):gs) = do
        flagVal <- unsafeRead f stop
        if not flagVal then act this_index gs
          else do
        startPos <- unsafeRead p start
        stopPos <- unsafeRead p stop
        (startParent,lengthParent) <- unsafeRead ma parent
        let ok = (0 <= startParent &&
                  0 <= lengthParent &&
                  startParent <= startPos &&
                  stopPos <= startPos + lengthParent)
        if not ok then act this_index gs
          else unsafeWrite ma this_index (startPos,stopPos-startPos)
  forM_ (range (1,b_max)) $ (\i -> act i (aGroups!i))
  unsafeFreeze ma

#ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe "memcpy"
    memcpy :: MutableByteArray# RealWorld -> MutableByteArray# RealWorld -> Int# -> IO ()

-- This has been updated for ghc 6.8.3
{-# INLINE copySTU #-}
copySTU :: (Show i,Ix i,MArray (STUArray s) e (ST s)) => STUArray s i e -> STUArray s i e -> ST s ()
copySTU (STUArray _ _ _ msource) (STUArray _ _ _ mdest) =
-- do b1 <- getBounds s1
--  b2 <- getBounds s2
--  when (b1/=b2) (error ("\n\nWTF copySTU: "++show (b1,b2)))
  ST $ \s1# ->
    case sizeofMutableByteArray# msource        of { n# ->
    case unsafeCoerce# memcpy mdest msource n# s1# of { (# s2#, () #) ->
    (# s2#, () #) }}

#else /* !__GLASGOW_HASKELL__ */

copySTU :: (MArray (STUArray s) e (ST s))=> STUArray s Tag e -> STUArray s Tag e -> ST s ()
copySTU source destination = do
  b@(start,stop) <- getBounds source
  b' <- getBounds destination
  -- traceCopy ("> copySTArray "++show b) $ do
  when (b/=b') (fail $ "Text.Regex.TDFA.RunMutState copySTUArray bounds mismatch"++show (b,b'))
  forM_ (range b) $ \index ->
    unsafeRead source index >>= unsafeWrite destination index
#endif /* !__GLASGOW_HASKELL__ */