module Multiarg.Types
( ArgSpec(..)
, OptSpec(..)
, optSpec
, ShortName
, shortNameToChar
, shortName
, LongName
, longNameToString
, longName
, Word(..)
, OptName(..)
, optNameToString
, OptArg(..)
, ShortTail(..)
, isLong
, isShort
, wordToOptArg
, splitShortTail
) where
data ArgSpec a
= ZeroArg a
| OneArg (String -> a)
| TwoArg (String -> String -> a)
| ThreeArg (String -> String -> String -> a)
instance Functor ArgSpec where
fmap f (ZeroArg a) = ZeroArg (f a)
fmap f (OneArg g) = OneArg $ \a -> f (g a)
fmap f (TwoArg g) = TwoArg $ \a b -> f (g a b)
fmap f (ThreeArg g) = ThreeArg $ \a b c -> f (g a b c)
instance Show (ArgSpec a) where
show (ZeroArg _) = "ZeroArg"
show (OneArg _) = "OneArg"
show (TwoArg _) = "TwoArg"
show (ThreeArg _) = "ThreeArg"
data OptSpec a = OptSpec [ShortName] [LongName] (ArgSpec a)
deriving Show
instance Functor OptSpec where
fmap f (OptSpec s l p) = OptSpec s l (fmap f p)
optSpec
:: [Char]
-> [String]
-> ArgSpec a
-> OptSpec a
optSpec ss ls = OptSpec (map mkShort ss) (map mkLong ls)
where
mkShort s = case shortName s of
Nothing -> error $ "invalid short option name: " ++ [s]
Just n -> n
mkLong s = case longName s of
Nothing -> error $ "invalid long option name: " ++ s
Just n -> n
newtype ShortName = ShortName { shortNameToChar :: Char }
deriving (Eq, Ord, Show)
newtype LongName = LongName { longNameToString :: String }
deriving (Eq, Ord, Show)
shortName :: Char -> Maybe ShortName
shortName '-' = Nothing
shortName x = Just $ ShortName x
longName :: String -> Maybe LongName
longName s = case s of
[] -> Nothing
'-':_ -> Nothing
xs | '=' `elem` xs -> Nothing
| otherwise -> Just $ LongName xs
newtype OptName = OptName (Either ShortName LongName)
deriving (Eq, Ord, Show)
optNameToString :: OptName -> String
optNameToString (OptName ei) = case ei of
Left shrt -> '-' : shortNameToChar shrt : []
Right lng -> "--" ++ longNameToString lng
newtype Word = Word String
deriving (Eq, Ord, Show)
newtype OptArg = OptArg { optArgToString :: String }
deriving (Eq, Ord, Show)
isLong
:: Word
-> Maybe (LongName, Maybe OptArg)
isLong (Word ('-':'-':[])) = Nothing
isLong (Word ('-':'-':xs)) = Just (LongName optName, arg)
where
(optName, end) = span (/= '=') xs
arg = case end of
[] -> Nothing
_:rs -> Just . OptArg $ rs
isLong _ = Nothing
newtype ShortTail = ShortTail String
deriving (Eq, Ord, Show)
isShort
:: Word
-> Maybe (ShortName, ShortTail)
isShort (Word ('-':'-':_)) = Nothing
isShort (Word ('-':[])) = Nothing
isShort (Word ('-':x:xs)) = Just (ShortName x, ShortTail xs)
isShort _ = Nothing
wordToOptArg :: Word -> OptArg
wordToOptArg (Word t) = OptArg t
splitShortTail :: ShortTail -> Maybe (ShortName, ShortTail)
splitShortTail (ShortTail s) = case s of
[] -> Nothing
x:xs -> Just (ShortName x, ShortTail xs)