{-# LANGUAGE ViewPatterns, TupleSections, ScopedTypeVariables, DeriveDataTypeable, PatternGuards, GADTs #-}
module Output.Tags(writeTags, completionTags, applyTags) where
import Data.Bifunctor
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 (bimap snd 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