Argument.hs

module System.Console.Argument
  (
    Type (Type,parser,name,defaultValue)
  
  -- * Argument types
  , optional
  , string
  , boolean
  , directory
  , file
  , device
  , natural
  , integer
  
  -- * Option descriptions
  , option
  ) where


import           Data.Char      (toLower)
import           Data.List.HT   (viewR)
import qualified Data.Map              as Map
import qualified System.Console.GetOpt as GetOpt
import qualified Text.Parsec.Extra     as P


data Type a
  = Type
  {
    parser       :: String -> String -> Either String a
  , name         :: String
  , defaultValue :: Maybe a
  }

instance Functor Type where
  fmap f t = t { parser = ((.) . (.)) (fmap f) (parser t), defaultValue = fmap f (defaultValue t) }

-- | Create an option description.
option
  :: (a -> s) -- ^ Function that creates a setting (of type @s@) from the option argument.
  -> [Char]   -- ^ List of short option characters.
  -> [String] -- ^ List of long option strings.
  -> Type a   -- ^ Type of option argument.
  -> String   -- ^ Description.
  -> GetOpt.OptDescr (Either String s) -- ^ The resulting option description.
option inj short long t description = case defaultValue t of
  Nothing -> GetOpt.Option short long (GetOpt.ReqArg                         (fmap inj . parser t (name t)) (name t)) description
  Just a  -> GetOpt.Option short long (GetOpt.OptArg (maybe (Right $ inj a) $ fmap inj . parser t (name t)) (name t)) description

-- Argument types.

optional
  :: a      -- ^ Default value.
  -> Type a
  -> Type a
optional x t = t { defaultValue = Just x }

-- | A plain string.
string :: Type String
string = Type (const Right) "STRING" Nothing

-- | A boolean. Argument can be \"1\",\"0\",\"true\",\"false\",\"on\",\"off\".
boolean :: Type Bool
boolean = Type
  {
    name    = "BOOL"
  , parser  = \ _ y -> maybe (e y) Right . flip Map.lookup m . map toLower $ y
  , defaultValue = Just True
  }
 where
  m = Map.fromList [("1",True),("0",False),("true",True),("false",False),("on",True),("off",False)]
  e y = Left $ "Argument " ++ show y ++ " could not be recognised as a boolean."

-- | A natural number (in decimal).
natural :: Type Integer
natural = Type { name = "INT (natural)", parser = const (P.parseM P.natural ""), defaultValue = Nothing }

-- | An integer number (in decimal).
integer :: Type Integer
integer = Type { name = "INT", parser = const (P.parseM P.integer ""), defaultValue = Nothing }

-- | A directory path. A trailing slash is stripped, if present.
directory :: Type FilePath
directory = Type { name = "DIR", parser = const (Right . stripTrailingSlash), defaultValue = Nothing }
 where
  stripTrailingSlash x = case viewR x of
    Nothing       -> ""
    Just (i,l)
      | l == '/'  -> i
      | otherwise -> x

-- | A file path.
file :: Type FilePath
file = string { name = "FILE" }

-- | A device path.
device :: Type FilePath
device = string { name = "DEVICE" }