spade-0.1.0.0: src/Common.hs

module Common
  ( module Common
  , TH.Lift
  ) where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.List as DL
import Data.Text as T
import Data.Text.IO as T
import qualified Language.Haskell.TH.Syntax as TH
import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..),
                            SGR(..), Underlining(..), setSGRCode)
import Test.Common

class HReadable a where
  hReadable :: a -> Text

getTimestamp :: IO Int
getTimestamp = (round . (* 10e12)) <$> getPOSIXTime

wait :: Double -> IO ()
wait s = threadDelay (floor $ s * 1000_000)

origin :: ScreenPos
origin = ScreenPos 0 0

data Dimensions = Dimensions
  { diW :: Int
  , diH :: Int
  } deriving (Eq, Show)

amendHeight :: Dimensions -> (Int -> Int) -> Dimensions
amendHeight d fn = d { diH = fn $ diH d }

amendWidth :: Dimensions -> (Int -> Int) -> Dimensions
amendWidth d fn = d { diW = fn $ diW d }

moveLeft :: Int -> ScreenPos -> ScreenPos
moveLeft i d = d { sX = sX d - i }

moveRight :: Int -> ScreenPos -> ScreenPos
moveRight i d = d { sX = sX d + i }

moveUp :: Int -> ScreenPos -> ScreenPos
moveUp i d = d { sY = sY d - i }

moveDown :: Int -> ScreenPos -> ScreenPos
moveDown i d = d { sY = sY d + i }

addSp :: ScreenPos -> ScreenPos -> ScreenPos
addSp s1 s2 = ScreenPos (sX s1 + sX s2) (sY s1 + sY s2)

type IntType = Integer
type FloatType = Double

data Style = FgBg Color Color| Fg Color | Bg Color | TextUnderline | NoStyle
  deriving (Eq, Show)

data StyledText = StyledText Style [StyledText] | Plain Text
  deriving (Show, Eq)

renderLines :: [[StyledText]] -> Text
renderLines st = T.intercalate "\n" $ (\i -> (T.concat $ stRender <$> i)) <$> st

instance HasGen StyledText where
  getGen = recursive choice
    [Plain . T.pack <$> txGen]
    [StyledText NoStyle <$> list (linear 1 100) getGen]
    where
      txGen = list (linear 1 100) (choice [lower, upper])

-- Punch a hole starting from offset of size length. Columns start
-- from 0. Returns chunks left and right of the hole.
punchHole :: (Int, Int) -> [StyledText] -> ([StyledText], [StyledText])
punchHole (tk, ln) sts = (stTake tk sts, stDrop (tk + ln) sts)

stInsert :: [StyledText] -> Int -> StyledText -> [StyledText]
stInsert sts cx t =
  let (lr, rg) = punchHole (cx, stLength t) sts
  in (lr <> [t] <> rg)

stDrop :: Int -> [StyledText] -> [StyledText]
stDrop l stsIn = snd $ DL.foldl' stDrop' (l, []) stsIn
  where
    stDrop' :: (Int, [StyledText]) -> StyledText -> (Int, [StyledText])
    stDrop' (0, sts) st = (0, sts <> [st])
    stDrop' (s, sts) (Plain t) = let
      r = T.drop s t
      rlen = T.length r
      in if rlen > 0
        then (s - (T.length t - rlen), sts <> [Plain r])
        else (s - T.length t, sts)
    stDrop' (s, sts) (StyledText st sts') =
     case DL.foldl' stDrop' (s, []) sts' of
      (s', sts''@(_:_)) -> (s', sts <> [StyledText st sts''])
      (s', _)           -> (s', sts)

stTake :: Int -> [StyledText] -> [StyledText]
stTake l stsIn = snd $ DL.foldl' stTake' (l, []) stsIn
  where
    stTake' :: (Int, [StyledText]) -> StyledText -> (Int, [StyledText])
    stTake' (0, sts) _ = (0, sts)
    stTake' (s, sts) (Plain t) = let
      r = T.take s t
      in (s - T.length r, sts <> [Plain r])
    stTake' (s, sts) (StyledText st sts') = let
      (s', sts'') = DL.foldl' stTake' (s, []) sts'
      in (s', sts <> [StyledText st sts''])

applyStyleToRange :: (StyledText -> StyledText) -> Int -> (Int, Int) -> [StyledText] -> [StyledText]
applyStyleToRange fn sStart (rStart, rEnd) segments =
  let
    sEnd = sStart + stTotalLength segments - 1
  in if rEnd >= sStart && rStart <= sEnd
    then
      let
        r1 = max 0 (rStart - sStart)
        r2 = rEnd - (max sStart rStart) + 1
      in (stTake r1 segments) <> (fn <$> (stTake r2 (stDrop r1 segments))) <> (stDrop (r1 + r2) segments)
    else segments

stLength :: StyledText -> Int
stLength (Plain t)          = T.length t
stLength (StyledText _ sts) = sum (stLength <$> sts)

stTotalLength :: [StyledText] -> Int
stTotalLength sts = sum $ stLength <$> sts

-- This implimentation is not optimal and does not correctly
-- render nested styles. But this appear to be good enough for now.
styleToPrefix :: Style -> Text
styleToPrefix st = T.pack $ case st of
  FgBg fg bg -> setSGRCode [SetColor Foreground Vivid fg] <> setSGRCode [SetColor Background Vivid bg]
  Bg bg -> setSGRCode [SetColor Background Vivid bg]
  Fg fg -> setSGRCode [SetColor Foreground Vivid fg]
  TextUnderline -> setSGRCode [SetUnderlining SingleUnderline]
  NoStyle -> mempty

stRender :: StyledText -> Text
stRender st = stRender' NoStyle st

mergeStyles :: Style -> Style -> Style
mergeStyles NoStyle a     = a
mergeStyles a NoStyle     = a
mergeStyles (Fg a) (Bg b) = (FgBg a b)
mergeStyles (Bg a) (Fg b) = (FgBg b a)
mergeStyles _ a           = a

stRender' :: Style -> StyledText -> Text
stRender' _ (Plain t) = T.replace "\n" " " t
stRender' pst (StyledText st sts) = let
  suffix = T.pack $ setSGRCode []
  prefix = styleToPrefix (mergeStyles pst st)
  in T.concat (((\x -> prefix <> x <> suffix) . stRender' st) <$> sts)

data ScreenPos = ScreenPos { sX :: Int, sY :: Int }
  deriving (Eq, Ord, Show)

type CursorInfo = (ScreenPos, CursorStyle)

emptyCursorInfo :: CursorInfo
emptyCursorInfo = (origin, Bar)

pass :: Monad m => m ()
pass = pure ()

data CursorStyle
  = Bar
  | Underline
  | Hidden
  deriving (Eq, Show)

class HasEmpty s where
  isEmpty :: s -> Bool

class HasLog m where
  appendLog :: Show a => a -> m ()

class ToSource a where
  toSource :: a -> Text
  toSourcePretty :: Int -> a -> Text
  toSource a = toSourcePretty 0 a
  toSourcePretty _ a = toSource a

instance ToSource a => ToSource [a] where
  toSourcePretty i fss = T.intercalate "\n" (toSourcePretty i <$> fss)

instance ToSource a => ToSource (Maybe a) where
  toSourcePretty i (Just x) = toSourcePretty i x
  toSourcePretty _ Nothing  = mempty

instance ToSource Text where
  toSource = id

indent :: Int -> Text
indent i = T.replicate i "  "

instance HasLog IO where
  appendLog a = void $ try @SomeException (T.appendFile "/tmp/spade.log" $ pack (show a <> "\n"))

-- Mostly for use with highlighting and not actual token parsing.
-- This represent any tokens we want to show in editors with highlighting.
class Highlightable a where
  getTokenLoc :: a -> Location
  highlight :: (StyledText, Maybe a) -> StyledText
  pairWithTokens :: [a] -> Int -> Text -> ([(Text, Maybe a)], [a])
  -- ^ Associate token type with their text sources
  -- First arg is stack of tokens at current location
  -- Second arg is the text offset at current location
  -- Third arg is the text at the current location
  --
  -- This is so that in an editor, a line of text can break at somewhere in the
  -- middle of a single token. So an editor cannot display tokenwise without more
  -- complex tracking of current offset in source text.

instance Highlightable Text where
  highlight (x, _) = x
  pairWithTokens _ _ t = ([(t, Nothing)], [])
  getTokenLoc = error "No token location for text"

genericPairWithTokens :: (a -> Int) -> (a -> Location) -> Int -> Text -> [a] -> ([(Text, Maybe a)], [a])
genericPairWithTokens _ _ _ "" [] = ([], [])
genericPairWithTokens _ _ _ src [] = ([(src, Nothing)], [])
genericPairWithTokens getOffsetEnd getLoc offset src ti@(tk:rst)
  | src == "" =  ([], ti)
  | (lcOffset (getLoc tk)) > offset = let
      tokenLen = (getOffsetEnd tk) - offset + 1
      frag = T.take tokenLen src
      (fragRst, ts) = genericPairWithTokens getOffsetEnd getLoc (offset+tokenLen) (T.drop tokenLen src) ti
      in ((frag, Just tk): fragRst, ts)
  | (lcOffset (getLoc tk)) <= offset = let
      tokenLen = (getOffsetEnd tk) - offset + 1
      frag = T.take tokenLen src
      rst' = if (getOffsetEnd tk) > (offset + T.length src - 1) then ti else rst
      (fragRst, ts) = genericPairWithTokens getOffsetEnd getLoc (offset+tokenLen) (T.drop tokenLen src) rst'
      in ((frag, Just tk): fragRst, ts)
  | otherwise = ([], ti)

data Location = Location { lcLine :: Int, lcColumn :: Int, lcOffset :: Int }
  deriving (TH.Lift, Show, Eq)

instance HReadable Location where
  hReadable l = T.pack $ "Line: " <> (show (lcLine l)) <> " Column: " <> show (lcColumn l) <> " Offset: " <> show (lcOffset l)

emptyLocation :: Location
emptyLocation = Location 1 1 0

toInt :: IntType -> Int
toInt x = if x > fromIntegral (maxBound @Int) then error "Int conversion out of bound" else fromIntegral x

safeIndex :: [a] -> Int -> Maybe a
safeIndex l i = fst $ DL.foldl' fn (Nothing, 0) l
  where
    fn (Just x, ci) _  = (Just x, ci)
    fn (Nothing, ci) a = if ci == i then (Just a, ci) else (Nothing, ci+1)