Load docs in Client.Commands.Docs

glguy · Jan 3, 2024 · e2d65e1 · e2d65e1
1 parent 6c72529
commit e2d65e1
Show file tree

Hide file tree

Showing 11 changed files with 127 additions and 126 deletions.
diff --git a/src/Client/Commands.hs b/src/Client/Commands.hs
@@ -228,63 +228,63 @@ commandsList =
   [ Command
       (pure "exit")
       (pure ())
-      $(clientDocs >>= cmdDoc "exit")
+      $(clientDocs `cmdDoc` "exit")
     $ ClientCommand cmdExit noClientTab
 
   , Command
       (pure "reload")
       (optionalArg (simpleToken "[filename]"))
-      $(clientDocs >>= cmdDoc "reload")
+      $(clientDocs `cmdDoc` "reload")
     $ ClientCommand cmdReload tabReload
 
   , Command
       (pure "extension")
       (liftA2 (,) (simpleToken "extension") (remainingArg "arguments"))
-      $(clientDocs >>= cmdDoc "extension")
+      $(clientDocs `cmdDoc` "extension")
     $ ClientCommand cmdExtension simpleClientTab
 
   , Command
       (pure "palette")
       (pure ())
-      $(clientDocs >>= cmdDoc "palette")
+      $(clientDocs `cmdDoc` "palette")
     $ ClientCommand cmdPalette noClientTab
 
   , Command
       (pure "digraphs")
       (pure ())
-      $(clientDocs >>= cmdDoc "digraphs")
+      $(clientDocs `cmdDoc` "digraphs")
     $ ClientCommand cmdDigraphs noClientTab
 
   , Command
       (pure "keymap")
       (pure ())
-      $(clientDocs >>= cmdDoc "keymap")
+      $(clientDocs `cmdDoc` "keymap")
     $ ClientCommand cmdKeyMap noClientTab
 
   , Command
       (pure "rtsstats")
       (pure ())
-      $(clientDocs >>= cmdDoc "rtsstats")
+      $(clientDocs `cmdDoc` "rtsstats")
     $ ClientCommand cmdRtsStats noClientTab
 
   , Command
       (pure "exec")
       (remainingArg "arguments")
-      $(clientDocs >>= cmdDoc "exec")
+      $(clientDocs `cmdDoc` "exec")
     $ ClientCommand cmdExec simpleClientTab
 
   , Command
       (pure "url")
       optionalNumberArg
-      $(clientDocs >>= cmdDoc "url")
+      $(clientDocs `cmdDoc` "url")
     $ ClientCommand cmdUrl noClientTab
 
   , newCertificateCommand
 
   , Command
       (pure "help")
       (optionalArg (simpleToken "[command]"))
-      $(clientDocs >>= cmdDoc "help")
+      $(clientDocs `cmdDoc` "help")
     $ ClientCommand cmdHelp tabHelp
 
   ------------------------------------------------------------------------

diff --git a/src/Client/Commands/Certificate.hs b/src/Client/Commands/Certificate.hs
@@ -46,7 +46,7 @@ newCertificateCommand =
   Command
     (pure "new-self-signed-cert")
     (liftA2 (,) (simpleToken "filename") keysizeArg)
-    $(netDocs >>= cmdDoc "new-self-signed-cert")
+    $(netDocs `cmdDoc` "new-self-signed-cert")
     (ClientCommand cmdNewCert noClientTab)
 
 cmdNewCert :: ClientCommand (String, Maybe (Int, String))

diff --git a/src/Client/Commands/Channel.hs b/src/Client/Commands/Channel.hs
@@ -40,43 +40,43 @@ channelCommands = CommandSection "IRC channel management"
   [ Command
       (pure "mode")
       (fromMaybe [] <$> optionalArg (extensionArg "[modes]" modeParamArgs))
-      $(chanopDocs >>= cmdDoc "mode")
+      $(chanopDocs `cmdDoc` "mode")
     $ NetworkCommand cmdMode tabMode
 
   , Command
       (pure "masks")
       (simpleToken "mode")
-      $(chanopDocs >>= cmdDoc "masks")
+      $(chanopDocs `cmdDoc` "masks")
     $ ChannelCommand cmdMasks noChannelTab
 
   , Command
       (pure "invite")
       (simpleToken "nick")
-      $(chanopDocs >>= cmdDoc "invite")
+      $(chanopDocs `cmdDoc` "invite")
     $ ChannelCommand cmdInvite simpleChannelTab
 
   , Command
       (pure "topic")
       (remainingArg "message")
-      $(chanopDocs >>= cmdDoc "topic")
+      $(chanopDocs `cmdDoc` "topic")
     $ ChannelCommand cmdTopic tabTopic
 
   , Command
       (pure "kick")
       (liftA2 (,) (simpleToken "nick") (remainingArg "reason"))
-      $(chanopDocs >>= cmdDoc "kick")
+      $(chanopDocs `cmdDoc` "kick")
     $ ChannelCommand cmdKick simpleChannelTab
 
   , Command
       (pure "kickban")
       (liftA2 (,) (simpleToken "nick") (remainingArg "reason"))
-      $(chanopDocs >>= cmdDoc "kickban")
+      $(chanopDocs `cmdDoc` "kickban")
     $ ChannelCommand cmdKickBan simpleChannelTab
 
   , Command
       (pure "remove")
       (liftA2 (,) (simpleToken "nick") (remainingArg "reason"))
-      $(chanopDocs >>= cmdDoc "remove")
+      $(chanopDocs `cmdDoc` "remove")
     $ ChannelCommand cmdRemove simpleChannelTab
 
   ]

diff --git a/src/Client/Commands/Chat.hs b/src/Client/Commands/Chat.hs
@@ -40,103 +40,103 @@ chatCommands = CommandSection "IRC commands"
   [ Command
       ("join" :| ["j"])
       (liftA2 (,) (simpleToken "channels") (optionalArg (simpleToken "[keys]")))
-      $(chatDocs >>= cmdDoc "join")
+      $(chatDocs `cmdDoc` "join")
     $ NetworkCommand cmdJoin simpleNetworkTab
 
   , Command
       (pure "part")
       (remainingArg "reason")
-      $(chatDocs >>= cmdDoc "part")
+      $(chatDocs `cmdDoc` "part")
     $ ChannelCommand cmdPart simpleChannelTab
 
   , Command
       (pure "msg")
       (liftA2 (,) (simpleToken "target") (remainingArg "message"))
-      $(chatDocs >>= cmdDoc "msg")
+      $(chatDocs `cmdDoc` "msg")
     $ NetworkCommand cmdMsg simpleNetworkTab
 
   , Command
       (pure "me")
       (remainingArg "message")
-      $(chatDocs >>= cmdDoc "me")
+      $(chatDocs `cmdDoc` "me")
     $ ChatCommand cmdMe simpleChannelTab
 
   , Command
       (pure "say")
       (remainingArg "message")
-      $(chatDocs >>= cmdDoc "say")
+      $(chatDocs `cmdDoc` "say")
     $ ChatCommand cmdSay simpleChannelTab
 
   , Command
       ("query" :| ["q"])
       (liftA2 (,) (simpleToken "target") (remainingArg "message"))
-      $(chatDocs >>= cmdDoc "query")
+      $(chatDocs `cmdDoc` "query")
     $ ClientCommand cmdQuery simpleClientTab
 
   , Command
       (pure "notice")
       (liftA2 (,) (simpleToken "target") (remainingArg "message"))
-      $(chatDocs >>= cmdDoc "notice")
+      $(chatDocs `cmdDoc` "notice")
     $ NetworkCommand cmdNotice simpleNetworkTab
 
   , Command
       (pure "wallops")
       (remainingArg "message to +w users")
-      $(chatDocs >>= cmdDoc "wallops")
+      $(chatDocs `cmdDoc` "wallops")
     $ NetworkCommand cmdWallops simpleNetworkTab
 
   , Command
       (pure "operwall")
       (remainingArg "message to +z opers")
-      $(chatDocs >>= cmdDoc "operwall")
+      $(chatDocs `cmdDoc` "operwall")
     $ NetworkCommand cmdOperwall simpleNetworkTab
 
   , Command
       (pure "ctcp")
       (liftA3 (,,) (simpleToken "target") (simpleToken "command") (remainingArg "arguments"))
-      $(chatDocs >>= cmdDoc "ctcp")
+      $(chatDocs `cmdDoc` "ctcp")
     $ NetworkCommand cmdCtcp simpleNetworkTab
 
   , Command
       (pure "nick")
       (simpleToken "nick")
-      $(chatDocs >>= cmdDoc "nick")
+      $(chatDocs `cmdDoc` "nick")
     $ NetworkCommand cmdNick simpleNetworkTab
 
   , Command
       (pure "away")
       (remainingArg "message")
-      $(chatDocs >>= cmdDoc "away")
+      $(chatDocs `cmdDoc` "away")
     $ NetworkCommand cmdAway simpleNetworkTab
 
   , Command
       (pure "names")
       (pure ())
-      $(chatDocs >>= cmdDoc "names")
+      $(chatDocs `cmdDoc` "names")
     $ ChannelCommand cmdChanNames noChannelTab
 
   , Command
       (pure "channelinfo")
       (pure ())
-      $(chatDocs >>= cmdDoc "channelinfo")
+      $(chatDocs `cmdDoc` "channelinfo")
     $ ChannelCommand cmdChannelInfo noChannelTab
 
   , Command
       (pure "knock")
       (liftA2 (,) (simpleToken "channel") (remainingArg "message"))
-      $(chatDocs >>= cmdDoc "knock")
+      $(chatDocs `cmdDoc` "knock")
     $ NetworkCommand cmdKnock simpleNetworkTab
 
   , Command
       (pure "quote")
       (remainingArg "raw IRC command")
-      $(chatDocs >>= cmdDoc "quote")
+      $(chatDocs `cmdDoc` "quote")
     $ NetworkCommand cmdQuote simpleNetworkTab
 
   , Command
       (pure "monitor")
       (extensionArg "[+-CLS]" monitorArgs)
-      $(chatDocs >>= cmdDoc "monitor")
+      $(chatDocs `cmdDoc` "monitor")
     $ NetworkCommand cmdMonitor simpleNetworkTab
 
   ]

diff --git a/src/Client/Commands/Connection.hs b/src/Client/Commands/Connection.hs
@@ -29,37 +29,37 @@ connectionCommands = CommandSection "Connection commands"
   [ Command
       (pure "connect")
       (simpleToken "network")
-      $(netDocs >>= cmdDoc "connect")
+      $(netDocs `cmdDoc` "connect")
     $ ClientCommand cmdConnect tabConnect
 
   , Command
       (pure "reconnect")
       (pure ())
-      $(netDocs >>= cmdDoc "reconnect")
+      $(netDocs `cmdDoc` "reconnect")
     $ ClientCommand cmdReconnect noClientTab
 
   , Command
       (pure "disconnect")
       (pure ())
-      $(netDocs >>= cmdDoc "disconnect")
+      $(netDocs `cmdDoc` "disconnect")
     $ NetworkCommand cmdDisconnect noNetworkTab
 
   , Command
       (pure "quit")
       (remainingArg "reason")
-      $(netDocs >>= cmdDoc "quit")
+      $(netDocs `cmdDoc` "quit")
     $ NetworkCommand cmdQuit simpleNetworkTab
 
   , Command
       (pure "cert")
       (pure ())
-      $(netDocs >>= cmdDoc "cert")
+      $(netDocs `cmdDoc` "cert")
     $ NetworkCommand cmdCert noNetworkTab
 
   , Command
       (pure "umode")
       (remainingArg "modes")
-      $(netDocs >>= cmdDoc "umode")
+      $(netDocs `cmdDoc` "umode")
     $ NetworkCommand cmdUmode noNetworkTab
   ]
 

diff --git a/src/Client/Commands/Docs.hs b/src/Client/Commands/Docs.hs
@@ -1,4 +1,4 @@
-{-# Language OverloadedStrings #-}
+{-# Language OverloadedStrings, TemplateHaskell #-}
 
 {-|
 Module      : Client.Commands.Docs
@@ -22,37 +22,38 @@ module Client.Commands.Docs
   , windowDocs
   ) where
 
-import Language.Haskell.TH (Q, Exp)
 import Client.Docs (Docs, loadDoc, lookupDoc, makeHeader)
+import Language.Haskell.TH (Q, Exp)
+import Language.Haskell.TH.Syntax (lift)
 
-cmdDoc :: String -> Docs -> Q Exp
-cmdDoc key = lookupDoc (makeHeader "Description") ('/':key)
+cmdDoc :: Docs -> String -> Q Exp
+cmdDoc docs key = lookupDoc (makeHeader "Description") ('/':key) docs
 
 -- TODO: Replace each id with something that splits off the command name.
 
-chanopDocs :: Q Docs
-chanopDocs = loadDoc id "cmds_chanop"
+chanopDocs :: Docs
+chanopDocs = $(loadDoc id "cmds_chanop" >>= lift)
 
-chatDocs :: Q Docs
-chatDocs = loadDoc id "cmds_chat"
+chatDocs :: Docs
+chatDocs = $(loadDoc id "cmds_chat" >>= lift)
 
-clientDocs :: Q Docs
-clientDocs = loadDoc id "cmds_client"
+clientDocs :: Docs
+clientDocs = $(loadDoc id "cmds_client" >>= lift)
 
-integrationDocs :: Q Docs
-integrationDocs = loadDoc id "cmds_integration"
+integrationDocs :: Docs
+integrationDocs = $(loadDoc id "cmds_integration" >>= lift)
 
-netDocs :: Q Docs
-netDocs = loadDoc id "cmds_net"
+netDocs :: Docs
+netDocs = $(loadDoc id "cmds_net" >>= lift)
 
-operDocs :: Q Docs
-operDocs = loadDoc id "cmds_oper"
+operDocs :: Docs
+operDocs = $(loadDoc id "cmds_oper" >>= lift)
 
-queriesDocs :: Q Docs
-queriesDocs = loadDoc id "cmds_queries"
+queriesDocs :: Docs
+queriesDocs = $(loadDoc id "cmds_queries" >>= lift)
 
-togglesDocs :: Q Docs
-togglesDocs = loadDoc id "cmds_toggles"
+togglesDocs :: Docs
+togglesDocs = $(loadDoc id "cmds_toggles" >>= lift)
 
-windowDocs :: Q Docs
-windowDocs = loadDoc id "cmds_window"
+windowDocs :: Docs
+windowDocs = $(loadDoc id "cmds_window" >>= lift)