    {-# LANGUAGE CPP #-}
    {-# LANGUAGE TemplateHaskell #-}

    -- |
    -- Module: Options.OptionTypes
    -- License: MIT
    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
    	{
    	-- | Short flags are a single character. When entered by a user,
    	-- they are preceded by a dash and possibly other short flags.
    	--
    	-- Short flags must be a letter or a number.
    	--
    	-- Example: An option with @optionShortFlags = [\'p\']@ may be set using:
    	--
    	-- >$ ./app -p 443
    	-- >$ ./app -p443
    	  optionShortFlags :: [Char]

    	-- | Long flags are multiple characters. When entered by a user, they
    	-- are preceded by two dashes.
    	--
    	-- Long flags may contain letters, numbers, @\'-\'@, and @\'_\'@.
    	--
    	-- Example: An option with @optionLongFlags = [\"port\"]@ may be set using:
    	--
    	-- >$ ./app --port 443
    	-- >$ ./app --port=443
    	, optionLongFlags :: [String]

    	-- | Options may have a default value. This will be parsed as if the
    	-- user had entered it on the command line.
    	, optionDefault :: String

    	-- | There are many types which an application or library might want
    	-- to use when designing their options. By default, options are
    	-- strings, but 'optionType' may be set to any supported type. See
    	-- the \"Option types\" section for a list of supported types.
    	, optionType :: OptionType a

    	-- | An option's description is used with the default implementation
    	-- of @--help@. It should be a short string describing what the option
    	-- does.
    	, optionDescription :: String

    	-- | Which group the option is in. See the \"Option groups\" section
    	-- for details.
    	, optionGroup :: Group
    	}

    data Group = Group
    	{ groupName :: Maybe String

    	-- | A short title for the group, which is used when printing
    	-- @--help@ output.
    	, groupTitle :: String

    	-- | A description of the group, which is used when printing
    	-- @--help@ output.
    	, groupDescription :: String
    	}

    -- | An option's type determines how the option will be parsed, and which
    -- Haskell type the parsed value will be stored as. There are many types
    -- available, covering most basic types and a few more advanced types.
    data OptionType a = OptionType Type Bool (String -> Either String a) (Q Exp)

    -- | Store an option as a @'Bool'@. The option's value must be either
    -- @\"true\"@ or @\"false\"@.
    --
    -- Boolean options are unary, which means that their value is optional when
    -- specified on the command line. If a flag is present, the option is set to
    -- True.
    --
    -- >$ ./app -q
    -- >$ ./app --quiet
    --
    -- Boolean options may still be specified explicitly by using long flags with
    -- the @--flag=value@ format. This is the only way to set a unary flag to
    -- @\"false\"@.
    --
    -- >$ ./app --quiet=true
    -- >$ ./app --quiet=false
    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
    	-- TODO: include option flag
    	_ -> Left (show s ++ " is not in {\"true\", \"false\"}.")

    -- | Store an option value as a @'String'@. The value is decoded to Unicode
    -- first, if needed. The value may contain non-Unicode bytes, in which case
    -- they will be stored using GHC 7.4's encoding for mixed-use strings.
    optionTypeString :: OptionType String
    optionTypeString = OptionType (ConT ''String) False Right [| Right |]

    -- | Store an option value as a @'Text.Text'@. The value is decoded to Unicode
    -- first, if needed. If the value cannot be decoded, the stored value may have
    -- the Unicode substitution character @'\65533'@ in place of some of the
    -- original input.
    optionTypeText :: OptionType Text.Text
    optionTypeText = OptionType (ConT ''Text.Text) False parseText [| parseText |]

    parseText :: String -> Either String Text.Text
    parseText = Right . Text.pack

    -- | Store an option value as a @'Path.FilePath'@.
    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.")

    -- | Store an option as an @'Int'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionTypeInt :: OptionType Int
    optionTypeInt = OptionType (ConT ''Int) False (parseBoundedIntegral "int") [| parseBoundedIntegral "int" |]

    -- | Store an option as an @'Int8'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionTypeInt8 :: OptionType Int8
    optionTypeInt8 = OptionType (ConT ''Int8) False (parseBoundedIntegral "int8") [| parseBoundedIntegral "int8" |]

    -- | Store an option as an @'Int16'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionTypeInt16 :: OptionType Int16
    optionTypeInt16 = OptionType (ConT ''Int16) False (parseBoundedIntegral "int16") [| parseBoundedIntegral "int16" |]

    -- | Store an option as an @'Int32'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionTypeInt32 :: OptionType Int32
    optionTypeInt32 = OptionType (ConT ''Int32) False (parseBoundedIntegral "int32") [| parseBoundedIntegral "int32" |]

    -- | Store an option as an @'Int64'@. The option value must be an integer /n/
    -- such that @'minBound' <= n <= 'maxBound'@.
    optionTypeInt64 :: OptionType Int64
    optionTypeInt64 = OptionType (ConT ''Int64) False (parseBoundedIntegral "int64") [| parseBoundedIntegral "int64" |]

    -- | Store an option as a @'Word'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionTypeWord :: OptionType Word
    optionTypeWord = OptionType (ConT ''Word) False (parseBoundedIntegral "word") [| parseBoundedIntegral "word" |]

    -- | Store an option as a @'Word8'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionTypeWord8 :: OptionType Word8
    optionTypeWord8 = OptionType (ConT ''Word8) False (parseBoundedIntegral "word8") [| parseBoundedIntegral "word8" |]

    -- | Store an option as a @'Word16'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionTypeWord16 :: OptionType Word16
    optionTypeWord16 = OptionType (ConT ''Word16) False (parseBoundedIntegral "word16") [| parseBoundedIntegral "word16" |]

    -- | Store an option as a @'Word32'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionTypeWord32 :: OptionType Word32
    optionTypeWord32 = OptionType (ConT ''Word32) False (parseBoundedIntegral "word32") [| parseBoundedIntegral "word32" |]

    -- | Store an option as a @'Word64'@. The option value must be a positive
    -- integer /n/ such that @0 <= n <= 'maxBound'@.
    optionTypeWord64 :: OptionType Word64
    optionTypeWord64 = OptionType (ConT ''Word64) False (parseBoundedIntegral "word64") [| parseBoundedIntegral "word64" |]

    -- | Store an option as an @'Integer'@. The option value must be an integer.
    -- There is no minimum or maximum value.
    optionTypeInteger :: OptionType Integer
    optionTypeInteger = OptionType (ConT ''Integer) False parseInteger [| parseInteger |]

    -- | Store an option as a @'Float'@. The option value must be a number. Due to
    -- the imprecision of floating-point math, the stored value might not exactly
    -- match the user's input. If the user's input is out of range for the
    -- @'Float'@ type, it will be stored as @Infinity@ or @-Infinity@.
    optionTypeFloat :: OptionType Float
    optionTypeFloat = OptionType (ConT ''Float) False parseFloat [| parseFloat |]

    -- | Store an option as a @'Double'@. The option value must be a number. Due to
    -- the imprecision of floating-point math, the stored value might not exactly
    -- match the user's input. If the user's input is out of range for the
    -- @'Double'@ type, it will be stored as @Infinity@ or @-Infinity@.
    optionTypeDouble :: OptionType Double
    optionTypeDouble = OptionType (ConT ''Double) False parseFloat [| parseFloat |]

    -- | Store an option as a @'Maybe'@ of another type. The value will be
    -- @Nothing@ if the option was not provided or is an empty string.
    --
    -- @
    --'option' \"optTimeout\" (\\o -> o
    --    { 'optionLongFlags' = [\"timeout\"]
    --    , 'optionType' = 'optionTypeMaybe' 'optionTypeInt'
    --    })
    -- @
    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| |])

    -- | Store an option as a @'Set.Set'@, using another option type for the
    -- elements. The separator should be a character that will not occur within
    -- the values, such as a comma or semicolon.
    --
    -- Duplicate elements in the input are permitted.
    --
    -- @
    --'option' \"optNames\" (\\o -> o
    --    { 'optionLongFlags' = [\"names\"]
    --    , 'optionDefault' = \"Alice;Bob;Charles\"
    --    , 'optionType' = 'optionTypeSet' \';\' 'optionTypeString'
    --    })
    -- @
    optionTypeSet :: Ord a
                  => Char -- ^ Element separator
                  -> OptionType a -- ^ Element type
                  -> 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) |]

    -- | Store an option as a 'Map.Map', using other option types for the keys and
    -- values.
    --
    -- The item separator is used to separate key/value pairs from eachother. It
    -- should be a character that will not occur within either the keys or values.
    --
    -- The value separator is used to separate the key from the value. It should
    -- be a character that will not occur within the keys. It may occur within the
    -- values.
    --
    -- Duplicate keys in the input are permitted. The final value for each key is
    -- stored.
    --
    -- @
    --'option' \"optNames\" (\\o -> o
    --    { 'optionLongFlags' = [\"names\"]
    --    , 'optionDefault' = \"name=Alice;hometown=Bucharest\"
    --    , 'optionType' = 'optionTypeMap' \';\' \'=\' 'optionTypeString' 'optionTypeString'
    --    })
    -- @
    optionTypeMap :: Ord k
                  => Char -- ^ Item separator
                  -> Char -- ^ Key/Value separator
                  -> OptionType k -- ^ Key type
                  -> OptionType v -- ^ Value type
                  -> 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| |])

    -- | Store an option as a list, using another option type for the elements.
    -- The separator should be a character that will not occur within the values,
    -- such as a comma or semicolon.
    --
    -- @
    --'option' \"optNames\" (\\o -> o
    --    { 'optionLongFlags' = [\"names\"]
    --    , 'optionDefault' = \"Alice;Bob;Charles\"
    --    , 'optionType' = 'optionTypeList' \';\' 'optionTypeString'
    --    })
    -- @
    optionTypeList :: Char -- ^ Element separator
                   -> OptionType a -- ^ Element type
                   -> 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) |]

    -- | Store an option as one of a set of enumerated values. The option
    -- type must be defined in a separate file.
    --
    -- >-- MyApp/Types.hs
    -- >data Mode = ModeFoo | ModeBar
    -- >    deriving (Enum)
    --
    -- @
    -- -- Main.hs
    --import MyApp.Types
    --
    --'defineOptions' \"MainOptions\" $ do
    --    'option' \"optMode\" (\\o -> o
    --        { 'optionLongFlags' = [\"mode\"]
    --        , 'optionDefault' = \"foo\"
    --        , 'optionType' = 'optionTypeEnum' ''Mode
    --            [ (\"foo\", ModeFoo)
    --            , (\"bar\", ModeBar)
    --            ]
    --        })
    -- @
    --
    -- >$ ./app
    -- >Running in mode ModeFoo
    -- >$ ./app --mode=bar
    -- >Running in mode ModeBar
    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)
    			-- TODO: include option flag and available values
    			Nothing -> Left (show s ++ " is not in " ++ setString) |]