1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
|
{- git autocorrection using Damerau-Levenshtein edit distance
-
- Copyright 2012-2024 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Git.AutoCorrect where
import Common
import Git.Types
import qualified Git.Config
import Text.EditDistance
import Control.Concurrent
import qualified Data.List.NonEmpty as NE
import Data.Char
{- 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 among 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 = restrictedDamerauLevenshteinDistance gitEditCosts 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 -> String -> (c -> String) -> NE.NonEmpty c -> Maybe Repo -> IO ()
prepare cmdname input showmatch matches r =
case readish . getcfg =<< r of
Just n
| n == 0 -> list
| n < 0 -> warn Nothing
| otherwise -> sleep n
Nothing -> case getcfg <$> r of
Just "prompt" -> prompt
Just "never" -> unknowncommand
Just "immediate" -> warn Nothing
_ -> list
where
getcfg = fromConfigValue . Git.Config.get "help.autocorrect" "0"
list = giveup $ unlines $
[ "Unknown command '" ++ input ++ "'"
, ""
, "Did you mean one of these?"
] ++ map (\m -> "\t" ++ showmatch m) (NE.toList matches)
warn :: Maybe Float -> IO ()
warn mdelaysec = hPutStr stderr $ unlines
[ warning
, case mdelaysec of
Nothing -> "Continuing under the assumption that you meant " ++ match ++ "."
Just sec -> "Continuing in " ++ show sec ++ " seconds, assuming that you meant " ++ match ++ "."
]
match = "'" ++ showmatch (NE.head matches) ++ "'"
warning = "WARNING: You called a " ++ cmdname ++ " command named '" ++
input ++ "', which does not exist."
sleep n = do
warn (Just (fromIntegral n / 10 :: Float))
threadDelay (n * 100000) -- deciseconds to microseconds
prompt = do
hPutStrLn stderr warning
hPutStr stderr ("Run " ++ match ++ " instead [y/N]? ")
hFlush stderr
resp <- headMaybe . map toLower <$> getLine
when (resp /= Just 'y') $
exitWith (ExitFailure 1)
unknowncommand = giveup $ "Unknown command '" ++ input ++ "'"
|
