werge/Opts.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RecordWildCards #-}

module Opts where

import Data.Bool
import Data.List
import Data.Maybe
import Data.Version (showVersion)
import Options.Applicative
import Paths_werge (version)

data Tokenizer
  = TokenizeFilter String
  | TokenizeCharCategory
  | TokenizeCharCategorySimple
  deriving (Show)

tokenizer =
  asum
    [ TokenizeFilter
        <$> strOption
              (long "tok-filter"
                 <> short 'F'
                 <> metavar "FILTER"
                 <> help "external program to separate the text to tokens")
    , flag'
        TokenizeCharCategorySimple
        (long "simple-tokens"
           <> short 'i'
           <> help
                "use wider character class to separate the tokens (results in larger tokens and ignores case)")
    , flag'
        TokenizeCharCategory
        (long "full-tokens"
           <> short 'I'
           <> help
                "separate characters by all known character classes (default)")
    , pure TokenizeCharCategory
    ]

data Spaces
  = SpacesNormal
  | SpacesConflict
  | SpacesMy
  | SpacesOld
  | SpacesYour
  deriving (Show, Eq)

spaceMode x
  | x `isPrefixOf` "normal" = Right SpacesNormal
  | x `isPrefixOf` "conflict" = Right SpacesConflict
  | x `isPrefixOf` "my" = Right SpacesMy
  | x `isPrefixOf` "old" = Right SpacesOld
  | x `isPrefixOf` "your" = Right SpacesYour
  | otherwise =
    Left
      $ "could not parse value `"
          ++ x
          ++ "', use one of `normal', `conflict', `my', `old', and `your'"

data Config = Config
  { cfgTokenizer :: Tokenizer
  , cfgSpaces :: Spaces
  , cfgContext :: Int
  , cfgZealous :: Bool
  , cfgLabelStart :: String
  , cfgLabelMyOld :: String
  , cfgLabelOldYour :: String
  , cfgLabelEnd :: String
  , cfgResolveSpaces :: Bool
  , cfgResolveOverlaps :: Bool
  , cfgResolveSeparate :: Bool
  } deriving (Show)

config = do
  cfgTokenizer <- tokenizer
  cfgSpaces <-
    option (eitherReader spaceMode)
      $ long "spaces"
          <> short 's'
          <> metavar "(normal|conflict|my|old|your)"
          <> help
               "mode of merging the space-only changes; instead of usual resolution one may choose to always conflict or to default the space from the source files (default: normal)"
          <> value SpacesNormal
  cfgContext <-
    option auto
      $ long "expand-context"
          <> short 'C'
          <> metavar "N"
          <> value 1
          <> showDefault
          <> help
               "Consider changes that are at most N tokens apart to be a single change. Zero may cause bad resolutions of near conflicting edits."
  cfgZealous <-
    asum
      [ flag' False $ long "no-zeal" <> help "avoid zealous mode (default)"
      , flag' True
          $ long "zeal"
              <> short 'z'
              <> help
                   "try to zealously minify conflicts, potentially resolving them"
      , pure False
      ]
  color <-
    flag False True
      $ long "color"
          <> short 'G'
          <> help
               "use shorter, gaily colored output markers by default (requires ANSI color support; good for terminals or `less -R')"
  labelStart <-
    optional . strOption
      $ long "label-start"
          <> metavar "\"<<<<<\""
          <> help "label for beginning of the conflict"
  labelMyOld <-
    optional . strOption
      $ long "label-mo"
          <> metavar "\"|||||\""
          <> help "separator of local edits and original"
  labelOldYour <-
    optional . strOption
      $ long "label-oy"
          <> metavar "\"=====\""
          <> help "separator of original and other people's edits"
  labelEnd <-
    optional . strOption
      $ long "label-end"
          <> metavar "\">>>>>\""
          <> help "label for end of the conflict"
  cfgResolveOverlaps <-
    fmap not . switch
      $ long "conflict-overlaps" <> help "do not resolve overlapping changes"
  cfgResolveSeparate <-
    fmap not . switch
      $ long "conflict-separate"
          <> help "do not resolve separate (non-overlapping) changes"
  pure
    Config
      { cfgLabelStart =
          bool "<<<<<" "\ESC[1;37m<\ESC[0;31m" color `fromMaybe` labelStart
      , cfgLabelMyOld =
          bool "|||||" "\ESC[1;37m|\ESC[1;30m" color `fromMaybe` labelMyOld
      , cfgLabelOldYour =
          bool "=====" "\ESC[1;37m=\ESC[0;32m" color `fromMaybe` labelOldYour
      , cfgLabelEnd =
          bool ">>>>>" "\ESC[1;37m>\ESC[0m" color `fromMaybe` labelEnd
      , ..
      }

data Command
  = CmdDiff3
      { d3my :: FilePath
      , d3old :: FilePath
      , d3your :: FilePath
      }
  | CmdGitMerge
      { gmFiles :: Maybe [FilePath]
      , gmDoAdd :: Bool
      }
  deriving (Show)

cmdDiff3 = do
  d3my <- strArgument $ metavar "MYFILE" <> help "version with local edits"
  d3old <- strArgument $ metavar "OLDFILE" <> help "original file version"
  d3your <-
    strArgument $ metavar "YOURFILE" <> help "version with other people's edits"
  pure CmdDiff3 {..}

cmdGitMerge = do
  gmFiles <-
    asum
      [ fmap Just . some
          $ strArgument
          $ metavar "UNMERGED"
              <> help "unmerged git file (can be specified repeatedly)"
      , flag'
          Nothing
          (long "unmerged"
             <> short 'u'
             <> help "process all files marked as unmerged by git")
      ]
  gmDoAdd <-
    asum
      [ flag'
          True
          (long "add"
             <> short 'a'
             <> help "run `git add' for fully merged files")
      , flag' False (long "no-add" <> help "prevent running `git add'")
      , pure False
      ]
  pure CmdGitMerge {..}

-- TODO have some option to output the (partially merged) my/old/your files so
-- that folks can continue with external program or so (such as meld)
cmd =
  hsubparser
    $ mconcat
        [ command "merge"
            $ info cmdDiff3
            $ progDesc "diff3-style merge of two changesets"
        , command "git"
            $ info cmdGitMerge
            $ progDesc "automerge unmerged files in git conflict"
        ]

parseOpts :: IO (Config, Command)
parseOpts =
  customExecParser (prefs helpShowGlobals)
    $ info
        (liftA2 (,) config cmd
           <**> helper
           <**> simpleVersioner (showVersion version))
        (fullDesc
           <> header
                "werge -- blanks-friendly mergetool for tiny interdwindled changes"
           <> (footer $ "werge is a free software, use it accordingly."))