spade-0.1.0.10: src/Common.hs

module Common
  ( module Common
  , TH.Lift
  ) where

import Control.Concurrent
import Control.Exception
import GHC.Generics
import Control.DeepSeq (NFData)
import Control.Monad.IO.Class
import Control.Monad
import Data.List as DL
import Data.Text as T
import Data.Text.IO as T
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Time.Format
import Data.Time.Clock.System
import Data.Time.LocalTime
import qualified Language.Haskell.TH.Syntax as TH

class HReadable a where
  hReadable :: a -> Text

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

getSystemTimestamp :: Num i => IO i
getSystemTimestamp = do
  st <- truncateSystemTimeLeapSecond <$> getSystemTime
  pure $ ((fromIntegral $ systemSeconds st) * 1e9) + (fromIntegral $ systemNanoseconds st)

getLocalTime :: IO LocalTime
getLocalTime =
  zonedTimeToLocalTime <$> getZonedTime

getLocalTimeString :: IO Text
getLocalTimeString = (formatLocalTime . localTimeOfDay) <$> getLocalTime

formatLocalTime :: TimeOfDay -> Text
formatLocalTime tod = pack $ formatTime defaultTimeLocale "%T" tod

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 :: (Int -> Int) -> Dimensions -> Dimensions
amendHeight fn d = d { diH = fn $ diH d }

amendWidth :: (Int -> Int) -> Dimensions -> Dimensions
amendWidth fn d = 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 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 MonadIO m => HasLog m where
  appendLog a = liftIO $ void $ try @SomeException (T.appendFile "/tmp/spade.log" $ pack (show a <> "\n"))

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 -- Line, obviously.
  , lcColumn :: Int -- Column, obviously
  , lcOffset :: Int -- Char offset from start of the token.
  } deriving (Generic, TH.Lift, Show, Eq)

instance NFData Location

instance HReadable Location where
  hReadable l = T.pack $ "Line: " <> (show (lcLine l)) <> " Column: " <> show (lcColumn 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)