hoogle 4.2.28 → 4.2.29

raw patch · 30 files changed

+509/−133 lines, 30 filesdep +QuickCheckdep +vectordep +vector-algorithms

Dependencies added: QuickCheck, vector, vector-algorithms

Files

• CHANGES.txt +7/−0
• hoogle.cabal +13/−1
• src/CmdLine/Load.hs +1/−7
• src/CmdLine/Type.hs +18/−4
• src/Console/All.hs +8/−10
• src/Console/Rank.hs +1/−1
• src/Console/Test.hs +5/−5
• src/General/Base.hs +18/−0
• src/General/BurrowsWheeler.hs +62/−0
• src/General/FMIndex.hs +60/−0
• src/General/Util.hs +17/−0
• src/Hoogle.hs +48/−15
• src/Hoogle/DataBase/All.hs +16/−1
• src/Hoogle/DataBase/Serialise.hs +18/−3
• src/Hoogle/DataBase/SubstrSearch.hs +1/−2
• src/Hoogle/DataBase2/Str.hs +76/−0
• src/Hoogle/DataBase2/Type.hs +15/−0
• src/Hoogle/Language/Haskell.hs +11/−11
• src/Hoogle/Store/All.hs +2/−2
• src/Hoogle/Store/Type.hs +25/−8
• src/Hoogle/Type/Docs.hs +5/−4
• src/Hoogle/Type/Item.hs +2/−0
• src/Hoogle/Type/TagStr.hs +18/−0
• src/Recipe/All.hs +23/−20
• src/Test/All.hs +3/−1
• src/Test/BWT_FM.hs +13/−0
• src/Test/Docs.hs +5/−4
• src/Test/General.hs +15/−34
• src/Test/Parse_Query.hs +1/−0
• src/Test/Parse_TypeSig.hs +2/−0

@@ -1,5 +1,12 @@ Changelog for Hoogle +4.2.29+    #55, if reading as UTF8 fails, explicitly try Latin1+    Add QuickCheck as a dependency+    Change createDatabase to also save the file+    Disable rank feature+    Remove running a hoogle query without converting the database+    Ignore packages without documentation to hoogle data 4.2.28     Upgrade to shake-0.11     #49, update "hoogle data" to be incremental

@@ -1,7 +1,7 @@ cabal-version:      >= 1.10 build-type:         Simple name:               hoogle-version:            4.2.28+version:            4.2.29 license:            BSD3 license-file:       docs/LICENSE category:           Development@@ -55,6 +55,9 @@         case-insensitive >= 0.2,         http-types >= 0.7,         wai >= 1.1,+        vector >= 0.9,+        vector-algorithms >= 0.6,+        QuickCheck,         haskell-src-exts >= 1.14 && < 1.15      if !os(mingw32)@@ -78,6 +81,8 @@         General.TypeMap         General.Base         General.System+        General.BurrowsWheeler+        General.FMIndex         General.Util         General.Web         Hoogle.DataBase.Aliases@@ -94,6 +99,8 @@         Hoogle.DataBase.TypeSearch.Result         Hoogle.DataBase.TypeSearch.TypeScore         Hoogle.DataBase.TypeSearch.All+        Hoogle.DataBase2.Str+        Hoogle.DataBase2.Type         Hoogle.Type.Docs         Hoogle.Type.Item         Hoogle.Type.Language@@ -124,6 +131,7 @@         bytestring, filepath, directory, process, random,         array, containers, time, old-locale,         safe,+        binary,         aeson >= 0.6.1,         cmdargs >= 0.7,         deepseq >= 1.1,@@ -132,6 +140,8 @@         http-types >= 0.7,         case-insensitive >= 0.2,         text >= 0.11,+        vector >= 0.9,+        vector-algorithms >= 0.6,         transformers >= 0.2,         uniplate >= 1.6,         conduit >= 0.2,@@ -140,6 +150,7 @@         warp >= 1.1,         Cabal >= 1.8,         shake >= 0.11,+        QuickCheck,         haskell-src-exts >= 1.14 && < 1.15      if !os(mingw32)@@ -162,6 +173,7 @@         Recipe.Haddock         Recipe.Keyword         Test.All+        Test.BWT_FM         Test.Docs         Test.General         Test.Parse_Query

@@ -17,13 +17,7 @@     fmap (second mconcat . partitionEithers) $ forM xs $ \x -> do         r <- findFile [p </> x <.> "hoo" | p <- paths]         case r of-            Nothing -> do-                r <- findFile [p </> x <.> "txt" | p <- paths]-                case r of-                    Nothing -> return $ Left x-                    Just x -> do-                        src <- readFileUtf8 x-                        return $ Right $ snd $ createDatabase Haskell [] src+            Nothing -> return $ Left x             Just x -> fmap Right $ loadDatabase x  

@@ -28,14 +28,26 @@         ,web :: Maybe String         ,repeat_ :: Int         ,queryChunks :: [String]-                 ,queryParsed :: Either ParseError Query         ,queryText :: String         }-    | Data {redownload :: Bool, rebuild :: Bool, local :: [String], datadir :: FilePath, threads :: Int, actions :: [String]}+    | Data {+          hackage    :: String+        , redownload :: Bool+        , rebuild :: Bool+        , local :: [String]+        , datadir :: FilePath+        , threads :: Int+        , actions :: [String]}     | Server {port :: Int, local_ :: Bool, databases :: [FilePath], resources :: FilePath, dynamic :: Bool, template :: [FilePath]}     | Combine {srcfiles :: [FilePath], outfile :: String}-    | Convert {srcfile :: String, outfile :: String, doc :: Maybe String, merge :: [String], haddock :: Bool}+    | Convert {+          hackage :: String+        , srcfile :: String+        , outfile :: String+        , doc :: Maybe String+        , merge :: [String]+        , haddock :: Bool}     | Log {logfiles :: [FilePath]}     | Test {testFiles :: [String], example :: Bool}     | Dump {database :: String, section :: [String]}@@ -92,7 +104,8 @@     } &= help "Combine multiple databases into one"  convert = Convert-    {srcfile = def &= argPos 0 &= typ "INPUT"+    {hackage = "http://hackage.haskell.org/" &= typ "URL" &= help "Hackage instance to target"+    ,srcfile = def &= argPos 0 &= typ "INPUT"     ,outfile = def &= argPos 1 &= typ "DATABASE" &= opt ""     ,doc = def &= typDir &= help "Path to the root of local or Hackage documentation for the package (implies --haddock)"     ,merge = def &= typ "DATABASE" &= help "Merge other databases"@@ -101,6 +114,7 @@  data_ = Data     {datadir = def &= typDir &= help "Database directory"+    ,hackage    = "http://hackage.haskell.org/" &= typ "URL" &= help "Hackage instance to target"     ,redownload = def &= help "Redownload all files from the web"     ,rebuild = def &= help "Rebuild everything"     ,threads = 1 &= typ "INT" &= name "j" &= help "Number of threads to use"

@@ -13,6 +13,7 @@ import General.Web import System.FilePath import Hoogle+import Hoogle.Type.All   action :: CmdLine -> IO ()@@ -39,11 +40,11 @@  action (Log files) = logFiles files -action (Convert from to doc merge haddock) = do+action (Convert url from to doc merge haddock) = do     when (any isUpper $ takeBaseName to) $ putStrLn $ "Warning: Hoogle databases should be all lower case, " ++ takeBaseName to     putStrLn $ "Converting " ++ from     src <- readFileUtf8 from-    convert merge (takeBaseName from) to $ unlines $ addLocalDoc doc (lines src)+    convert url merge (takeBaseName from) to $ unlines $ addLocalDoc doc (lines src)     where       addLocalDoc :: Maybe FilePath -> [String] -> [String]       addLocalDoc doc = if haddock@@ -61,8 +62,7 @@  action (Combine from to) = do     putStrLn $ "Combining " ++ show (length from) ++ " databases"-    xs <- mapM loadDatabase from-    saveDatabase to $ mconcat xs+    mergeDatabase from to  action (Dump file sections) = do     d <- loadDatabase file@@ -77,14 +77,12 @@   --- convert a single database-convert :: [FilePath] -> String -> FilePath -> String -> IO ()-convert deps x out src = do+convert :: HackageURL -> [FilePath] -> String -> FilePath -> String -> IO ()+convert url deps x out src = do     deps2 <- filterM doesFileExist deps     when (deps /= deps2) $ putStrLn $ "Warning: " ++ x ++ " doesn't know about dependencies on " ++ unwords (deps \\ deps2)     dbs <- mapM loadDatabase deps2-    let (err,db) = createDatabase Haskell dbs src-    unless (null err) $ putStrLn $ "Skipped " ++ show (length err) ++ " warnings in " ++ x     putStr $ "Converting " ++ x ++ "... "-    performGC-    saveDatabase out db+    err <- createDatabase url Haskell dbs src out     putStrLn "done"+    unless (null err) $ putStrLn $ "Skipped " ++ show (length err) ++ " warnings in " ++ x

@@ -16,7 +16,7 @@ scores (pre,xs) = concatMap trans     [         [ fst $ head $ search db q ++ [error $ "Did not find in " ++ query ++ ", " ++ y]-        | y <- ys , let (err,db) = createDatabase Haskell [] $ unlines $ pre ++ ["a::" ++ y]+        | y <- ys , let (err,db) = (error "this feature has been disabled" createDatabase) Haskell [] $ unlines $ pre ++ ["a::" ++ y]         , null err || error "Errors while converting rank database"         ]     | (query,ys) <- xs, let q = right ("Could not parse query: " ++ query) $ parseQuery Haskell query]

@@ -25,12 +25,12 @@     dat <- getDataDir     createDirectoryIfMissing True $ dat </> "databases"     src <- readFileUtf8 $ dat </> "testdata.txt"-    let (errs, dbOld) = createDatabase Haskell [] src-    unless (null errs) $ error $ unlines $ "Couldn't convert testdata database:" : map show errs     let dbfile = dat </> "databases/testdata.hoo"-    saveDatabase dbfile dbOld+    errs <- createDatabase "http://hackage.haskell.org/" Haskell [] src dbfile+    unless (null errs) $ error $ unlines $ "Couldn't convert testdata database:" : map show errs     db <- loadDatabase dbfile-    when (show dbOld /= show db) $ error "Database did not save properly"+    -- this test is now mostly redundant because i can't get the file before saving+    when (show db /= show db) $ error "Database did not save properly"   testFile :: (CmdLine -> IO ()) -> FilePath -> IO Int@@ -88,7 +88,7 @@     where         f [] _ = Nothing         f (x:xs) a = case match (code x) a of-            Nothing -> Just $ "Failed to match: " ++ x+            Nothing -> Just $ unlines $ ["Failed to match","Expected: " ++ x,"Got:"] ++ fst a ++ snd a             Just a -> f xs a          code ('@':xs) = second (drop 1) $ break (== ' ') xs

@@ -4,6 +4,7 @@ --   have been in base, or could plausibly be added. module General.Base(module General.Base, module X) where +import Control.Applicative as X ((<*>),(<$>)) import Control.Arrow as X import Control.DeepSeq as X import Control.Monad as X@@ -104,6 +105,23 @@ readFileUtf8 x = do     h <- openFile x ReadMode     hSetEncoding h utf8+    hGetContents h+#endif+++readFileLatin1' :: FilePath -> IO String+readFileLatin1' x = do+    src <- readFileLatin1 x+    length src `seq` return src+++readFileLatin1 :: FilePath -> IO String+#if __GLASGOW_HASKELL__ < 612+readFileLatin1 x = readFile x+#else+readFileLatin1 x = do+    h <- openFile x ReadMode+    hSetEncoding h latin1     hGetContents h #endif 

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleContexts, PatternGuards #-}++-- | Burrows-Wheeler Transform, based on <http://www.cs.jhu.edu/~langmea/resources/bwt_fm.pdf>.+module General.BurrowsWheeler(compress, compressIndicies, decompress) where++import qualified Data.ByteString as BS+import qualified Data.Vector.Algorithms.AmericanFlag as AmericanFlag+import qualified Data.Vector.Unboxed as V+import qualified Data.Vector.Unboxed.Mutable as VM+import Control.Monad.ST+import Data.Word+import Data.Function+++compress :: BS.ByteString -> (Int, BS.ByteString)+compress bs = (i, fst $ BS.unfoldrN (BS.length bs) step 0)+    where (i, vs) = compressIndicies bs+          step i = Just (BS.index bs (fromIntegral $ vs V.! i-1), i + 1)+++compressIndicies :: BS.ByteString -> (Int, V.Vector Word32)+compressIndicies bs | Just i <- V.elemIndex 0 is = (i, V.take i is V.++ V.drop (i+1) is)+    where+        len = BS.length bs+        is = V.modify (AmericanFlag.sortBy (compare `on` slice) terminate size index) $+                    V.enumFromN (0 :: Word32) $ len + 1++        slice i = BS.drop (fromIntegral i) bs++        -- Copied from the Lexicographic ByteString instance, adapted to use an offset+        size = 257+        terminate b i = i + fromIntegral b >= len+        index i b+            | i + fromIntegral b >= len = 0+            | otherwise = fromIntegral (BS.index bs $ i + fromIntegral b) + 1+++decompress :: (Int, BS.ByteString) -> BS.ByteString+decompress (pos, bs) = BS.reverse $ fst $ BS.unfoldrN (BS.length bs) step 0+    where+        step i | j == -1 = Nothing+               | otherwise = let c = BS.index bs j in Just (c, fromIntegral $ (first V.! fromIntegral c) + (ranks V.! j) + 1)+            where j = if i >= pos then i-1 else i+        (ranks, tots) = rankBwt bs+        first = firstCol tots+++rankBwt :: BS.ByteString -> (V.Vector Word32, V.Vector Word32)+rankBwt bs = runST $ do+    tots <- VM.replicate 256 0+    ranks <- V.generateM (BS.length bs) $ \i -> do+        let c = fromIntegral $ BS.index bs i+        j <- VM.read tots c+        VM.write tots c $ j + 1+        return j+    tots <- V.freeze tots+    return (ranks, tots)+++-- If you sorted the input, at what index would 'c' come+firstCol :: V.Vector Word32 -> V.Vector Word32+firstCol = V.prescanl' (+) 0

@@ -0,0 +1,60 @@+
+module General.FMIndex(
+    FMIndex,
+    create, fromHandle,
+    extract,
+    Find(..), count, locate
+    ) where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import Data.Binary
+import Control.Applicative
+import Control.Arrow
+import System.IO
+
+
+data FMIndex a = FMIndex Char [(BS.ByteString, a)] deriving Show
+
+{-
+data FMIndex a = FMIndex
+    {specialChar :: Char -- Character used to separate words, and which there are associations for
+    ,positions :: V.Vector Word32 -- if positions[c] = n, that means there are n substrings that are less than c
+    ,associated :: V.Vector a -- values associated with each specialChar
+    ,rankAll :: V.Vector Word32 -- ranks, stored every 1024 entries, where rankAll[(n*256)/1024 + c] = rank of c at character n
+    ,contents :: BS.ByteString
+    }
+-}
+
+instance Functor FMIndex where
+    fmap f (FMIndex a b) = FMIndex a $ map (second f) b
+
+instance Binary a => Binary (FMIndex a) where
+    put (FMIndex a b) = put a >> put b
+    get = FMIndex <$> get <*> get
+
+-- assign these indicies to this information
+create :: Char -> [(BS.ByteString, a)] -> FMIndex a
+create = FMIndex
+
+extract :: FMIndex a -> [(BS.ByteString, a)]
+extract (FMIndex _ x) = x
+
+data Find = Exact | Prefix | Suffix | Infix
+
+count :: FMIndex a -> Find -> BS.ByteString -> Int
+count idx mode x = length $ locate idx mode x
+
+
+locate :: FMIndex a -> Find -> BS.ByteString -> [(a, Int)] -- The int is how many characters you are along this string
+locate (FMIndex _ xs) mode x = [(i, p) | (a,i) <- xs, Just p <- [op a]]
+    where
+        op = case mode of
+            Exact -> \a -> if x == a then Just 0 else Nothing
+            Prefix -> \a -> if x `BS.isPrefixOf` a then Just 0 else Nothing
+            Suffix -> \a -> if x `BS.isSuffixOf` a then Just $ BS.length a - BS.length x else Nothing
+            Infix -> \a -> let (y,z) = BS.breakSubstring x a in if BS.null z then Nothing else Just $ BS.length y
+
+
+fromHandle :: Binary a => Handle -> IO (FMIndex a)
+fromHandle = fmap decode . LBS.hGetContents

@@ -2,8 +2,18 @@ module General.Util where  import General.Base+import qualified Data.Set as Set +nubOrdOn :: Ord k => (a -> k) -> [a] -> [a]+nubOrdOn op = f Set.empty+    where f mp [] = []+          f mp (x:xs) | op x `Set.member` mp = f mp xs+                      | otherwise = x : f (Set.insert (op x) mp) xs +nubOrd :: Ord a => [a] -> [a]+nubOrd = nubOrdOn id++ -- | Only append strings if neither one is empty (++?) :: String -> String -> String a ++? b = if null a || null b then [] else a ++ b@@ -114,3 +124,10 @@ findM p (x:xs) = do     v <- p x     if v then return $ Just x else findM p xs++partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])+partitionM f [] = return ([], [])+partitionM f (x:xs) = do+    res <- f x+    (as,bs) <- partitionM f xs+    return ([x | res]++as, [x | not res]++bs)

@@ -8,7 +8,7 @@     URL,     H.Language(..),     -- * Database-    Database, loadDatabase, saveDatabase, createDatabase, showDatabase,+    Database, loadDatabase, saveDatabase, createDatabase, mergeDatabase, showDatabase,     -- * Query     Query, parseQuery, H.renderQuery,     H.queryDatabases, H.queryPackages, H.querySetPackage,@@ -21,6 +21,10 @@ import Hoogle.Store.All import General.Base import General.System+import System.FilePath+import Hoogle.DataBase2.Type+import Hoogle.DataBase2.Str+import System.IO.Unsafe  import Hoogle.Type.TagStr import qualified Hoogle.DataBase.All as H@@ -33,6 +37,9 @@ import Hoogle.Query.All(Query, exactSearch) import Hoogle.Score.All(Score) +-- Turn on the new index/search pieces+new = False+new2 = False  -- * Database @@ -45,10 +52,9 @@ --   [Serialization] A database is saved to disk with 'saveDatabase' and loaded from disk with 'loadDatabase'. -- --   [Searching] A database is searched using 'search'.-newtype Database = Database [H.DataBase]+newtype Database = Database [(FilePath, H.DataBase)] -toDataBase (Database x) = H.combineDataBase x-fromDataBase x = Database [x]+toDataBase (Database x) = H.combineDataBase $ map snd x  instance NFData Database where     rnf (Database a) = rnf a@@ -63,28 +69,51 @@  -- | Save a database to a file. saveDatabase :: FilePath -> Database -> IO ()-saveDatabase file x = do+saveDatabase file x@(Database xs) = do     performGC     H.saveDataBase file $ toDataBase x+    when new $ do+        performGC+        mergeStr [x <.> "str" | (x,_) <- xs] (file <.> "str")  +mergeDatabase :: [FilePath] -> FilePath -> IO ()+mergeDatabase src out = do+    x <- mapM loadDatabase src+    saveDatabase out $ mconcat x++ -- | Load a database from a file. If the database was not saved with the same version of Hoogle, --   it will probably throw an error. loadDatabase :: FilePath -> IO Database-loadDatabase = fmap fromDataBase . H.loadDataBase+loadDatabase x = do db <- H.loadDataBase x; return $ Database [(x, db)]   -- | Create a database from an input definition. Source files for Hoogle databases are usually --   stored in UTF8 format, and should be read using 'hSetEncoding' and 'utf8'. createDatabase-    :: H.Language -- ^ Which format the input definition is in.+    :: H.HackageURL+    -> H.Language -- ^ Which format the input definition is in.     -> [Database] -- ^ A list of databases which contain definitions this input definition relies upon (e.g. types, aliases, instances).     -> String -- ^ The input definitions, usually with one definition per line, in a format specified by the 'Language'.-    -> ([H.ParseError], Database) -- ^ A pair containing any parse errors present in the input definition, and the database ignoring any parse errors.-createDatabase _ dbs src = (err, fromDataBase $ H.createDataBase xs res)-    where-        (err,res) = H.parseInputHaskell src-        xs = concat [x | Database x <- dbs]+    -> FilePath -- ^ Output file+    -> IO [H.ParseError] -- ^ A list of any parse errors present in the input definition that were skipped.+createDatabase url _ dbs src out = do+    let (err,res) = H.parseInputHaskell url src+    let xs = concat [map snd x | Database x <- dbs]+    let db = H.createDataBase xs res+    performGC+    items <- H.saveDataBase out db+    -- don't build .str for .dep files+    when (new && takeExtension out == ".hoo") $ do+        createStr' (newPackage $ takeBaseName out) (map (Pos *** fromOnce) items) (out <.> "str")+    when (new2 && takeExtension out == ".hoo") $ do+        items <- fmap (map snd) $ H.saveDataBase (dropExtension out <.> "idx.hoo") $ H.createDataBaseEntries res+        items <- return $ flip map items $ unsafeFmapOnce $ \e -> e{H.entryLocations = map (first $ const "") $ H.entryLocations e, H.entryName="", H.entryText=mempty, H.entryDocs=mempty}+        H.saveDataBase (dropExtension out <.> "str.hoo") $ H.createDataBaseText items+        H.saveDataBase (dropExtension out <.> "typ.hoo") $ H.createDataBaseType xs res items+        return ()+    return err   -- | Show debugging information on some parts of the database. If the second argument@@ -122,15 +151,19 @@  -- | Perform a search. The results are returned lazily. search :: Database -> Query -> [(Score,Result)]-search (Database xs) q = map toResult $ H.search xs q+search (Database xs@((root,_):_)) (H.Query [name] Nothing scopes Nothing False) | new && all simple scopes =+    unsafePerformIO $ map toResult <$> searchStr' resolve (map fst xs) name+    where resolve pkg pos = runSGetAt pos (takeDirectory root </> pkg <.> "hoo") get+          simple (H.Scope a b _) = a && b == H.Package+search (Database xs) q = map toResult $ H.search (map snd xs) q  -- | Given a query and a database optionally give a list of what the user might have meant. suggestions :: Database -> Query -> Maybe TagStr-suggestions (Database dbs) q = H.suggestQuery dbs q+suggestions (Database dbs) q = H.suggestQuery (map snd dbs) q  -- | Given a query string and a database return a list of the possible completions for the search. completions :: Database -> String -> [String]-completions x = H.completions (toDataBase x)+completions x = H.completions (toDataBase x) -- FIXME: Doing a merge on completions? Bad idea.  -- | Given a query, set whether it is an exact query. queryExact :: Maybe H.ItemKind -> Query -> Query

@@ -1,4 +1,3 @@- module Hoogle.DataBase.All     (DataBase, showDataBase     ,module Hoogle.DataBase.All@@ -25,6 +24,22 @@         is = createInstances (map instances deps) facts         tys = [(sig, x) | x <- ys, Just sig <- [entryType $ fromOnce x]] ++createDataBaseEntries :: Input -> DataBase+createDataBaseEntries (facts,xs) = DataBase (createItems xs) (createSubstrSearch []) (createTypeSearch mempty mempty []) mempty mempty mempty++createDataBaseText :: [Once Entry] -> DataBase+createDataBaseText ys = DataBase mempty ns (createTypeSearch mempty mempty []) mempty mempty mempty+    where ns = createSubstrSearch [(k, y) | y <- ys, let k = entryKey $ fromOnce y, k /= ""]++createDataBaseType :: [DataBase] -> Input -> [Once Entry] -> DataBase+createDataBaseType deps (facts,_) ys = DataBase mempty+        (createSubstrSearch []) (createTypeSearch as is tys)+        (createSuggest (map suggest deps) facts) as is+    where+        as = createAliases (map aliases deps) facts+        is = createInstances (map instances deps) facts+        tys = [(sig, x) | x <- ys, Just sig <- [entryType $ fromOnce x]]   combineDataBase :: [DataBase] -> DataBase

@@ -9,8 +9,11 @@ import General.System  import Hoogle.DataBase.Type+import Hoogle.Type.All+import Control.Monad.IO.Class import Paths_hoogle(version) import Data.Version+import Data.IORef   hooVersion = take 4 $ map fromIntegral (versionBranch version) ++ [0..]@@ -33,9 +36,21 @@         return Identity  --saveDataBase :: FilePath -> DataBase -> IO ()-saveDataBase file db = runSPut file $ put (Identity, db)+saveDataBase :: FilePath -> DataBase -> IO [(Word32, Once Entry)]+saveDataBase file db = do+    ref <- newIORef []+    runSPut file $ do+        put (Identity, db)+        runAfter $ do+            res <- forM (entriesItems $ items db) $ \e -> do+                pos <- findOnce e+                case pos of+                    Nothing -> do+                        liftIO $ print $ "Could not find position of " ++ show e+                        return Nothing+                    Just pos -> return $ Just (pos, e)+            liftIO $ writeIORef ref $ catMaybes res+    readIORef ref   loadDataBase :: FilePath -> IO DataBase

@@ -168,8 +168,7 @@ bsMatch :: BS.ByteString -> Int -> BS.ByteString -> Maybe TextMatch bsMatch x     | nx == 0 = \ny _ -> Just $ if ny == 0 then MatchExact else MatchPrefix-    | nx == 1 = let c = BS.head x-                in \ny y ->+    | nx == 1 = \ny y ->                 maybe (bsCharMatch MatchExactCI MatchPrefixCI False                            (BS.head (bsLower x)) ny (bsLower y))                     Just (bsCharMatch MatchExact MatchPrefix True

@@ -0,0 +1,76 @@+{-# LANGUAGE RecordWildCards #-}++module Hoogle.DataBase2.Str(+    createStr', searchStr',+    createStr, mergeStr, searchStr+    ) where++import General.Base+import Hoogle.DataBase2.Type+import Hoogle.Type.All+import Hoogle.Score.All+import General.Util+import Data.Binary+import System.IO.Unsafe+import System.FilePath+import qualified General.FMIndex as FM+import qualified Data.ByteString.Char8 as BS+++data Strs = Strs+    {posMaximum :: Pos+    ,posOffset :: [(Package, Pos)]+    ,fmIndex :: FM.FMIndex Pos+    } deriving Show++posResolve :: Strs -> Pos -> (Package, Pos)+posResolve Strs{..} p = f posOffset+    where+        f [(pkg,off)] = (pkg,p-off)+        f ((p1,o1):(p2,o2):rest)+            | p < o2 = (p1,p-o1)+            | otherwise = f $ (p2,o2):rest+++instance Binary Strs where+    put (Strs a b c) = put a >> put b >> put c+    get = Strs <$> get <*> get <*> get+++saveStr :: FilePath -> Strs -> IO ()+saveStr = encodeFile++loadStr :: FilePath -> IO Strs+loadStr = decodeFile+++createStr :: Package -> [(Pos, BS.ByteString)] -> FilePath -> IO ()+createStr pkg items file = saveStr file $ Strs (maximum $ 0 : map fst items) [(pkg, 0)] $ FM.create '\0' $ map ((BS.map toLower . snd) &&& fst) items++mergeStr :: [FilePath] -> FilePath -> IO ()+mergeStr xs file = do+    let f mx Strs{..} = (mx + posMaximum, Strs 0 (map (second (+mx)) posOffset) (fmap (+mx) fmIndex))+    (mx,xs) <- mapAccumL f 0 <$> mapM loadStr xs+    saveStr file $ Strs mx (concatMap posOffset xs) (FM.create '\0' $ concatMap (FM.extract . fmIndex) xs)+++searchStr :: [FilePath] -> BS.ByteString -> IO [(Package, Pos, [EntryView], Score)]+searchStr files x = do+    files <- mapM loadStr files+    let locate (how1,how2) =+            [ ((pkg,pos),(pkg,pos,[FocusOn $ BS.unpack x],textScore how2))+            | file <- files+            , ((pkg,pos),_) <- map (first $ posResolve file) $ FM.locate (fmIndex file) how1 $ BS.map toLower x]+    return $ map snd $ nubOrdOn fst $ concatMap locate [(FM.Exact,MatchExact), (FM.Prefix,MatchPrefix), (FM.Infix,MatchSubstr)]+++---------------------------------------------------------------------++createStr' :: Package -> [(Pos, Entry)] -> FilePath -> IO ()+createStr' pkg items out = createStr pkg (mapMaybe f items) out+    where f (pos, Entry{..}) = if null entryKey then Nothing else Just (pos, BS.pack entryKey)++searchStr' :: (String -> Word32 -> IO Entry) -> [FilePath] -> String -> IO [Result]+searchStr' resolve files x = do+    res <- searchStr (map (<.> "str") files) $ BS.pack x+    return $ flip map res $ \(Package a,Pos b,c,d) -> Result (unsafePerformIO $ resolve (BS.unpack a) b) c d

@@ -0,0 +1,15 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Hoogle.DataBase2.Type where++import Data.Binary+import qualified Data.ByteString.Char8 as BS+import Foreign.Storable++newtype Pos = Pos Word32 deriving (Binary,Eq,Ord,Num,Show,Storable)++newtype Package = Package BS.ByteString deriving (Binary,Ord,Eq,Show)+++newPackage :: String -> Package+newPackage = Package . BS.pack

@@ -14,8 +14,8 @@ type S = SrcSpanInfo  -parseInputHaskell :: String -> ([ParseError], Input)-parseInputHaskell = join . f [] "" . zip [1..] . lines+parseInputHaskell :: HackageURL -> String -> ([ParseError], Input)+parseInputHaskell hackage = join . f [] "" . zip [1..] . lines     where         f com url [] = []         f com url ((i,s):is)@@ -23,7 +23,7 @@             | "--" `isPrefixOf` s = f ([dropWhile isSpace $ drop 2 s | com /= []] ++ com) url is             | "@url " `isPrefixOf` s =  f com (drop 5 s) is             | all isSpace s = f [] "" is-            | otherwise = (case parseLine i s of+            | otherwise = (case parseLine hackage i s of                                Left y -> Left y                                Right (as,bs) -> Right (as,[b{itemURL=if null url then itemURL b else url, itemDocs=unlines $ reverse com} | b <- bs]))                           : f [] "" is@@ -33,15 +33,15 @@                   (as,bs) = unzip items  -parseLine :: Int -> String -> Either ParseError ([Fact],[TextItem])-parseLine line x | "(##)" `isPrefixOf` x = Left $ parseErrorWith line 1 "Skipping due to HSE bug #206" "(##)"-parseLine line ('@':str) = case a of+parseLine :: HackageURL -> Int -> String -> Either ParseError ([Fact],[TextItem])+parseLine _ line x | "(##)" `isPrefixOf` x = Left $ parseErrorWith line 1 "Skipping due to HSE bug #206" "(##)"+parseLine url line ('@':str) = case a of         "entry" | b <- words b, b /= [] -> Right $ itemEntry b-        "package" | [b] <- words b, b /= "" -> Right $ itemPackage b+        "package" | [b] <- words b, b /= "" -> Right $ itemPackage url b         _ -> Left $ parseErrorWith line 2 ("Unknown attribute: " ++ a) $ '@':str     where (a,b) = break isSpace str-parseLine line x | ["module",a] <- words x = Right $ itemModule $ split '.' a-parseLine line x+parseLine _ line x | ["module",a] <- words x = Right $ itemModule $ split '.' a+parseLine _ line x     | not continue = res     | otherwise = fromMaybe res $ fmap Right $ parseTuple x `mappend` parseCtor x     where (continue,res) = parseFunction line x@@ -77,9 +77,9 @@  fact x y = (x,[y]) -itemPackage x = fact [] $ textItem{itemLevel=0, itemKey="", itemName=x,+itemPackage hackageUrl x = fact [] $ textItem{itemLevel=0, itemKey="", itemName=x,     itemKind=PackageItem,-    itemURL="http://hackage.haskell.org/package/" ++ x ++ "/",+    itemURL= hackageUrl ++ "package/" ++ x ++ "/",     itemDisp=Tags [emph "package",space,bold x]}  itemEntry (x:xs) = fact [] $ textItem{itemName=y, itemKey=y,

@@ -1,8 +1,8 @@ {-# LANGUAGE ScopedTypeVariables #-}  module Hoogle.Store.All(-    SPut, SGet, runSPut, runSGet,-    Once, fromOnce, once, getDefer, putDefer,+    SPut, SGet, runSPut, runSGet, runSGetAt, runAfter,+    Once, fromOnce, once, findOnce, unsafeFmapOnce, getDefer, putDefer,     module Hoogle.Store.All     ) where 

@@ -1,9 +1,9 @@ {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}  module Hoogle.Store.Type(-    Once, once, fromOnce, putOnce, getOnce,-    SPut, runSPut, putByteString, putStorable, putDefer,-    SGet, runSGet, getByteString, getStorable, getDefer, getLazyList+    Once, once, fromOnce, putOnce, getOnce, findOnce, unsafeFmapOnce,+    SPut, runSPut, putByteString, putStorable, putDefer, runAfter,+    SGet, runSGet, runSGetAt, getByteString, getStorable, getDefer, getLazyList     ) where  import General.Base@@ -29,6 +29,9 @@ data Once a = Once {_onceKey :: Int, valueOnce :: a}               deriving Typeable +unsafeFmapOnce :: (a -> b) -> Once a -> Once b+unsafeFmapOnce f (Once k v) = Once k $ f v+ instance NFData a => NFData (Once a) where     rnf (Once a b) = rnf (a,b) @@ -57,9 +60,9 @@ readPos = liftIO . W.getPos =<< asks putBuffer  -runSPut :: FilePath -> SPut () -> IO ()+runSPut :: FilePath -> SPut a -> IO a runSPut file act = withBinaryFile file WriteMode $ \h -> do-    pending <- newIORef [act]+    pending <- newIORef []     once <- newIORef IntMap.empty      W.withBuffer h $ \buffer -> do@@ -69,7 +72,7 @@                 forM_ xs $ \x -> do                     x                     flush-        runReaderT flush $ SPutS buffer once pending+        runReaderT (do res <- act; flush; return res) $ SPutS buffer once pending   putByteString :: BString -> SPut ()@@ -93,7 +96,10 @@         liftIO $ W.patch buf pos val         act +runAfter :: SPut () -> SPut ()+runAfter act = modifyRef putPending (++[act]) + {-# NOINLINE once #-} once :: a -> Once a once x = System.IO.Unsafe.unsafePerformIO $ do@@ -103,6 +109,14 @@  type PutOnce = Either [Word32] Word32 +findOnce :: Once a -> SPut (Maybe Word32)+findOnce (Once key _) = do+    ref <- asks putOnces+    mp <- liftIO $ readIORef ref+    return $ case IntMap.lookup key mp of+        Just (Right val) -> Just val+        _ -> Nothing+ putOnce :: (a -> SPut ()) -> Once a -> SPut () putOnce act (Once key x) = do     ref <- asks putOnces@@ -137,12 +151,15 @@   runSGet :: Typeable a => FilePath -> SGet a -> IO a-runSGet file m = do+runSGet = runSGetAt 0++runSGetAt :: Typeable a => Word32 -> FilePath -> SGet a -> IO a+runSGetAt pos file m = do     h <- openBinaryFile file ReadMode     sz <- hFileSize h     buf <- R.newBuffer h     one <- onceKeys $ fromIntegral sz-    runReaderT (getDeferFrom 0 m) $ SGetS buf one+    runReaderT (getDeferFrom pos m) $ SGetS buf one   getStorable :: Typeable a => Storable a => SGet a

@@ -1,22 +1,23 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Hoogle.Type.Docs(-    Docs, readDocsHTML, renderDocs+    Docs(..), readDocsHTML, renderDocs     ) where  import General.Base import Hoogle.Type.TagStr import Hoogle.Store.All import Data.ByteString.Char8(ByteString,pack,unpack)+import Data.Binary  -newtype Docs = Docs ByteString-    deriving (Eq,Ord)+newtype Docs = Docs {fromDocs :: ByteString}+    deriving (Eq,Ord,Binary,Monoid)   instance Store Docs where     put (Docs x) = put1 x     get = get1 Docs-  readDocsHTML :: String -> Docs readDocsHTML = Docs . pack

@@ -11,6 +11,8 @@ import Data.Generics.Uniplate  +type HackageURL = String+ type Input = ([Fact], [TextItem])  data ItemKind = PackageItem

@@ -12,6 +12,8 @@ import General.Web import Data.Generics.Uniplate import Hoogle.Store.All+import qualified Data.Binary as B+import qualified Data.ByteString.Char8 as BS   data TagStr@@ -22,6 +24,22 @@     | TagLink String TagStr -- ^ A hyperlink to a URL.     | TagColor Int TagStr -- ^ Colored text. Index into a 0-based palette. Text without any 'TagColor' should be black.       deriving (Data,Typeable,Ord,Show,Eq)++instance B.Binary TagStr where+    put (Str x) = B.putWord8 0 >> B.put (BS.pack x)+    put (Tags x) = B.putWord8 1 >> B.put x+    put (TagBold x) = B.putWord8 2 >> B.put x+    put (TagEmph x) = B.putWord8 3 >> B.put x+    put (TagLink x y) = B.putWord8 4 >> B.put (BS.pack x) >> B.put y+    put (TagColor x y) = B.putWord8 5 >> B.put x >> B.put y++    get = B.getWord8 >>= \x -> case x of+        0 -> Str . BS.unpack <$> B.get+        1 -> Tags <$> B.get+        2 -> TagBold <$> B.get+        3 -> TagEmph <$> B.get+        4 -> do x <- B.get; y <- B.get; return $ TagLink (BS.unpack x) y+        5 -> TagColor <$> B.get <*> B.get  instance NFData TagStr where     rnf (Str a) = rnf a

@@ -4,6 +4,7 @@  import General.Base hiding (readFile') import General.System as Sys+import General.Util import Control.Concurrent import Control.Exception as E import qualified Data.Map as Map@@ -30,11 +31,10 @@     createDirectoryIfMissing True datadir     withDirectory datadir $ do         when redownload $ do-            forM_ urls $ \(file,_) -> removeFile_ $ "downloads" </> file+            forM_ (urls opt) $ \(file,_) -> removeFile_ $ "downloads" </> file         when rebuild $ removeFile ".shake.database"         (count, file) <- withWarnings $ \warn ->-            shake shakeOptions{shakeVersion=showVersion V.version, shakeThreads=threads, shakeProgress=progressSimple} $ do-                want $ map (<.> "hoo") $ if null actions then ["default"] else actions+            shake shakeOptions{shakeVersion=showVersion V.version, shakeThreads=threads, shakeProgress=progressSimple} $                 rules opt warn         putStrLn $ show count ++ " warnings, saved to " ++ file         putStrLn "Data generation complete"@@ -44,14 +44,14 @@ newtype HoogleVersion = HoogleVersion String deriving (Show,Typeable,Eq,Hashable,Binary,NFData)  rules :: CmdLine -> ([String] -> IO ()) -> Rules ()-rules Data{..} warn = do+rules opts@Data{..} warn = do     let srcCabal name ver = "downloads/cabal" </> name </> ver </> name <.> "cabal"     let srcHoogle name ver = "downloads/hoogle" </> name </> ver </> "doc" </> "html" </> name <.> "txt" -    (\x -> "downloads/*" ?== x && isJust (lookup (takeFileName x) urls)) ?> \out -> do-        let Just url = lookup (takeFileName out) urls+    (\x -> "downloads/*" ?== x &&+           isJust (lookup (takeFileName x) (urls opts))) ?> \out -> do+        let Just url = lookup (takeFileName out) (urls opts)         putNormal $ "Downloading " ++ out-        -- liftIO $ copyFile ("C:/spacework/hoogle/cache" </> takeFileName out) out         wget url out         putNormal $ "Downloaded " ++ out @@ -86,6 +86,11 @@     verCabal  <- addOracle $ \(CabalVersion  x) -> fmap (Map.lookup x) $ index "downloads/cabal.index"     verHoogle <- addOracle $ \(HoogleVersion x) -> fmap (Map.lookup x) $ index "downloads/hoogle.index" +    if null actions then want ["default.hoo"] else action $ do+        (good,bad) <- partitionM (fmap isJust . verHoogle . HoogleVersion) actions+        forM_ (delete "all" bad) $ \x -> putNormal $ "Couldn't generate database for " ++ x ++ ", no Hoogle docs available"+        need $ map (<.> "hoo") $ ["all" | "all" `elem` bad] ++ good+     alternatives $ do -- Match *.txt         "keyword.txt" *> \out -> do             let src = "downloads/keyword.htm.cache"@@ -109,7 +114,7 @@                     Right src ->                         [""] ++ zipWith (++) ("-- | " : repeat "--   ") (cabalDescription src) ++                         ["--","-- Version " ++ ver, "@url package/" ++ name, "@entry package " ++ name]-            liftIO $ writeFileUtf8 out $ unlines $ "@url http://hackage.haskell.org/" : "@package package" : concat xs+            liftIO $ writeFileUtf8 out $ unlines $ ("@url " ++ hackage) : "@package package" : concat xs          "*.txt" *> \out -> do             let name = takeBaseName out@@ -119,7 +124,7 @@                    then need ["downloads/base.txt.cache"] >> return (Just "downloads/base.txt.cache")                    else fmap (fmap $ srcHoogle name) $ verHoogle (HoogleVersion name)             hoo <- return $ fromMaybe (error $ "Couldn't find hoogle file for " ++ name) hoo-            hoo <- liftIO $ readFileUtf8' hoo `E.catch` \(_ :: SomeException) -> readFile hoo+            hoo <- liftIO $ readFileUtf8' hoo `E.catch` \(_ :: SomeException) -> readFileLatin1' hoo             deps <- liftIO $ case cab of                 Nothing -> return []                 Just cab -> do@@ -157,27 +162,25 @@             if not (null contents) && "@combine " `isPrefixOf` head contents then do                 let deps = [x <.> "hoo" | x <- contents, Just x <- [stripPrefix "@combine " x]]                 need deps-                dbs <- liftIO $ mapM loadDatabase deps                 putNormal $ "Creating " ++ out ++ " from " ++ show (length deps) ++ " databases... "-                liftIO $ performGC-                liftIO $ saveDatabase out $ mconcat dbs+                liftIO $ mergeDatabase deps out              else do                 (deps, contents) <- return $ splitDeps contents                 deps <- genImported (Set.singleton $ takeBaseName out) deps-                let (err,db) = createDatabase Haskell [snd $ createDatabase Haskell [] $ unlines deps] $ unlines contents-                liftIO $ warn [takeBaseName out ++ ": " ++ show e | e <- err]                 putNormal $ "Creating " ++ out ++ "... "-                liftIO $ performGC-                liftIO $ saveDatabase out db+                liftIO $ createDatabase hackage Haskell [] (unlines deps) $ out -<.> "dep"+                deps <- liftIO $ loadDatabase $ out -<.> "dep"+                err <- liftIO $ createDatabase hackage Haskell [deps] (unlines contents) out+                liftIO $ warn [takeBaseName out ++ ": " ++ show e | e <- err]  -urls :: [(FilePath, URL)]-urls = let (*) = (,) in+urls :: CmdLine -> [(FilePath, URL)]+urls Data{..} = let (*) = (,) in     ["keyword.htm" * "http://www.haskell.org/haskellwiki/Keywords"     ,"platform.cabal" * "http://code.galois.com/darcs/haskell-platform/haskell-platform.cabal"     ,"base.txt" * "http://www.haskell.org/hoogle/base.txt"-    ,"cabal.tar.gz" * "http://hackage.haskell.org/packages/index.tar.gz"-    ,"hoogle.tar.gz" * "http://hackage.haskell.org/packages/hoogle.tar.gz"]+    ,"cabal.tar.gz" * (hackage ++ "packages/index.tar.gz")+    ,"hoogle.tar.gz" * (hackage ++ "packages/hoogle.tar.gz")]   withWarnings :: (([String] -> IO ()) -> IO ()) -> IO (Int, FilePath)

@@ -4,10 +4,12 @@ import Test.Parse_TypeSig import Test.Parse_Query import Test.Docs+import Test.BWT_FM   test :: IO ()-test = print $ do+test = do     parse_TypeSig     parse_Query     docs+    bwt_fm

@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}++module Test.BWT_FM(bwt_fm) where++import Test.General+import Test.QuickCheck+import General.BurrowsWheeler+++bwt_fm = do+    compress "tomorrow and tomorrow and tomorrow" === (31,"wwwdd  nnoooaatttmmmrrrrrrooo  ooo")+    decompress (31,"wwwdd  nnoooaatttmmmrrrrrrooo  ooo") === "tomorrow and tomorrow and tomorrow"+    quickCheck $ \x -> decompress (compress x) == x

@@ -1,12 +1,13 @@  module Test.Docs(docs) where -import Test.General import Hoogle.Type.TagStr import Hoogle.Type.Docs+import Test.General  +docs :: IO () docs = do-    let a === b = if renderDocs (readDocsHTML a) == b then pass else error $ "differences in docs " ++ show (renderDocs (readDocsHTML a))-    "foo" === Str "foo"-    "foo <i>bar</i> baz" === Tags [Str "foo ", TagEmph (Str "bar"), Str " baz"]+    let a =#= b = renderDocs (readDocsHTML a) === b+    "foo" =#= Str "foo"+    "foo <i>bar</i> baz" =#= Tags [Str "foo ", TagEmph (Str "bar"), Str " baz"]

@@ -1,48 +1,29 @@-{-# OPTIONS_GHC -fno-warn-missing-methods #-} -module Test.General where+module Test.General(parseTest, (===), randCheck) where +import Control.Monad+import qualified Data.ByteString as BS+import Test.QuickCheck ------------------------------------------------------------------------- The Test Monad -data Test a = Test--instance Monad Test where-    a >> b = a `seq` b--instance Show (Test a) where-    show x = x `seq` "All tests passed"--pass :: Test ()-pass = Test+instance Arbitrary BS.ByteString where+    arbitrary = fmap BS.pack arbitrary  +parseTest :: (Show a, Show e, Eq a) => (String -> Either e a) -> String -> a -> IO () parseTest f input output =     case f input of         Left x -> err "Parse failed" (show x)-        Right x -> if x == output then pass else-                   err "Parse not equal" (show x)-    where-        err pre post = error $ pre ++ ":\n  " ++ input ++ "\n  " ++ show output ++ "\n  " ++ post--parseTest2 f input output =-    case f input of-        (x:xs,_) -> err "Parse failed" (show x)-        ([],  x) -> if x == output then pass else-                    err "Parse not equal" (show x)+        Right x -> when (x /= output) $ err "Parse not equal" (show x)     where         err pre post = error $ pre ++ ":\n  " ++ input ++ "\n  " ++ show output ++ "\n  " ++ post  ------------------------------------------------------------------------- The List Monad--data List a b = List {fromList :: [a]}--instance Monad (List a) where-    List a >> List b = List (a++b)--pair :: a -> b -> List (a,b) c-pair a b = List [(a,b)]+(===) :: (Show a, Eq a) => a -> a -> IO ()+a === b = when (a /= b) $ error $ "Expected: " ++ show a ++ "\nGot: " ++ show b +randCheck :: Testable a => a -> IO ()+randCheck p = do+    res <- quickCheckWithResult stdArgs p+    let bad = case res of Failure{} -> True; GaveUp{} -> True; _ -> False+    when bad $ error "QuickCheck failed"

@@ -6,6 +6,7 @@ import Hoogle.Query.All import Hoogle.Type.All +parse_Query :: IO () parse_Query = do     let (===) = parseTest parseQuery         q = mempty

@@ -6,6 +6,8 @@ import Hoogle.Type.All import Hoogle.Query.All ++parse_TypeSig :: IO () parse_TypeSig = do     let parseTypeSig x = either Left (Right . fromMaybe (error $ "Couldn't find type in: " ++ x) . typeSig) $ parseQuery (":: " ++ x)     let (===) = parseTest parseTypeSig