Text.hs

{-# LANGUAGE OverloadedStrings #-}
------------------------------------------------------------------------
-- |
-- Module      :  Graphics.Wayland.Scanner.Text
-- Copyright   :  (c) Andrea Rossato 2026
-- License     :  BSD3-style (see LICENSE)
--
-- Maintainer  :  andrea.rossato@unitn.it
-- Stability   :  stable
-- Portability :  portable
--
-- This module exports some functions for 'Text' manipulation and some
-- templates.
------------------------------------------------------------------------
module Graphics.Wayland.Scanner.Text where

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

import Graphics.Wayland.Scanner.Types

capitalize :: Text -> Text
capitalize t =
  case T.uncons t of
    Nothing -> t
    Just (c, rest) -> T.cons (toUpper c) rest

lowerFirst :: Text -> Text
lowerFirst t =
  case T.uncons t of
    Nothing -> t
    Just (c, rest) -> T.cons (toLower c) rest

toCamel :: Text -> Text
toCamel t =
  let parts = T.splitOn "_" t
  in case parts of
       []     -> t
       (x:xs) -> x <> T.concat (map capitalize xs)

toHsType :: Text -> Text
toHsType = capitalize . toCamel

toHsFcn :: Text -> Text
toHsFcn = lowerFirst . toCamel

wordWrap :: Int -> Text -> Text
wordWrap maxLen = unlines' . concatMap (wrapLine maxLen) . T.lines

wrapLine :: Int -> Text -> [Text]
wrapLine maxLen line = go (T.words line) T.empty []
  where
    go [] cur acc = map haddockIdent $ reverse $ flush cur acc
    go (w:ws) cur acc
      | T.null cur          = go ws w acc
      | T.length cur + 1 + T.length w <= maxLen
                            = go ws (cur <> " " <> w) acc
      | otherwise           = go ws w (cur : acc)
    flush cur acc = if T.null cur then acc else cur : acc

haddockIdent :: Text -> Text
haddockIdent = T.unwords . map go . T.words
  where
    go w
      | "__" `T.isInfixOf` w = w
      | "_"  `T.isInfixOf` w = "@" <> w <> "@"
      | otherwise            = w

formatHaddockSec :: Text -> Text
formatHaddockSec t =
  unlines'
  [ "-- * " <> t
  , "--"
  , "-- $"  <> T.replace " " "_" t
  ]

formatHaddockSubSec :: Text -> Text
formatHaddockSubSec t =
  unlines'
  [ "-- ** " <> t
  , "--"
  , "-- $"   <> T.replace " " "_" t
  ]

formatArgs :: [Text] -> Text
formatArgs [] = ""
formatArgs as = T.intercalate "\n    -> " as

formatArgComment :: Text -> Text
formatArgComment "" = ""
formatArgComment c = "-- ^ " <> haddockIdent c

formatTopLevelComment :: Text -> Text
formatTopLevelComment "" = ""
formatTopLevelComment c =
  unlines'
  [ "{- |"
  , T.intercalate "\n\n" $ map (wordWrap 80) $ T.lines c
  , "-}"
  ]

formatHaddockHeader :: Name -> Text -> Text
formatHaddockHeader name desc =
  unlines'
  [ "{- |"
  , "Module      :  " <> name
  , "Copyright   :  Public Domain (generated by hs-wayland-scanner)"
  , "License     :  Public Domain (generated by hs-wayland-scanner)"
  , ""
  , "Maintainer  :  <https://codeberg.org/andrea_rossato/hs-wayland-scanner>"
  , "Stability   :  stable"
  , "Portability :  portable"
  , ""
  , T.intercalate "\n\n" $ map (wordWrap 80) $ T.lines desc
  , "-}"
  ]

moduleHeader :: HwsConfig -> SolvedProtocol -> [Text]
moduleHeader (HwsConfig _ nameSpace role _ _ _) (SolvedProtocol name desc _ deps _) =
  [ "{-# LANGUAGE ForeignFunctionInterface #-}"
  , "{-# OPTIONS_GHC -Wno-unused-imports #-}"
  , formatHaddockHeader modName desc
  , "module " <> modName <> " where"
  , ""
  , if name /= "wayland" then "import "<> T.pack nameSpace <> "." <> "Wayland.Protocol.Wayland" else ""
  , "import "<> T.pack nameSpace <> "." <> "Wayland." <> modRole <> ".Core"
  , "import "<> T.pack nameSpace <> "." <> "Wayland.Protocol." <> toHsType name
  , ""
  , "import Foreign"
  , "import Foreign.C.String"
  , "import Foreign.C.Types"
  , imports
  , "#include \"" <> name <> "-" <> T.toLower modRole <> "-protocol.h\"\n"
  ]
  where
    modName  = T.pack nameSpace  <> ".Wayland." <> modRole <> ".Protocol." <> toHsType name
    modRole  = T.pack $ show role
    modImp d = "import " <> T.pack nameSpace <> ".Wayland." <> modRole <> ".Protocol." <> toHsType d
    imports  = T.unlines $ map modImp deps

moduleEnumHeader :: HwsConfig -> SolvedProtocol -> [Text]
moduleEnumHeader (HwsConfig _ nameSpace role _ _ _) p =
  [ "{-# LANGUAGE ForeignFunctionInterface #-}"
  , "{-# LANGUAGE PatternSynonyms #-}"
  , formatHaddockHeader modName "Data types and 'enum' shared by the client and server protocols."
  , "module " <> modName <> " where"
  , ""
  , "import Foreign"
  , "#include \"" <> solvedProtoName p <> "-" <> T.toLower modRole <> "-protocol.h\"\n"
  ] ++
  if solvedProtoName p /= "wayland" then [] else
    [ "data WlArray"
    , "data WlRegistry"
    , "data WlDisplay"
    , "data WlInterface"
    ]
  where
    modName  = T.pack nameSpace <> ".Wayland.Protocol." <> toHsType (solvedProtoName p)
    modRole  = T.pack $ show role

-- | The core modules implement wayland-server-core and
-- wayland-client-core.
moduleCore :: HwsConfig -> [Text]
moduleCore c@(HwsConfig _ _ Client _ _ _) = moduleClientCore c
moduleCore c@(HwsConfig _ _ Server _ _ _) = moduleServerCore c

moduleClientCore :: HwsConfig -> [Text]
moduleClientCore (HwsConfig _ nameSpace role _ _ _) =
  [ formatHaddockHeader modName "An implementation of the wayland-client-core library"
  , "module " <> modName <> ".Core where\n"
  , "import Foreign"
  , "import Foreign.C.String"
  , "import Foreign.C.Types\n"
  , "import "<> T.pack nameSpace <> ".Wayland.Protocol.Wayland\n"
  , "data WlEventQueue"
  , ""
  , "-- Core connection"
  , "foreign import ccall \"wl_display_connect\""
  , "  wl_display_connect :: CString -> IO (Ptr WlDisplay)"
  , ""
  , "foreign import ccall \"wl_display_disconnect\""
  , "  wl_display_disconnect :: Ptr WlDisplay -> IO ()"
  , ""
  , "foreign import ccall \"wl_display_get_fd\""
  , "  wl_display_get_fd :: Ptr WlDisplay -> IO CInt"
  , ""
  , "foreign import ccall \"wl_display_roundtrip\""
  , "  wl_display_roundtrip :: Ptr WlDisplay -> IO CInt"
  , ""
  , "-- Buffer management"
  , "foreign import ccall \"wl_display_flush\""
  , "  wl_display_flush :: Ptr WlDisplay -> IO CInt"
  , ""
  , "-- Processes incoming events. Blocks until events are read."
  , "foreign import ccall \"wl_display_dispatch\""
  , "  wl_display_dispatch :: Ptr WlDisplay -> IO CInt"
  ]
  where
    modName = T.pack nameSpace <> ".Wayland." <> T.pack (show role)

moduleServerCore :: HwsConfig -> [Text]
moduleServerCore (HwsConfig _ nameSpace role _ _ _) =
  [ formatHaddockHeader modName "An implementation of the wayland-server-core library"
  , "module " <> modName <> ".Core where\n"
  , "import Foreign"
  , "import Foreign.C.String"
  , "import Foreign.C.Types\n"
  , "import "<> T.pack nameSpace <> ".Wayland.Protocol.Wayland\n"
  , "data WlClient"
  , "data WlResource"
  , "data WlGlobal"
  , ""
  , "foreign import ccall \"wl_display_create\""
  , "  wl_display_create :: IO (Ptr WlDisplay)"
  , ""
  , "foreign import ccall \"wl_display_destroy\""
  , "  wl_display_destroy :: Ptr WlDisplay -> IO ()"
  , ""
  , "foreign import ccall \"wl_display_run\""
  , "  wl_display_run :: Ptr WlDisplay -> IO ()"
  , ""
  , "foreign import ccall \"wl_display_add_socket_fd\""
  , "  wl_display_add_socket_fd :: Ptr WlDisplay -> CInt -> IO CInt"
  , ""
  , "foreign import ccall \"wl_display_add_socket_auto\""
  , "  wl_display_add_socket_auto :: Ptr WlDisplay -> IO CString"
  , ""
  , "type WlGlobalBindFuncCb = Ptr WlClient -> Ptr () -> Word32 -> Word32 -> IO ()"
  , ""
  , "foreign import ccall \"wl_global_create\""
  , "  wl_global_create"
  , "    :: Ptr WlDisplay"
  , "    -> Ptr WlInterface"
  , "    -> CInt"
  , "    -> Ptr ()"
  , "    -> FunPtr WlGlobalBindFuncCb"
  , "    -> IO (Ptr WlGlobal)"
  , ""
  , "foreign import ccall \"wrapper\""
  , "  mkWlGlobalBindFuncCb :: WlGlobalBindFuncCb -> IO (FunPtr WlGlobalBindFuncCb)"
  , ""
  , "foreign import ccall \"wl_resource_create\""
  , "  wl_resource_create"
  , "    :: Ptr WlClient"
  , "    -> Ptr WlInterface"
  , "    -> CInt"
  , "    -> Word32"
  , "    -> IO (Ptr WlResource)"
  , ""
  , "foreign import ccall \"wl_resource_destroy\""
  , "  wl_resource_destroy :: Ptr WlResource -> IO ()"
  , ""
  , "type WlResourceDestroyFunc = Ptr WlResource -> IO ()"
  , ""
  , "foreign import ccall \"wl_resource_set_implementation\""
  , "  wl_resource_set_implementation"
  , "    :: Ptr WlResource"
  , "    -> Ptr ()                         -- ^ interface struct (opaque pointer): cast with 'castPtr'"
  , "    -> Ptr ()                         -- ^ user data"
  , "    -> FunPtr WlResourceDestroyFunc   -- ^ destroy callback"
  , "    -> IO ()"
  , ""
  , "foreign import ccall \"wrapper\""
  , "  mkWlResourceDestroyFunc :: WlResourceDestroyFunc -> IO (FunPtr WlResourceDestroyFunc)"
  , ""
  , "foreign import ccall \"wl_resource_post_event\""
  , "  wl_resource_post_event :: Ptr WlResource -> Word32 -> IO ()"
  ]
  where
    modName = T.pack nameSpace <> ".Wayland." <> T.pack (show role)

autogenComment :: Text
autogenComment =
  "/* Auto-generated by hs-wayland-scanner.\n" <>
  "Do not manually edit unless you know what you are doing. */\n\n"

autogenWrapperComment :: Text
autogenWrapperComment =
  "/* Auto-generated by hs-wayland-scanner.\n" <>
  "Aggregates Wayland protocol sources and FFI wrappers.\n" <>
  "Do not compile individual protocol .c files separately. */\n\n"

unlines' :: [Text] -> Text
unlines' = T.intercalate "\n"