module SearchMatchingFunctions
	( searchKeys
	, searchMap
	, matchAnything
	) where

import Data.Char (toLower)
import Data.List ((\\), find, maximumBy, nub)
import Data.Map as Map (Map, lookup, empty, toList)
import Data.Ord (comparing)
import Distribution.Compiler (CompilerFlavor(..))
import Distribution.ModuleName (components)
import Distribution.Package (PackageIdentifier(..))
import Distribution.PackageDescription as Cabal
		(PackageDescription(..), hasLibs, exposedModules, exeName, descCabalVersion)
import Distribution.Text
import Distribution.Version (withinRange)

import SearchTypes
import SearchUtils (similarity, getNameAndVersion, getVersion)

-- Search keys ----------------------------------------------------------------

-- | The available search keys. These keys may be used as tags in a search
--   string.
searchKeys :: [String]
searchKeys = fst (unzip searchMap)

-- | Maps search keys and corresponding matching functions.
searchMap :: [(String, Either (String -> LocalMatchingFunction)
				(String -> GlobalMatchingFunction))]
searchMap =
	[ ("package",       Left matchPackage)
	, ("description",   Left matchDescription)
	, ("depends-on",    Right matchDependsOn)
	, ("required-by",   Right matchRequiredBy)
	, ("category",      Left matchCategory)
	, ("has-library",   Left matchHasLibrary)
	, ("executable",    Left matchExecutable)
	, ("stability",     Left matchStability)
	, ("maintainer",    Left matchMaintainer)
	, ("author",        Left matchAuthor)
	, ("license",       Left matchLicense)
	, ("tested-with",   Left matchTestedWith)
	, ("cabal-version", Left matchCabalVersion)
	, ("build-type",    Left matchBuildType)
	]

-- Local matching functions ---------------------------------------------------

-- | A matching function for the package description field @package@.
--   This function only matches against the name of a package.
matchPackage :: String -> LocalMatchingFunction
matchPackage string pd = localMatchingValue pd "package" $
	similarity string (display $ pkgName $ Cabal.package pd)

-- | A matching function for the package description fields @description@ and
--   @synopsis@.
matchDescription :: String -> LocalMatchingFunction
matchDescription string pd = localMatchingValue pd "description" $
	similarity string (Cabal.synopsis pd ++ " " ++ Cabal.description pd)

-- | A matching function for the package description field @category@.
matchCategory :: String -> LocalMatchingFunction
matchCategory string pd = localMatchingValue pd "category" $
	if null . words $ Cabal.category pd
	    then if hasLibs pd
		   then similarity string
		. unwords
		. maybe [] (nub . map (head . components) . exposedModules)
		$ library pd
	       else similarity string "Unclassified"
	    else similarity string $ Cabal.category pd

-- | A matching function for the package description field @library@.
--   The argument should be either @yes@, @no@, @true@, or @false@, where
--   upper case and lower case letters are treated similar.
matchHasLibrary :: String -> LocalMatchingFunction
matchHasLibrary string pd = localMatchingValue pd "has-library" $
	if Just (hasLibs pd) == expected then 1.0 else 0.0
  where expected = case map toLower string of
		"yes"   -> Just True
		"true"  -> Just True
		"no"    -> Just False
		"false" -> Just False
		_       -> Nothing

-- | A matching function for the package description field @executables@.
--   The function matches against the executables' name.
matchExecutable :: String -> LocalMatchingFunction
matchExecutable string pd = localMatchingValue pd "executable" $
	similarity string . unwords . map exeName $ Cabal.executables pd

-- | A matching function for the package description field @stability@.
matchStability :: String -> LocalMatchingFunction
matchStability string pd = localMatchingValue pd "stability" .
	similarity string $ Cabal.stability pd

-- | A matching function for the package description field @maintainer@.
matchMaintainer :: String -> LocalMatchingFunction
matchMaintainer string pd = localMatchingValue pd "maintainer" $
	similarity string $ Cabal.maintainer pd

-- | A matching function for the package description field @author@.
matchAuthor :: String -> LocalMatchingFunction
matchAuthor string pd = localMatchingValue pd "author" $
	similarity string $ Cabal.author pd

-- | A matching function for the package description field @license@.
matchLicense :: String -> LocalMatchingFunction
matchLicense string pd = localMatchingValue pd "license" $
	similarity string . show $ Cabal.license pd

-- | A matching function for the package description field @tested-with@.
--   The argument must be compiler name with an optional "Data.Version.Version".
matchTestedWith :: String -> LocalMatchingFunction
matchTestedWith string pd = localMatchingValue pd "tested-with" $
	case getNameAndVersion string of
		Nothing                   -> 0.0
		Just (name, Nothing)      ->
			similarity (display name) . unwords . map (compilerName . fst) $
				Cabal.testedWith pd
		Just (name, Just version) ->
			(\xs -> if null xs then 0.0 else maximum xs)
			. map (\(c,vr) ->
				let p1 = similarity (display name) (compilerName c)
				    p2 = if version `withinRange` vr
					       then 1.0
					       else 0.0
				in (p1 + p2) / 2)
			$ Cabal.testedWith pd
  where compilerName flavor = case flavor of
		OtherCompiler c -> c
		_               -> show flavor

-- | A matching function for the package description field @cabal-version@.
--   The argument must be parseable to a "Data.Version.Version".
matchCabalVersion :: String -> LocalMatchingFunction
matchCabalVersion string pd = localMatchingValue pd "cabal-version" $
	case getVersion string of
		Nothing -> 0.0
		Just v  -> if v `withinRange` Cabal.descCabalVersion pd
			then 1.0 else 0.0

-- | A matching function for the package description field @build-type@.
matchBuildType :: String -> LocalMatchingFunction
matchBuildType string pd = localMatchingValue pd "build-type" $
	similarity string (show $ Cabal.buildType pd)

-- | A matching function which tries to find results from nearly all available
--   keys. Only those with fixed structure are not taken into account.
matchAnything :: String -> LocalMatchingFunction
matchAnything string pd =
	uncurry (localMatchingValue pd)
	. maximumBy (comparing snd)
	. map (head . Map.toList . snd . head . Map.toList)
	. map (\f -> f string pd Map.empty)
	$ [ matchPackage
	  , matchDescription
	  , matchCategory
	  , matchExecutable
	  , matchStability
	  , matchMaintainer
	  , matchAuthor
	  , matchLicense
	  , matchTestedWith
	  ]

-- Global matching functions --------------------------------------------------

-- | Matches all packages on which the given one depends.
--   The argument must be parseable to a name with an optional version.
matchDependsOn :: String -> GlobalMatchingFunction
matchDependsOn string gd valueMap =
	matchGlobal (allAvailablePackages gd) (dependsOnMap gd) "depends-on"
		valueMap string

-- | Matches all packages which are required by the given one.
--   The argument must be parseable to a name with an optional version.
matchRequiredBy :: String -> GlobalMatchingFunction
matchRequiredBy string gd valueMap =
	matchGlobal (allAvailablePackages gd) (requiredByMap gd) "required-by"
		valueMap string

matchGlobal ::
	[PackageIdentifier]
	-> Map.Map PackageIdentifier [PackageIdentifier]
	-> String
	-> MatchingMap
	-> String
	-> MatchingMap
matchGlobal allPkgs depMap key vMap string =
	case getNameAndVersion string of
	    Nothing                   -> vMap
	    Just (name, Nothing)      ->
		foldl (matchDependencies depMap key) vMap
			. filter (\p -> pkgName p == name)
			$ allPkgs
	    Just (name, Just version) ->
		maybe vMap (matchDependencies depMap key vMap)
			. find (== PackageIdentifier name version)
			$ allPkgs

matchDependencies ::
	Map.Map PackageIdentifier [PackageIdentifier]
	-> String
	-> MatchingMap
	-> PackageIdentifier
	-> MatchingMap
matchDependencies depMap key mMap pkg =
	breadthMatch 1 [] mMap (selectChildren pkg)
  where
	selectChildren p = maybe [] id (Map.lookup p depMap)

	breadthMatch ::
		Int
		-> [PackageIdentifier]
		-> MatchingMap
		-> [PackageIdentifier]
		-> MatchingMap
	breadthMatch _ _ vMap [] = vMap
	breadthMatch level done vMap pkgs =
		breadthMatch (level + 1) done' vMap' nextPkgs
	  where v = 1 / sqrt (fromIntegral level)
		vMap' = foldr (\p -> globalMatchingValue p key v) vMap pkgs
		done' = done ++ pkgs
		nextPkgs = concatMap selectChildren pkgs \\ done'