cmdlib-0.1: testcmd.hs

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

import Data.Char
import System.Console.CmdLib hiding ( Record )

data Flag = Name String | Author String | RemoveTestDirectory Bool
          | Test Bool | All | Pipe | Interactive Bool
          | Matches String | Patches String                       -- Matching
          | SshCm Bool | HttpPipelining Bool | RemoteDarcs String -- Network
          | TrustTimes Bool                                       -- Advanced
    deriving (Typeable, Data, Show, Eq)

matching = Matches +% Patches
network = SshCm +% HttpPipelining +% RemoteDarcs

ann cmd f opts = do putStrLn $ "command: " ++ cmd
                    putStr $ unlines $ map disp f
                    putStrLn $ "non-options: " ++ unwords opts
                 where disp x = drop 1 (hyphenate ctor) ++ ":" ++ rest
                         where ctor = takeWhile (/=' ') (show x)
                               rest = dropWhile (/=' ') (show x)
                       hyphenate (x:xs) | isUpper x = '-' : toLower x : hyphenate xs
                                        | otherwise = x : hyphenate xs
                       hyphenate [] = []

instance Attributes Flag where
  attributes _ =
    Name        %> Help "specify the name of patch" %+ short 'm' %+ ArgHelp "NAME"    %%
    Author      %> Help "specify author identity"                                     %%
    Test        %> Help "run the test script"                                         %%
    All         %> Help "answer yes to all patches" %+ short 'a'                      %%
    Pipe        %> Help "ask user interactively for the patch metadata"               %%
    Interactive %> Help "prompt user interactively" %+ Default True                   %%

    Group "Matching patches" <% matching                                              %%
    Matches     %> Help "select patches matching PATTERN" %+ ArgHelp "PATTERN"        %%
    Patches     %> Help "select patches matching REGEXP" %+ ArgHelp "REGEXP"          %%

    Group "Network options" <% network                                                %%
    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 "Advanced options" <% RemoveTestDirectory +% TrustTimes                     %%
    RemoveTestDirectory
                %> Help "remove the test directory" %+ Default True                   %%
    TrustTimes  %> Help "trust the file modification times" %+ Default True           %%

    everywhere disable

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

data ShowRepo deriving Typeable
data ShowContents deriving Typeable

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

instance Command ShowCmd (ADT 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 (ADT Flag) where
  options _ =  enable <% Name +% Author +% Test +% RemoveTestDirectory +% All +% Pipe +%
                         Interactive +% TrustTimes
  summary _ = "Create a patch from unrecorded changes."

  run _ = ann "record"

instance Command Pull (ADT Flag) where
  options _  =  enable <% matching +% network +% TrustTimes
  summary _  = "Copy and apply patches from another repository to this one."
  synopsis _ = "darcs pull [OPTION]... [REPOSITORY]..."

  run _ = ann "pull"

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

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

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

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

main = getArgs >>= dispatch commands