module Options.OptionTypes where
import Data.Int
import Data.List (intercalate)
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import Data.Word
import qualified Filesystem.Path as Path
import qualified Filesystem.Path.Rules as Path
import Language.Haskell.TH
data Option a = Option
{
optionShortFlags :: [Char]
, optionLongFlags :: [String]
, optionDefault :: String
, optionType :: OptionType a
, optionDescription :: String
, optionGroup :: Group
}
data Group = Group
{ groupName :: Maybe String
, groupTitle :: String
, groupDescription :: String
}
data OptionType a = OptionType Type Bool (String -> Either String a) (Q Exp)
optionTypeBool :: OptionType Bool
optionTypeBool = OptionType (ConT ''Bool) True parseBool [| parseBool |]
parseBool :: String -> Either String Bool
parseBool s = case s of
"true" -> Right True
"false" -> Right False
_ -> Left (show s ++ " is not in {\"true\", \"false\"}.")
optionTypeString :: OptionType String
optionTypeString = OptionType (ConT ''String) False Right [| Right |]
optionTypeText :: OptionType Text.Text
optionTypeText = OptionType (ConT ''Text.Text) False parseText [| parseText |]
parseText :: String -> Either String Text.Text
parseText = Right . Text.pack
optionTypeFilePath :: OptionType Path.FilePath
optionTypeFilePath = OptionType (ConT ''Path.FilePath) False parsePath [| parsePath |]
parsePath :: String -> Either String Path.FilePath
#if defined(CABAL_OS_WINDOWS)
parsePath s = Right (Path.decodeString Path.windows s)
#elif __GLASGOW_HASKELL__ == 702
parsePath s = Right (Path.decodeString Path.posix_ghc702 s)
#else
parsePath s = Right (Path.decodeString Path.posix_ghc704 s)
#endif
parseInteger :: String -> Either String Integer
parseInteger s = parsed where
parsed = if valid
then Right (read s)
else Left (show s ++ " is not an integer.")
valid = case s of
[] -> False
'-':s' -> allDigits s'
_ -> allDigits s
allDigits = all (\c -> c >= '0' && c <= '9')
parseBoundedIntegral :: (Bounded a, Integral a) => String -> String -> Either String a
parseBoundedIntegral label = parse where
getBounds :: (Bounded a, Integral a) => (String -> Either String a) -> a -> a -> (Integer, Integer)
getBounds _ min' max' = (toInteger min', toInteger max')
(minInt, maxInt) = getBounds parse minBound maxBound
parse s = case parseInteger s of
Left err -> Left err
Right int -> if int < minInt || int > maxInt
then Left (show int ++ " is not within bounds [" ++ show minInt ++ ":" ++ show maxInt ++ "] of type " ++ label ++ ".")
else Right (fromInteger int)
parseFloat :: Read a => String -> Either String a
parseFloat s = case reads s of
[(x, "")] -> Right x
_ -> Left (show s ++ " is not a number.")
optionTypeInt :: OptionType Int
optionTypeInt = OptionType (ConT ''Int) False (parseBoundedIntegral "int") [| parseBoundedIntegral "int" |]
optionTypeInt8 :: OptionType Int8
optionTypeInt8 = OptionType (ConT ''Int8) False (parseBoundedIntegral "int8") [| parseBoundedIntegral "int8" |]
optionTypeInt16 :: OptionType Int16
optionTypeInt16 = OptionType (ConT ''Int16) False (parseBoundedIntegral "int16") [| parseBoundedIntegral "int16" |]
optionTypeInt32 :: OptionType Int32
optionTypeInt32 = OptionType (ConT ''Int32) False (parseBoundedIntegral "int32") [| parseBoundedIntegral "int32" |]
optionTypeInt64 :: OptionType Int64
optionTypeInt64 = OptionType (ConT ''Int64) False (parseBoundedIntegral "int64") [| parseBoundedIntegral "int64" |]
optionTypeWord :: OptionType Word
optionTypeWord = OptionType (ConT ''Word) False (parseBoundedIntegral "word") [| parseBoundedIntegral "word" |]
optionTypeWord8 :: OptionType Word8
optionTypeWord8 = OptionType (ConT ''Word8) False (parseBoundedIntegral "word8") [| parseBoundedIntegral "word8" |]
optionTypeWord16 :: OptionType Word16
optionTypeWord16 = OptionType (ConT ''Word16) False (parseBoundedIntegral "word16") [| parseBoundedIntegral "word16" |]
optionTypeWord32 :: OptionType Word32
optionTypeWord32 = OptionType (ConT ''Word32) False (parseBoundedIntegral "word32") [| parseBoundedIntegral "word32" |]
optionTypeWord64 :: OptionType Word64
optionTypeWord64 = OptionType (ConT ''Word64) False (parseBoundedIntegral "word64") [| parseBoundedIntegral "word64" |]
optionTypeInteger :: OptionType Integer
optionTypeInteger = OptionType (ConT ''Integer) False parseInteger [| parseInteger |]
optionTypeFloat :: OptionType Float
optionTypeFloat = OptionType (ConT ''Float) False parseFloat [| parseFloat |]
optionTypeDouble :: OptionType Double
optionTypeDouble = OptionType (ConT ''Double) False parseFloat [| parseFloat |]
optionTypeMaybe :: OptionType a -> OptionType (Maybe a)
optionTypeMaybe (OptionType valType unary valParse valParseExp) = OptionType (AppT (ConT ''Maybe) valType) unary
(parseMaybe valParse)
[| parseMaybe $valParseExp |]
parseMaybe :: (String -> Either String a) -> String -> Either String (Maybe a)
parseMaybe p s = case s of
"" -> Right (Nothing)
_ -> case p s of
Left err -> Left err
Right a -> Right (Just a)
$([d| |])
optionTypeSet :: Ord a
=> Char
-> OptionType a
-> OptionType (Set.Set a)
optionTypeSet sep (OptionType valType _ valParse valParseExp) = OptionType (AppT (ConT ''Set.Set) valType) False
(\s -> parseSet valParse (split sep s))
[| \s -> parseSet $valParseExp (split sep s) |]
optionTypeMap :: Ord k
=> Char
-> Char
-> OptionType k
-> OptionType v
-> OptionType (Map.Map k v)
optionTypeMap itemSep keySep (OptionType keyType _ keyParse keyParseExp) (OptionType valType _ valParse valParseExp) = OptionType (AppT (AppT (ConT ''Map.Map) keyType) valType) False
(\s -> parseMap keySep keyParse valParse (split itemSep s))
[| \s -> parseMap keySep $keyParseExp $valParseExp (split itemSep s) |]
parseList :: (String -> Either String a) -> [String] -> Either String [a]
parseList p = loop where
loop [] = Right []
loop (x:xs) = case p x of
Left err -> Left err
Right v -> case loop xs of
Left err -> Left err
Right vs -> Right (v:vs)
parseSet :: Ord a => (String -> Either String a) -> [String] -> Either String (Set.Set a)
parseSet p strs = case parseList p strs of
Left err -> Left err
Right xs -> Right (Set.fromList xs)
parseMap :: Ord k => Char -> (String -> Either String k) -> (String -> Either String v) -> [String] -> Either String (Map.Map k v)
parseMap keySep pKey pVal = parsed where
parsed strs = case parseList pItem strs of
Left err -> Left err
Right xs -> Right (Map.fromList xs)
pItem s = case break (== keySep) s of
(sKey, valAndSep) -> case valAndSep of
[] -> Left ("Map item " ++ show s ++ " has no value.")
_ : sVal -> case pKey sKey of
Left err -> Left err
Right key -> case pVal sVal of
Left err -> Left err
Right val -> Right (key, val)
split :: Char -> String -> [String]
split _ [] = []
split sep s0 = loop s0 where
loop s = let
(chunk, rest) = break (== sep) s
cont = chunk : loop (tail rest)
in if null rest then [chunk] else cont
$([d| |])
optionTypeList :: Char
-> OptionType a
-> OptionType [a]
optionTypeList sep (OptionType valType _ valParse valParseExp) = OptionType (AppT ListT valType) False
(\s -> parseList valParse (split sep s))
[| \s -> parseList $valParseExp (split sep s) |]
optionTypeEnum :: Enum a => Name -> [(String, a)] -> OptionType a
optionTypeEnum typeName values = do
let intlist = [(k, fromEnum v) | (k, v) <- values]
let setString = "{" ++ intercalate ", " [show k | (k, _) <- values] ++ "}."
OptionType (ConT typeName) False
(\s -> case lookup s values of
Just v -> Right v
Nothing -> Left (show s ++ " is not in " ++ setString))
[| \s -> case lookup s intlist of
Just v -> Right (toEnum v)
Nothing -> Left (show s ++ " is not in " ++ setString) |]