module HFlags (
defineCustomFlag,
defineEQFlag,
FlagType(..),
initHFlags,
arguments
) where
import Control.Exception
import Control.Monad
import Data.Char
import Data.Function
import Data.List
import Data.IORef
import Data.Maybe
import qualified Data.Map as Map
import Data.Map (Map, (!))
import qualified Data.Text
import Language.Haskell.TH
import System.Console.GetOpt
import System.Environment
import System.IO
import System.IO.Unsafe
import System.Exit
import Prelude
data FlagData = FlagData
{ fName :: String
, fShort :: Maybe Char
, fDefValue :: String
, fArgHelp :: String
, fDescription :: String
, fModuleName :: String
, fCheck :: IO ()
}
class Flag a where
getFlagData :: a -> FlagData
defineCustomFlag :: String -> ExpQ -> String -> ExpQ -> ExpQ -> String -> Q [Dec]
defineCustomFlag name' defQ argHelp readQ showQ description =
do (name, short) <- case () of
() | length name' == 0 -> fail "Flag's without names are not supported."
| length name' == 1 -> return (name', Just $ head name')
| length name' == 2 -> return (name', Nothing)
| name' !! 1 == ':' -> return (drop 2 name', Just $ head name')
| otherwise -> return (name', Nothing)
defE <- defQ
flagType <- case defE of
SigE _ flagType -> return flagType
_ -> fail "Default value for defineCustomFlag has to be an explicitly typed expression, like (12 :: Int)"
moduleName <- fmap loc_module location
let accessorName = mkName $ "flags_" ++ name
let dataName = mkName $ "HFlag_" ++ name
dataDec <- return $ DataD [] dataName [] [] []
instanceDec <- instanceD
(return [])
(appT (conT ''Flag) (conT dataName))
[funD 'getFlagData [clause [wildP]
(normalB
[| FlagData
name
short
$(appE showQ defQ)
argHelp
description
moduleName
(evaluate $(varE accessorName) >> return ())
|]) []]]
flagPragmaDec <- return $ PragmaD $ InlineP accessorName NoInline FunLike AllPhases
flagSig <- return $ SigD accessorName flagType
flagDec <- funD accessorName [clause [] (normalB [| case True of
True -> $(appE readQ [| lookupFlag name moduleName |])
False -> $(defQ) |]) []]
return [dataDec, instanceDec, flagPragmaDec, flagSig, flagDec]
defineEQFlag :: String -> ExpQ -> String -> String -> Q [Dec]
defineEQFlag name defQ argHelp description =
defineCustomFlag name defQ argHelp [| read |] [| show |] description
class FlagType t where
defineFlag :: String -> t -> String -> Q [Dec]
boolShow :: Bool -> String
boolShow True = "true"
boolShow False = "false"
boolRead :: String -> Bool
boolRead = boolRead' . map toLower
where
boolRead' ('y':_) = True
boolRead' ('t':_) = True
boolRead' ('1':_) = True
boolRead' ('n':_) = False
boolRead' ('f':_) = False
boolRead' ('0':_) = False
boolRead' s = error $ "Unable to parse string as boolean: " ++ s
instance FlagType Bool where
defineFlag n v = defineCustomFlag n [| v :: Bool |] "BOOL" [| boolRead |] [| boolShow |]
instance FlagType Int where
defineFlag n v = defineEQFlag n [| v :: Int |] "INT"
instance FlagType Integer where
defineFlag n v = defineEQFlag n [| v :: Integer |] "INTEGER"
instance FlagType String where
defineFlag n v = defineCustomFlag n [| v :: String |] "STRING" [| id |] [| id |]
instance FlagType Double where
defineFlag n v = defineEQFlag n (sigE (litE (RationalL (toRational v))) [t| Double |] ) "DOUBLE"
instance FlagType Data.Text.Text where
defineFlag n v =
let s = Data.Text.unpack v
in defineCustomFlag n [| Data.Text.pack s :: Data.Text.Text |] "TEXT" [| Data.Text.pack |] [| Data.Text.unpack |]
globalHFlags :: IORef (Maybe (Map String String))
globalHFlags = unsafePerformIO $ newIORef Nothing
globalArguments :: IORef (Maybe [String])
globalArguments = unsafePerformIO $ newIORef Nothing
arguments :: [String]
arguments = unsafePerformIO $ do
margs <- readIORef globalArguments
case margs of
Just args -> return $ args
Nothing -> error $ "HFlags.arguments used before calling initHFlags."
lookupFlag :: String -> String -> String
lookupFlag fName fModuleName = unsafePerformIO $ do
flags <- readIORef globalHFlags
case flags of
Just flagmap -> return $ flagmap ! fName
Nothing -> error $ "Flag " ++ fName ++ " (from module: " ++ fModuleName ++ ") used before calling initHFlags."
initFlags :: String -> [FlagData] -> [String] -> IO [String]
initFlags progDescription flags args = do
doHelp
let (opts, nonopts, errs) | doUndefok = (\(a,b,_,c) -> (a,b,c)) $ getOpt' Permute getOptFlags args
| otherwise = getOpt Permute getOptFlags args
when (not $ null errs) $ do
mapM_ (hPutStrLn stderr) errs
exitFailure
let defaults = map (\FlagData { fName, fDefValue } -> (fName, fDefValue)) flags
env <- getEnvironment
let envDefaults = map (mapFst (fromJust . stripPrefix "HFLAGS_")) $ filter ((isPrefixOf "HFLAGS_") . fst) env
writeIORef globalHFlags $ Just $ Map.fromList $ defaults ++ envDefaults ++ opts
writeIORef globalArguments $ Just nonopts
mapM_ forceFlag flags
return nonopts
where
mapFst f (a, b) = (f a, b)
helpOption = Option "h" ["help", "usage", "version"] (NoArg ("", "")) "Display help and version information."
doHelp = case getOpt Permute [helpOption] args of
([], _, _) -> return ()
_ -> do putStrLn $ usageInfo (progDescription ++ "\n") (helpOption:undefokOption:getOptFlags)
exitFailure
undefokOption = Option "" ["undefok"] (NoArg ("", "")) "Whether to fail on unrecognized command line options."
doUndefok = case getOpt Permute [undefokOption] args of
([], _, _) -> False
_ -> True
flagToGetOptArgDescr FlagData { fName, fArgHelp }
| fArgHelp == "BOOL" = OptArg (\a -> (fName, maybe "True" id a)) fArgHelp
| otherwise = ReqArg (\a -> (fName, a)) fArgHelp
getOptFlags = flip map flags $ \flagData@(FlagData { fName, fShort, fDefValue, fDescription, fModuleName }) ->
Option (maybeToList fShort) [fName] (flagToGetOptArgDescr flagData)
(fDescription ++ " (default: " ++ fDefValue ++ ", from module: " ++ fModuleName ++ ")")
forceFlag FlagData { fName, fModuleName, fCheck } =
fCheck `catch`
(\e -> error $
"Error while parsing argument for flag: " ++ fName ++
", value: " ++ lookupFlag fName fModuleName ++
", error: " ++ show (e :: ErrorCall))
initHFlags :: String -> ExpQ
initHFlags progDescription = do
ClassI _ instances <- reify ''Flag
case dupes instances of
[] -> return ()
(dupe:_) -> fail ("Multiple definition of flag " ++ (snd $ head dupe) ++
", modules: " ++ (show $ map fst dupe))
[| getArgs >>= initFlags progDescription $(listE $ map instanceToOptTuple instances ) |]
where
instanceToOptTuple (InstanceD _ (AppT _ inst) _) = [| getFlagData (undefined :: $(return inst)) |]
instanceToOptTuple _ = error "Shouldn't happen"
instanceToModuleNamePair (InstanceD _ (AppT _ (ConT inst)) _) =
let (flagrev, modrev) = span (/= '.') $ reverse $ show inst
modName = reverse $ drop 1 modrev
flag = drop 1 $ dropWhile (/= '_') $ reverse $ flagrev
in (modName, flag)
instanceToModuleNamePair _ = error "Shouldn't happen"
dupes instances = filter ((>1) . length) $
groupBy ((==) `on` snd) $
sortBy (compare `on` snd) $
map instanceToModuleNamePair instances