aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--CmdLine.hs51
-rw-r--r--Git/AutoCorrect.hs71
-rw-r--r--GitAnnex.hs2
-rw-r--r--GitAnnexShell.hs2
-rw-r--r--debian/changelog4
-rw-r--r--debian/control1
-rw-r--r--doc/install.mdwn1
-rw-r--r--git-annex.cabal4
8 files changed, 115 insertions, 21 deletions
diff --git a/CmdLine.hs b/CmdLine.hs
index 05f7bfe2e..5330f40fc 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -1,6 +1,6 @@
{- git-annex command line parsing and dispatch
-
- - Copyright 2010 Joey Hess <joey@kitenet.net>
+ - Copyright 2010-2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@@ -21,6 +21,7 @@ import qualified Annex
import qualified Annex.Queue
import qualified Git
import qualified Git.Command
+import qualified Git.AutoCorrect
import Annex.Content
import Annex.Ssh
import Command
@@ -29,8 +30,8 @@ type Params = [String]
type Flags = [Annex ()]
{- Runs the passed command line. -}
-dispatch :: Params -> [Command] -> [Option] -> String -> IO Git.Repo -> IO ()
-dispatch args cmds commonoptions header getgitrepo = do
+dispatch :: Bool -> Params -> [Command] -> [Option] -> String -> IO Git.Repo -> IO ()
+dispatch fuzzyok allargs allcmds commonoptions header getgitrepo = do
setupConsole
r <- E.try getgitrepo :: IO (Either E.SomeException Git.Repo)
case r of
@@ -38,30 +39,46 @@ dispatch args cmds commonoptions header getgitrepo = do
Right g -> do
state <- Annex.new g
(actions, state') <- Annex.run state $ do
+ checkfuzzy
sequence_ flags
prepCommand cmd params
- tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdoneshot cmd]
+ tryRun state' cmd $ [startup] ++ actions ++ [shutdown $ cmdoneshot cmd]
where
- (flags, cmd, params) = parseCmd args cmds commonoptions header
+ err msg = msg ++ "\n\n" ++ usage header allcmds commonoptions
+ cmd = Prelude.head cmds
+ (cmds, name, args) = findCmd fuzzyok allargs allcmds err
+ (flags, params) = getOptCmd args cmd commonoptions err
+ checkfuzzy = when (length cmds > 1) $
+ inRepo $ Git.AutoCorrect.prepare name cmdname cmds
-{- Parses command line, and returns actions to run to configure flags,
- - the Command being run, and the remaining parameters for the command. -}
-parseCmd :: Params -> [Command] -> [Option] -> String -> (Flags, Command, Params)
-parseCmd argv cmds commonoptions header
- | isNothing name = err "missing command"
- | null matches = err $ "unknown command " ++ fromJust name
- | otherwise = check $ getOpt Permute (commonoptions ++ cmdoptions cmd) args
+{- Parses command line params far enough to find the Command to run, and
+ - returns the remaining params.
+ - Does fuzzy matching if necessary, which may result in multiple Commands. -}
+findCmd :: Bool -> Params -> [Command] -> (String -> String) -> ([Command], String, Params)
+findCmd fuzzyok argv cmds err
+ | isNothing name = error $ err "missing command"
+ | not (null exactcmds) = (exactcmds, fromJust name, args)
+ | fuzzyok && not (null inexactcmds) = (inexactcmds, fromJust name, args)
+ | otherwise = error $ err $ "unknown command " ++ fromJust name
where
(name, args) = findname argv []
findname [] c = (Nothing, reverse c)
findname (a:as) c
| "-" `isPrefixOf` a = findname as (a:c)
| otherwise = (Just a, reverse c ++ as)
- matches = filter (\c -> name == Just (cmdname c)) cmds
- cmd = Prelude.head matches
- check (flags, rest, []) = (flags, cmd, rest)
- check (_, _, errs) = err $ concat errs
- err msg = error $ msg ++ "\n\n" ++ usage header cmds commonoptions
+ exactcmds = filter (\c -> name == Just (cmdname c)) cmds
+ inexactcmds = case name of
+ Nothing -> []
+ Just n -> Git.AutoCorrect.fuzzymatches n cmdname cmds
+
+{- Parses command line options, and returns actions to run to configure flags
+ - and the remaining parameters for the command. -}
+getOptCmd :: Params -> Command -> [Option] -> (String -> String) -> (Flags, Params)
+getOptCmd argv cmd commonoptions err = check $
+ getOpt Permute (commonoptions ++ cmdoptions cmd) argv
+ where
+ check (flags, rest, []) = (flags, rest)
+ check (_, _, errs) = error $ err $ concat errs
{- Runs a list of Annex actions. Catches IO errors and continues
- (but explicitly thrown errors terminate the whole command).
diff --git a/Git/AutoCorrect.hs b/Git/AutoCorrect.hs
new file mode 100644
index 000000000..a18bf5619
--- /dev/null
+++ b/Git/AutoCorrect.hs
@@ -0,0 +1,71 @@
+{- git autocorrection using Damerau-Levenshtein edit distance
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Git.AutoCorrect where
+
+import Common
+import Git.Types
+import qualified Git.Config
+
+import Text.EditDistance
+import Control.Concurrent
+
+{- These are the same cost values as used in git. -}
+gitEditCosts :: EditCosts
+gitEditCosts = EditCosts
+ { deletionCosts = ConstantCost 4
+ , insertionCosts = ConstantCost 1
+ , substitutionCosts = ConstantCost 2
+ , transpositionCosts = ConstantCost 0
+ }
+
+{- Git's source calls this "an empirically derived magic number" -}
+similarityFloor :: Int
+similarityFloor = 7
+
+{- Finds inexact matches for the input amoung the choices.
+ - Returns an ordered list of good enough matches, or an empty list if
+ - nothing matches well. -}
+fuzzymatches :: String -> (c -> String) -> [c] -> [c]
+fuzzymatches input showchoice choices = fst $ unzip $
+ sortBy comparecost $ filter similarEnough $ zip choices costs
+ where
+ distance v = restrictedDamerauLevenshteinDistance gitEditCosts v input
+ costs = map (distance . showchoice) choices
+ comparecost a b = compare (snd a) (snd b)
+ similarEnough (_, cst) = cst < similarityFloor
+
+{- Takes action based on git's autocorrect configuration, in preparation for
+ - an autocorrected command being run. -}
+prepare :: String -> (c -> String) -> [c] -> Repo -> IO ()
+prepare input showmatch matches r =
+ case readish $ Git.Config.get "help.autocorrect" "0" r of
+ Just n
+ | n == 0 -> list
+ | n < 0 -> warn
+ | otherwise -> sleep n
+ Nothing -> list
+ where
+ list = error $ unlines $
+ [ "Unknown command '" ++ input ++ "'"
+ , ""
+ , "Did you mean one of these?"
+ ] ++ map (\m -> "\t" ++ showmatch m) matches
+ warn =
+ hPutStr stderr $ unlines
+ [ "WARNING: You called a command named '" ++
+ input ++ "', which does not exist."
+ , "Continuing under the assumption that you meant '" ++
+ showmatch (Prelude.head matches) ++ "'"
+ ]
+ sleep n = do
+ warn
+ hPutStrLn stderr $ unwords
+ [ "in"
+ , show (fromIntegral n / 10 :: Float)
+ , "seconds automatically..."]
+ threadDelay (n * 100000) -- deciseconds to microseconds
diff --git a/GitAnnex.hs b/GitAnnex.hs
index 4a0888b53..52886c308 100644
--- a/GitAnnex.hs
+++ b/GitAnnex.hs
@@ -131,4 +131,4 @@ header :: String
header = "Usage: git-annex command [option ..]"
run :: [String] -> IO ()
-run args = dispatch args cmds options header Git.Construct.fromCurrent
+run args = dispatch True args cmds options header Git.Construct.fromCurrent
diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs
index 3394bc477..0cf81f0e2 100644
--- a/GitAnnexShell.hs
+++ b/GitAnnexShell.hs
@@ -83,7 +83,7 @@ builtins = map cmdname cmds
builtin :: String -> String -> [String] -> IO ()
builtin cmd dir params = do
checkNotReadOnly cmd
- dispatch (cmd : filterparams params) cmds options header $
+ dispatch False (cmd : filterparams params) cmds options header $
Git.Construct.repoAbsPath dir >>= Git.Construct.fromAbsPath
external :: [String] -> IO ()
diff --git a/debian/changelog b/debian/changelog
index 274879f6e..0884f7574 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -3,6 +3,10 @@ git-annex (3.20120407) UNRELEASED; urgency=low
* bugfix: Adding a dotfile also caused all non-dotfiles to be added.
* bup: Properly handle key names with spaces or other things that are
not legal git refs.
+ * git-annex (but not git-annex-shell) supports the git help.autocorrect
+ configuration setting, doing fuzzy matching using the restricted
+ Damerau-Levenshtein edit distance, just as git does. This adds a build
+ dependency on the haskell edit-distance library.
-- Joey Hess <joeyh@debian.org> Sun, 08 Apr 2012 12:23:42 -0400
diff --git a/debian/control b/debian/control
index d8ba09f7c..2510e2b33 100644
--- a/debian/control
+++ b/debian/control
@@ -19,6 +19,7 @@ Build-Depends:
libghc-json-dev,
libghc-ifelse-dev,
libghc-bloomfilter-dev,
+ libghc-edit-distance-dev,
ikiwiki,
perlmagick,
git,
diff --git a/doc/install.mdwn b/doc/install.mdwn
index 0698a8bc4..04d961e00 100644
--- a/doc/install.mdwn
+++ b/doc/install.mdwn
@@ -36,6 +36,7 @@ To build and use git-annex, you will need:
* [json](http://hackage.haskell.org/package/json)
* [IfElse](http://hackage.haskell.org/package/IfElse)
* [bloomfilter](http://hackage.haskell.org/package/bloomfilter)
+ * [edit-distance](http://hackage.haskell.org/package/edit-distance)
* Shell commands
* [git](http://git-scm.com/)
* [uuid](http://www.ossp.org/pkg/lib/uuid/)
diff --git a/git-annex.cabal b/git-annex.cabal
index e047bb285..0f2858985 100644
--- a/git-annex.cabal
+++ b/git-annex.cabal
@@ -1,5 +1,5 @@
Name: git-annex
-Version: 3.20120406
+Version: 3.20120407
Cabal-Version: >= 1.8
License: GPL
Maintainer: Joey Hess <joey@kitenet.net>
@@ -32,7 +32,7 @@ Executable git-annex
unix, containers, utf8-string, network, mtl, bytestring, old-locale, time,
pcre-light, extensible-exceptions, dataenc, SHA, process, hS3, json, HTTP,
base >= 4.5, base < 5, monad-control, transformers-base, lifted-base,
- IfElse, text, QuickCheck >= 2.1, bloomfilter
+ IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance
Other-Modules: Utility.Touch
C-Sources: Utility/diskfree.c
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-10 20:38:14 +0000