View.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DefaultSignatures #-}

{- | SwiftUI-like view tree

The layout keeps the propose-report-place protocol, but chops some parts away.

* Views are abstracted and the 'View' constructor punches a hole in a tree (a hollow?) for a UI toolkit to fill in later.
* There's no "tree builder", so containers and modifiers are constructed directly. Although it is easy to recover modifier with the "Data.Function.(&)" operator.
* There's no "ideal size", "fixed size" etc. and the views are fully flexible. The UI tookit wrappers can instead self-wrap their Views in a 'Frame'/'FlexibleFrame' as needed.
-}

module Geomancy.Layout.View where

import Data.Bifunctor (Bifunctor(..))
import Data.Foldable (toList)
import Data.Foldable1 (foldMap1')
import Data.Functor.Identity (Identity)
import Data.List (mapAccumL, foldl', sortOn)
import Data.List.NonEmpty (nonEmpty)
import Geomancy ((^*))
import Geomancy.Gl.Funs (glClamp)
import Geomancy.Layout qualified as Layout
import Geomancy.Layout.Alignment (Alignment)
import Geomancy.Layout.Alignment qualified as Alignment
import Geomancy.Layout.Box (Box(..))
import Geomancy.Layout.Box qualified as Box
import Geomancy.Vec2 (Vec2, vec2, withVec2, pattern WithVec2)
import Geomancy.Vec4 (Vec4, withVec4)
import GHC.Arr (array)

-- | Run all the layout steps to annotate the nodes with their final placement boxes.
layout :: LayoutView stuff => Box -> View () stuff -> View Box (Placed stuff)
layout initialBox = place initialBox . measure

-- | Do all of the layout steps and fold placed views
--
-- Mostly an example. The better way is to cache intermediate steps.
--
-- (Actually a pun on "fold views".)
foldWith :: (LayoutView stuff, Monoid a) => (Placed stuff -> a) -> Box -> View () stuff -> a
foldWith f initialBox = foldMap f . place initialBox . measure

{- | An interface to plug UI toolkits into the layout.

Alternatively, convert them to `ViewFun`, which has the instance.

The "minimal: none" is a lie. Most likely you will need to adjust either 'ReportedCache ' or 'Placed' types and implement the other function accordingly.

The most gnarly code would be for "rendered text" widgets since they would be dynamically sized and have to be processed/cached on each step.
-}
class LayoutView stuff where
  -- | Measurement pre-pass
  viewFlexibility :: stuff -> ViewSize

  -- XXX: argument order is optimized for \case

  -- | Propose step: return the actual size and store intermediate data.
  proposeView :: Vec2 -> stuff -> (Vec2, ReportedCache stuff)
  type ReportedCache stuff
  type ReportedCache stuff = stuff

  -- | Placement step: get the reported size augmented with a final position, produce the result.
  placeView :: Box -> ReportedCache stuff -> Placed stuff
  type Placed stuff
  type Placed stuff = stuff

  -- | Default implementation is "the view *will* adapt to any size"
  default viewFlexibility :: stuff -> ViewSize
  viewFlexibility = const infinite_

  -- | Default implementation for "accept everything" reporting
  default proposeView :: (ReportedCache stuff ~ stuff) => Vec2 -> stuff -> (Vec2, ReportedCache stuff)
  proposeView = (,)

  -- | Default implementation for "box function" placement
  default placeView :: (ReportedCache stuff ~ (Box -> Placed stuff)) => Box -> ReportedCache stuff -> Placed stuff
  placeView placed f = f placed

-- | "Variant-lite" instance to mix widgets of different type
--
-- XXX: the foldable/traversable would skip the Lefts.
-- Use something like `foldWith` to pre-process and normalize to a common "backend" type
instance (LayoutView l, LayoutView r) => LayoutView (Either l r) where
  type ReportedCache (Either l r) = Either (ReportedCache l) (ReportedCache r)
  type Placed (Either l r) = Either (Placed l) (Placed r)
  viewFlexibility = either viewFlexibility viewFlexibility
  proposeView proposed = either (fmap Left <$> proposeView proposed) (fmap Right <$> proposeView proposed)
  placeView placed = \case
    Left x -> Left $ placeView @l placed x
    Right x -> Right $ placeView @r placed x

{- | Do-nothing pass-through instance

You'll have to peek at the @View{ann}@ of the placement tree.
-}
instance LayoutView (Identity stuff) where
  viewFlexibility = const infinite_
  proposeView = (,)
  placeView _placed = id

{- | A model type for the protocol

The fields correspond to the 3 steps:

* Measurement into ViewSize - static.
* Proposing and reporting - depends on parent size / caches size-related data.
* Placement - depends on placement ('Box' = reported size + position), can use cached data.
-}
data ViewFun stuff = ViewFun ViewSize (Vec2 -> (Vec2, Box -> stuff))
  deriving (Functor)

-- | A wrapper to construct 'ViewFun'-based views
viewFun :: ViewSize -> (Vec2 -> (Vec2, Box -> stuff)) -> View () (ViewFun stuff)
viewFun flex steps = View{ann=(), stuff=ViewFun flex steps}

-- | A wrapper to construct 'ViewFun'-based views by assuming infinite flex and no intrinsic size
boxFun :: (Box -> stuff) -> View () (ViewFun stuff)
boxFun f = viewFun infinite_ (,f)

instance LayoutView (ViewFun stuff) where
  type ReportedCache (ViewFun stuff) = Box -> stuff -- ^ Propose to resolve the outer
  type Placed (ViewFun stuff) = stuff
  viewFlexibility (ViewFun vs _) = vs
  proposeView size (ViewFun _ f) = f size
  placeView placed f = f placed

-- * View tree

{- | Layout skeleton

It is Functor-Foldable-Traversable on 'View' so you can use things like 'Control.Monad.void' to suppress payload and 'show' the intermediate structure.
-}
data View ann stuff
  = View
      { ann :: ann
      , stuff :: stuff
      } -- ^ UI-specific payload
  | Spacer
      { ann :: ann
      }

  -- "containers"
  | HStack
      { ann :: ann
        -- TODO: placement direction
        -- TODO: spacing to inject
      , children :: [View ann stuff]
      } -- ^ Place children side-by-side (LTR)
  | VStack
      { ann :: ann
        -- TODO: placement direction
        -- TODO: spacing to inject
      , children :: [View ann stuff]
      } -- ^ Place children top-to-bottom
  | ZStack
      { ann :: ann
      , children :: [View ann stuff]
      } -- ^ Place children atop of each other
  | Overlay
      { ann :: ann
      , secondary :: View ann stuff
      , primary :: View ann stuff
      } -- ^ Propose the size of the primary view to the secondary view

  -- "modifiers"
  | Frame
      { ann :: ann
      , size :: Vec2
      , align :: Alignment
      , inner :: View ann stuff
      } -- ^ Propose/report size unconditionally
  | FlexibleFrame
      { ann :: ann
      , flex :: ViewSize -- ^ Acceptable size ranges
      , align :: Alignment
      , inner :: View ann stuff
      } -- ^ Adjust measurement flex and clamp proposed/reported size
  | AspectRatio
      { ann :: ann
      , aspect :: Vec2 -- ^ Like 'Ratio Float', for example @vec2 16 9@ or @1@ (= @vec2 1 1@, i.e. square)
      , align :: Alignment
      -- TODO: fit/crop
      , inner :: View ann stuff
      } -- ^ Frame-like wrapper that fits
  | Padding
      { ann :: ann
      , trbl :: Box.TRBL
      , inner :: View ann stuff
      } -- ^ Subtracts a CSS-tyle padding (top/right/bottom/left) from parent
  | Offset
      { ann :: ann
      , xy :: Vec2
      , inner :: View ann stuff
      } -- ^ Adds offset when placing a view
  deriving (Eq, Show, Functor, Foldable, Traversable)

instance Bifunctor View where
  first f = \case
    View{..} -> View{ann = f ann, stuff}
    Spacer{..} -> Spacer{ann = f ann}
    HStack{ann, children} -> HStack{ann = f ann, children = map (first f) children}
    VStack{ann, children} -> VStack{ann = f ann, children = map (first f) children}
    ZStack{ann, children} -> ZStack{ann = f ann, children = map (first f) children}
    Overlay{ann, primary, secondary} -> Overlay{ann = f ann, primary = first f primary, secondary = first f secondary}
    Frame{..} -> Frame{ann = f ann, inner = first f inner, ..}
    FlexibleFrame{..} -> FlexibleFrame{ann = f ann, inner = first f inner, ..}
    Padding{..} -> Padding{ann = f ann, inner = first f inner, ..}
    Offset{..} -> Offset{ann = f ann, inner = first f inner, ..}
    AspectRatio{..} -> AspectRatio{ann = f ann, inner = first f inner, ..}
  second = fmap

-- ** Some shortcuts

view_ :: stuff -> View () stuff
view_ stuff = View{ann=(), ..}

spacer_ :: View () stuff
spacer_ = Spacer{ann=()}

-- *** Containers

hstack_ :: [View () stuff] -> View () stuff
hstack_ children = HStack{ann=(), ..}

vstack_ :: [View () stuff] -> View () stuff
vstack_ children = VStack{ann=(), ..}

zstack_ :: [View () stuff] -> View () stuff
zstack_ children = ZStack{ann=(), ..}

overlay_ :: View () stuff -> View () stuff -> View () stuff
overlay_ secondary primary = Overlay{ann=(), ..}

-- *** Modifiers

frame_ :: Vec2 -> View () stuff -> View () stuff
frame_ size inner = Frame{ann=(), align = Alignment.center, ..}

flexible_ :: ViewSize -> Alignment -> View () stuff -> View () stuff
flexible_ flex align inner = FlexibleFrame{ann=(), ..}

aspect_ :: Vec2 -> View () stuff -> View () stuff
aspect_ ratio inner = AspectRatio{ann=(), aspect=ratio, align=Alignment.center, ..}

padding_ :: Vec4 -> View () stuff -> View () stuff
padding_ trbl inner = Padding{ann=(), trbl=Box.TRBL trbl, ..}

offset_ :: Vec2 -> View () stuff -> View () stuff
offset_ xy inner = Offset{ann=(), ..}

-- * Flexibility helper

-- | Represents size constraints and flexibility for a layout node.
data ViewSize = ViewSize
  { minWidth, maxWidth
  , minHeight, maxHeight :: Maybe Float
  -- XXX: put ideal size here?
  } deriving (Eq, Show)

-- | Creates a ViewSize for a fixed-size view.
fixed_ :: Vec2 -> ViewSize
fixed_ size =
  withVec2 size \w h ->
    ViewSize
      { minWidth = Just w
      , maxWidth = Just w
      , minHeight = Just h
      , maxHeight = Just h
      }

-- | Creates a ViewSize for a fully flexible view.
infinite_ :: ViewSize
infinite_ = ViewSize
  { minWidth = Just 0
  , maxWidth = Just inf
  , minHeight = Just 0
  , maxHeight = Just inf
  }

range_ :: Vec2 -> Vec2 -> ViewSize
range_ a b =
  withVec2 a \aw ah ->
    withVec2 b \bw bh ->
      ViewSize
        { minWidth = Just $ min aw bw
        , maxWidth = Just $ max aw bw
        , minHeight = Just $ min ah bh
        , maxHeight = Just $ max ah bh
        }

-- | Creates a ViewSize that reports parent size
parent_ :: ViewSize
parent_ = ViewSize
  { minWidth = Nothing
  , maxWidth = Nothing
  , minHeight = Nothing
  , maxHeight = Nothing
  }

parentWidth :: ViewSize -> ViewSize
parentWidth a = a {minWidth = Nothing, maxWidth = Nothing}

parentHeight :: ViewSize -> ViewSize
parentHeight a = a {minHeight = Nothing, maxHeight = Nothing}

-- * Layout steps

-- | Measurement pre-pass
measure :: LayoutView stuff => View () stuff -> View ViewSize stuff
measure = \case
  View {stuff} -> View{ann=viewFlexibility stuff, stuff}
  Spacer{} -> Spacer{ann=infinite_}
  Frame{..} -> Frame{ann=fixed_ size, inner=measure inner, ..}
  FlexibleFrame{..} -> FlexibleFrame{ann=flex', inner=inner', ..}
    where
      inner' = measure inner
      innerFlex = inner'.ann
      flex' = ViewSize -- intersection of flexibility ranges
        { minWidth = max <$> flex.minWidth <*> innerFlex.minWidth
        , maxWidth = min <$> flex.maxWidth <*> innerFlex.maxWidth
        , minHeight = max <$> flex.minHeight <*> innerFlex.minHeight
        , maxHeight = min <$> flex.maxHeight <*> innerFlex.maxHeight
        }
  Padding{..} -> Padding{ann=expanded, inner=inner', ..}
    where
      inner' = measure inner
      innerFlex = inner'.ann
      expanded = withVec4 trbl4 \t r b l -> innerFlex
        { minWidth = (+ (l + r)) <$> innerFlex.minWidth
        , minHeight = (+ (t + b)) <$> innerFlex.minHeight
        }
      Box.TRBL trbl4 = trbl
  Offset{..} -> Offset{ann=inner'.ann, inner=inner', ..}
    where
      inner' = measure inner
  AspectRatio{..} -> AspectRatio{ann=ann', inner=inner', ..}
    where
      ann' = inner'.ann -- XXX: pass-through?
      inner' = measure inner
  HStack{children} -> HStack{ann=stackViewSize, children=measured}
    where
      measured = map measure children
      stackViewSize = foldl' (\vs -> stackViewSize' vs . ann) (fixed_ 0) measured
      stackViewSize' a b = ViewSize
        { minWidth = (+) <$> a.minWidth <*> b.minWidth -- combined horizontal flex
        , maxWidth = (+) <$> a.maxWidth <*> b.maxWidth
        , minHeight = max <$> a.minHeight <*> b.minHeight -- intersection of vertical flex
        , maxHeight = min <$> a.maxHeight <*> b.maxHeight
        }
  VStack{children} -> VStack{ann=stackViewSize, children=measured}
    where
      measured = map measure children
      stackViewSize = foldl' (\vs -> stackViewSize' vs . ann) (fixed_ 0) measured
      stackViewSize' a b = ViewSize
        { minWidth = max <$> a.minWidth <*> b.minWidth -- intersection of horizontal flex
        , maxWidth = min <$> a.maxWidth <*> b.maxWidth
        , minHeight = (+) <$> a.minHeight <*> b.minHeight --  combined vertical flex
        , maxHeight = (+) <$> a.maxHeight <*> b.maxHeight
        }
  ZStack{children} -> ZStack{ann=stackViewSize, children=measured}
    where
      measured = map measure children
      stackViewSize = foldl' (\vs -> stackViewSize' vs . ann) (fixed_ 0) measured
      stackViewSize' a b = ViewSize
        { minWidth = max <$> a.minWidth <*> b.minWidth -- intersection of horizontal flex
        , maxWidth = min <$> a.maxWidth <*> b.maxWidth
        , minHeight = max <$> a.minHeight <*> b.minHeight --  intersection of vertical flex
        , maxHeight = min <$> a.maxHeight <*> b.maxHeight
        }
  Overlay{primary, secondary} -> Overlay{ann=primary'.ann, primary=primary', secondary=secondary'}
    where
      primary' = measure primary -- pass-through wrt primary measurements
      secondary' = measure secondary -- ignore secondary flex

-- | Run the propose-report-place protocol on a flex-measured view tree
place :: LayoutView stuff => Box -> View ViewSize stuff -> View Box (Placed stuff)
place parent element = snd (suspend parent.size element) parent

-- | Propose-Report-Place protocol using continuations
--
-- Inner children can't be placed until the whole propose-report dance finishes.
suspend
  :: forall stuff
  .  LayoutView stuff
  => Vec2
  -> View ViewSize stuff
  -> (Vec2, Box -> View Box (Placed stuff))
suspend proposed = \case
  Spacer{} ->
    ( proposed -- report the proposed
    , \placed -> Spacer{ann=placed} -- keep the placed
    )
  View{stuff} ->
    ( reported -- report dynamic size
    , \placed ->
        View
          { ann = placed
          , stuff = placeView @stuff placed cache -- instantiate the placed view
          }
    )
    where
      (reported, cache) = proposeView proposed stuff
  Frame{..} ->
    ( size -- frame reports its size right away
    , \placedFrame ->
        Frame
          { ann = placedFrame -- keep the placed for itself
          , inner =
              let
                -- now that the frame has its own box, it can properly place its contents
                innerBox = Layout.placeSize align reported placedFrame
              in
                -- and resolve the continuation
                suspended innerBox
          , ..
          }
    )
    where
      (reported, suspended) = suspend size inner -- frame proposes its size
  FlexibleFrame{..} ->
    ( vsClamp proposed flex reported -- reports clamped to self, while defaulting to parent
    , \placed ->
        let
          innerBox = Layout.placeSize align reported placed
        in
          FlexibleFrame
            { ann = placed
            , inner = suspended innerBox
            , ..
            }
    )
    where
      -- proposes clamped parent
      (reported, suspended) = suspend (vsClamp proposed flex proposed) inner
  Padding{..} ->
    ( reported + pads
    , \placed ->
        let
          innerBox = Box.addPadding trbl placed
        in
        Padding
          { ann = placed
          , inner = suspended innerBox
          , ..
          }
    )
    where
      (reported, suspended) = suspend (proposed - pads) inner
      pads = withVec4 trbl4 \t r b l -> vec2 (l + r) (t + b)
      Box.TRBL trbl4 = trbl
  Offset{..} ->
    ( reported
    , \placed -> Offset
        { ann = placed
        , inner = suspended $ Box.move xy placed
        , ..
        }
    )
    where
      (reported, suspended) = suspend proposed inner
  AspectRatio{..} ->
    ( reported
    , \placed ->
        let
          innerBox = Layout.placeSize align reported placed
        in
        AspectRatio
          { ann = placed
          , inner = suspended innerBox
          , ..
          }
    )
    where
      -- 1. query direct size, ignore suspended
      probed = fst $ suspend (aspect ^* scale proposed) inner
      -- 2. re-query with the fit size
      (reported, suspended) = suspend (aspect ^* scale probed) inner
      scale p =
        withVec2 aspect \aw ah ->
          withVec2 p \pw ph ->
            if pw / ph > aw / ah then
              ph / ah
            else
              pw / aw
  HStack{children} ->
    -- Like the Frame, but operating on multiple elements
    ( foldl' combineH 0 $ map fst children' -- stack reports the combined size of its children reports
    , \placedStack ->
        let
          placedChildren :: [View Box (Placed stuff)]
          placedChildren = snd $ mapAccumL placeLeftToRight placedStack children'
            where
              placeLeftToRight :: Box -> (Vec2, Box -> View Box (Placed stuff)) -> (Box, View Box (Placed stuff))
              placeLeftToRight remaining (reportedSize, suspended) =
                ( remaining'
                , suspended placed
                )
                where
                  (slot, remaining') = withVec2 reportedSize \w _h -> Layout.cutLeft w remaining
                  placed = Layout.placeSize Alignment.center reportedSize slot
        in
          HStack
            { ann = maybe placedStack (foldMap1' ann) $ nonEmpty placedChildren
            , children = placedChildren
            }
    )
    where
      -- | Record index, sort by flexibility, process, restore order
      children' =
        toList . array (0, numChildren - 1) $
          snd $ mapAccumL f (fromIntegral numChildren, proposed) $
            sortOn (widthFlexibility . ann . snd) $ zip [0 :: Int ..] children
      numChildren = length children

      f (childrenRemaining, WithVec2 remW remH) (ix, child) =
        ( (childrenRemaining - 1.0, vec2 (remW - reportedWidth) remH)
        , ( ix
          , child'
          ) -- XXX: can use combineH here
        )
        where
          WithVec2 reportedWidth _ = fst child'
          child' = suspend (vec2 proposeWidth remH) child
          proposeWidth = remW / childrenRemaining
  VStack{children} ->
    -- Like the HStack, but advancing vertically
    ( foldl' combineV 0 $ map fst children'
    , \placedStack ->
        let
          placedChildren :: [View Box (Placed stuff)]
          placedChildren = snd $ mapAccumL placeTopToBottom placedStack children'
            where
              placeTopToBottom :: Box -> (Vec2, Box -> View Box (Placed stuff)) -> (Box, View Box (Placed stuff))
              placeTopToBottom remaining (reportedSize, suspended) =
                ( remaining'
                , suspended placed
                )
                where
                  (slot, remaining') = withVec2 reportedSize \_w h -> Layout.cutTop h remaining
                  placed = Layout.placeSize Alignment.center reportedSize slot
        in
          VStack
            { ann = maybe placedStack (foldMap1' ann) $ nonEmpty placedChildren
            , children = placedChildren
            }
    )
    where
      -- | Record index, sort by flexibility, process, restore order
      children' =
        toList . array (0, numChildren - 1) $
          snd $ mapAccumL f (fromIntegral numChildren, proposed) $
            sortOn (heightFlexibility . ann . snd) $ zip [0 :: Int ..] children
      numChildren = length children

      f (childrenRemaining, WithVec2 remW remH) (ix, child) =
        ( (childrenRemaining - 1.0, vec2 remW (remH - reportedHeight))
        , ( ix
          , child'
          ) -- XXX: can use combineH here
        )
        where
          WithVec2 _ reportedHeight = fst child'
          child' = suspend (vec2 remW proposeHeight) child
          proposeHeight = remH / childrenRemaining
  ZStack{children} ->
    ( foldl' max2 0 reporteds
    , \placedStack ->
        let
          placedChildren = map ($ placedStack) suspendeds
        in
          ZStack
            { ann = maybe placedStack (foldMap1' ann) $ nonEmpty placedChildren
            , children = placedChildren
            }
    )
    where
      (reporteds, suspendeds) = unzip $ map (suspend proposed) children
  Overlay{primary, secondary} ->
    ( reportedPri
    , \placed ->
        let
          placedPrimary = suspendedPri placed
        in
          Overlay
            { ann = placed
            , primary = placedPrimary
            , secondary = suspendedSec placedPrimary.ann -- inspect primary box
            }
    )
    where
      (reportedPri, suspendedPri) = suspend proposed primary
      (_reportedSec, suspendedSec) = suspend reportedPri secondary -- inspect primary size

-- * Internals

inf :: Float
inf = 1 / 0

widthFlexibility :: ViewSize -> Float
widthFlexibility ViewSize{..} = maybeBoth (-1) (-) maxWidth minWidth

heightFlexibility :: ViewSize -> Float
heightFlexibility ViewSize{..} = maybeBoth (-1) (-) maxHeight minHeight

vsClamp :: Vec2 -> ViewSize -> Vec2 -> Vec2
vsClamp parent ViewSize{..} v =
  withVec2 parent \pw ph ->
    withVec2 v \w h ->
      vec2
        (maybeBoth pw (glClamp w) minWidth maxWidth)
        (maybeBoth ph (glClamp h) minHeight maxHeight)

{-# INLINE maybeBoth #-}
maybeBoth :: t1 -> (t2 -> t3 -> t1) -> Maybe t2 -> Maybe t3 -> t1
maybeBoth _ j (Just a) (Just b) = j a b
maybeBoth n _ _ _ = n

combineH :: Vec2 -> Vec2 -> Vec2
combineH a b =
  withVec2 a \aw ah ->
    withVec2 b \bw bh ->
      vec2 (aw + bw) (max ah bh)

combineV :: Vec2 -> Vec2 -> Vec2
combineV a b =
  withVec2 a \aw ah ->
    withVec2 b \bw bh ->
      vec2 (max aw bw) (ah + bh)

max2 :: Vec2 -> Vec2 -> Vec2
max2 a b =
  withVec2 a \aw ah ->
    withVec2 b \bw bh ->
      vec2 (max aw bw) (max ah bh)