module System.Console.Argument
(
Option
, option
, Type(Type,parser,name,defaultValue)
, optional
, string
, boolean
, directory
, file
, device
, natural
, integer
) where
import System.Console.Internal hiding (name)
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 -> 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) }
option
:: [Char]
-> [String]
-> Type a
-> a
-> String
-> Option a
option short long t def description = let
names = map Short short ++ map Long long
identifier = identify names
in Option
names
(GetOpt.Option
short
long
(maybe
(GetOpt.ReqArg ((,) identifier . Just) $ name t)
(const $ GetOpt.OptArg ((,) identifier) $ name t)
(defaultValue t))
description)
def
(maybe (maybe (Left "Option argument missing.") Right $ defaultValue t) (parser t))
optional
:: a
-> Type a
-> Type a
optional x t = t { defaultValue = Just x }
string :: Type String
string = Type Right "STRING" Nothing
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),("yes",True),("no",False)]
e y = Left $ "Argument " ++ show y ++ " could not be recognised as a boolean."
natural :: Type Integer
natural = Type { name = "INT (natural)", parser = P.parseM P.natural "", defaultValue = Nothing }
integer :: Type Integer
integer = Type { name = "INT", parser = P.parseM P.integer "", defaultValue = Nothing }
directory :: Type FilePath
directory = Type { name = "DIR", parser = Right . stripTrailingSlash, defaultValue = Nothing }
where
stripTrailingSlash x = case viewR x of
Nothing -> ""
Just (i,l)
| l == '/' -> i
| otherwise -> x
file :: Type FilePath
file = string { name = "FILE" }
device :: Type FilePath
device = string { name = "DEVICE" }