module Text.Preprocess.Rewrites where

import Data.Function
import Text.Parsec
import Text.Parsec.Pos
import Text.Parsec.PosOps
import Text.Parsec.ExtraCombinators
import Text.Preprocess.Helpers

-- | Invariant: there are no overlapping rewrites
data RewriteSet = RewriteSet { rewriteSetElems :: [Rewrite] }
                    deriving Show

emptyRewSet :: RewriteSet
emptyRewSet = RewriteSet []

-- | Representation of a rewrite event
data Rewrite = Rewrite { fromPos :: SourcePos
                       , fromStr :: String
                       , toPos :: SourcePos
                       , toStr :: String
                       , rewritesInside :: RewriteSet
                       , source :: RewriteTrigger 
                       } 

-- | The cause of the rewrite
data RewriteTrigger = CommentRemoval | EquRewrite | EquDefinition 
                    | MacroRewrite | MacroDefinition | IfDefTriggered | IncludeTriggered 
                      deriving Show                       
   
-- | Creates a new rewrite   
createRewrite :: SourcePos -> String -> SourcePos -> String -> RewriteTrigger -> Rewrite
createRewrite origPos origStr toPos toStr trig 
  = Rewrite origPos origStr toPos toStr emptyRewSet trig
  
-- | Adds a rewrite to the rewrite set while keeping the invariant of the rewrite set
addRewrite :: Rewrite -> RewriteSet -> RewriteSet
addRewrite rew (RewriteSet others)
  = if toStr rew == fromStr rew then RewriteSet others else 
      case updateWhere insertIfContains others of
        Just rews -> RewriteSet rews
        Nothing -> RewriteSet (rew : others)
      where insertIfContains r 
              = if rew `rewInside` r then Just (r { rewritesInside = addRewrite rew (rewritesInside r) }) 
                                     else Nothing
  
-- | Checks if a rewrite happened inside another rewrite
rewInside :: Rewrite -> Rewrite -> Bool
rewInside = rangeInside `on` toRange
  
-- | Simplifies a nested rewrite
flattenRew :: Rewrite -> Rewrite
flattenRew rew 
  = let inners = (rewritesInside rew) `rewSetRelativelyTo` (fromPos rew) 
     in rew { toStr = foldl (\str irew -> apply irew str) (toStr rew) (rewriteSetElems inners)
            , toPos = correctPos inners (toPos rew)
            , rewritesInside = emptyRewSet }
  
    
-- | Gets the range where the rewrite happened in the original file
fromRange :: Rewrite -> SourceRange
fromRange rew@(Rewrite {fromPos = fromPos}) = SourceRange fromPos (fromEnd rew)

fromEnd :: Rewrite -> SourcePos
fromEnd (Rewrite {fromPos = fromPos, fromStr = fromStr}) = updatePosString fromPos fromStr

-- | Gets the range where the rewrite results was inserted in the preprocessed file
toRange :: Rewrite -> SourceRange
toRange rew@(Rewrite { toPos = toPos }) = SourceRange toPos (toEnd rew)

-- | Gets the end position of the code generated by the rewrite
toEnd :: Rewrite -> SourcePos
toEnd (Rewrite {toPos = toPos, toStr = toStr}) = updatePosString toPos toStr
   
-- | Do a rewrite
apply :: Rewrite -> String -> String
apply rw@(Rewrite fromPos fromStr toPos toStr inner _) s 
  = doRewrite fromPos fromStr toStr "" (initialPos (sourceName fromPos)) s 

-- | Undo a rewrite
takeBack :: Rewrite -> String -> String
takeBack rw@(Rewrite fromPos fromStr toPos toStr inner _) s 
  = doRewrite toPos toStr fromStr "" (initialPos (sourceName fromPos)) s

-- performs a rewrite, back or forth
doRewrite fromPos fromStr toStr pre pos s 
  | fromPos == pos
  = let (pref,suf) = splitAt (length fromStr) s 
     in if pref == fromStr then reverse pre ++ toStr ++ suf
                           else error $ "doRewrite : not found the source str in position. Expected : " ++ fromStr ++ ", found: " ++ pref ++ ", in: " ++ s
doRewrite fromPos fromStr toStr pre pos (head : tail)       
  = doRewrite fromPos fromStr toStr (head : pre) (updatePosChar pos head) tail
doRewrite fromPos fromStr toStr pre pos [] 
  = error ("doRewrite : input had run out before position " ++ show fromPos ++ " found, while trying to do the substitution '" ++ fromStr ++ "' --> '" ++ toStr ++ "', after parsing " ++ pre)
                       

-- | Gets the original form of a parsed entry, before it was preprocessed
-- rewrites that happened on the beginning or end of the element are not taken back.
originalForm :: Monad m => RewriteSet -> ParsecT String u m a -> ParsecT String u m (a,String)
originalForm (RewriteSet rews) p 
  = do pos0 <- getPosition
       (res,procSrc) <- captureInputStr p
       pos1 <- getPosition
       let procRng = SourceRange pos0 pos1
       return $ (res, takeBackAll procSrc procRng pos0)
  where takeBackAll str rng pos0
          = foldl (flip takeBack) str (map (`rewRelativelyTo` pos0) (filterInside rews))
          where filterInside = filter ((`rangeInside` rng) . toRange)
          
correctRange :: RewriteSet -> SourceRange -> SourceRange
correctRange rews = rangeMapBoth (correctPos rews)
          
       
-- | Gets the corresponding position in the original file. 
-- If the position is inside a source range that is produced by a rewrite, the start position of the rewrite is returned.
correctPos :: RewriteSet -> SourcePos -> SourcePos
correctPos (RewriteSet rews) sp = case findEffectiveRew rews Nothing of
          Right Nothing -> sp                      -- no rewrites before
          Right (Just rew) -> correctByRew rew sp  -- correct by last rewrite
          Left rew -> fromPos rew                  -- position is generated from rewrite
  where findEffectiveRew :: [Rewrite] -> Maybe Rewrite -> Either Rewrite (Maybe Rewrite)
        findEffectiveRew [] precRew = Right precRew
        findEffectiveRew (rew:rews) precRew 
          = if toPos rew <= sp && toEnd rew <= sp 
                && (case precRew of Nothing -> True; Just prec -> toEnd prec < toEnd rew) then
              findEffectiveRew rews (Just rew) 
            else if toPos rew <= sp && toEnd rew > sp then
              Left rew
            else findEffectiveRew rews precRew

-- | Transforms a position by a rewrite
correctByRew :: Rewrite -> SourcePos -> SourcePos
correctByRew rew sp = let flatRew = flattenRew rew
                       in fromEnd flatRew `offsetedBy` (sp `relativelyTo` toEnd flatRew)
          
-- | Substracts the given position from the bounds of the rewrite
rewRelativelyTo :: Rewrite -> SourcePos -> Rewrite
(Rewrite fromPos fromStr toPos toStr inner trig) `rewRelativelyTo` sp 
  = Rewrite (fromPos `relativelyTo` sp) fromStr (toPos `relativelyTo` sp) 
            toStr (inner `rewSetRelativelyTo` sp) trig
      
-- | Substracts the given position from the bounds of all rewrites in a rewrite set.
rewSetRelativelyTo :: RewriteSet -> SourcePos -> RewriteSet
rewSetRelativelyTo (RewriteSet rews) sp = RewriteSet $ map (`rewRelativelyTo` sp) rews
      
instance Show Rewrite where
  show (Rewrite fromPos fromStr toPos toStr inner trig) 
    = show fromPos ++ " '" ++ fromStr ++ "' --> " ++ show toPos ++ " '" ++ toStr ++ "' (by " ++ show trig ++ ")" ++ show inner