metabrush/src/metabrushes/MetaBrush/Document/History.hs

module MetaBrush.Document.History
  ( DocumentHistory(..)
  , back, fwd, newHistory, newFutureStep
  , atStart, atEnd
  , affirmPresentSaved
  )
  where

-- base
import GHC.Generics
  ( Generic )

-- containers
import Data.Sequence
  ( Seq(..) )
import qualified Data.Sequence as Seq
  ( length, drop )

-- deepseq
import Control.DeepSeq
  ( NFData(..), deepseq )

-- generic-lens
import Data.Generics.Product.Fields
  ( field' )

-- lens
import Control.Lens
  ( set )
import Control.Lens.Tuple
  ( _1, _2 )

-- MetaBrush
import MetaBrush.Document
  ( Document(..), DocumentContent(..) )
import MetaBrush.Document.Diff
  ( HistoryDiff )

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

data DocumentHistory
  = History
  { past    :: !( Seq ( DocumentContent, HistoryDiff ) )
  , present :: !Document
  , future  :: ![ ( HistoryDiff, DocumentContent ) ]
  }
  deriving stock ( Show, Generic )
instance NFData DocumentHistory where
  rnf ( History { past = ps, present, future } ) =
    ps `deepseq` present `deepseq` future `deepseq` ()

back :: DocumentHistory -> DocumentHistory
back hist@( History { past = ps, present = c, future = fs } ) = case ps of
  Empty
    -> hist
  qs :|> ( q, diff )
    -> History { past = qs
               , present = c { documentContent = q }
               , future = ( diff, documentContent c ) : fs }

fwd :: DocumentHistory -> DocumentHistory
fwd hist@( History { past = ps, present = c, future = fs } ) = case fs of
  []
    -> hist
  ( diff, g ) : gs
    -> History { past = ps :|> ( documentContent c, diff )
               , present = c { documentContent = g }
               , future = gs }

newHistory :: Document -> DocumentHistory
newHistory a = History { past = Empty, present = a, future = [] }

newFutureStep :: Int -> HistoryDiff -> Document -> DocumentHistory -> DocumentHistory
newFutureStep maxPastDocs diff a ( History { past = ps, present = c } ) =
  History
    { past    = Seq.drop ( n - maxPastDocs ) ( ps :|> ( documentContent c, diff ) )
    , present = a
    , future  = []
    }
    where
      n :: Int
      n = 1 + Seq.length ps



atStart, atEnd :: DocumentHistory -> Bool
atStart hist = null ( past   hist )
atEnd   hist = null ( future hist )

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

affirmPresentSaved :: DocumentHistory -> DocumentHistory
affirmPresentSaved
  = set ( field' @"past"    . traverse                  . _1 . field' @"unsavedChanges" )
      True
  . set ( field' @"present" . field' @"documentContent" .      field' @"unsavedChanges" )
      False
  . set ( field' @"future"  . traverse                  . _2 . field' @"unsavedChanges" )
      True