module Hoogle.DataBase.Items where
import Control.Monad.State
import Data.Binary.Defer.Index
import General.Code
import Hoogle.TextBase.All
import Hoogle.TypeSig.All
import Hoogle.Item.All
import Data.Binary.Defer hiding (get,put)
import qualified Data.Binary.Defer as D
data Items = Items
{packages :: Index Package
,modules :: Index Module
,entries :: Index Entry
}
instance BinaryDefer Items where
put (Items a b c) = put3 a b c
get = do
res@(Items a b c) <- get3 Items
getDeferPut a
getDeferPut b
getDeferPut c
return res
instance Show Items where
show (Items a b c) = f "Packages" a ++ "\n" ++ f "Modules" b ++ "\n" ++ f "Entries" c
where f header x = "== " ++ header ++ " ==\n\n" ++ show x
data S a = S {count :: Int, values :: [a]}
newS = S (1) []
newIndexS = newIndex . reverse . values
addS x (S i xs) = S (i+1) (x:xs)
getS (S i (x:xs)) = newLink i x
getS _ = error "DataBase.Items.getS, lacking a package/module?"
entriesItems :: Items -> [Link Entry]
entriesItems = indexLinks . entries
createItems :: [(TextItem,String)] -> Items
createItems xs = Items (newIndexS pkgs) (newIndexS mods)
(newIndex $ sortOn entryScore ents)
where
(ents, (pkgs,mods)) = flip runState (newS,newS) $ concatMapM addTextItem $ init $ tails xs
addTextItem :: [(TextItem,String)] -> State (S Package, S Module) [Entry]
addTextItem ((ti,doc):rest) = case ti of
ItemInstance{} -> return []
ItemAttribute "keyword" name ->
add False EntryKeyword [Keyword "keyword",Text " ",Focus name]
ItemAttribute "package" name -> do
modify $ \(ps,ms) -> (addS (addPkg (Package name "" "" "") rest) ps, ms)
add False EntryPackage [Keyword "package",Text " ",Focus name]
ItemAttribute _ _ -> return []
ItemModule xs -> do
modify $ \(ps,ms) -> (ps, addS (Module xs) ms)
add True EntryModule [Keyword "module", Text $ ' ' : concatMap (++ ".") (init xs), Focus (last xs)]
_ -> add True EntryOther (renderTextItem ti)
where
add modu typ txt = do
(ps,ms) <- get
let sig = case ti of ItemFunc _ s -> Just (Defer s); _ -> Nothing
return [Entry (if modu then Just $ getS ms else Nothing) (getS ps)
(headDef "" [i | Focus i <- txt])
txt typ (newHaddock doc) sig]
addPkg pkg ((ItemAttribute "version" x,_) : xs) = addPkg pkg{packageVersion=x} xs
addPkg pkg ((ItemAttribute "haddock" x,_) : xs) = addPkg pkg{haddockURL =x} xs
addPkg pkg ((ItemAttribute "hackage" x,_) : xs) = addPkg pkg{hackageURL =x} xs
addPkg pkg _ = pkg
mergeItems :: [Items] -> Items
mergeItems [x] = x
mergeItems xs = Items
(newIndex $ concat $ reverse ps)
(newIndex $ concat $ reverse ms)
(newIndex $ sortOn entryScore $ concat $ reverse es)
where
(pi,ps,mi,ms,ei,es) = foldl' f (0,[],0,[],0,[]) xs
f (pi,ps,mi,ms,ei,es) (Items p m e) =
(pi+length p3,p3:ps, mi+length m3,m3:ms, ei+length e3,e3:es)
where
(p2,p3) = add pi p id
(m2,m3) = add mi m id
(e2,e3) = add ei e $ \x -> x{entryModule = liftM (\x -> m2 !! linkKey x) $ entryModule x
,entryPackage = p2 !! linkKey (entryPackage x)}
add i xs f = (zipWith newLink [i..] xs2, xs2)
where xs2 = map (f . fromLink) $ indexLinks xs