OwlLayers.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- TODO move to Potato.Flow.Controller
module Potato.Flow.Controller.OwlLayers where

import           Relude

import           Potato.Flow.Controller.Types
import           Potato.Flow.Types
import Potato.Flow.Serialization.Snake
import           Potato.Flow.OwlItem
import Potato.Flow.Owl
import Potato.Flow.OwlState
import Potato.Flow.DebugHelpers

import           Control.Lens                 (over, _2)
import Data.Foldable (foldl)
import           Data.Default
import qualified Data.IntMap                  as IM
import qualified Data.IntSet as IS
import           Data.Sequence                ((><), (|>))
import qualified Data.Sequence                as Seq
import qualified Data.Text as T
import qualified Text.Show

data LockHiddenState = LHS_True | LHS_False | LHS_True_InheritTrue | LHS_False_InheritTrue deriving (Eq, Show)

lockHiddenStateToBool :: LockHiddenState -> Bool
lockHiddenStateToBool = \case
  LHS_False -> False
  _ -> True

toggleLockHiddenState :: LockHiddenState -> LockHiddenState
toggleLockHiddenState = \case
  LHS_True -> LHS_False
  LHS_False -> LHS_True
  LHS_True_InheritTrue -> LHS_False_InheritTrue
  LHS_False_InheritTrue -> LHS_True_InheritTrue

setLockHiddenStateInChildren :: LockHiddenState -> Bool -> LockHiddenState
setLockHiddenStateInChildren parentstate = \case
  False -> case parentstate of
    LHS_False -> LHS_False
    _         -> LHS_False_InheritTrue
  True -> case parentstate of
    LHS_False -> LHS_True
    _         -> LHS_True_InheritTrue

-- ancestor state got set, update the child
updateLockHiddenStateInChildren :: LockHiddenState -> LockHiddenState -> LockHiddenState
updateLockHiddenStateInChildren parentstate = \case
  LHS_False -> case parentstate of
    LHS_True  -> LHS_False_InheritTrue
    LHS_False -> LHS_False
    _         -> invalid
  LHS_True -> case parentstate of
    LHS_True  -> LHS_True_InheritTrue
    LHS_False -> LHS_True
    _         -> invalid
  LHS_True_InheritTrue -> case parentstate of
    LHS_False -> LHS_True
    LHS_True  -> LHS_True_InheritTrue
    _         -> invalid
  LHS_False_InheritTrue -> case parentstate of
    LHS_False -> LHS_False
    LHS_True  -> LHS_False_InheritTrue
    _         -> invalid
  where
    invalid = error "toggling of LHS_XXX_InheritTrue elements disallowed"

-- TODO be careful with hidden cost of Eq SuperOwl
-- this stores info just for what is displayed, Seq LayerEntry is uniquely generated from LayerMetaMap and PFState
data LayerEntry = LayerEntry {
  _layerEntry_lockState      :: LockHiddenState
  , _layerEntry_hideState      :: LockHiddenState
  , _layerEntry_isCollapsed    :: Bool -- this parameter is ignored if not a folder, Maybe Bool instead?
  , _layerEntry_superOwl :: SuperOwl
} deriving (Eq)

instance Show LayerEntry where
  show LayerEntry {..} = "LayerEntry (lhc: "
    <> show _layerEntry_lockState
    <> "," <> show _layerEntry_hideState
    <> "," <> show _layerEntry_isCollapsed
    <> "):\n" <> (T.unpack $ potatoShow _layerEntry_superOwl)

layerEntry_depth :: LayerEntry -> Int
layerEntry_depth LayerEntry {..} = _owlItemMeta_depth . _superOwl_meta $ _layerEntry_superOwl

layerEntry_display :: LayerEntry -> Text
layerEntry_display LayerEntry {..} = hasOwlItem_name _layerEntry_superOwl

layerEntry_isFolder :: LayerEntry -> Bool
layerEntry_isFolder LayerEntry {..} = mommyOwl_hasKiddos _layerEntry_superOwl

layerEntry_rEltId :: LayerEntry -> REltId
layerEntry_rEltId LayerEntry {..} = _superOwl_id _layerEntry_superOwl

-- index type into Seq LayerEntry
type LayerEntryPos = Int
type LayerEntries = Seq LayerEntry

layerEntriesToPrettyText :: LayerEntries -> Text
layerEntriesToPrettyText lentries = foldr foldrfn "" lentries where
  foldrfn le@LayerEntry {..} acc = r where
    collapseText = if layerEntry_isFolder le
      then if _layerEntry_isCollapsed
        then ">"
        else "v"
      else " "
    hideText = case _layerEntry_hideState of
      LHS_True              -> "▓"
      LHS_False             -> " "
      LHS_True_InheritTrue  -> "▓"
      LHS_False_InheritTrue -> "▒"
    lockText = case _layerEntry_lockState of
      LHS_True              -> "▓"
      LHS_False             -> " "
      LHS_True_InheritTrue  -> "▓"
      LHS_False_InheritTrue -> "▒"
    sowl = _layerEntry_superOwl
    r = T.replicate (layerEntry_depth le) " " <> collapseText <> hideText <> lockText <> " " <> hasOwlItem_name sowl <> "\n" <> acc

data LayersState = LayersState {
    -- mapping from REltId to element meta data
    _layersState_meta :: LayerMetaMap
    -- sequence of visible folders
    , _layersState_entries :: LayerEntries
    , _layersState_scrollPos :: Int
  } deriving (Show, Eq)

instance PotatoShow LayersState where
  potatoShow LayersState{..} = r where
    r = "LayersState: "
      <> show _layersState_meta
      <> "\nLayerEntries:\n"
      <> layerEntriesToPrettyText _layersState_entries

--instance Show LayersState where
--  show ls = T.unpack (potatoShow ls)


data LockHideCollapseOp = LHCO_ToggleLock | LHCO_ToggleHide | LHCO_ToggleCollapse deriving (Show)

alterWithDefault :: (Eq a, Default a) => (a -> a) -> REltId -> REltIdMap a -> REltIdMap a
alterWithDefault f k m = IM.alter f' k m where
  apply x = if fx == def then Nothing else Just fx where
    fx = f x
  f' = \case
    Nothing -> apply def
    Just x -> apply x

lookupWithDefault :: (Default a) => REltId -> REltIdMap a -> a
lookupWithDefault rid ridm = case IM.lookup rid ridm of
  Nothing -> def
  Just x  -> x





-- TODO test
-- | assumes LayersState is after hide state of given lepos has just been toggled
changesFromToggleHide :: OwlPFState -> LayersState -> LayerEntryPos -> SuperOwlChanges
changesFromToggleHide OwlPFState {..} LayersState {..} lepos = r where
  le = Seq.index _layersState_entries lepos
  sowl = _layerEntry_superOwl le
  lerid = _superOwl_id sowl
  lm = lookupWithDefault lerid _layersState_meta
  isHidden = _layerMeta_isHidden lm

  -- find all children that weren't already hidden
  children = owliteratechildrenat _owlPFState_owlTree lerid
  isunhidden sowl' = not . _layerMeta_isHidden $ lookupWithDefault (_superOwl_id sowl') _layersState_meta
  unhiddenChildren = toList . fmap (\sowl' -> (_superOwl_id sowl', sowl')) $ Seq.filter isunhidden children

  r = if isHidden
    then IM.fromList $ (lerid, Nothing) : (fmap (over _2 (const Nothing)) unhiddenChildren)
    else IM.fromList $ (lerid,Just sowl) : (fmap (over _2 Just) unhiddenChildren)

-- iterates over LayerEntryPos, skipping all children of entries where skipfn evaluates to true
doChildrenRecursive :: (LayerEntry -> Bool) -> (LayerEntry -> LayerEntry) -> Seq LayerEntry -> Seq LayerEntry
doChildrenRecursive skipfn entryfn = snd . mapAccumL mapaccumlfn maxBound where
  mapaccumlfn skipdepth le = (newskipdepth, newle) where
    depth = layerEntry_depth le
    newskipdepth
      -- skip, so keep skipping
      | depth >= skipdepth = skipdepth
      -- skip all children
      -- note, no need to check for collapsed state because we are iterating over LayerEntry which do not include children of collapsed entries
      | skipfn le = depth + 1
      -- either we exited a skipped folder or aren't skipping, reset skip counter (since we skip subfolders of skipped entries, maximal skip stack depth is 1 so reset is OK)
      | otherwise = maxBound
    newle = if depth >= skipdepth
      then le -- no changes to skipped elts
      else entryfn le


toggleLayerEntry :: OwlPFState -> LayersState -> LayerEntryPos -> LockHideCollapseOp -> LayersState
toggleLayerEntry OwlPFState {..} LayersState {..} lepos op = r where
  le = Seq.index _layersState_entries lepos
  lerid = layerEntry_rEltId le
  ledepth = layerEntry_depth le
  childFrom nextLayerEntry = layerEntry_depth nextLayerEntry > ledepth
  -- visible children of le
  childles = Seq.takeWhileL childFrom . Seq.drop (lepos+1) $ _layersState_entries
  -- everything before le
  frontOfLe = Seq.take lepos _layersState_entries
  -- everything after childles
  backOfChildles = Seq.drop (lepos + 1 + Seq.length childles) _layersState_entries

  -- simple helper function for setting lock/hidden state
  togglefn fn setlmfn setlefn = (LayersState newlmm newlentries 0) where
    newlhsstate = toggleLockHiddenState $ fn le
    newlmm = alterWithDefault (\lm' -> setlmfn lm' (lockHiddenStateToBool newlhsstate)) lerid _layersState_meta
    entryfn childle = setlefn childle $ updateLockHiddenStateInChildren newlhsstate (fn childle)
    newchildles = doChildrenRecursive (lockHiddenStateToBool . fn) entryfn childles
    newle = setlefn le newlhsstate
    newlentries = (frontOfLe |> newle) >< newchildles >< backOfChildles

  r = case op of
    LHCO_ToggleCollapse -> (LayersState newlmm newlentries 0) where
      newcollapse = not $ _layerEntry_isCollapsed le
      newlmm = alterWithDefault (\le' -> le' { _layerMeta_isCollapsed = newcollapse }) lerid _layersState_meta
      newle = le { _layerEntry_isCollapsed = newcollapse }
      newchildles = buildLayerEntriesRecursive _owlPFState_owlTree _layersState_meta Seq.empty (Just newle)
      newlentries = if newcollapse
        then (frontOfLe |> newle) >< backOfChildles
        else (frontOfLe |> newle) >< newchildles >< backOfChildles

    LHCO_ToggleLock -> togglefn _layerEntry_lockState (\lm' x -> lm' { _layerMeta_isLocked = x }) (\le' x -> le' { _layerEntry_lockState = x })
    LHCO_ToggleHide -> togglefn _layerEntry_hideState (\lm' x -> lm' { _layerMeta_isHidden = x }) (\le' x -> le' { _layerEntry_hideState = x })

expandAllCollapsedParents :: Selection -> OwlPFState -> LayersState -> LayersState
expandAllCollapsedParents selection pfs ls = r where
  ops = owlParliamentSet_findParents (hasOwlTree_owlTree pfs) . superOwlParliament_toOwlParliamentSet $  selection
  oldlmm = _layersState_meta ls
  iscollapsedfilterfn rid = case IM.lookup rid oldlmm of
    Just lm -> _layerMeta_isCollapsed lm
    Nothing -> defaultFolderCollapseState
  collapsedParents = IS.filter iscollapsedfilterfn ops
  alterfn mlm = case mlm of
    Nothing -> Just (def { _layerMeta_isCollapsed = False })
    Just x -> Just (x { _layerMeta_isCollapsed = False })
  newlmm = IS.foldr (IM.alter alterfn) oldlmm collapsedParents
  r = if IS.null collapsedParents
    then ls
    -- can we do this more efficiently?
    else (makeLayersStateFromOwlPFState pfs newlmm) { _layersState_scrollPos = _layersState_scrollPos ls }

makeLayersStateFromOwlPFState :: OwlPFState -> LayerMetaMap -> LayersState
makeLayersStateFromOwlPFState pfs lmm = LayersState {
    _layersState_meta = lmm
    , _layersState_entries = generateLayersNew (_owlPFState_owlTree pfs) lmm
    , _layersState_scrollPos = 0
  }

updateLayers :: OwlPFState -> SuperOwlChanges -> LayersState -> LayersState
updateLayers pfs changes LayersState {..} = r where
  -- update _layersState_meta
  (deletestuff, maybenewstuff) = IM.partition isNothing changes

  maybenewstuffcollapsed = (fmap (const (def {_layerMeta_isCollapsed = True})) maybenewstuff)

  newlmm = IM.difference (IM.union _layersState_meta maybenewstuffcollapsed) deletestuff


  -- keep deleted elts so that folder state is preserved after undos/redos
  --newlmm = IM.union _layersState_meta (fmap (const def) maybenewstuff)

  -- TODO incremental rather than regenerate...
  newlentries = generateLayersNew (_owlPFState_owlTree pfs) newlmm

  r = LayersState newlmm newlentries _layersState_scrollPos

buildLayerEntriesRecursive :: OwlTree -> LayerMetaMap -> Seq LayerEntry -> Maybe LayerEntry -> Seq LayerEntry
buildLayerEntriesRecursive ot lmm acc mparent = r where
  foldlfn acclentries rid = newacclentries where
    sowl = owlTree_mustFindSuperOwl ot rid
    lm = lookupWithDefault rid lmm
    -- add self
    lentry = case mparent of
      Nothing -> LayerEntry {
        _layerEntry_lockState =  if _layerMeta_isLocked lm then LHS_True else LHS_False
        , _layerEntry_hideState = if _layerMeta_isHidden lm then LHS_True else LHS_False
        , _layerEntry_isCollapsed = _layerMeta_isCollapsed lm
        , _layerEntry_superOwl = sowl
      }
      Just parent -> LayerEntry {
        _layerEntry_lockState = setLockHiddenStateInChildren (_layerEntry_lockState parent) $ _layerMeta_isLocked lm
        , _layerEntry_hideState = setLockHiddenStateInChildren (_layerEntry_hideState parent) $ _layerMeta_isHidden lm
        , _layerEntry_isCollapsed = _layerMeta_isCollapsed lm
        , _layerEntry_superOwl = sowl
      }
    newacclentries' = acclentries |> lentry
    -- recursively add children
    newacclentries = if _layerMeta_isCollapsed lm
      then newacclentries'
      else buildLayerEntriesRecursive ot lmm newacclentries' (Just lentry)
  r = foldl foldlfn acc $ fromMaybe Seq.empty $ case mparent of
    Nothing -> mommyOwl_kiddos ot
    Just lentry -> mommyOwl_kiddos (_layerEntry_superOwl lentry)

generateLayersNew :: OwlTree -> LayerMetaMap -> Seq LayerEntry
generateLayersNew ot lmm = buildLayerEntriesRecursive ot lmm Seq.empty Nothing


layerMetaMap_isInheritHiddenOrLocked :: OwlTree -> REltId -> LayerMetaMap -> Bool
layerMetaMap_isInheritHiddenOrLocked ot rid lmm = case IM.lookup rid lmm of
  -- these may both be false, but it may inherit from a parent where these are true therefore we still need to walk up the tree if these are both false
  Just lm | _layerMeta_isLocked lm || _layerMeta_isHidden lm -> True
  _ -> case IM.lookup rid (_owlTree_mapping ot) of
    Nothing -> False
    Just (oem,_) -> layerMetaMap_isInheritHiddenOrLocked ot (_owlItemMeta_parent oem) lmm

layerMetaMap_isInheritHidden :: OwlTree -> REltId -> LayerMetaMap -> Bool
layerMetaMap_isInheritHidden ot rid lmm = case IM.lookup rid lmm of
  Just lm | _layerMeta_isHidden lm -> True
  _ -> case IM.lookup rid (_owlTree_mapping ot) of
    Nothing -> False
    Just (oem,_) -> layerMetaMap_isInheritHidden ot (_owlItemMeta_parent oem) lmm