コマンドラインオプションの解析(ちょー簡易版getopts)そのに

Haskell

コマンドラインオプションの解析(ちょー簡易版getopts) - 趣味的にっきで書いたちょー簡易版getoptsですが、もちっと実用になるように実装してみました。(opts, oargs, rests) <- parseOpts . getOpts "hvab:c" =<< getArgsのように、main関数の一行でコマンドラインオプションの解析ができてきれいです。
特徴は以下の通りです。

  • 受け付け可能なオプションの指定ができるようにしました。引数が必要なオプションも指定できます(-o fileみたいなの)。指定方法はよくあるgetoptsを同じ。
  • 「--」で区切るとそれ以降は、オプション以外の引数として扱います。
  • getOptsの返り値は、「指定されたオプションのリスト」、「引数を指定されたオプションの連想リスト」、「オプション以外の引数のリスト」です。
  • 受付不可能なオプションが渡されるとerrorで終了します。←この辺、乱暴。
  • オプション関係の関数をUtilモジュールにまとめています。

ファイル: Util.hs

module Util (getOpts, OptionResult, usage, version) where

import Data.List (isPrefixOf)
import System.Environment (getProgName)
import System.Exit (exitWith, ExitCode(ExitFailure))
import System.IO (stderr, hPutStrLn)

type OptionFormat = ([String], [String])
type OptionResult = ([String], [(String, String)], [String])

getOpts :: String -> [String] -> OptionResult
getOpts fmt args = 
  let (os, rs) = spanDM args
      (os', oas, rs') = spanFmt (parseFmt $ reverse fmt) "" os
  in (os', oas, rs' ++ rs)
  where
    spanDM :: [String] -> ([String], [String])
    spanDM [] = ([], [])
    spanDM (x : xs)
      | x /= "--" = let (ys, zs) = spanDM xs in (x : ys, zs)
      | otherwise = ([], xs)

    parseFmt :: String -> OptionFormat
    parseFmt [] = ([], [])
    parseFmt (':' : x : xs) =
      let (ys, zs) = parseFmt xs in (['-', x] : ys, zs)
    parseFmt (x : xs) =
      let (ys, zs) = parseFmt xs in (ys, ['-', x] : zs)

    spanFmt :: OptionFormat -> String -> [String] -> OptionResult
    spanFmt _ "" [] = ([], [], [])
    spanFmt fs "" (x : xs)
      | elem x $ fst fs =
          let (os, oas, rs) = spanFmt fs x  xs in (x : os, oas, rs)
      | elem x $ snd fs =
          let (os, oas, rs) = spanFmt fs "" xs in (x : os, oas, rs)
      | "-" `isPrefixOf` x = error $ "invalid option: " ++ x
      | otherwise = ([], [], x : xs)
    spanFmt fs b [] = error $ "invalid option: " ++ b
    spanFmt fs b (x : xs) =
      let (os, oas, rs) = spanFmt fs "" xs in (os, (b, x) : oas, rs)

usage :: String -> IO ()
usage m = do
  prog <- getProgName
  hPutStrLn stderr $ "usage: " ++ prog ++ " " ++ m
  exitWith (ExitFailure 1)

version :: String -> IO ()
version m = do
  prog <- getProgName
  hPutStrLn stderr $ prog ++ " - " ++ m
  exitWith (ExitFailure 1)

使い方: ファイル: a.hs

module Main (main) where

import Control.Monad (when)
import System.Environment (getArgs)
import Util (getOpts, OptionResult, usage, version)

parseOpts :: OptionResult -> IO OptionResult
parseOpts (os, oas, rs) = do
  when ("-h" `elem` os) $ usage   "[opts] [files]"
  when ("-v" `elem` os) $ version "0.1a"
  return (os, oas, rs)

main :: IO ()
main = do
  (opts, oargs, rests) <- parseOpts . getOpts "hvab:c" =<< getArgs
  putStrLn $ "opts:  " ++ show opts  -- 指定したオプション。
  putStrLn $ "oargs: " ++ show oargs -- オプションの引数。
  putStrLn $ "rests: " ++ show rests -- オプション以外。

-- Local Variables:
-- compile-command: "ghc -W -fno-warn-unused-matches --make -o a a"
-- End:

実行例:

$ ./a -a -b foo -c bar baz
opts:  ["-a","-b","-c"]
oargs: [("-b","foo")]
rests: ["bar","baz"]
$ ./a -a -b foo -- -c bar baz
opts:  ["-a","-b"]
oargs: [("-b","foo")]
rests: ["-c","bar","baz"]

BUGS: よくあるgetoptsとの微妙な仕様差異は調べてません。