Patch.hs

module Descript.Misc.Build.Write.Print.Patch
  ( Change
  , CChange
  , Patch (..)
  , CPatch (..)
  , replacePatch
  , mkCPatch
  , liftCPatch
  , apPatch
  , alignRange
  , isInsertPatch
  ) where

import Descript.Misc.Loc
import Data.Monoid
import Core.Data.Group
import Data.List hiding ((\\))
import Data.Text (Text)
import qualified Data.Text as Text

-- | Completely replaces or patches text.
type Change = Either Text Patch

-- | Completely replaces or patches text.
type CChange = Either Text CPatch

-- | Replaces parts of text inside a bigger block.
data Patch
  = Patch
  { cpatches :: [CPatch] -- ^ Continuous blocks which are replaced. Assumed to be in order.
  , patchOffset :: LocDiff -- ^ The change in size after the patch is applied.
  } deriving (Eq, Ord, Read, Show)

-- | Replaces a continuous block of text inside a bigger block.
data CPatch
  = CPatch
  { cpatchRange :: Range
  , cpatchText :: Text
  } deriving (Eq, Ord, Read, Show)

-- | Assumes when 2 patches are appended, the later patch's range is
-- after the earlier patch's range.
instance Monoid Patch where
  mempty
    = Patch
    { cpatches = []
    , patchOffset = mempty
    }

  -- | Assumes the later patch's range is after the earlier patch's range.
  Patch xCPatches xPatchOffset `mappend` Patch yCPatches yPatchOffset
    = Patch
    { cpatches = xCPatches ++ yCPatches'
    , patchOffset = xPatchOffset <> yPatchOffset
    }
    where yCPatches' = map (offsetCPatch xPatchOffset) yCPatches

-- | Creates a patch which replaces the first text with the second.
replacePatch :: Text -> Text -> Patch
replacePatch = mkCPatch . textRange

-- | Creates a continuous 'Patch', spanning the given range with the
-- given text.
mkCPatch :: Range -> Text -> Patch
mkCPatch range = liftCPatch . CPatch range

liftCPatch :: CPatch -> Patch
liftCPatch cpatch
  | isCPatchEmpty cpatch = mempty
  | otherwise
  = Patch
  { cpatches = [cpatch]
  , patchOffset = cpatchOffset cpatch
  }

isCPatchEmpty :: CPatch -> Bool
isCPatchEmpty (CPatch range text) = isSingletonRange range && Text.null text

cpatchOffset :: CPatch -> LocDiff
cpatchOffset (CPatch range text)
  = textDiff (line $ start range) text \\ rangeDiff range

offsetCPatch :: LocDiff -> CPatch -> CPatch
offsetCPatch diff (CPatch range text)
  = CPatch (offsetRange diff range) text

-- | Applies the patch to the text - replaces all patched ranges.
apPatch :: Patch -> Text -> Text
apPatch patch text = foldl' (flip apCPatch) text $ cpatches patch

apCPatch :: CPatch -> Text -> Text
apCPatch (CPatch range patch) orig
   = start range `beforeInText` orig
  <> patch
  <> end range `afterInText` orig

-- | Adjusts the range in text before the patch so it contains the same
-- content (except if deleted) in text after the patch.
alignRange :: Patch -> Range -> Range
alignRange = alignRangeCs . cpatches

alignRangeCs :: [CPatch] -> Range -> Range
alignRangeCs = flip $ foldl' $ flip alignRangeC

-- | Adjusts the range in text before the patch so it contains the same
-- content (except if deleted) in text after the patch.
alignRangeC :: CPatch -> Range -> Range
alignRangeC (CPatch (Range pStart pEnd) content) (Range xStart xEnd)
  | pEnd <= xStart
  = Range
  { start = xStart `addDiff` coff
  , end = xEnd `addDiff` coff
  }
  | pStart >= xEnd
  = Range
  { start = xStart
  , end = xEnd
  }
  | pStart <= xStart && pEnd < xEnd
  = Range
  { start = pEnd `addDiff` coff
  , end = xEnd `addDiff` coff
  }
  | pStart <= xStart && pEnd >= xEnd -- Patch completely replaces range
  = Range -- Both could be `pStart or `offsetRange coff pEnd`, must be same
  { start = pStart
  , end = pStart
  }
  | pStart > xStart && pEnd < xEnd
  = Range
  { start = xStart
  , end = xEnd `addDiff` coff
  }
  | pStart > xStart && pEnd >= xEnd
  = Range
  { start = xStart
  , end = pEnd `addDiff` coff
  }
  | otherwise
  = error "unexpected \"impossible\" location comparison"
  where coff = textDiff (line pStart) content

-- | Whether the patch only inserts text, doesn't remove any.
isInsertPatch :: Patch -> Bool
isInsertPatch = all isInsertCPatch . cpatches

-- | Whether the patch only inserts text, doesn't remove any.
isInsertCPatch :: CPatch -> Bool
isInsertCPatch (CPatch range _) = isSingletonRange range