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

{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DeriveGeneric        #-}
{-# LANGUAGE DerivingVia          #-}
{-# LANGUAGE MonoLocalBinds       #-}
{-# LANGUAGE NamedFieldPuns       #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE UndecidableInstances #-}

module MetaBrush.Document.History
  ( DocumentHistory(..)
  , back, fwd, newHistory, newFutureStep
  , atStart, atEnd
  , affirmPresent
  )
  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 )

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

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

data DocumentHistory
  = History
  { past    :: !( Seq DocumentContent )
  , present :: !Document
  , future  :: ![ 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 -> History { past = qs, present = c { documentContent = q }, future = documentContent c : fs }

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

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

newFutureStep :: Int -> Document -> DocumentHistory -> DocumentHistory
newFutureStep maxPastDocs a ( History { past = ps, present = c } ) =
  History
    { past    = Seq.drop ( n - maxPastDocs ) ( ps :|> documentContent c )
    , 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 )

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

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