Tags.hs

{-# 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 TYPE

-- matches (a,b) if i >= a && i <= b

data Packages a where Packages :: Packages (BStr0, V.Vector (TargetId, TargetId)) deriving Typeable
    -- list of packages, sorted by popularity, lowercase, interspersed with \0
    -- for each index in PackageNames, the first is the module item, any in the bounds are in that package

data Modules a where Modules :: Modules (BStr0, V.Vector (TargetId, TargetId)) deriving Typeable
    -- list of modules, sorted by popularity, not unique, lowercase, interspersed with \0
    -- for each index in ModuleNames, the first is the module item, any in the bounds are in that module

data Categories a where Categories :: Categories (BStr0, Jagged (TargetId, TargetId)) deriving Typeable
    -- list of categories, sorted by name, interspersed with \0
    -- for each index in CategoryNames, a range of items containing a category, first item is a package

data Completions a where Completions :: Completions BStr0 deriving Typeable
    -- a list of things to complete to, interspersed with \0


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


---------------------------------------------------------------------
-- SIMPLE SELECTORS

completionTags :: StoreRead -> [String]
completionTags store = map BS.unpack $ bstr0Split $ storeRead store Completions


---------------------------------------------------------------------
-- DATA TYPE, PARSE, PRINT

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
        -- make the assumption the first letter always disambiguates
        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)


---------------------------------------------------------------------
-- TAG SEMANTICS

-- | Given a tag, find the ranges of identifiers it covers (if it restricts the range)
-- An empty range means an empty result, while a Nothing means a search on the entire range
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)
        -- look for people who are an exact prefix, sort by remaining length, if there are ties, pick the first one
        | 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


---------------------------------------------------------------------
-- TAG QUERIES

-- | Given a query produce: (refined query, is:exact, filter, enumeration)
--   You should apply the filter to other peoples results, or if you have nothing else, use the enumeration.
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)


-- | Given a search which has no type or string in it, run the query on the tag bits.
--   Using for things like IsModule, EqCategory etc.
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