{-# LANGUAGE OverloadedStrings #-}

module TextViewport
  ( Item(..)
  , Buffer(..)
  , WrapMode(..)
  , RenderedLine(..)
  , RenderedBuffer
  , renderBuffer
  , flatten
  , modifyItem
  , updateRenderedItem
  , Viewport(..)
  , defaultViewport
  , scrollUp
  , scrollDown
  , visibleLines
  , lookupPosition
  ) where

import Data.Text (Text)
import qualified Data.Text as T

--------------------------------------------------------------------------------
-- Logical model
--------------------------------------------------------------------------------

newtype Item = Item { unItem :: Text }
newtype Buffer = Buffer { unBuffer :: [Item] }

modifyItem :: Int -> (Item -> Item) -> Buffer -> Buffer
modifyItem ix f (Buffer xs) =
    Buffer (take ix xs ++ [f (xs !! ix)] ++ drop (ix+1) xs)

--------------------------------------------------------------------------------
-- Rendering with provenance
--------------------------------------------------------------------------------

data WrapMode = NoWrap | Wrap
  deriving (Eq, Show)

-- | A physical line with provenance.
data RenderedLine = RenderedLine
  { rlText      :: !Text
  , rlItemIx    :: !Int
  , rlLineIx    :: !Int
  , rlCharStart :: !Int
  } deriving (Eq, Show)

-- | RenderedBuffer keeps per-item blocks so we can update only one item.
type RenderedBuffer = [[RenderedLine]]

flatten :: RenderedBuffer -> [RenderedLine]
flatten = concat

renderBuffer :: WrapMode -> Int -> Buffer -> RenderedBuffer
renderBuffer mode w (Buffer items) =
    zipWith (renderItem mode w) [0..] items

renderItem :: WrapMode -> Int -> Int -> Item -> [RenderedLine]
renderItem mode w itemIx (Item t) =
    concat $ zipWith (renderLogicalLine mode w itemIx) [0..] (T.splitOn "\n" t)

renderLogicalLine :: WrapMode -> Int -> Int -> Int -> Text -> [RenderedLine]
renderLogicalLine mode w itemIx lineIx txt =
    case mode of
      NoWrap ->
        [ RenderedLine (T.take w txt) itemIx lineIx 0 ]
      Wrap ->
        let chunks = chunk w txt
        in zipWith mkChunk [0, w ..] chunks
  where
    mkChunk off chunkTxt =
      RenderedLine chunkTxt itemIx lineIx off

chunk :: Int -> Text -> [Text]
chunk w t
  | T.null t  = [""]
  | otherwise = go t
  where
    go s
      | T.null s  = []
      | otherwise =
          let (c, r) = T.splitAt w s
          in c : go r

--------------------------------------------------------------------------------
-- Incremental re-rendering
--------------------------------------------------------------------------------

updateRenderedItem
  :: WrapMode
  -> Int
  -> Int
  -> Buffer
  -> RenderedBuffer
  -> RenderedBuffer
updateRenderedItem mode w itemIx (Buffer items) rb =
    let newBlock = renderItem mode w itemIx (items !! itemIx)
    in take itemIx rb ++ [newBlock] ++ drop (itemIx+1) rb

--------------------------------------------------------------------------------
-- Viewport
--------------------------------------------------------------------------------

data Viewport = Viewport
  { vpWidth  :: !Int
  , vpHeight :: !Int
  , vpOffset :: !Int
  } deriving (Eq, Show)

defaultViewport :: Int -> Int -> [RenderedLine] -> Viewport
defaultViewport w h rendered =
    let total = length rendered
        off   = max 0 (total - h)
    in Viewport w h off

scrollUp :: Int -> Viewport -> Viewport
scrollUp k vp =
    vp { vpOffset = max 0 (vpOffset vp - k) }

scrollDown :: Int -> [RenderedLine] -> Viewport -> Viewport
scrollDown k rendered vp =
    let total  = length rendered
        maxOff = max 0 (total - vpHeight vp)
        newOff = min maxOff (vpOffset vp + k)
    in vp { vpOffset = newOff }

visibleLines :: [RenderedLine] -> Viewport -> [RenderedLine]
visibleLines rendered vp =
    take (vpHeight vp) . drop (vpOffset vp) $ rendered

--------------------------------------------------------------------------------
-- Coordinate lookup
--------------------------------------------------------------------------------

lookupPosition
  :: Int              -- ^ x coordinate
  -> Int              -- ^ y coordinate
  -> Viewport
  -> [RenderedLine]
  -> Maybe (Int, Int) -- ^ (itemIx, charOffsetInLogicalLine)
lookupPosition x y vp rendered = do
    let lineIx = vpOffset vp + y
    rl <- renderedAt lineIx rendered
    pure (rlItemIx rl, rlCharStart rl + x)
  where
    renderedAt ix rs
      | ix < 0 || ix >= length rs = Nothing
      | otherwise                 = Just (rs !! ix)