{-# LANGUAGE DuplicateRecordFields #-}
module Main (main) where

import Control.Exception
import Data.Aeson
import Data.ByteString.Lazy.Char8 qualified as L8
import Data.Maybe
import GHC.Generics
import Graphics.X11.Xlib.Atom
import Graphics.X11.Xlib.Display
import Graphics.X11.Xlib.Misc
import Graphics.X11.Xrandr
import System.Environment


data Output =
    Output
      { device_scale_factor :: Float
      , dpi_x :: Float
      , dpi_y :: Float
      , height :: Int
      , height_mm :: Int
      , name :: String
      , width :: Int
      , width_mm :: Int
      }
    deriving (Generic, Show)

instance ToJSON Output

data Override =
    Override
      { height_mm :: Maybe Int
      , width_mm :: Maybe Int
      }
    deriving (Generic, Show)

instance FromJSON Override

emptyOverride :: Override
emptyOverride =
    Override
      { height_mm = Nothing
      , width_mm = Nothing
      }

main :: IO ()
main = do
    let
        -- This assumes DPI has not been configured
        -- (e.g. by passing -dpi to X or calling xrandr --dpi)
        default_dpi = 96
    bracket (getEnv "DISPLAY" >>= openDisplay) closeDisplay $ \dpy -> do
      let w = defaultRootWindow dpy
      (_, _, _, x, y, _, _, _) <- queryPointer dpy w
      filter (isPointedAt x y) . fromJust <$> xrrGetMonitors dpy w True
        >>= mapM (xrrMonitorInfoToOutput dpy default_dpi)
        >>= mapM_ (L8.putStrLn . encode)
  where
    isPointedAt
        x
        y
        XRRMonitorInfo
          { xrr_moninf_x
          , xrr_moninf_y
          , xrr_moninf_width
          , xrr_moninf_height
          } =
      xrr_moninf_x <= x && x < xrr_moninf_x + xrr_moninf_width &&
      xrr_moninf_y <= y && y < xrr_moninf_y + xrr_moninf_height
    xrrMonitorInfoToOutput
        dpy
        default_dpi
        XRRMonitorInfo
          { xrr_moninf_name
          , xrr_moninf_width
          , xrr_moninf_height
          , xrr_moninf_mwidth
          , xrr_moninf_mheight
          } = do
      name <- fromMaybe "???" <$> getAtomName dpy xrr_moninf_name

      Override
        { width_mm = override_width_mm
        , height_mm = override_height_mm
        } <-
        fromMaybe emptyOverride . maybe Nothing (decode . L8.pack)
          <$> lookupEnv "XOUTINFO_OVERRIDE"

      let
          width = fromIntegral xrr_moninf_width
          height = fromIntegral xrr_moninf_height
          width_mm =
            fromMaybe (fromIntegral xrr_moninf_mwidth)
                      override_width_mm
          height_mm =
            fromMaybe (fromIntegral xrr_moninf_mheight)
                      override_height_mm
          dpi_x = fromIntegral width / fromIntegral width_mm * 25.4
          dpi_y = fromIntegral height / fromIntegral height_mm * 25.4
      return Output
        { name = name
        , device_scale_factor = dpi_x / default_dpi
        , dpi_x = dpi_x
        , dpi_y = dpi_y
        , width = width
        , height = height
        , width_mm = width_mm
        , height_mm = height_mm
        }