Args.hs

-- This file is part of khph.
--
-- Copyright 2016 Bryan Gardiner <bog@khumba.net>
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE CPP #-}

-- | Command-line argument parsing.
module Khph.Args (
  description,
  CommonArgs (..),
  Request (..),
  parseFlags,
  ) where

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$), (<*), (*>))
#endif
import Data.Functor.Identity (Identity)
import Khph.Util
import System.Console.CmdArgs.Explicit (
  Flag,
  HelpFormat,
  Mode,
  flagArg,
  flagBool,
  flagHelpFormat,
  flagNone,
  flagReq,
  helpText,
  mode,
  processArgs,
  )
import System.Console.CmdArgs.Text (TextFormat, showText)
import Text.Parsec ((<|>), (<?>), ParsecT, anyToken, choice, eof, many, parse, try)

-- | A summary string describing khph.
description :: String
description = "Command-line file tagging and organization tool"

data CommonArgs = CommonArgs
  { caProject :: String
  , caPrintSummaries :: Bool
  , caPrintFileActions :: Bool
  }

data Request =
    FileCount
  | List {listQuery :: Maybe String}
  | TagList {tagListSpec :: Maybe String}
  | TagCreate {tags :: [String]}
  | TagAdd {tags :: [String], files :: [FilePath]}
  | TagRemove {tags :: [String], files :: [FilePath]}
  | Realize {tag :: String, query :: String, tagsInName :: Bool}
  | Help
  deriving (Show)

data Term = TermFlag String | TermValue String
          deriving (Eq)

instance Show Term where
  show (TermFlag str) = str
  show (TermValue str) = concat ["non-flag argument \"", str, "\""]

data Flags = Flags
  { fProject :: String
  , fTerms :: [Term]
  , fPrintSummaries :: Bool
  , fPrintFileActions :: Bool
  , fHelp :: Maybe (HelpFormat, TextFormat)
  , fTagsInName :: Bool
  } deriving (Show)

defaultFlags = Flags
  { fProject = ""
  , fTerms = []
  , fPrintSummaries = True
  , fPrintFileActions = False
  , fHelp = Nothing
  , fTagsInName = False
  }

projectUpdater :: String -> Flags -> Either String Flags
projectUpdater value flags = case fProject flags of
  "" -> Right flags {fProject = value}
  _ -> Left "--project flag specified multiple times."

printSummariesUpdater :: Bool -> Flags -> Flags
printSummariesUpdater value flags = flags {fPrintSummaries = value}

printFileActionsUpdater :: Bool -> Flags -> Flags
printFileActionsUpdater value flags = flags {fPrintFileActions = value}

tagsInNameUpdater :: Bool -> Flags -> Flags
tagsInNameUpdater value flags = flags {fTagsInName = value}

-- | Creates a cmdargs 'Flag' that parses a no-argument @--flag@ with the given
-- name into a 'Term' in 'fTerms'
flagTerm :: String -> String -> Flag Flags
flagTerm name help =
  flagNone [name] (\flags -> flags {fTerms = TermFlag ('-':'-':name) : fTerms flags}) help

parameters :: Mode Flags
parameters =
  mode "khph" defaultFlags
  (unlines [ description
           , "    ><>"
           , "Exactly one command must be provided.  Command arguments indicate"
           , "their syntax in their description.  Other arguments are optional."
           , "    ><>"
           , "ENTRY : /foo/bar    - Absolute, refers to <project>/foo/bar."
           , "        foo/bar     - Absolute, refers to <project>/foo/bar."
           , "        ./foo/bar   - Relative, refers to $PWD/foo/bar."
           , "        foo         - By-name, refers to all entries named foo."
           , "TAG : Same as ENTRY, except by-name results match tags instead."
           , "QUERY : A predicate to apply to entries.  See README.md."
           ])
  (flagArg (\x f -> Right f {fTerms = TermValue x : fTerms f}) "COMMAND")
  [ flagHelpFormat $ \helpFormat textFormat f -> f {fHelp = Just (helpFormat, textFormat)}
  , flagReq ["p", "project"] projectUpdater "PATH" "The project root directory or project file."
  , flagBool ["print-summaries"] printSummariesUpdater "Print out summaries of actions performed."
  , flagBool ["print-file-actions"] printFileActionsUpdater "Print out individual file actions."
  , flagBool ["tags-in-name"] tagsInNameUpdater "Include tags in --realize'd link names."
  , flagTerm "list" $
    concat [ "--list [QUERY]: Lists one hard link (else soft link) for each "
           , "entry matching the query (defaults to matching all entries)."
           ]
  , flagTerm "tags" "--tags [TAG]: Lists all tags (matching the given tag specification)."
  , flagTerm "tag-create" $
    concat [ "--tag-create TAG...: Creates the named tags, if they don't exist.  "
           , "TAG must not be by-name."
           ]
  , flagTerm "tag-add" "--tag-add TAG... --files ENTRY...: Adds tags to entries."
  , flagTerm "tag-remove" "--tag-remove TAG... --files ENTRY...: Removes tags from entries."
  , flagTerm "realize" $
    concat [ "--realize TAG QUERY: Creates TAG, removes it from all entries, then "
           , "assigns entries matching QUERY to it."
           ]
  , flagTerm "files" ""
  ]

postProcessFlags :: Flags -> Flags
postProcessFlags flags = flags {fTerms = reverse $ fTerms flags}

parseFlags :: IO (Either String (CommonArgs, Maybe Request))
parseFlags = do
  flags <- fmap postProcessFlags $ processArgs parameters
  let commonArgs =
        CommonArgs
        { caProject = fProject flags
        , caPrintSummaries = fPrintSummaries flags
        , caPrintFileActions = fPrintFileActions flags
        }
  case fHelp flags of
    Just (helpFormat, textFormat) -> do
      printHelp helpFormat textFormat
      return $ Right (commonArgs, Just Help)
    Nothing -> case parse requestParser "command line arguments" $ fTerms flags of
      Left err -> return $ Left $ show err
      Right maybeRequest ->
        let postprocessedRequest = case maybeRequest of
              Just request@(Realize {}) ->
                Just $ request {tagsInName = fTagsInName flags}
              _ -> maybeRequest
        in return $ Right (commonArgs, postprocessedRequest)
  -- TODO Validate common args.

  where printHelp helpFormat textFormat =
          putStrLn $ showText textFormat $ helpText [] helpFormat parameters

type TermParser = ParsecT [Term] () Identity

valueParser :: TermParser String
valueParser =
  try (do t <- anyToken
          case t of
            TermValue str -> return str
            _ -> fail "") <?>
  "non-flag argument"

requestParser :: TermParser (Maybe Request)
requestParser =
  Nothing <$ eof <|>
  Just <$> choice [ listParser
                  , tagListParser
                  , tagCreateParser
                  , tagAddParser
                  , tagRemoveParser
                  , realizeParser
                  ]

listParser :: TermParser Request
listParser =
  parserEq (TermFlag "--list") *>
  (List {listQuery = Nothing} <$ eof <|>
   do q <- valueParser <* eof
      return List {listQuery = Just q})

tagListParser :: TermParser Request
tagListParser =
  parserEq (TermFlag "--tags") *>
  (TagList {tagListSpec = Nothing} <$ eof <|>
   do spec <- valueParser <* eof
      return TagList {tagListSpec = Just spec})

tagCreateParser :: TermParser Request
tagCreateParser = do
  parserEq $ TermFlag "--tag-create"
  tags <- many valueParser
  return TagCreate {tags = tags}

tagAddParser :: TermParser Request
tagAddParser = do
  parserEq $ TermFlag "--tag-add"
  tags <- many valueParser
  parserEq $ TermFlag "--files"
  files <- many valueParser
  eof
  return TagAdd {tags = tags, files = files}

tagRemoveParser :: TermParser Request
tagRemoveParser = do
  parserEq $ TermFlag "--tag-remove"
  tags <- many valueParser
  parserEq $ TermFlag "--files"
  files <- many valueParser
  eof
  return TagRemove {tags = tags, files = files}

realizeParser :: TermParser Request
realizeParser = do
  parserEq $ TermFlag "--realize"
  tag <- valueParser
  query <- valueParser
  return Realize {tag = tag, query = query, tagsInName = False}