cmdlib-0.2: testrec.hs

{-# LANGUAGE ScopedTypeVariables, EmptyDataDecls, MultiParamTypeClasses,
             DeriveDataTypeable, FlexibleInstances #-}
module Main where
import Prelude hiding ( readFile, all, last )

import Data.Char
import Data.List ( isPrefixOf )
import Data.List.Split ( splitOn )
import System.Console.CmdLib hiding ( Record, disable )
import qualified System.Console.CmdLib as Cmd

data ApplyAs = ApplyAs String | ApplyAsSelf deriving (Typeable, Data, Show, Eq)
data Conflicts = Mark | Allow | Disallow deriving (Typeable, Data, Show, Eq)
data Posthook = Always | Never | Prompt deriving (Typeable, Data, Show, Eq)

newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord, Typeable, Data, Show)
data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord, Typeable, Data, Show)

data Flag = Flag
  { test :: Bool
  , onlyToFiles :: Bool
  , removeTestDirectory :: Bool

  -- matching several
  , all :: Bool
  , matches :: String
  , patches :: String
  , tags :: String

  -- matching one
  , match :: String
  , patch :: String
  , tag :: String

  -- matching range
  , toMatch :: String
  , fromMatch :: String
  , fromPatch :: String
  , toPatch :: String
  , fromTag :: String
  , toTag :: String

  -- matching numerically
  , last :: Int
  , maxCount :: Int
  , index :: (Int,Int)

  , context :: AbsolutePath

  -- bundle sending/output
  , to :: String
  , cc :: String
  , output :: AbsolutePathOrStd
  , outputAutoName :: Maybe AbsolutePath
  , subject :: String
  , inReplyTo :: String
  , sendmailCmd :: String

  -- recording
  , author :: String
  , name :: String
  , logfile :: AbsolutePath
  , deleteLogfile :: Bool
  , pipe :: Bool

  -- amend
  , keepDate :: Bool

  -- add
  , recursive :: Bool
  , dateTrick :: Bool
  , boring :: Bool
  , caseOk :: Bool
  , reservedOk :: Bool

  -- push/pull/apply
  , setDefault :: Bool
  , applyAs :: ApplyAs
  , conflicts :: Conflicts
  , skipConflicts :: Bool
  , externalMerge :: String
  , setScriptsExecutable :: Bool

  -- repo combinators
  , union :: Bool
  , complement :: Bool
  , intersection :: Bool

  -- output
  , number :: Bool
  , count :: Bool

  -- misc
  , distName :: String
  , trustTimes :: Bool
  , dryRun :: Bool
  , disable :: Bool
  , promptForDependencies :: Bool

  -- hooks
  , runPosthook :: Posthook
  , posthook :: String

  -- network
  , sshCm :: Bool
  , httpPipelining :: Bool
  , remoteDarcs :: String

  -- verbosity & debugging
  , timings :: Bool
  , verbosity :: Int
  , debug :: Bool
  , debugHttp :: Bool

  } deriving (Typeable, Data, Show, Eq)

matchSeveral = matches +% patches +% tags +% all
matchRange = toMatch +% fromMatch +% toPatch +% fromPatch +% toTag +% fromTag
matchOne = match +% patch +% tag
matchNum = maxCount +% last +% index
apply = conflicts +% skipConflicts +% externalMerge +% setScriptsExecutable
posthooks = posthook +% runPosthook
reposet = intersection +% complement +% union

network = sshCm +% httpPipelining +% remoteDarcs

ann cmd f opts = do putStrLn $ "command = " ++ cmd
                    putStrLn $ disp (unwords . drop 1 . words $ show f)
                    putStrLn $ "non-options = " ++ unwords opts
                 where disp ('{':r) = disp r
                       disp ('}':r) = disp r
                       disp (',':' ':r) = '\n':disp r
                       disp (x:xs) = x:disp xs
                       disp [] = []

instance Attributes Flag where
  readFlag _ = readCommon <+< applyas <+< interval
    where applyas "self" = ApplyAsSelf
          applyas x | "user" `isPrefixOf` x = ApplyAs (drop 5 x)
                    | otherwise = error $ "Error decoding --apply-as argument " ++
                                          x ++ ". Expected \"self\" or \"user:STRING\""
          interval :: String -> (Int, Int)
          interval str = case splitOn "-" str of
            [x, y] -> (read x, read y)
            _ -> error $ "Error parsing interval " ++ str

  attributes _ =

    group "Options" [
      name   %> [ short 'm', Help "specify the name of patch", ArgHelp "NAME" ],
      author %> [ short 'A', Help "specify author identity" ],
      test   %> [            Help "run the test script" ],
      all    %> [ short 'a', Help "answer yes to all patches",
                             InvLong ["interactive", "no-all"] ],
      pipe   %> [            Help "ask user interactively for the patch metadata" ] %+ simple
    ] %%

    group "Matching patches" [
      matches    %> [ Help "select patches matching PATTERN", ArgHelp "PATTERN" ],
      patches    %> [ Help "select patches matching REGEXP",  ArgHelp "REGEXP"  ],
      tags       %> [ Help "select tags matching REGEXP",     ArgHelp "REGEXP"  ]
    ] %%

    group "Network options" [
      sshCm          %> Help "use SSH ControlMaster feature",
      remoteDarcs    %> [ Help "name/path of the remote darcs binary"
                        , Default "darcs", ArgHelp "BINARY" ],
      httpPipelining %> [ Help "enable HTTP pipelining", Default True ]
    ] %%

    group "Applying patches" [
      conflicts      %> [ Help "how to treat conflicts", ArgHelp "allow|mark|disallow" ],
      externalMerge  %> [ Help "use external tool to merge conflicts", ArgHelp "COMMAND" ],
      skipConflicts  %> Help "filter out any patches that would create conflicts"
    ] %%

    group "Advanced options" [
      removeTestDirectory %> [ Help "remove the test directory", Default True ],
      trustTimes          %> [ Help "trust the file modification times", Default True
                             , InvLong ["ignore-times", "no-trust-times"] ],
      disable             %> Help "disable this command"
    ] %%

    group "Verbosity control" [
      verbosity %> Help "set verbosity level",
      debug     %> Help "give debug output",
      debugHttp %> Help "give debug output for libcurl (HTTP)",
      timings   %> Help "provide debugging timings information"
    ] %%

    enable <% verbosity +% debug +% disable %% everywhere Cmd.disable
    %% everywhere (Default (-1 :: Int, -1 :: Int))
    %% everywhere (Default $ AbsolutePath "")
    %% everywhere (Default $ APStd)
    %% everywhere (Default $ (Nothing :: Maybe AbsolutePath))
    %% everywhere (Default ApplyAsSelf)
    %% everywhere (Default Mark)
    %% everywhere (Default Never)

data Record = Record deriving Typeable
data Pull = Pull deriving Typeable
data Push = Push deriving Typeable
data Changes = Changes deriving Typeable
data Apply = Apply deriving Typeable
data ShowCmd = ShowCmd deriving Typeable

data ShowRepo deriving Typeable
data ShowContents deriving Typeable

show_subcommands = (cmd :: ShowRepo) %: (cmd :: ShowContents)

instance Command ShowCmd (Cmd.Record Flag) where
  summary      _ = "Show information which is stored by darcs."
  help         _ = "Subcommands:\n" ++ helpCommands show_subcommands
  cmdname      _ = "show" -- override
  supercommand _ = True

  run _ f opts = dispatch [] show_subcommands opts

instance Command Record (Cmd.Record Flag) where
  options _ =  enable <% name +% author +% test +% removeTestDirectory +% all +% pipe
                      +% trustTimes
  summary _ = "Create a patch from unrecorded changes."

  run _ = ann "record"

instance Command Pull (Cmd.Record Flag) where
  options _  =  enable <% matchSeveral +% network +% trustTimes +% apply +% posthooks
                       +% promptForDependencies +% reposet
  summary _  = "Copy and apply patches from another repository to this one."
  synopsis _ = "darcs pull [OPTION]... [REPOSITORY]..."

  run _ = ann "pull"

instance Command Push (Cmd.Record Flag) where
  options _  =  enable <% matchSeveral +% network
  summary _  = "Copy and apply patches from this repository to another one."
  run _ = ann "push"

instance Command Changes (Cmd.Record Flag) where
  options _  =  enable <% matchSeveral +% matchRange +% matchNum
  summary _  = "List patches in the repository."
  run     _  = ann "changes"

instance Command Apply (Cmd.Record Flag) where
  options _  =  enable <% matchSeveral +% matchRange +% matchNum +% apply
  summary _  = "Apply a patch bundle created by `darcs send'."
  run     _  = ann "apply"

instance Command ShowRepo (Cmd.Record Flag) where
  cmdname      _ = "repo"
  summary      _ = "Show repository summary information"
  run _          = ann "show repo"

instance Command ShowContents (Cmd.Record Flag) where
  cmdname      _ = "contents"
  summary      _ = "Outputs a specific version of a file."
  run _          = ann "show contents"

commands = commandGroup "Copying changes between the working copy and the repository"
           Record
        %: commandGroup "Copying patches between repositories with working copy update"
                   (Pull %: Push %: Apply)
        %: commandGroup "Querying the repository"
                   (Changes %: ShowCmd)

main = getArgs >>= dispatch [] commands