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