1{- git autocorrection using Damerau-Levenshtein edit distance
2 -
3 - Copyright 2012 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE OverloadedStrings #-}
9
10module Git.AutoCorrect where
11
12import Common
13import Git.Types
14import qualified Git.Config
15
16import Text.EditDistance
17import Control.Concurrent
18
19{- These are the same cost values as used in git. -}
20gitEditCosts :: EditCosts
21gitEditCosts = EditCosts
22	{ deletionCosts = ConstantCost 4
23	, insertionCosts = ConstantCost 1
24	, substitutionCosts = ConstantCost 2
25	, transpositionCosts = ConstantCost 0
26	}
27
28{- Git's source calls this "an empirically derived magic number" -}
29similarityFloor :: Int
30similarityFloor = 7
31
32{- Finds inexact matches for the input among the choices.
33 - Returns an ordered list of good enough matches, or an empty list if
34 - nothing matches well. -}
35fuzzymatches :: String -> (c -> String) -> [c] -> [c]
36fuzzymatches input showchoice choices = fst $ unzip $
37	sortBy comparecost $ filter similarEnough $ zip choices costs
38  where
39	distance = restrictedDamerauLevenshteinDistance gitEditCosts input
40	costs = map (distance . showchoice) choices
41	comparecost a b = compare (snd a) (snd b)
42	similarEnough (_, cst) = cst < similarityFloor
43
44{- Takes action based on git's autocorrect configuration, in preparation for
45 - an autocorrected command being run.
46 -}
47prepare :: String -> (c -> String) -> [c] -> Maybe Repo -> IO ()
48prepare input showmatch matches r =
49	case readish . fromConfigValue . Git.Config.get "help.autocorrect" "0" =<< r of
50		Just n
51			| n == 0 -> list
52			| n < 0 -> warn Nothing
53			| otherwise -> sleep n
54		Nothing -> list
55  where
56	list = giveup $ unlines $
57		[ "Unknown command '" ++ input ++ "'"
58		, ""
59		, "Did you mean one of these?"
60		] ++ map (\m -> "\t" ++ showmatch m) matches
61	warn :: Maybe Float -> IO ()
62	warn mdelaysec = hPutStr stderr $ unlines
63		[ "WARNING: You called a git-annex command named '" ++
64		  input ++ "', which does not exist."
65		, case mdelaysec of
66			Nothing -> "Continuing under the assumption that you meant " ++ match
67			Just sec -> "Continuing in " ++ show sec ++ " seconds, assuming that you meant " ++ match
68		]
69	  where
70		match = "'" ++ showmatch (Prelude.head matches) ++ "'."
71	sleep n = do
72		warn (Just (fromIntegral n / 10 :: Float))
73		threadDelay (n * 100000) -- deciseconds to microseconds
74