{-# LANGUAGE ViewPatterns, TupleSections, ScopedTypeVariables, DeriveDataTypeable, PatternGuards, GADTs #-}
module Output.Tags(writeTags, completionTags, applyTags) where
import Data.Function
import Data.List.Extra
import Data.Tuple.Extra
import Data.Maybe
import Foreign.Storable.Tuple()
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector.Storable as V
import qualified Data.ByteString.Char8 as BS
import Input.Item
import Query
import General.Util
import General.Store
import General.Str
data Packages a where Packages :: Packages (BStr0, V.Vector (TargetId, TargetId)) deriving Typeable
data Modules a where Modules :: Modules (BStr0, V.Vector (TargetId, TargetId)) deriving Typeable
data Categories a where Categories :: Categories (BStr0, Jagged (TargetId, TargetId)) deriving Typeable
data Completions a where Completions :: Completions BStr0 deriving Typeable
writeTags :: StoreWrite -> (PkgName -> Bool) -> (PkgName -> [(String,String)]) -> [(Maybe TargetId, Item)] -> IO ()
writeTags store keep extra xs = do
let splitPkg = splitIPackage xs
let packages = addRange splitPkg
storeWrite store Packages (bstr0Join $ map (strUnpack . fst) packages, V.fromList $ map snd packages)
let categories = map (first snd . second reverse) $ Map.toList $ Map.fromListWith (++)
[(((weightTag ex, both lower ex), joinPair ":" ex),[rng]) | (p,rng) <- packages, ex <- extra p]
storeWrite store Categories (bstr0Join $ map fst categories, jaggedFromList $ map snd categories)
let modules = addRange $ concatMap (splitIModule . snd) splitPkg
storeWrite store Modules (bstr0Join $ map (lower . strUnpack . fst) modules, V.fromList $ map snd modules)
storeWrite store Completions $ bstr0Join $
takeWhile ("set:" `isPrefixOf`) (map fst categories) ++
map ("package:"++) (sortOn lower $ map strUnpack $ nubOrd $ filter keep $ map fst packages) ++
map (joinPair ":") (sortOn (weightTag &&& both lower) $ nubOrd [ex | (p,_) <- packages, keep p, ex <- extra p, fst ex /= "set"])
where
addRange :: [(Str, [(Maybe TargetId,a)])] -> [(Str, (TargetId, TargetId))]
addRange xs = [(a, (minimum' is, maximum' is)) | (a,b) <- xs, let is = mapMaybe fst b, not $ strNull a, is /= []]
weightTag ("set",x) = fromMaybe 0.9 $ lookup x [("stackage",0.0),("haskell-platform",0.1)]
weightTag ("package",x) = 1
weightTag ("category",x) = 2
weightTag ("license",x) = 3
weightTag _ = 4
completionTags :: StoreRead -> [String]
completionTags store = map BS.unpack $ bstr0Split $ storeRead store Completions
data Tag = IsExact | IsPackage | IsModule | EqPackage String | EqModule String | EqCategory String String deriving Eq
parseTag :: String -> String -> Maybe Tag
parseTag k v
| k ~~ "is" = case () of
_ | v ~~ "exact" -> Just IsExact
| v ~~ "package" -> Just IsPackage
| v ~~ "module" -> Just IsModule
| otherwise -> Nothing
| k ~~ "package" = if v == "" then Nothing else Just $ EqPackage v
| k ~~ "module" = if v == "" then Nothing else Just $ EqModule v
| v /= "" = Just $ EqCategory k v
| otherwise = Nothing
where
x ~~ lit = x /= "" && lower x `isPrefixOf` lit
showTag :: Tag -> (String, String)
showTag IsExact = ("is","exact")
showTag IsPackage = ("is","package")
showTag IsModule = ("is","module")
showTag (EqPackage x) = ("package",x)
showTag (EqModule x) = ("module",x)
showTag (EqCategory k v) = (k,v)
resolveTag :: StoreRead -> Tag -> (Tag, Maybe [(TargetId,TargetId)])
resolveTag store x = case x of
IsExact -> (IsExact, Nothing)
IsPackage -> (IsPackage, Just $ map (dupe . fst) $ V.toList packageIds)
IsModule -> (IsModule, Just $ map (dupe . fst) $ V.toList moduleIds)
EqPackage orig@(BS.pack -> val)
| res@(_:_) <- [(BS.length x, (i,x)) | (i,x) <- zip [0..] $ bstr0Split packageNames, val `BS.isPrefixOf` x]
-> let (i,x) = snd $ minimumBy (compare `on` fst) res in (EqPackage $ BS.unpack x, Just [packageIds V.! i])
| otherwise -> (EqPackage orig , Just [])
EqModule x -> (EqModule x, Just $ map (moduleIds V.!) $ findIndices (eqModule $ lower x) $ bstr0Split moduleNames)
EqCategory cat val -> (EqCategory cat val, Just $ concat
[ V.toList $ jaggedAsk categoryIds i
| i <- elemIndices (BS.pack (cat ++ ":" ++ val)) $ bstr0Split categoryNames])
where
eqModule x | Just x <- stripPrefix "." x, Just x <- stripSuffix "." x = (==) (BS.pack x)
| Just x <- stripPrefix "." x = BS.isPrefixOf $ BS.pack x
| otherwise = let y = BS.pack x; y2 = BS.pack ('.':x)
in \v -> y `BS.isPrefixOf` v || y2 `BS.isInfixOf` v
(packageNames, packageIds) = storeRead store Packages
(categoryNames, categoryIds) = storeRead store Categories
(moduleNames, moduleIds) = storeRead store Modules
applyTags :: StoreRead -> [Query] -> ([Query], Bool, TargetId -> Bool, [TargetId])
applyTags store qs = (qs2, exact, filt, searchTags store qs)
where (qs2, exact, filt) = filterTags store qs
filterTags :: StoreRead -> [Query] -> ([Query], Bool, TargetId -> Bool)
filterTags ts qs = (map redo qs, exact, \i -> all ($ i) fs)
where fs = map (filterTags2 ts . snd) $ groupSort $ map (scopeCategory &&& id) $ filter isQueryScope qs
exact = Just IsExact `elem` [parseTag a b | QueryScope True a b <- qs]
redo (QueryScope sense cat val)
| Just (k,v) <- fmap (showTag . fst . resolveTag ts) $ parseTag cat val = QueryScope sense k v
| otherwise = QueryNone $ ['-' | not sense] ++ cat ++ ":" ++ val
redo q = q
filterTags2 ts qs = \i -> not (negq i) && (noPosRestrict || posq i)
where (posq,negq) = both inRanges (pos,neg)
(pos, neg) = both (concatMap snd) $ partition fst xs
xs = catMaybes restrictions
noPosRestrict = all pred restrictions
restrictions = map getRestriction qs
pred Nothing = True
pred (Just (sense, _)) = not sense
getRestriction :: Query -> Maybe (Bool,[(TargetId, TargetId)])
getRestriction (QueryScope sense cat val) = do
tag <- parseTag cat val
ranges <- snd $ resolveTag ts tag
return (sense, ranges)
searchTags :: StoreRead -> [Query] -> [TargetId]
searchTags ts qs
| x:xs <- [map fst $ maybe [] (fromMaybe [] . snd . resolveTag ts) $ parseTag cat val | QueryScope True cat val <- qs]
= if null xs then x else filter (`Set.member` foldl1' Set.intersection (map Set.fromList xs)) x
searchTags ts _ = map fst $ fromMaybe [] $ snd $ resolveTag ts IsPackage