content: {-# LANGUAGE CPP                        #-}
  {-# LANGUAGE DataKinds                  #-}
  {-# LANGUAGE DefaultSignatures          #-}
  {-# LANGUAGE ExistentialQuantification  #-}
  {-# LANGUAGE FlexibleContexts           #-}
  {-# LANGUAGE FlexibleInstances          #-}
  {-# LANGUAGE GADTs                      #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE KindSignatures             #-}
  {-# LANGUAGE MultiWayIf                 #-}
  {-# LANGUAGE PolyKinds                  #-}
  {-# LANGUAGE RankNTypes                 #-}
  {-# LANGUAGE ScopedTypeVariables        #-}
  {-# LANGUAGE TupleSections              #-}
  {-# LANGUAGE TypeFamilies               #-}
  {-# LANGUAGE TypeOperators              #-}
  
  -- | Declarative options parser
  
  module Options.Declarative (
      -- * Command type
      IsCmd,
      Cmd,
      logStr,
      getVerbosity,
      getLogger,
  
      -- * Argument definition tools
      Option(..),
      Flag,
      Arg,
  
      -- * Defining argument types
      ArgRead(..),
      Def,
  
      -- * Subcommands support
      Group(..),
      SubCmd, subCmd,
  
      -- * Run a command
      run, run_,
      ) where
  
  import           Control.Applicative
  import           Control.Monad
  import           Control.Monad.Catch
  import           Control.Monad.Fix
  import           Control.Monad.Reader
  import           Data.List
  import           Data.Maybe
  import           Data.Monoid
  import           Data.Proxy
  import           GHC.TypeLits
  import           System.Console.GetOpt
  import           System.Environment
  import           System.Exit
  import           System.IO
  import           Text.Read
  
  #if !MIN_VERSION_base(4,13,0)
  import           Control.Monad.Fail
  #endif
  
  -- | Command line option
  class Option a where
      -- | Type of the argument' value
      type Value a :: *
      -- | Get the argument' value
      get :: a -> Value a
  
  -- | Named argument
  newtype Flag (shortNames  :: Symbol  )
               (longNames   :: [Symbol])
               (placeholder :: Symbol  )
               (help        :: Symbol  )
               a
      = Flag { getFlag :: a }
  
  -- | Unnamed argument
  newtype Arg (placeholder :: Symbol) a = Arg { getArg :: a }
  
  instance ArgRead a => Option (Flag _a _b _c _d a) where
      type Value (Flag _a _b _c _d a) = Unwrap a
      get = unwrap . getFlag
  
  instance Option (Arg _a a) where
      type Value (Arg _a a) = a
      get = getArg
  
  -- | Command line option's annotated types
  class ArgRead a where
      -- | Type of the argument
      type Unwrap a :: *
      type Unwrap a = a
  
      -- | Get the argument's value
      unwrap :: a -> Unwrap a
      default unwrap :: a ~ Unwrap a => a -> Unwrap a
      unwrap = id
  
      -- | Argument parser
      argRead :: [String] -> Maybe a
      default argRead :: Read a => [String] -> Maybe a
      argRead ss = getLast $ mconcat $ Last . readMaybe <$> ss
  
      -- | Indicate this argument is mandatory
      needArg :: Proxy a -> Bool
      needArg _ = True
  
  instance ArgRead Int
  
  instance ArgRead Integer
  
  instance ArgRead Double
  
  instance {-# OVERLAPPING #-} ArgRead String where
      argRead [] = Nothing
      argRead xs = Just $ last xs
  
  instance ArgRead Bool where
      argRead []    = Just False
      argRead ["f"] = Just False
      argRead ["t"] = Just True
      argRead _     = Nothing
  
      needArg _ = False
  
  instance ArgRead a => ArgRead (Maybe a) where
      argRead [] = Just Nothing
      argRead xs = Just <$> argRead xs
  
  instance {-# OVERLAPPABLE #-} ArgRead a => ArgRead [a] where
      argRead xs = Just $ mapMaybe (argRead . (:[])) xs
  
  -- | The argument which has default value
  newtype Def (defaultValue :: Symbol) a =
      Def { getDef :: a }
  
  instance (KnownSymbol defaultValue, ArgRead a) => ArgRead (Def defaultValue a) where
      type Unwrap (Def defaultValue a) = Unwrap a
      unwrap = unwrap . getDef
  
      argRead s =
          let s' = case s of
                   [] -> [symbolVal (Proxy :: Proxy defaultValue)]
                   v  -> v
          in Def <$> argRead s'
  
  -- | Command
  newtype Cmd (help :: Symbol) a =
      Cmd (ReaderT Int IO a)
      deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadFix, MonadPlus, MonadFail, MonadThrow, MonadCatch)
  
  -- | Output string when the verbosity level is greater than or equal to `logLevel`
  logStr :: Int         -- ^ Verbosity Level
         -> String      -- ^ Message
         -> Cmd help ()
  logStr logLevel msg = do
      l <- getLogger
      l logLevel msg
  
  -- | Return the verbosity level ('--verbosity=n')
  getVerbosity :: Cmd help Int
  getVerbosity = Cmd ask
  
  -- | Retrieve the logger function
  getLogger :: MonadIO m => Cmd a (Int -> String -> m ())
  getLogger = do
      verbosity <- getVerbosity
      return $ \logLevel msg -> when (verbosity >= logLevel) $ liftIO $ putStrLn msg
  
  -- | Command group
  data Group =
      Group
      { groupHelp :: String
      , groupCmds :: [SubCmd]
      }
  
  -- | Sub command
  data SubCmd = forall c. IsCmd c => SubCmd String c
  
  -- | Command class
  class IsCmd c where
      getCmdHelp  :: c -> String
      default getCmdHelp :: (c ~ (a -> b), IsCmd b) => c -> String
      getCmdHelp f = getCmdHelp $ f undefined
  
      getOptDescr :: c -> [OptDescr (String, String)]
      default getOptDescr :: (c ~ (a -> b), IsCmd b) => c -> [OptDescr (String, String)]
      getOptDescr f = getOptDescr $ f undefined
  
      getUsageHeader :: c -> String -> String
      default getUsageHeader :: (c ~ (a -> b), IsCmd b) => c -> String -> String
      getUsageHeader f = getUsageHeader $ f undefined
  
      getUsageFooter :: c -> String -> String
      default getUsageFooter :: (c ~ (a -> b), IsCmd b) => c -> String -> String
      getUsageFooter f = getUsageFooter $ f undefined
  
      runCmd :: c
             -> [String]            -- ^ Command name
             -> Maybe String        -- ^ Version
             -> [(String, String)]  -- ^ Options
             -> [String]            -- ^ Non options
             -> [String]            -- ^ Unrecognized options
             -> IO ()
  
  class KnownSymbols (s :: [Symbol]) where
      symbolVals :: Proxy s -> [String]
  
  instance KnownSymbols '[] where
      symbolVals _ = []
  
  instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where
      symbolVals _ = symbolVal (Proxy :: Proxy s) : symbolVals (Proxy :: Proxy ss)
  
  instance ( KnownSymbol shortNames
           , KnownSymbols longNames
           , KnownSymbol placeholder
           , KnownSymbol help
           , ArgRead a
           , IsCmd c )
           => IsCmd (Flag shortNames longNames placeholder help a -> c) where
      getOptDescr f =
          let flagName = head $
                         symbolVals (Proxy :: Proxy longNames) ++
                         [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ]
          in Option
              (symbolVal (Proxy :: Proxy shortNames))
              (symbolVals (Proxy :: Proxy longNames))
              (if needArg (Proxy :: Proxy a)
               then ReqArg
                    (flagName, )
                    (symbolVal (Proxy :: Proxy placeholder))
               else NoArg
                    (flagName, "t"))
              (symbolVal (Proxy :: Proxy help))
          : getOptDescr (f undefined)
  
      runCmd f name mbver options nonOptions unrecognized =
          let flagName = head $
                         symbolVals (Proxy :: Proxy longNames) ++
                         [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ]
              mbs = map snd $ filter ((== flagName) . fst) options
          in case (argRead mbs, mbs) of
              (Nothing, []) ->
                  errorExit name $ "flag must be specified: --" ++ flagName
              (Nothing, s:_) ->
                  errorExit name $ "bad argument: --" ++ flagName ++ "=" ++ s
              (Just arg, _) ->
                  runCmd (f $ Flag arg) name mbver options nonOptions unrecognized
  
  instance {-# OVERLAPPABLE #-}
           ( KnownSymbol placeholder, ArgRead a, IsCmd c )
           => IsCmd (Arg placeholder a -> c) where
      getUsageHeader = getUsageHeaderOne (Proxy :: Proxy placeholder)
  
      runCmd = runCmdOne
  
  instance {-# OVERLAPPING #-}
           ( KnownSymbol placeholder, IsCmd c )
           => IsCmd (Arg placeholder String -> c) where
      getUsageHeader = getUsageHeaderOne (Proxy :: Proxy placeholder)
  
      runCmd = runCmdOne
  
  getUsageHeaderOne :: ( KnownSymbol placeholder, ArgRead a, IsCmd c )
                    => Proxy placeholder -> (Arg placeholder a -> c) -> String -> String
  getUsageHeaderOne proxy f prog =
      " " ++ symbolVal proxy ++ getUsageHeader (f undefined) prog
  
  runCmdOne f name mbver options nonOptions unrecognized =
      case nonOptions of
          [] -> errorExit name "not enough arguments"
          (opt: rest) ->
              case argRead [opt] of
                  Nothing ->
                      errorExit name $ "bad argument: " ++ opt
                  Just arg ->
                      runCmd (f $ Arg arg) name mbver options rest unrecognized
  
  instance {-# OVERLAPPING #-}
           ( KnownSymbol placeholder, ArgRead a, IsCmd c )
           => IsCmd (Arg placeholder [a] -> c) where
      getUsageHeader f prog =
          " " ++ symbolVal (Proxy :: Proxy placeholder) ++ getUsageHeader (f undefined) prog
  
      runCmd f name mbver options nonOptions unrecognized =
          case traverse argRead $ (:[]) <$> nonOptions of
              Nothing ->
                  errorExit name $ "bad arguments: " ++ unwords nonOptions
              Just opts ->
                  runCmd (f $ Arg opts) name mbver options [] unrecognized
  
  instance KnownSymbol help => IsCmd (Cmd help ()) where
      getCmdHelp  _ = symbolVal (Proxy :: Proxy help)
      getOptDescr _ = []
  
      getUsageHeader _ _ = ""
      getUsageFooter _ _ = ""
  
      runCmd (Cmd m) name _ options nonOptions unrecognized =
          case (options, nonOptions, unrecognized) of
              (_, [], []) -> do
                  let verbosityLevel = fromMaybe 0 $ do
                          s <- lookup "verbose" options
                          if | null s         -> return 1
                             | all (== 'v') s -> return $ length s + 1
                             | otherwise      -> readMaybe s
                  runReaderT m verbosityLevel
  
              _ -> do
                  forM_ nonOptions $ \o ->
                      errorExit name $ "unrecognized argument '" ++ o ++ "'"
                  forM_ unrecognized $ \o ->
                      errorExit name $ "unrecognized option '" ++ o ++ "'"
                  exitFailure
  
  instance IsCmd Group where
      getCmdHelp = groupHelp
      getOptDescr _ = []
  
      getUsageHeader _ _ = " <COMMAND> [ARGS...]"
      getUsageFooter g _ = unlines $
          [ ""
          , "Commands: "
          ] ++
          [ "  " ++ name ++ replicate (12 - length name) ' ' ++ getCmdHelp c
          | SubCmd name c <- groupCmds g
          ]
  
      runCmd g name mbver _options (cmd: nonOptions) unrecognized =
          case [ SubCmd subname c | SubCmd subname c <- groupCmds g, subname == cmd ] of
             [SubCmd subname c] ->
                 run' c (name ++ [subname]) mbver (nonOptions ++ unrecognized)
             _ ->
                 errorExit name $ "unrecognized command: " ++ cmd
      runCmd _ name _ _ _ _ =
          errorExit name "no command given"
  
  -- | Make a sub command
  subCmd :: IsCmd c => String -> c -> SubCmd
  subCmd = SubCmd
  
  -- runner
  
  run' :: IsCmd c => c -> [String] -> Maybe String -> [String] -> IO ()
  run' cmd name mbver args = do
      let optDescr =
              getOptDescr cmd
              ++ [ Option "?" ["help"]    (NoArg ("help",    "t")) "display this help and exit" ]
              ++ [ Option "V" ["version"] (NoArg ("version", "t")) "output version information and exit"
                 | isJust mbver ]
              ++ [ Option "v" ["verbose"] (OptArg (\arg -> ("verbose", fromMaybe "" arg)) "n") "set verbosity level" ]
  
          prog     = unwords name
          verMsg   = prog ++ maybe "" (" version " ++) mbver
          header = "Usage: " ++ prog ++ " [OPTION...]" ++ getUsageHeader cmd prog ++ "\n" ++
                   "  " ++ getCmdHelp cmd ++ "\n\n" ++
                   "Options:"
  
          usage    =
              usageInfo header optDescr ++
              getUsageFooter cmd prog
  
      case getOpt' RequireOrder optDescr args of
          (options, nonOptions, unrecognized, errors)
              | not $ null errors ->
                    errorExit name $ intercalate ", " errors
              | isJust (lookup "help" options) -> do
                    putStr usage
                    exitSuccess
              | isJust (lookup "version" options) -> do
                    putStrLn verMsg
                    exitSuccess
              | otherwise ->
                    runCmd cmd name mbver options nonOptions unrecognized
  
  -- | Run a command with specifying program name and version
  run :: IsCmd c => String -> Maybe String -> c -> IO ()
  run progName progVer cmd =
      run' cmd [progName] progVer =<< getArgs
  
  -- | Run a command
  run_ :: IsCmd c => c -> IO ()
  run_ cmd = do
      progName <- getProgName
      run progName Nothing cmd
  
  errorExit :: [String] -> String -> IO ()
  errorExit name msg = do
      let prog = unwords name
      hPutStrLn stderr $ prog ++ ": " ++ msg
      hPutStrLn stderr $ "Try '" ++ prog ++ " --help' for more information."
      exitFailure
  