Commit 41529934 authored by Andrzej Rybczak's avatar Andrzej Rybczak Committed by Mikhail Glushenkov
Browse files

Merge the same items and refine a list of alternatives

parent 74bc5ba6
......@@ -66,7 +66,7 @@ import Distribution.Client.Utils
( makeRelativeToCwd )
import Data.List
( nub, nubBy, stripPrefix, partition, intercalate, sortBy, groupBy )
( nubBy, stripPrefix, partition, intercalate, sortBy, sortOn, groupBy )
import Data.Maybe
( listToMaybe, maybeToList )
import Data.Either
......@@ -83,6 +83,8 @@ import qualified Data.Map as Map.Lazy
import qualified Data.Map as Map
import Data.Map (Map)
#endif
import qualified Data.Set as Set
import Control.Arrow ((&&&))
import Control.Monad
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..), (<$>))
......@@ -101,7 +103,8 @@ import System.Directory
, getCurrentDirectory )
import System.FilePath
( (</>), (<.>), normalise )
import Text.EditDistance
( defaultEditCosts, restrictedDamerauLevenshteinDistance )
-- ------------------------------------------------------------
-- * User build targets
......@@ -498,15 +501,33 @@ resolveBuildTarget ppinfo opinfo userTarget =
expected = [ (thing, got)
| (_, MatchErrorExpected thing got)
<- map (innerErr Nothing) errs ]
nosuch = [ (inside, thing, got, alts)
| (inside, MatchErrorNoSuch thing got alts)
<- map (innerErr Nothing) errs ]
nosuch = Map.foldrWithKey genResults [] $ Map.fromListWith Set.union $
[ ((inside, thing, got), Set.fromList alts)
| (inside, MatchErrorNoSuch thing got alts) <- map (innerErr Nothing) errs
]
genResults (inside, thing, got) alts acc = (
inside
, thing
, got
, take maxResults
$ map fst
$ takeWhile distanceLow
$ sortOn snd
$ map addLevDist
$ Set.toList alts
) : acc
where
addLevDist = id &&& restrictedDamerauLevenshteinDistance defaultEditCosts got
distanceLow (_, dist) = dist < length got `div` 2
maxResults = 3
innerErr _ (MatchErrorIn kind thing m)
= innerErr (Just (kind,thing)) m
innerErr c m = (c,m)
-- | The various ways that trying to resolve a 'UserBuildTarget' to a
-- 'BuildTarget' can fail.
--
......@@ -1502,11 +1523,6 @@ nubMatchesBy _ (NoMatch d msgs) = NoMatch d msgs
nubMatchesBy eq (ExactMatch d xs) = ExactMatch d (nubBy eq xs)
nubMatchesBy eq (InexactMatch d xs) = InexactMatch d (nubBy eq xs)
nubMatchErrors :: Match a -> Match a
nubMatchErrors (NoMatch d msgs) = NoMatch d (nub msgs)
nubMatchErrors (ExactMatch d xs) = ExactMatch d xs
nubMatchErrors (InexactMatch d xs) = InexactMatch d xs
-- | Lift a list of matches to an exact match.
--
exactMatches, inexactMatches :: [a] -> Match a
......@@ -1530,15 +1546,14 @@ tryEach = exactMatches
-- you may have an 'Ambiguous' match with several possibilities.
--
findMatch :: Match a -> MaybeAmbiguous a
findMatch match =
case nubMatchErrors match of
NoMatch _ msgs -> None msgs
ExactMatch _ [x] -> Unambiguous x
InexactMatch _ [x] -> Unambiguous x
ExactMatch _ [] -> error "findMatch: impossible: ExactMatch []"
InexactMatch _ [] -> error "findMatch: impossible: InexactMatch []"
ExactMatch _ xs -> Ambiguous True xs
InexactMatch _ xs -> Ambiguous False xs
findMatch match = case match of
NoMatch _ msgs -> None msgs
ExactMatch _ [x] -> Unambiguous x
InexactMatch _ [x] -> Unambiguous x
ExactMatch _ [] -> error "findMatch: impossible: ExactMatch []"
InexactMatch _ [] -> error "findMatch: impossible: InexactMatch []"
ExactMatch _ xs -> Ambiguous True xs
InexactMatch _ xs -> Ambiguous False xs
data MaybeAmbiguous a = None [MatchError] | Unambiguous a | Ambiguous Bool [a]
deriving Show
......
......@@ -259,6 +259,8 @@ BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\."
# >=1.0
CRYPTOHASH_SHA256_VER="0.11.7.1"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?"
# 0.11.*
EDIT_DISTANCE_VER="0.2.2.1"; EDIT_DISTANCE_VER_REGEXP="0\.2\.2\.?"
# 0.2.2.*
ED25519_VER="0.0.5.0"; ED25519_VER_REGEXP="0\.0\.?"
# 0.0.*
HACKAGE_SECURITY_VER="0.5.2.2"; HACKAGE_SECURITY_VER_REGEXP="0\.5\.(2\.[2-9]|[3-9])"
......@@ -483,6 +485,7 @@ info_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \
${BASE64_BYTESTRING_VER_REGEXP}
info_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \
${CRYPTOHASH_SHA256_VER_REGEXP}
info_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP}
info_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP}
info_pkg "tar" ${TAR_VER} ${TAR_VER_REGEXP}
info_pkg "hashable" ${HASHABLE_VER} ${HASHABLE_VER_REGEXP}
......@@ -518,6 +521,7 @@ do_pkg "base64-bytestring" ${BASE64_BYTESTRING_VER} \
${BASE64_BYTESTRING_VER_REGEXP}
do_pkg "cryptohash-sha256" ${CRYPTOHASH_SHA256_VER} \
${CRYPTOHASH_SHA256_VER_REGEXP}
do_pkg "edit-distance" ${EDIT_DISTANCE_VER} ${EDIT_DISTANCE_VER_REGEXP}
do_pkg "ed25519" ${ED25519_VER} ${ED25519_VER_REGEXP}
# We conditionally install bytestring-builder, depending on the bytestring
......
......@@ -410,6 +410,7 @@ executable cabal
containers >= 0.4 && < 0.6,
cryptohash-sha256 >= 0.11 && < 0.12,
deepseq >= 1.3 && < 1.5,
edit-distance >= 0.2.2 && < 0.2.3,
filepath >= 1.3 && < 1.5,
hashable >= 1.0 && < 2,
HTTP >= 4000.1.5 && < 4000.4,
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment