module System.Console.Argument
(
Type (Type,parser,name,defaultValue)
, optional
, string
, boolean
, directory
, file
, device
, natural
, integer
, 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) }
option
:: (a -> s)
-> [Char]
-> [String]
-> Type a
-> String
-> GetOpt.OptDescr (Either String s)
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
optional
:: a
-> Type a
-> Type a
optional x t = t { defaultValue = Just x }
string :: Type String
string = Type (const 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)]
e y = Left $ "Argument " ++ show y ++ " could not be recognised as a boolean."
natural :: Type Integer
natural = Type { name = "INT (natural)", parser = const (P.parseM P.natural ""), defaultValue = Nothing }
integer :: Type Integer
integer = Type { name = "INT", parser = const (P.parseM P.integer ""), defaultValue = Nothing }
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
file :: Type FilePath
file = string { name = "FILE" }
device :: Type FilePath
device = string { name = "DEVICE" }