language-python-colour-0.1: src/Language/Python/Colour/Options.hs

-----------------------------------------------------------------------------
-- |
-- Module      : Language.Python.Colour.Options
-- Copyright   : (c) 2009 Bernie Pope 
-- License     : BSD-style
-- Maintainer  : bjpop@csse.unimelb.edu.au
-- Stability   : experimental
-- Portability : ghc
--
-- Command line option processing for the Python colouring program.
-----------------------------------------------------------------------------
module Language.Python.Colour.Options 
   ( processOptions
   , programName
   , Flag (..)
   , PythonVersion (..)
   , getPyVersion
   , probeFlags
   , probeFlagsFirst
   , existsFlag
   , defaultPyVersion
   )
   where

import System.Console.GetOpt 
import Data.Maybe (fromMaybe)
import Data.Char (toLower, isDigit)
import Data.Maybe (catMaybes)
import IO (stderr, hPutStrLn)
import System

programName :: String
programName = "pycol"

-- This should really come from the cabal file somehow.
versionNumber :: String
versionNumber = "0.1"

versionInfo :: String
versionInfo = unwords [programName, "version", versionNumber]

processOptions :: [String] -> IO ([Flag], String)
processOptions argv = 
   case getOpt RequireOrder options argv of
      (flags, nonOpts, []) 
         | existsFlag flags Help -> do 
              putStrLn $ usageInfo header options
              exitWith ExitSuccess
         | existsFlag flags Version -> do 
              putStrLn versionInfo 
              exitWith ExitSuccess
         | length nonOpts /= 1 ->
              raiseError ["You must specify a single input Python file.\n"]  
         | otherwise -> return (flags, head nonOpts)
      (_, _, errs) -> raiseError errs
      where 
      header = "Usage: " ++ programName ++ " [OPTION...] file"
      failureMsg = programName ++ ": command line error.\n"
      raiseError errs = do
         hPutStrLn stderr $ failureMsg ++ concat errs ++ usageInfo header options
         exitFailure

probeFlags :: [Flag] -> (Flag -> Maybe a) -> [a]
probeFlags flags probe = catMaybes (map probe flags)

probeFlagsFirst :: [Flag] -> (Flag -> Maybe a) -> a -> a
probeFlagsFirst flags probe defaultValue
   | null probed = defaultValue 
   | otherwise = head probed
   where
   probed = probeFlags flags probe

existsFlag :: [Flag] -> Flag -> Bool
existsFlag flags f
   = probeFlagsFirst flags probe False 
   where
   probe someFlag = if f == someFlag then Just True else Nothing 
    
data Flag 
  = PyVersion PythonVersion  -- ^ Which version of Python to parse (2 or 3).
  | Help                   -- ^ Print a help message and exit.
  | Version                -- ^ Print the version number. 
  deriving (Eq, Ord, Show)

getPyVersion :: Flag -> Maybe PythonVersion
getPyVersion (PyVersion v) = Just v
getPyVersion _ = Nothing

data PythonVersion
   = V2 
   | V3 
   deriving (Eq, Ord, Show)

options :: [OptDescr Flag]
options =
 [ Option ['p']     ["pyver"]     (ReqArg mkPyVersion "VERSION") "VERSION of Python to parse: 2 or 3 (default is 2)"
 , Option ['v']     ["version"]   (NoArg Version)            "show version number"
 , Option ['h']     ["help"]      (NoArg Help)               "get help about using this program"
 ]

defaultPyVersion :: PythonVersion 
defaultPyVersion = V2 

mkPyVersion :: String -> Flag
mkPyVersion = normalMkVersion . map toLower
   where
   normalMkVersion "2"   = PyVersion V2 
   normalMkVersion "3"   = PyVersion V3 
   normalMkVersion other = PyVersion defaultPyVersion