content: {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables #-}
  module Vimus.Command.Core (
    Command
  , commandName
  , commandAction
  , commandSynopsis
  , Argument (..)
  , ArgumentSpec (..)
  , noCompletion
  , argumentParser
  , Action (..)
  , VimusAction
  , runAction
  , command
  
  -- * Helpers for defining @Argument@ instances
  , missingArgument
  , invalidArgument
  , specificArgumentError
  
  -- * exported for testing
  , readParser
  , IsAction (..)
  ) where
  
  import           Control.Applicative
  import           Control.Monad (unless)
  import           Data.Char
  
  import           Vimus.Type (Vimus)
  import           Text.Read (readMaybe)
  import           Vimus.WindowLayout (WindowColor(..), defaultColor)
  import           UI.Curses (Color, black, red, green, yellow, blue, magenta, cyan, white)
  import           Vimus.Command.Type
  import           Vimus.Command.Help () -- for the (IsString Help) instance
  import           Vimus.Command.Completion
  import           Vimus.Command.Parser
  import           Vimus.Song.Format (SongFormat)
  import qualified Vimus.Song.Format as SongFormat
  import qualified Vimus.Song as Song
  
  runAction :: Action a -> String -> Either String a
  runAction action s = either (Left . show) (Right . fst) $ runParser (unAction action <* endOfInput) s
  
  
  class IsAction a b where
    toAction :: a -> Action b
    actionArguments :: a -> b -> [ArgumentInfo]
  
  instance IsAction a a where
  
    toAction a = Action $ do
      r <- takeInput
      unless (null r) $ do
        parserFail (SuperfluousInput r)
      return a
  
    actionArguments _ _ = []
  
  instance (Argument a, IsAction b c) => IsAction (a -> b) c where
    toAction action = Action $ (argumentParser <* skipWhile isSpace) >>= unAction . toAction . action
    actionArguments _ _ = mkArgumentInfo (argumentSpec :: (ArgumentSpec a)) : actionArguments (undefined :: b) (undefined :: c)
  
  -- | Get help text for given command.
  commandSynopsis :: Command -> String
  commandSynopsis c = unwords $ commandName c : map (\x -> "{" ++ argumentInfoName x ++ "}") (commandArguments c)
  
  -- | Define a command.
  command :: forall a . IsAction a (Vimus ()) => String -> Help -> a -> Command
  command name description action = Command name description (actionArguments action (undefined :: Vimus ())) (toAction action)
  
  -- | Create an ArgumentInfo from given ArgumentSpec.
  mkArgumentInfo :: ArgumentSpec a -> ArgumentInfo
  mkArgumentInfo arg = ArgumentInfo {
      argumentInfoName   = argumentSpecName arg
    , argumentInfoComplete = argumentSpecComplete arg
    }
  
  -- | Like ArgumentInfo, but includes a parser for the argument.
  data ArgumentSpec a = ArgumentSpec {
    argumentSpecName   :: String
  , argumentSpecComplete :: CompletionFunction
  , argumentSpecParser :: Parser a
  }
  
  -- | An argument.
  class Argument a where
    -- | A parser for this argument, together with a description.
    --
    -- The description provides information about the argument, that can be used
    -- for command-line completion and online help.
    --
    -- The parser can assume that the input is either empty or starts with a
    -- non-whitespace character.
    argumentSpec :: ArgumentSpec a
  
  
  argumentParser :: Argument a => Parser a
  argumentParser = argumentSpecParser argumentSpec
  
  argumentName :: forall a . Argument a => a -> String
  argumentName _ = argumentSpecName (argumentSpec :: ArgumentSpec a)
  
  -- | A parser for arguments in the Read class.
  readParser :: forall a . (Read a, Argument a) => Parser a
  readParser = mkParser readMaybe
  
  -- | A helper function for constructing argument parsers.
  mkParser :: forall a . (Argument a) => (String -> Maybe a) -> Parser a
  mkParser f = do
    r <- takeWhile1 (not . isSpace) <|> missingArgument (undefined :: a)
    maybe (invalidArgument (undefined ::a) r) return (f r)
  
  -- | A failing parser that indicates a missing argument.
  missingArgument :: Argument a => a -> Parser b
  missingArgument = parserFail . MissingArgument . argumentName
  
  -- | A failing parser that indicates an invalid argument.
  invalidArgument :: Argument a => a -> Value -> Parser b
  invalidArgument t = parserFail . InvalidArgument (argumentName t)
  
  -- | A failing parser that indicates a specific error.  It takes precedence
  -- over any other kind of error.
  specificArgumentError :: String -> Parser b
  specificArgumentError = parserFail . SpecificArgumentError
  
  instance Argument Int where
    argumentSpec = ArgumentSpec "int" noCompletion readParser
  
  instance Argument Integer where
    argumentSpec = ArgumentSpec "integer" noCompletion readParser
  
  instance Argument Float where
    argumentSpec = ArgumentSpec "float" noCompletion readParser
  
  instance Argument Double where
    argumentSpec = ArgumentSpec "double" noCompletion readParser
  
  instance Argument String where
    argumentSpec = ArgumentSpec "string" noCompletion (mkParser Just)
  
  instance Argument SongFormat where
    argumentSpec = ArgumentSpec "songformat" noCompletion (SongFormat.parser Song.metaQueries)
  
  -- | Create an ArgumentSpec from an association list.
  mkArgumentSpec :: Argument a => String -> [(String, a)] -> ArgumentSpec a
  mkArgumentSpec name values = ArgumentSpec name complete parser
    where
      parser   = mkParser ((`lookup` values) . map toLower)
      complete = completeOptions (map fst values)
  
  instance Argument WindowColor where
    argumentSpec = mkArgumentSpec "item" [
        ("main", MainColor)
      , ("ruler", RulerColor)
      , ("tab", TabColor)
      , ("input", InputColor)
      , ("playstatus", PlayStatusColor)
      , ("songstatus", SongStatusColor)
      , ("error", ErrorColor)
      , ("suggestions", SuggestionsColor)
      ]
  
  instance Argument Color where
    argumentSpec = mkArgumentSpec "color" [
        ("default", defaultColor)
      , ("black", black)
      , ("red", red)
      , ("green", green)
      , ("yellow", yellow)
      , ("blue", blue)
      , ("magenta", magenta)
      , ("cyan", cyan)
      , ("white", white)
      ]
  