autocorrection

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.

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