From: Michael Orlitzky <michael@orlitzky.com>
Date: Tue, 4 Nov 2014 14:32:43 +0000 (-0500)
Subject: Use explicit annotation to reduce duplication in CommandLine.
X-Git-Tag: 0.4.3~2
X-Git-Url: http://gitweb.michael.orlitzky.com/?p=haeredes.git;a=commitdiff_plain;h=f1884dbeaf2c312f412b496017951917a99c078d

Use explicit annotation to reduce duplication in CommandLine.
---

diff --git a/src/CommandLine.hs b/src/CommandLine.hs
index 1a1c313..85381de 100644
--- a/src/CommandLine.hs
+++ b/src/CommandLine.hs
@@ -6,21 +6,24 @@ module CommandLine (
 where
 
 import System.Console.CmdArgs (
+  Ann,
+  Annotate( (:=) ),
   Data,
   Typeable,
-  (&=),
+  (+=),
   args,
   auto,
-  cmdArgs,
+  cmdArgs_,
   def,
   details,
   explicit,
   groupname,
   help,
   helpArg,
-  modes,
+  modes_,
   name,
   program,
+  record,
   summary,
   typ,
   versionArg )
@@ -31,42 +34,62 @@ import Data.Version (showVersion)
 
 import Timeout (Timeout(..))
 
+
 -- | Description of the 'NS' mode.
+--
 ns_description :: String
 ns_description =
   "Confirm delegation of NS records. " ++
   "This is the default mode."
 
+
 -- | Description of the 'MX' mode.
+--
 mx_description :: String
 mx_description = "Confirm delegation of MX records."
 
+
+-- | The name of the program, appears in the \"help\" output.
+--
 program_name :: String
 program_name = "haeredes"
 
+
+-- | A short summary (program name and version) that are output
+--   as part of the help.
+--
 my_summary :: String
 my_summary = program_name ++ "-" ++ (showVersion version)
 
+
+-- | Description of the --no-append-root flag.
+--
 no_append_root_help :: String
 no_append_root_help =
   "Don't append a trailing dot to DNS names"
 
--- | Help string for the --server flag.
+
+-- | Description of the --server flag.
+--
 server_help :: String
 server_help =
   "IP address or hostname of server to query " ++
   "(will use resolv.conf if not specified)"
 
--- | Help string for the --timeout flag.
+
+-- | Description of the --timeout flag.
+--
 timeout_help :: String
 timeout_help =
   "Query timeout, in seconds (default: " ++ defstr ++ ")"
   where
     defstr = show $ seconds (def :: Timeout)
 
--- | The Args type represents the possible command-line options. The
---   duplication here seems necessary; CmdArgs' magic requires us to
+
+-- | The 'Args' type represents the possible command-line options. The
+--   duplication here seems necessary; CmdArgs's magic requires us to
 --   define some things explicitly.
+--
 data Args =
   NS { no_append_root :: Bool,
        server :: Maybe String,
@@ -78,64 +101,66 @@ data Args =
        delegates :: [String] }
   deriving (Data, Show, Typeable)
 
-arg_spec :: Args
+
+
+-- | The big argument specification. We use explicit annotation here
+--   because otherwise there's come CmdArgs magic going on that
+--   requires us to specify /all/ of the arguments for /each/ mode;
+--   i.e. we have to duplicate all of them for both 'NS' and 'MX.
+--
+--   This is slightly arcane but at least it doesn't repeat yoself.
+--
+arg_spec :: Annotate Ann
 arg_spec =
-  modes [ns &= auto, mx]
-    &= program program_name
-    &= summary my_summary
-    &= helpArg [explicit,
+  modes_ [ns += auto, mx]
+    += program program_name
+    += summary my_summary
+    += helpArg [explicit,
                 name "help",
                 name "h",
                 groupname "Common flags"]
-    &= versionArg [explicit,
+    += versionArg [explicit,
                    name "version",
                    name "v",
                    groupname "Common flags"]
   where
-    -- The repetition here is necessary, some CmdArgs magic going on.
-    ns :: Args
-    ns = NS {
-           no_append_root = def
-                         &= groupname "Common flags"
-                         &= help no_append_root_help,
-
-           server = def
-                 &= groupname "Common flags"
-                 &= typ "HOST"
-                 &= help server_help,
-
-           timeout = def
-                   &= groupname "Common flags"
-                   &= typ "SECONDS"
-                   &= help timeout_help,
-
-           delegates = def
-                    &= args
-                    &= typ "DELEGATES" }
-
-            &= details [ns_description]
-
-    mx :: Args
-    mx = MX {
-           no_append_root = def
-                         &= groupname "Common flags"
-                         &= help no_append_root_help,
-
-           server = def
-                 &= groupname "Common flags"
-                 &= typ "IP"
-                 &= help server_help,
-
-           timeout = def
-                   &= groupname "Common flags"
-                   &= typ "SECONDS"
-                   &= help timeout_help,
-
-           delegates = def
-                    &= args
-                    &= typ "DELEGATES" }
-
-            &= details [mx_description]
-
+    -- | Create a mode, adding all of the common flags to it
+    --   automatically. The big ugly type of the first argument is
+    --   simply the type of our NS/MX constructors.
+    --
+    make_mode :: (Bool -> Maybe String -> Timeout -> [String] -> Args)
+              -> String
+              -> (Annotate Ann)
+    make_mode ctor desc =
+      record (ctor def def def def) [
+        no_append_root := def
+                       += groupname "Common flags"
+                       += help no_append_root_help,
+
+        server := def
+               += groupname "Common flags"
+               += typ "IP"
+               += help server_help,
+
+        timeout := def
+                += groupname "Common flags"
+                += typ "SECONDS"
+                += help timeout_help,
+
+        delegates := def
+                  += args
+                  += typ "DELEGATES" ]
+        += details ["  " ++ desc]
+
+
+    -- Here we just create the NS/MX modes using our make_mode from above.
+    ns = make_mode NS ns_description
+    mx = make_mode MX mx_description
+
+
+
+-- | This is the public interface; i.e. what 'main' should use to get
+--   the command-line arguments.
+--
 get_args :: IO Args
-get_args = cmdArgs arg_spec
+get_args = cmdArgs_ arg_spec