" + text + "
")}, - showResult: function(text){$body.html(text);} + showResult: function(text){$body.html(text); newDocs();} } } @@ -216,45 +216,84 @@ ///////////////////////////////////////////////////////////////////// // DOCUMENTATION -function docs(i) +$(function(){ + if (embed) return; + $(window).resize(resizeDocs); + newDocs(); +}); + +function resizeDocs() { - var e = document.getElementById("d" + i); - e.className = (e.className == "shut" ? "open" : "shut"); - return false; + $("#body .doc").each(function(){ + // If a segment is open, it should remain open forever + var $this = $(this); + var toosmall = ($.support.preWrap && $this.hasClass("newline")) || + ($this.height() < $this.children().height()); + if (toosmall && !$this.hasClass("open")) + $this.addClass("shut"); + else if (!toosmall && $this.hasClass("shut")) + $this.removeClass("shut"); + }); } +function newDocs() +{ + resizeDocs(); + $("#body .doc").click(function(){ + var $this = $(this); + if ($this.hasClass("open") || $this.hasClass("shut")) + $this.toggleClass("open").toggleClass("shut"); + }); +} + ///////////////////////////////////////////////////////////////////// +// iOS TWEAKS + +$(function(){ + if ($.support.inputSearch) + $("#hoogle")[0].type = "search"; +}); + + +///////////////////////////////////////////////////////////////////// // LIBRARY BITS // Access the browser query string // From http://stackoverflow.com/questions/901115/get-querystring-values-with-jquery/3867610#3867610 -;(function ($) { - $.extend({ - getQueryString: function (name) { - function parseParams() { - var params = {}, - e, - a = /\+/g, // Regex for replacing addition symbol with a space - r = /([^&=]+)=?([^&]*)/g, - d = function (s) { return decodeURIComponent(s.replace(a, " ")); }, - q = window.location.search.substring(1); +$.getQueryString = function(name) +{ + function parseParams() { + var params = {}, + e, + a = /\+/g, // Regex for replacing addition symbol with a space + r = /([^&=]+)=?([^&]*)/g, + d = function (s) { return decodeURIComponent(s.replace(a, " ")); }, + q = window.location.search.substring(1); - while (e = r.exec(q)) - params[d(e[1])] = d(e[2]); + while (e = r.exec(q)) + params[d(e[1])] = d(e[2]); - return params; - } + return params; + } - if (!this.queryStringParams) - this.queryStringParams = parseParams(); + if (!this.queryStringParams) + this.queryStringParams = parseParams(); - return this.queryStringParams[name]; - } - }); -})(jQuery); + return this.queryStringParams[name]; +} +// Supports white-space: pre-wrap; +$.support.preWrap = !($.browser.msie && $.browser.version < 8); +$.support.iOS = + (navigator.platform.indexOf("iPhone") != -1) || + (navigator.platform.indexOf("iPod") != -1) || + (navigator.platform.indexOf("iPad") != -1); + +// Supports +$.support.inputSearch = $.support.iOS; + var Key = { Up: 38, Down: 40, @@ -262,11 +301,9 @@ Escape: 27 }; - function unpx(x){var r = 1 * x.replace("px",""); return isNaN(r) ? 0 : r;} function px(x){return x + "px";} - function cache(maxElems) { // FIXME: Currently does not evict things @@ -284,7 +321,6 @@ } }; } - function watchdog(time, fun) { diff --git a/datadir/resources/template.html b/datadir/resources/template.html new file mode 100644 --- /dev/null +++ b/datadir/resources/template.html @@ -0,0 +1,89 @@ + +#export header css js query + + + + ++ Hoogle is a Haskell API search engine, which allows you to search many standard Haskell libraries + by either function name, or by approximate type signature. +
+
+ Example searches:
+ $query=map$ $#search$
+ $query=(a -> b) -> [a] -> [b]$ $#search$
+ $query=Ord a => [a] -> [a]$ $#search$
+ $query=Data.Map.insert$ $#search$
+
Enter your own search at the top of the page.
+
+ The Hoogle manual contains more details, + including further details on search queries, how to install Hoogle as a command line application + and how to integrate Hoogle with Firefox/Emacs/Vim etc. +
++ I am very interested in any feedback you may have. Please + email me, or add an entry to my + bug tracker. +
+ + +#export parseError ++ Parse error: $&errMessage$ +
+ For information on what queries should look like, see the + user manual. +
diff --git a/datadir/resources/template_example.html b/datadir/resources/template_example.html new file mode 100644 --- /dev/null +++ b/datadir/resources/template_example.html @@ -0,0 +1,11 @@ + +#homepage +example.com + + +#export welcome ++ This copy of Hoogle overrides a few example settings, to allow you to better integrate it + in any local installations. +
diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.6 build-type: Simple name: hoogle -version: 4.2.1 +version: 4.2.2 license: GPL license-file: docs/LICENSE category: Development @@ -24,6 +24,7 @@ resources/*.ico resources/*.js resources/*.png + resources/*.html -- Cabal doesn't find files with . in them, Cabal bug #794 resources/jquery-1.4.2.js resources/jquery.cookie.js @@ -35,7 +36,7 @@ array, bytestring, containers, directory, filepath, process, random, safe, binary, - parsec == 2.1.*, + parsec >= 2.1, transformers == 0.2.*, uniplate == 1.6.*, haskell-src-exts >= 1.9 && < 1.11 @@ -57,12 +58,6 @@ Hoogle.Language.Haskell other-modules: - Data.Binary.Defer - Data.Binary.Defer.Array - Data.Binary.Defer.Class - Data.Binary.Defer.Index - Data.Binary.Defer.Monad - Data.Binary.Raw Data.Heap Data.TypeMap General.Base @@ -83,7 +78,7 @@ Hoogle.DataBase.TypeSearch.Result Hoogle.DataBase.TypeSearch.TypeScore Hoogle.DataBase.TypeSearch.All - Hoogle.Type.Documentation + Hoogle.Type.Docs Hoogle.Type.Item Hoogle.Type.Language Hoogle.Type.TagStr @@ -97,19 +92,25 @@ Hoogle.Score.Scoring Hoogle.Score.Type Hoogle.Search.Results + Hoogle.Store.All + Hoogle.Store.ReadBuffer + Hoogle.Store.Type + Hoogle.Store.WriteBuffer executable hoogle main-is: Main.hs hs-source-dirs: src build-depends: - time, old-locale, + time, old-time, old-locale, cmdargs == 0.6.*, tagsoup >= 0.11 && < 0.13, enumerator == 0.4.*, - blaze-builder == 0.2.*, - wai == 0.3.0, - warp == 0.3.0, + blaze-builder >= 0.2 && < 0.4, + http-types == 0.6.*, + case-insensitive == 0.2.*, + wai == 0.4.*, + warp == 0.4.*, Cabal >= 1.8 && < 1.11 other-modules: @@ -127,9 +128,11 @@ Recipe.Download Recipe.General Recipe.Hackage + Recipe.Haddock Recipe.Keyword Recipe.Type Test.All + Test.Docs Test.General Test.Parse_Query Test.Parse_TypeSig @@ -137,3 +140,4 @@ Web.Page Web.Response Web.Server + Web.Template diff --git a/src/CmdLine/Type.hs b/src/CmdLine/Type.hs --- a/src/CmdLine/Type.hs +++ b/src/CmdLine/Type.hs @@ -32,7 +32,7 @@ ,queryText :: String } | Data {redownload :: Bool, local :: [String], datadir :: FilePath, threads :: Int, actions :: [String]} - | Server {port :: Int, local_ :: Bool, databases :: [FilePath], resources :: FilePath} + | Server {port :: Int, local_ :: Bool, databases :: [FilePath], resources :: FilePath, dynamic :: Bool, template :: [FilePath]} | Combine {srcfiles :: [FilePath], outfile :: String} | Convert {srcfile :: String, outfile :: String} | Log {logfiles :: [FilePath]} @@ -71,6 +71,8 @@ {port = 80 &= typ "INT" &= help "Port number" ,resources = "" &= typDir &= help "Directory to use for resources (images, CSS etc)" ,local_ = def &= help "Rewrite and serve file: links (potential security hole)" + ,dynamic = def &= name "x" &= help "Allow resource files to change during execution" + ,template = def &= typFile &= help "Template files to use instead of default definitions" } &= help "Start a Hoogle server" dump = Dump diff --git a/src/Data/Binary/Defer.hs b/src/Data/Binary/Defer.hs deleted file mode 100644 --- a/src/Data/Binary/Defer.hs +++ /dev/null @@ -1,18 +0,0 @@ - -module Data.Binary.Defer( - module Data.Binary.Defer.Monad, - module Data.Binary.Defer.Class, - BinaryDeferGet(..), - FixedBinary(..) - ) where - -import Data.Binary.Defer.Monad -import Data.Binary.Defer.Class -import Data.Binary - - -class BinaryDeferGet a where - binaryDeferGet :: DeferGet (Get a) - -class FixedBinary a where - fixedSize :: a -> Int diff --git a/src/Data/Binary/Defer/Array.hs b/src/Data/Binary/Defer/Array.hs deleted file mode 100644 --- a/src/Data/Binary/Defer/Array.hs +++ /dev/null @@ -1,57 +0,0 @@ - -module Data.Binary.Defer.Array( - (!), Array, array, elems, arraySize - ) where - -import Data.Array hiding ((!), Array, array, elems) -import qualified Data.Array as A -import Data.Binary.Defer -import Data.Binary.Raw -import System.IO.Unsafe -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader - - -newtype Array a = Array (A.Array Int a) - -array :: [a] -> Array a -array xs = Array $ listArray (0, length xs - 1) xs - -(!) :: Array a -> Int -> a -(!) (Array a) i = a A.! i - -elems :: Array a -> [a] -elems (Array a) = A.elems a - - -arraySize (Array a) = 1 + y - x - where (x,y) = bounds a - -instance Functor Array where - fmap f (Array x) = Array (fmap f x) - -instance Eq a => Eq (Array a) where - Array x == Array y = x == y - -instance Show a => Show (Array a) where - show (Array x) = show x - -instance BinaryDefer a => BinaryDefer (Array a) where - put (Array xs) = putDefer $ do - putInt $ snd $ bounds xs - mapM_ putFixed (A.elems xs) - - get = getDefer ans - where - ans = do - n <- getInt - h <- asks fst - s <- ask - i <- liftIO $ hGetPos h - let f j = unsafePerformIO $ do - hSetPos h (i + toInteger (sz*j)) - runReaderT getFixed s - return $ Array $ listArray (0,n) $ map f [0..n] - - unwrap = undefined :: DeferGet (Array a) -> a - sz = size $ unwrap ans diff --git a/src/Data/Binary/Defer/Class.hs b/src/Data/Binary/Defer/Class.hs deleted file mode 100644 --- a/src/Data/Binary/Defer/Class.hs +++ /dev/null @@ -1,223 +0,0 @@ - -module Data.Binary.Defer.Class where - -import Control.Arrow -import Control.Monad -import Data.Binary.Defer.Monad -import Data.Binary.Raw -import Data.ByteString(ByteString) -import qualified Data.Map as Map -import General.Util(splitAtLength) - ---------------------------------------------------------------------- --- BinaryDefer - -class BinaryDefer a where - put :: a -> DeferPut () - get :: DeferGet a - - size :: a -> Int - size _ = 4 - - putFixed :: a -> DeferPut () - putFixed = putDefer . put - - getFixed :: DeferGet a - getFixed = getDefer get - - -errorDeferGet :: String -> a -errorDeferGet typ = error $ "BinaryDefer.get(" ++ typ ++ "), corrupt database" - - -get0 f = return f -get1 f = do x1 <- get; return (f x1) -get2 f = do x1 <- get; x2 <- get; return (f x1 x2) -get3 f = do x1 <- get; x2 <- get; x3 <- get; return (f x1 x2 x3) -get4 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; return (f x1 x2 x3 x4) -get5 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; return (f x1 x2 x3 x4 x5) -get6 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; return (f x1 x2 x3 x4 x5 x6) -get7 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; x7 <- get; return (f x1 x2 x3 x4 x5 x6 x7) -get8 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; x7 <- get; x8 <- get; return (f x1 x2 x3 x4 x5 x6 x7 x8) -get9 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; x7 <- get; x8 <- get; x9 <- get; return (f x1 x2 x3 x4 x5 x6 x7 x8 x9) - - -getFixed0 f = return f -getFixed1 f = do x1 <- getFixed; return (f x1) -getFixed2 f = do x1 <- getFixed; x2 <- getFixed; return (f x1 x2) -getFixed3 f = do x1 <- getFixed; x2 <- getFixed; x3 <- getFixed; return (f x1 x2 x3) -getFixed4 f = do x1 <- getFixed; x2 <- getFixed; x3 <- getFixed; x4 <- getFixed; return (f x1 x2 x3 x4) -getFixed5 f = do x1 <- getFixed; x2 <- getFixed; x3 <- getFixed; x4 <- getFixed; x5 <- getFixed; return (f x1 x2 x3 x4 x5) -getFixed6 f = do x1 <- getFixed; x2 <- getFixed; x3 <- getFixed; x4 <- getFixed; x5 <- getFixed; x6 <- getFixed; return (f x1 x2 x3 x4 x5 x6) - - -put0 = return () :: DeferPut () -put1 x1 = put x1 -put2 x1 x2 = put x1 >> put x2 -put3 x1 x2 x3 = put x1 >> put x2 >> put x3 -put4 x1 x2 x3 x4 = put x1 >> put x2 >> put x3 >> put x4 -put5 x1 x2 x3 x4 x5 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 -put6 x1 x2 x3 x4 x5 x6 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 -put7 x1 x2 x3 x4 x5 x6 x7 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 -put8 x1 x2 x3 x4 x5 x6 x7 x8 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8 -put9 x1 x2 x3 x4 x5 x6 x7 x8 x9 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8 >> put x9 - - -putFixed0 = return () :: DeferPut () -putFixed1 x1 = putFixed x1 -putFixed2 x1 x2 = putFixed x1 >> putFixed x2 -putFixed3 x1 x2 x3 = putFixed x1 >> putFixed x2 >> putFixed x3 -putFixed4 x1 x2 x3 x4 = putFixed x1 >> putFixed x2 >> putFixed x3 >> putFixed x4 -putFixed5 x1 x2 x3 x4 x5 = putFixed x1 >> putFixed x2 >> putFixed x3 >> putFixed x4 >> putFixed x5 -putFixed6 x1 x2 x3 x4 x5 x6 = putFixed x1 >> putFixed x2 >> putFixed x3 >> putFixed x4 >> putFixed x5 >> putFixed x6 - - -putEnumByte :: Enum a => a -> DeferPut () -putEnumByte x = putByte $ fromIntegral $ fromEnum x - -getEnumByte :: Enum a => DeferGet a -getEnumByte = fmap (toEnum . fromIntegral) getByte - - -instance BinaryDefer Int where - put = putInt - get = getInt - size _ = 4 - putFixed = put - getFixed = get - -instance BinaryDefer Char where - put = putChr - get = getChr - size _ = 1 - putFixed = put - getFixed = get - -instance BinaryDefer Bool where - put x = putChr (if x then '1' else '0') - get = fmap (== '1') getChr - size _ = 1 - putFixed = put - getFixed = get - - -instance BinaryDefer () where - put () = return () - get = return () - size _ = 0 - putFixed = put - getFixed = get - -instance (BinaryDefer a, BinaryDefer b) => BinaryDefer (a,b) where - put (a,b) = put2 a b - get = get2 (,) - size x = let ~(a,b) = x in size a + size b - putFixed (a,b) = putFixed2 a b - getFixed = getFixed2 (,) - -instance (BinaryDefer a, BinaryDefer b, BinaryDefer c) => - BinaryDefer (a,b,c) where - put (a,b,c) = put3 a b c - get = get3 (,,) - size x = let ~(a,b,c) = x in size a + size b + size c - putFixed (a,b,c) = putFixed3 a b c - getFixed = getFixed3 (,,) - -instance (BinaryDefer a, BinaryDefer b, BinaryDefer c, BinaryDefer d) => - BinaryDefer (a,b,c,d) where - put (a,b,c,d) = put4 a b c d - get = get4 (,,,) - size x = let ~(a,b,c,d) = x in size a + size b + size c + size d - putFixed (a,b,c,d) = putFixed4 a b c d - getFixed = getFixed4 (,,,) - -instance (BinaryDefer a, BinaryDefer b, BinaryDefer c, BinaryDefer d, - BinaryDefer e) => BinaryDefer (a,b,c,d,e) where - put (a,b,c,d,e) = put5 a b c d e - get = get5 (,,,,) - size x = let ~(a,b,c,d,e) = x in size a + size b + size c + size d + size e - putFixed (a,b,c,d,e) = putFixed5 a b c d e - getFixed = getFixed5 (,,,,) - -instance (BinaryDefer a, BinaryDefer b, BinaryDefer c, BinaryDefer d, - BinaryDefer e, BinaryDefer f) => BinaryDefer (a,b,c,d,e,f) where - put (a,b,c,d,e,f) = put6 a b c d e f - get = get6 (,,,,,) - size x = let ~(a,b,c,d,e,f) = x in size a + size b + size c + size d + size e + size f - putFixed (a,b,c,d,e,f) = putFixed6 a b c d e f - getFixed = getFixed6 (,,,,,) - -instance BinaryDefer a => BinaryDefer (Maybe a) where - put Nothing = putByte 0 - put (Just a) = putByte 1 >> put a - - get = do i <- getByte - case i of - 0 -> get0 Nothing - 1 -> get1 Just - _ -> errorDeferGet "Maybe" - -instance (BinaryDefer a, BinaryDefer b) => BinaryDefer (Either a b) where - put (Left a) = putByte 0 >> put a - put (Right a) = putByte 1 >> put a - - get = do i <- getByte - case i of - 0 -> get1 Left - 1 -> get1 Right - _ -> errorDeferGet "Either" - - --- strategy: write out in 100 byte chunks, where each successive --- chunk is lazy, but the first is not -instance BinaryDefer a => BinaryDefer [a] where - put xs = putList xs - - get = do - i <- getByte - if i /= maxByte then - replicateM (fromIntegral i) get - else do - xs <- replicateM 100 get - ys <- getDefer get - return (xs++ys) - - --- Extracted to allow putList to appear on the profile -putList :: BinaryDefer a => [a] -> DeferPut () -putList xs | null b = putByte (fromIntegral n) >> mapM_ put a - | otherwise = putByte maxByte >> mapM_ put a >> putDefer (put b) - where (n,a,b) = splitAtLength 100 xs - - -instance BinaryDefer ByteString where - put = putDefer . putByteString - get = getDefer getByteString - putFixed = put - getFixed = get - - -newtype Defer a = Defer a - -fromDefer :: Defer a -> a -fromDefer (Defer x) = x - -instance BinaryDefer a => BinaryDefer (Defer a) where - put (Defer x) = putDefer $ put x - get = getDefer $ fmap Defer get - putFixed = put - getFixed = get - - -instance (Ord k, BinaryDefer k, BinaryDefer v) => BinaryDefer (Map.Map k v) where - put = putDefer . putVector . Prelude.map (second Defer) . Map.toAscList - where - putVector xs = putDefer $ do - putInt (length xs) - mapM_ put xs - - get = getDefer $ fmap (Map.fromAscList . Prelude.map (second fromDefer)) getVector - where - getVector = getDefer $ do - i <- getInt - replicateM i get diff --git a/src/Data/Binary/Defer/Index.hs b/src/Data/Binary/Defer/Index.hs deleted file mode 100644 --- a/src/Data/Binary/Defer/Index.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Data.Binary.Defer.Index( - Id, - Index, newIndex, - Link, newLink, fromLink, linkKey, indexLinks - ) where - -import qualified Data.Binary as Bin -import qualified Data.Binary.Get as Bin -import qualified Data.Binary.Put as Bin -import Data.Binary.Defer -import Data.Binary.Defer.Array -import Data.Ord -import Data.Typeable - -type Id = Int - - ---------------------------------------------------------------------- --- INDEX - -newtype Index a = Index (Array a) - deriving Typeable - - --- | Items will obtain the Id's 0..length-1 -newIndex :: [a] -> Index a -newIndex = Index . array - - -instance (Typeable a, BinaryDefer a) => BinaryDefer (Index a) where - put (Index x) = put x - get = do res <- get1 Index; getDeferPut res; return res - -instance Show a => Show (Index a) where - show (Index xs) = unlines $ zipWith f [0..] (elems xs) - where - f i x = "#" ++ si ++ replicate (width - length si + 1) ' ' ++ show x - where si = show i - width = length $ show $ arraySize xs - - ---------------------------------------------------------------------- --- LINK - -data Link a = Link Id a - -newLink :: Id -> a -> Link a -newLink = Link - -fromLink :: Link a -> a -fromLink (Link k v) = v - -linkKey :: Link a -> Id -linkKey (Link k v) = k - -instance Eq (Link a) where - a == b = linkKey a == linkKey b - -instance Ord a => Ord (Link a) where - compare a b = compare (fromLink a) (fromLink b) - -instance Show a => Show (Link a) where - show = show . fromLink - -instance Typeable a => BinaryDefer (Link a) where - put = put . linkKey - get = do - i <- get - Index xs <- getDeferGet - return $ Link i $ xs ! i - - size _ = size (0 :: Id) - putFixed = put - getFixed = get - - -instance Bin.Binary (Link a) where - put = Bin.putWord32host . fromIntegral . linkKey - get = error "Can't implement Data.Binary.Get on Link" - -instance Typeable a => BinaryDeferGet (Link a) where - binaryDeferGet = do - Index xs <- getDeferGet - return $ do - i <- fmap fromIntegral Bin.getWord32host - return $ Link i $ xs ! i - -instance FixedBinary (Link a) where - fixedSize _ = 4 - -indexLinks :: Index a -> [Link a] -indexLinks (Index x) = zipWith newLink [0..] $ elems x diff --git a/src/Data/Binary/Defer/Monad.hs b/src/Data/Binary/Defer/Monad.hs deleted file mode 100644 --- a/src/Data/Binary/Defer/Monad.hs +++ /dev/null @@ -1,233 +0,0 @@ - -module Data.Binary.Defer.Monad( - DeferPut, putDefer, runDeferPut, - putInt, putByte, putChr, putByteString, putLazyByteString, - DeferGet, getDefer, runDeferGet, - getInt, getByte, getChr, getByteString, getLazyByteString, - getDeferGet, getDeferPut, - unwrapDeferGet - ) where - -import System.IO -import System.IO.Unsafe -import Data.Binary.Raw -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -import Data.IORef -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS - -import Data.Typeable -import qualified Data.TypeMap as TypeMap -import Foreign - - ---------------------------------------------------------------------- --- Defer Put - --- Storing the position explicitly gives a ~5% speed up --- and removes hGetPos as being a bottleneck --- possibly still not worth it though - --- FIXME: Should be a newtype -type DeferPut a = ReaderT (Buffer, IORef [DeferPending], IORef [DeferPatchup]) IO a -data DeferPending = DeferPending !Int (DeferPut ()) -data DeferPatchup = DeferPatchup !Int !Int -- a b = at position a, write out b - -putValue :: Storable a => a -> DeferPut () -putValue x = do - (buf,_,_) <- ask - liftIO $ bufferAdd buf x - -putInt :: Int -> DeferPut () -putInt x = putValue (fromIntegral x :: Int32) - -putByte :: Word8 -> DeferPut () -putByte x = putValue x - -putChr :: Char -> DeferPut () -putChr x = putByte $ fromIntegral $ fromEnum x - -putByteString :: BS.ByteString -> DeferPut () -putByteString x = do - (buf,_,_) <- ask - putInt $ BS.length x - liftIO $ bufferAddByteString buf x - -putLazyByteString :: LBS.ByteString -> DeferPut () -putLazyByteString x = do - (buf,_,_) <- ask - putInt $ fromIntegral $ LBS.length x - liftIO $ bufferAddLazyByteString buf x - -putDefer :: DeferPut () -> DeferPut () -putDefer x = do - (buf,ref,_) <- ask - liftIO $ do - p <- bufferPos buf - bufferAdd buf (0 :: Int32) -- to backpatch - modifyIORef ref (DeferPending p x :) - -runDeferPut :: Handle -> DeferPut () -> IO () -runDeferPut h m = do - buf <- bufferNew h - ref <- newIORef [] - back <- newIORef [] - runReaderT (m >> runDeferPendings) (buf,ref,back) - bufferFlush buf - patch <- readIORef back - mapM_ (\(DeferPatchup a b) -> do hSetPos h (toInteger a); hPutInt h b) patch - - -runDeferPendings :: DeferPut () -runDeferPendings = do - (_,ref,back) <- ask - todo <- liftIO $ readIORef ref - liftIO $ writeIORef ref [] - mapM_ runDeferPending todo - - -runDeferPending :: DeferPending -> DeferPut () -runDeferPending (DeferPending pos act) = do - (buf,_,back) <- ask - liftIO $ do - p <- bufferPos buf - b <- bufferPatch buf pos (fromIntegral p :: Int32) - unless b $ modifyIORef back (DeferPatchup pos p :) - act - runDeferPendings - - ---------------------------------------------------------------------- --- Buffer for writing - -bufferSize = 10000 :: Int - --- (number in file, number in buffer) -data Buffer = Buffer !Handle !(IORef Int) !(Ptr ()) !(IORef Int) - - -bufferNew :: Handle -> IO Buffer -bufferNew h = do - i <- hGetPos h - file <- newIORef $ fromInteger i - buf <- newIORef 0 - ptr <- mallocBytes bufferSize - return $ Buffer h file ptr buf - - -bufferAdd :: Storable a => Buffer -> a -> IO () -bufferAdd (Buffer h file ptr buf) x = do - let sz = sizeOf x - buf2 <- readIORef buf - if sz + buf2 >= bufferSize then do - hPutBuf h ptr buf2 - pokeByteOff ptr 0 x - modifyIORef file (+buf2) - writeIORef buf sz - else do - pokeByteOff ptr buf2 x - writeIORef buf (buf2+sz) - - -bufferAddByteString :: Buffer -> BS.ByteString -> IO () -bufferAddByteString (Buffer h file ptr buf) x = do - let sz = BS.length x - buf2 <- readIORef buf - when (buf2 /= 0) $ do - hPutBuf h ptr buf2 - writeIORef buf 0 - modifyIORef file (+ (buf2+sz)) - BS.hPut h x - - -bufferAddLazyByteString :: Buffer -> LBS.ByteString -> IO () -bufferAddLazyByteString (Buffer h file ptr buf) x = do - let sz = fromIntegral $ LBS.length x - buf2 <- readIORef buf - when (buf2 /= 0) $ do - hPutBuf h ptr buf2 - writeIORef buf 0 - modifyIORef file (+ (buf2+sz)) - LBS.hPut h x - - -bufferFlush :: Buffer -> IO () -bufferFlush (Buffer h file ptr buf) = do - buf2 <- readIORef buf - hPutBuf h ptr buf2 - modifyIORef file (+buf2) - writeIORef buf 0 - - -bufferPos :: Buffer -> IO Int -bufferPos (Buffer h file ptr buf) = do - i <- readIORef file - j <- readIORef buf - return $ i + j - - --- Patch at position p, with value v --- Return True if you succeeded -bufferPatch :: Buffer -> Int -> Int32 -> IO Bool -bufferPatch (Buffer h file ptr buf) p v = do - i <- readIORef file - if p < i then return False else do - pokeByteOff ptr (p-i) v - return True - ---------------------------------------------------------------------- --- Defer Get - -type DeferGet a = ReaderT (Handle, IORef TypeMap.TypeMap) IO a - -getInt :: DeferGet Int -getInt = do h <- asks fst; liftIO $ hGetInt h - -getByte :: DeferGet Word8 -getByte = do h <- asks fst; liftIO $ fmap fromIntegral $ hGetByte h - -getChr :: DeferGet Char -getChr = do h <- asks fst; liftIO $ hGetChar h - -getByteString :: DeferGet BS.ByteString -getByteString = do - h <- asks fst - len <- liftIO $ hGetInt h - liftIO $ BS.hGet h len - -getLazyByteString :: DeferGet LBS.ByteString -getLazyByteString = fmap (LBS.fromChunks . return) getByteString - -getDefer :: DeferGet a -> DeferGet a -getDefer x = do - h <- asks fst - i <- liftIO $ hGetInt h - s <- ask - liftIO $ unsafeInterleaveIO $ do - hSetPos h (toInteger i) - runReaderT x s - -runDeferGet :: Handle -> DeferGet a -> IO a -runDeferGet h m = do - ref <- newIORef TypeMap.empty - runReaderT m (h,ref) - - -getDeferGet :: Typeable a => DeferGet a -getDeferGet = do - ref <- asks snd - mp <- liftIO $ readIORef ref - return $ TypeMap.find mp - -getDeferPut :: Typeable a => a -> DeferGet () -getDeferPut x = do - ref <- asks snd - liftIO $ modifyIORef ref $ TypeMap.insert x - - -unwrapDeferGet :: DeferGet a -> DeferGet (IO a) -unwrapDeferGet act = do - s <- ask - return $ runReaderT act s diff --git a/src/Data/Binary/Raw.hs b/src/Data/Binary/Raw.hs deleted file mode 100644 --- a/src/Data/Binary/Raw.hs +++ /dev/null @@ -1,59 +0,0 @@ - --- Note: Some of these functions, when written in a point-free --- style have a significant impact on the runtime speed of --- unoptimised code, for example hGetPos contributes ~20% extra time - -module Data.Binary.Raw( - hGetInt, hPutInt, - hGetByte, hPutByte, maxByte, - hGetPos, hSetPos - ) where - -import System.IO -import Data.Bits -import Data.Word -import Data.Char - - -hGetPos :: Handle -> IO Integer -hGetPos hndl = hTell hndl - -hSetPos :: Handle -> Integer -> IO () -hSetPos hndl i = hSeek hndl AbsoluteSeek i - - -maxByte :: Word8 -maxByte = 0xff - --- FROM the Binary module, thanks to the Hac 07 people! - -hPutInt :: Handle -> Int -> IO () -hPutInt hndl w32 = do - let w4 = (w32 `shiftR` 24) .&. 0xff - w3 = (w32 `shiftR` 16) .&. 0xff - w2 = (w32 `shiftR` 8) .&. 0xff - w1 = w32 .&. 0xff - hPutByte hndl w1 - hPutByte hndl w2 - hPutByte hndl w3 - hPutByte hndl w4 - -hPutByte :: Handle -> Int -> IO () -hPutByte hndl i = hPutChar hndl $ chr i - - -hGetInt :: Handle -> IO Int -hGetInt hndl = do - w1 <- hGetByte hndl - w2 <- hGetByte hndl - w3 <- hGetByte hndl - w4 <- hGetByte hndl - return $! (w4 `shiftL` 24) .|. - (w3 `shiftL` 16) .|. - (w2 `shiftL` 8) .|. - w1 - - -hGetByte :: Handle -> IO Int -hGetByte hndl = fmap ord $ hGetChar hndl - diff --git a/src/General/Base.hs b/src/General/Base.hs --- a/src/General/Base.hs +++ b/src/General/Base.hs @@ -15,13 +15,14 @@ import Data.Monoid as X import Data.Ord as X import Data.String as X +import Data.Int as X +import Data.Word as X import Debug.Trace as X (trace) import Numeric as X (readHex,showHex) import System.FilePath as X hiding (combine) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS -import Control.Exception(bracket) import System.IO @@ -97,10 +98,14 @@ #if __GLASGOW_HASKELL__ < 612 writeFileUtf8 x y = writeFile x y #else -writeFileUtf8 x y = bracket (openFile x WriteMode) hClose $ \h -> do +writeFileUtf8 x y = withFile x WriteMode $ \h -> do hSetEncoding h utf8 hPutStr h y #endif + + +writeFileBinary :: FilePath -> String -> IO () +writeFileBinary x y = withBinaryFile x WriteMode $ \h -> hPutStr h y ltrim = dropWhile isSpace diff --git a/src/General/System.hs b/src/General/System.hs --- a/src/General/System.hs +++ b/src/General/System.hs @@ -25,6 +25,13 @@ #endif +isWindows :: Bool +#ifdef mingw32_HOST_OS +isWindows = True +#else +isWindows = False +#endif + withDirectory dir cmd = E.bracket (do x <- getCurrentDirectory; setCurrentDirectory dir; return x) diff --git a/src/General/Util.hs b/src/General/Util.hs --- a/src/General/Util.hs +++ b/src/General/Util.hs @@ -10,7 +10,7 @@ sortOn f = sortBy (comparing f) groupOn f = groupBy ((==) `on` f) - +nubOn f = nubBy ((==) `on` f) sortFst mr = sortOn fst mr groupFst mr = groupOn fst mr diff --git a/src/General/Web.hs b/src/General/Web.hs --- a/src/General/Web.hs +++ b/src/General/Web.hs @@ -5,9 +5,8 @@ -} module General.Web( - statusOK, hdrContentType, hdrCacheControl, - responseOK, responseBadRequest, responseNotFound, responseError, - responseFlatten, + responseOK, responseNotFound, + responseFlatten, responseEvaluate, URL, filePathToURL, combineURL, escapeURL, (++%), unescapeURL, escapeHTML, (++&), htmlTag, Args, cgiArgs, cgiResponse, parseHttpQueryArgs @@ -16,6 +15,8 @@ import General.System import General.Base import Network.Wai +import Network.HTTP.Types +import Data.CaseInsensitive(original) import Blaze.ByteString.Builder(toLazyByteString) import Data.Enumerator.List(consume) import qualified Data.ByteString.Lazy.Char8 as LBS @@ -27,22 +28,20 @@ --------------------------------------------------------------------- -- WAI STUFF -statusOK = status200 -hdrContentType = fromString "Content-Type" :: ResponseHeader -hdrCacheControl = fromString "Cache-Control" :: ResponseHeader - responseOK = responseLBS statusOK -responseBadRequest x = responseLBS status400 [] $ fromString $ "Bad request: " ++ x responseNotFound x = responseLBS status404 [] $ fromString $ "File not found: " ++ x -responseError x = responseLBS status500 [] $ fromString $ "Internal server error: " ++ x - responseFlatten :: Response -> IO (Status, ResponseHeaders, LBString) responseFlatten r = responseEnumerator r $ \s hs -> do builders <- consume return (s, hs, toLazyByteString $ mconcat builders) +responseEvaluate :: Response -> IO () +responseEvaluate (ResponseBuilder _ _ x) = LBS.length (toLazyByteString x) `seq` return () +responseEvaluate _ = return () + + --------------------------------------------------------------------- -- HTML STUFF @@ -53,6 +52,7 @@ f '<' = "<" f '>' = ">" f '&' = "&" + f '\"' = """ f x = [x] @@ -125,7 +125,7 @@ cgiResponse r = do (status,headers,body) <- responseFlatten r LBS.putStr $ LBS.unlines $ - [LBS.fromChunks [ciOriginal a, fromString ": ", b] | (a,b) <- headers] ++ + [LBS.fromChunks [original a, fromString ": ", b] | (a,b) <- headers] ++ [fromString "",body] diff --git a/src/Hoogle.hs b/src/Hoogle.hs --- a/src/Hoogle.hs +++ b/src/Hoogle.hs @@ -18,7 +18,7 @@ Result(..), search, suggestions, completions ) where -import Data.Binary.Defer.Index +import Hoogle.Store.All import General.Base import General.System @@ -107,14 +107,13 @@ } toResult :: H.Result -> (Score,Result) -toResult r@(H.Result entry view score) = (score, Result parents self docs) +toResult r@(H.Result ent view score) = (score, Result parents self docs) where - ent = fromLink entry self = H.renderResult r parents = map (second $ map f) $ H.entryLocations ent - f = (H.entryURL &&& H.entryName) . fromLink - docs = H.renderDocumentation $ H.entryDocs ent + f = (H.entryURL &&& H.entryName) . fromOnce + docs = H.renderDocs $ H.entryDocs ent -- | Perform a search. The results are returned lazily. diff --git a/src/Hoogle/DataBase/Aliases.hs b/src/Hoogle/DataBase/Aliases.hs --- a/src/Hoogle/DataBase/Aliases.hs +++ b/src/Hoogle/DataBase/Aliases.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Hoogle.DataBase.Aliases( Aliases, createAliases, normAliases @@ -5,7 +6,7 @@ import Hoogle.Type.All import qualified Data.Map as Map -import Data.Binary.Defer +import Hoogle.Store.All import Data.Generics.Uniplate import General.Base import Safe @@ -13,7 +14,7 @@ newtype Aliases = Aliases {fromAliases :: Map.Map String Alias} -instance BinaryDefer Aliases where +instance Store Aliases where put = put . fromAliases get = get1 Aliases @@ -26,8 +27,9 @@ {_args :: [String] -- the free variables ,rhs :: Type -- the resulting type } + deriving Typeable -instance BinaryDefer Alias where +instance Store Alias where put (Alias a b) = put2 a b get = get2 Alias diff --git a/src/Hoogle/DataBase/All.hs b/src/Hoogle/DataBase/All.hs --- a/src/Hoogle/DataBase/All.hs +++ b/src/Hoogle/DataBase/All.hs @@ -5,7 +5,7 @@ ,module Hoogle.DataBase.Serialise ) where -import Data.Binary.Defer.Index +import Hoogle.Store.All import Data.Monoid import Hoogle.DataBase.Type import Hoogle.Type.All @@ -20,10 +20,10 @@ where items = createItems xs ys = entriesItems items - ns = createSubstrSearch [(k, y) | y <- ys, let k = entryKey $ fromLink y, k /= ""] + ns = createSubstrSearch [(k, y) | y <- ys, let k = entryKey $ fromOnce y, k /= ""] as = createAliases (map aliases deps) facts is = createInstances (map instances deps) facts - tys = [(sig, x) | x <- ys, Just sig <- [entryType $ fromLink x]] + tys = [(sig, x) | x <- ys, Just sig <- [entryType $ fromOnce x]] @@ -35,18 +35,18 @@ where items_ = mconcat $ map items dbs ys = entriesItems items_ - ns = createSubstrSearch [(entryKey $ fromLink y, y) | y <- ys] + ns = createSubstrSearch [(entryKey $ fromOnce y, y) | y <- ys] ss = mconcat $ map suggest dbs as = mconcat $ map aliases dbs is = mconcat $ map instances dbs - tys = [(sig, x) | x <- ys, Just sig <- [entryType $ fromLink x]] + tys = [(sig, x) | x <- ys, Just sig <- [entryType $ fromOnce x]] -searchName :: DataBase -> String -> [(Link Entry,EntryView,Score)] +searchName :: DataBase -> String -> [(Once Entry,EntryView,Score)] searchName db = searchSubstrSearch (nameSearch db) -searchType :: DataBase -> TypeSig -> [(Link Entry,[EntryView],Score)] +searchType :: DataBase -> TypeSig -> [(Once Entry,[EntryView],Score)] -- although aliases and instances are given, they are usually not used searchType db = searchTypeSearch (aliases db) (instances db) (typeSearch db) diff --git a/src/Hoogle/DataBase/Instances.hs b/src/Hoogle/DataBase/Instances.hs --- a/src/Hoogle/DataBase/Instances.hs +++ b/src/Hoogle/DataBase/Instances.hs @@ -6,7 +6,7 @@ import General.Base import Hoogle.Type.All -import Data.Binary.Defer +import Hoogle.Store.All import qualified Data.Map as Map @@ -18,7 +18,7 @@ where f (v,cs) = "instance " ++ v ++ " <= " ++ unwords cs -instance BinaryDefer Instances where +instance Store Instances where put = put1 . fromInstances get = get1 Instances diff --git a/src/Hoogle/DataBase/Items.hs b/src/Hoogle/DataBase/Items.hs --- a/src/Hoogle/DataBase/Items.hs +++ b/src/Hoogle/DataBase/Items.hs @@ -2,23 +2,21 @@ module Hoogle.DataBase.Items(Items, createItems, entriesItems) where -import Data.Binary.Defer.Index import General.Base import General.Util import General.Web import Hoogle.Type.All import qualified Data.Map as Map -import Data.Binary.Defer hiding (get,put) -import qualified Data.Binary.Defer as D +import Hoogle.Store.All --- Invariant: Index Entry is by order of EntryScore -newtype Items = Items {fromItems :: Index Entry} +-- Invariant: items are by order of EntryScore +newtype Items = Items {fromItems :: Defer [Once Entry]} -entriesItems :: Items -> [Link Entry] -entriesItems (Items x) = indexLinks x +entriesItems :: Items -> [Once Entry] +entriesItems = fromDefer . fromItems -instance BinaryDefer Items where +instance Store Items where put (Items a) = put1 a get = get1 Items @@ -34,47 +32,29 @@ createItems :: [TextItem] -> Items -createItems xs = mergeItems [Items $ newIndex $ fs Nothing Nothing $ zip [0..] xs] +createItems xs = mergeItems [Items $ Defer $ fs Nothing Nothing xs] where fs pkg mod [] = [] - fs pkg mod ((i,x):xs) = r : fs pkg2 mod2 xs + fs pkg mod (x:xs) = r : fs pkg2 mod2 xs where r = f pkg2 mod2 x - pkg2 = if itemLevel x == 0 then Just $ newLink i r else pkg - mod2 = if itemLevel x == 1 then Just $ newLink i r else mod + pkg2 = if itemLevel x == 0 then Just r else pkg + mod2 = if itemLevel x == 1 then Just r else mod - f pkg mod TextItem{..} = Entry [(url, catMaybes [pkg,mod])] itemName itemDisp - (htmlDocumentation itemDocs) itemPriority itemKey itemType - where url | Just pkg <- pkg, itemLevel == 1 || (itemLevel > 1 && isNothing mod) = entryURL (fromLink pkg) `combineURL` itemURL - | Just mod <- mod, itemLevel > 1 = entryURL (fromLink mod) `combineURL` itemURL + f pkg mod TextItem{..} = once $ Entry [(url, catMaybes [pkg,mod])] itemName itemDisp + (readDocsHTML itemDocs) itemPriority itemKey itemType + where url | Just pkg <- pkg, itemLevel == 1 || (itemLevel > 1 && isNothing mod) = entryURL (fromOnce pkg) `combineURL` itemURL + | Just mod <- mod, itemLevel > 1 = entryURL (fromOnce mod) `combineURL` itemURL | otherwise = itemURL -- | Given a set of items, which may or may not individually satisfy the entryScore invariant, -- make it so they _do_ satisfy the invariant. -- Also merge any pair of items which are similar enough. +-- +-- If something which is a parent gets merged, then it will still point into the database, +-- but it won't be very useful. mergeItems :: [Items] -> Items -mergeItems xs = Items $ newIndex $ map (reindex (mp Map.!) . snd) ys - where - mp = Map.fromList [(i, newLink n y) | (n,(is, y)) <- zip [0..] ys, i <- is] - ys = reorder $ flatten $ map (map (linkKey &&& fromLink) . indexLinks . fromItems) xs - - -reorder :: [(a,Entry)] -> [([a],Entry)] -reorder = sortOn (entryScore . snd) . Map.elems . foldl' f Map.empty - where - f mp (i,e@Entry{..}) = Map.insertWith g key ([i],e) mp - where key = (entryName, entryText, entryDocs, entryKey, entryType) - g (i1,e1) (i2,e2) = (i1++i2, e1 - {entryPriority=min (entryPriority e1) (entryPriority e2) - ,entryLocations=nub $ concatMap entryLocations $ if entryScore e1 < entryScore e2 then [e1,e2] else [e2,e1]}) - - -flatten :: [[(Int,Entry)]] -> [(Int,Entry)] -flatten xs = concat $ zipWith f ns xs +mergeItems = Items . Defer . sortOn (entryScore . fromOnce) . Map.elems . foldl' add Map.empty . concatMap entriesItems where - ns = 0 : scanl1 (+) (map length xs) - f n x = [(i+n, reindex (\j -> newLink (j+n) (snd $ x!!j)) y) | (i,y) <- x] - - -reindex :: (Int -> Link Entry) -> Entry -> Entry -reindex op x = x{entryLocations = map (second $ map $ op . linkKey) $ entryLocations x} + add mp x = Map.insertWith (\x1 x2 -> once $ entryJoin (fromOnce x1) (fromOnce x2)) + (entryUnique $ fromOnce x) x mp diff --git a/src/Hoogle/DataBase/Serialise.hs b/src/Hoogle/DataBase/Serialise.hs --- a/src/Hoogle/DataBase/Serialise.hs +++ b/src/Hoogle/DataBase/Serialise.hs @@ -1,49 +1,47 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Hoogle.DataBase.Serialise( saveDataBase, loadDataBase ) where -import Data.Binary.Defer -import Data.Binary.Raw +import Hoogle.Store.All import General.Base import General.System import Hoogle.DataBase.Type -import Data.Version -- FIXME: Has become hard coded, go back to minor version lumps -hooVersion :: [Int] -hooVersion = [4,0,0,5] -- take 4 $ versionBranch version ++ repeat 0 - +hooVersion = [4,0,0,5] hooString = "HOOG" +data Identity = Identity deriving (Show, Typeable) +instance Store Identity where + put Identity = mapM_ put hooString >> mapM_ putByte hooVersion + get = do + cs <- replicateM 4 get + vr <- replicateM 4 getByte + when (cs /= hooString) $ + error $ "Not a hoogle database" + + let showVer = intercalate "." . map show + when (vr /= hooVersion) $ + error $ "Wrong hoogle database version: " ++ showVer vr ++ + " found, expected " ++ showVer hooVersion + return Identity + + + saveDataBase :: FilePath -> DataBase -> IO () -saveDataBase file db = do - h <- openBinaryFile file WriteMode - mapM_ (hPutChar h) hooString - mapM_ (hPutByte h) hooVersion - runDeferPut h $ put db - hClose h +saveDataBase file db = runSPut file $ put (Identity, db) loadDataBase :: FilePath -> IO DataBase loadDataBase file = do - h <- openBinaryFile file ReadMode - size <- hFileSize h - - when (size < 8) $ - error $ "Not a hoogle database: " ++ file - - str <- replicateM 4 (hGetChar h) - when (str /= hooString) $ + sz <- withFile file ReadMode hFileSize + when (sz < 12) $ error $ "Not a hoogle database: " ++ file - let showVer = showVersion . flip Version [] - ver <- replicateM 4 (hGetByte h) - when (ver /= hooVersion) $ - error $ "Wrong hoogle database version: " ++ showVer ver ++ - " found, expected " ++ showVer hooVersion - - runDeferGet h get + (Identity,db) <- runSGet file get + return db diff --git a/src/Hoogle/DataBase/SubstrSearch.hs b/src/Hoogle/DataBase/SubstrSearch.hs --- a/src/Hoogle/DataBase/SubstrSearch.hs +++ b/src/Hoogle/DataBase/SubstrSearch.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Hoogle.DataBase.SubstrSearch (SubstrSearch, createSubstrSearch @@ -5,20 +6,45 @@ ,completionsSubstrSearch ) where -import Data.Binary.Defer +import Hoogle.Store.All +import qualified Data.Set as Set import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Char8 as BSC -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Binary as Bin -import qualified Data.Binary.Get as Bin -import qualified Data.Binary.Put as Bin -import qualified Data.Set as Set import General.Base +import Data.Array import Hoogle.Type.All import Hoogle.Score.All +{- +Format 2: +-- build a Huffman table +huffman :: Eq a => [a] -> Huffman a + +-- encode a value using the table +-- return the first 32 bits of the encoding, and a mask (will be all 1's if more than 32 bits) +encode :: Huffman a -> [a] -> (Word32, Word32) + + +-- We have 4 buckets, one per priority level - Prelude first, then base, then platform, then anything +data Substr a = Substr [Bucket a] + +-- Each bucket contains the encoding of each entry (a pointer to it) along +-- with the Word32 prefix of each string +-- the 31'st bit is 1 if the string comes from the start of a string +-- and the 32'nd bit is 1 if the string contains upper case letters +-- within each entry, the tree is used to find shifts +-- items are sorted by prefixes +data Bucket a = Bucket {answers :: [a], prefixes :: [Word32], tree :: Tree} + +-- at each tree point the range is the start/end index where you may find things with that prefix +-- if the Maybe is Just then all the points in that range are shifted by one bit +data Tree = Tree {range :: (Int, Int), rest :: Maybe (Tree, Tree)} +-} + + + -- idea for speed improvement -- store as one long bytestring with \0 between the words, then do findSubstrings to find the indexes -- store the lengths in a separate bytestring then use index to step through them, retrieving the data as Word8 via foldl @@ -34,18 +60,19 @@ -- keys are sorted after being made lower case data SubstrSearch a = SubstrSearch - {text :: BS.ByteString -- all the bytestrings, in preference order - ,lens :: BS.ByteString -- a list of lengths - ,inds :: Int -> a -- a way of retrieving each index + {text :: BString -- all the bytestrings, in preference order + ,lens :: BString -- a list of lengths + ,inds :: Array Int a -- the results } + deriving Typeable -- | Create a substring search index. Values are returned in order where possible. createSubstrSearch :: [(String,a)] -> SubstrSearch a createSubstrSearch xs = SubstrSearch - (BSC.pack $ concat ts2) + (fromString $ concat ts2) (BS.pack $ map fromIntegral ls2) - (is !!) + (listArray (0,length is-1) is) where (ts,is) = unzip $ map (first $ map toLower) xs (ts2,ls2) = f "" ts @@ -76,8 +103,8 @@ addCount s = s{sCount=sCount s+1} moveFocus i s = s{sFocus=BS.unsafeDrop i $ sFocus s} - addMatch MatchSubstr s = s{sInfix =(inds x $ sCount s,view,textScore MatchSubstr):sInfix s} - addMatch t s = s{sPrefix=(inds x $ sCount s,view,textScore t):sPrefix s} + addMatch MatchSubstr s = s{sInfix =(inds x ! sCount s,view,textScore MatchSubstr):sInfix s} + addMatch t s = s{sPrefix=(inds x ! sCount s,view,textScore t):sPrefix s} data S2 = S2 @@ -90,7 +117,7 @@ s2Result $ BS.foldl f (S2 (text x) Set.empty) $ lens x where ny = length y - ly = BSC.pack $ map toLower y + ly = fromString $ map toLower y f (S2 foc res) ii = S2 (BS.unsafeDrop i foc) (if ly `BS.isPrefixOf` x then Set.insert x res else res) where x = BS.unsafeTake i foc i = fromIntegral ii @@ -99,37 +126,9 @@ instance Show a => Show (SubstrSearch a) where show x = "SubstrSearch" -instance (Bin.Binary a, BinaryDeferGet a, FixedBinary a) => BinaryDefer (SubstrSearch a) where - put x = putDefer $ putLazyByteString $ Bin.runPut $ putBinary Bin.put x - - get = do - g <- binaryDeferGet - x <- getDefer getLazyByteString - return $ Bin.runGet (getBinary (fixedSize $ tyUnGet g) g) x - where - tyUnGet :: Bin.Get a -> a - tyUnGet = undefined - - -putBinary :: (a -> Bin.Put) -> SubstrSearch a -> Bin.Put -putBinary p x = do - Bin.put $ text x - Bin.put $ lens x - Bin.put $ fromLBS $ Bin.runPut $ mapM_ (p . inds x) [0.. fromIntegral (BS.length $ lens x) - 1] - - -getBinary :: Int -> Bin.Get a -> Bin.Get (SubstrSearch a) -getBinary size g = do - text <- Bin.get - lens <- Bin.get - indsData <- Bin.get - let inds i = Bin.runGet g $ toLBS $ BS.take size $ BS.drop (i * size) indsData - return $ SubstrSearch text lens inds - - -fromLBS = BS.concat . LBS.toChunks -toLBS = LBS.fromChunks . return - +instance (Typeable a, Store a) => Store (SubstrSearch a) where + put (SubstrSearch a b c) = putDefer $ put3 a b c + get = getDefer $ get3 SubstrSearch -- if first word is empty, always return Exact/Prefix diff --git a/src/Hoogle/DataBase/Suggest.hs b/src/Hoogle/DataBase/Suggest.hs --- a/src/Hoogle/DataBase/Suggest.hs +++ b/src/Hoogle/DataBase/Suggest.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Hoogle.DataBase.Suggest(Suggest, createSuggest, askSuggest) where import General.Base import General.Util -import Data.Binary.Defer +import Hoogle.Store.All import qualified Data.Map as Map import Hoogle.Type.All import Data.Generics.Uniplate @@ -17,6 +18,7 @@ ,suggestData :: [(String,Int)] -- data type, name (case correct), and possible kinds ,suggestClass :: [(String,Int)] -- class, name (case correct), kinds } + deriving Typeable instance Show Suggest where @@ -29,11 +31,11 @@ f msg xs = [msg ++ " " ++ a ++ " " ++ show b | (a,b) <- xs] -instance BinaryDefer Suggest where +instance Store Suggest where put (Suggest x) = put x get = get1 Suggest -instance BinaryDefer SuggestItem where +instance Store SuggestItem where put (SuggestItem a b c) = put3 a b c get = get3 SuggestItem diff --git a/src/Hoogle/DataBase/Type.hs b/src/Hoogle/DataBase/Type.hs --- a/src/Hoogle/DataBase/Type.hs +++ b/src/Hoogle/DataBase/Type.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} module Hoogle.DataBase.Type(module Hoogle.DataBase.Type, module X) where @@ -7,8 +8,7 @@ import Hoogle.DataBase.Instances as X import Hoogle.DataBase.SubstrSearch as X import Hoogle.DataBase.TypeSearch.All as X -import Data.Binary.Defer -import Data.Binary.Defer.Index +import Hoogle.Store.All import Hoogle.Type.All import General.Base @@ -17,15 +17,16 @@ -- that depend on this database data DataBase = DataBase {items :: Items - ,nameSearch :: SubstrSearch (Link Entry) + ,nameSearch :: SubstrSearch (Once Entry) ,typeSearch :: TypeSearch ,suggest :: Suggest ,aliases :: Aliases ,instances :: Instances } + deriving Typeable -instance BinaryDefer DataBase where +instance Store DataBase where put (DataBase a b c d e f) = put6 a b c d e f get = get6 DataBase diff --git a/src/Hoogle/DataBase/TypeSearch/All.hs b/src/Hoogle/DataBase/TypeSearch/All.hs --- a/src/Hoogle/DataBase/TypeSearch/All.hs +++ b/src/Hoogle/DataBase/TypeSearch/All.hs @@ -11,8 +11,7 @@ import Hoogle.DataBase.TypeSearch.TypeScore import Hoogle.DataBase.Instances import Hoogle.DataBase.Aliases -import Data.Binary.Defer -import Data.Binary.Defer.Index +import Hoogle.Store.All import Hoogle.Type.All import Hoogle.Score.All @@ -22,7 +21,7 @@ instance Show TypeSearch where show (TypeSearch x) = show x -instance BinaryDefer TypeSearch where +instance Store TypeSearch where put (TypeSearch x) = put x get = get1 TypeSearch @@ -30,13 +29,13 @@ --------------------------------------------------------------------- -- CREATION -createTypeSearch :: Aliases -> Instances -> [(TypeSig, Link Entry)] -> TypeSearch +createTypeSearch :: Aliases -> Instances -> [(TypeSig, Once Entry)] -> TypeSearch createTypeSearch aliases instances xs = TypeSearch $ newGraphs aliases instances xs --------------------------------------------------------------------- -- SEARCHING -searchTypeSearch :: Aliases -> Instances -> TypeSearch -> TypeSig -> [(Link Entry,[EntryView],Score)] +searchTypeSearch :: Aliases -> Instances -> TypeSearch -> TypeSig -> [(Once Entry,[EntryView],Score)] searchTypeSearch as is (TypeSearch g) t = [(a, b, typeScore $ costsTypeScore c) | (a,b,c) <- graphsSearch as is g t] diff --git a/src/Hoogle/DataBase/TypeSearch/EntryInfo.hs b/src/Hoogle/DataBase/TypeSearch/EntryInfo.hs --- a/src/Hoogle/DataBase/TypeSearch/EntryInfo.hs +++ b/src/Hoogle/DataBase/TypeSearch/EntryInfo.hs @@ -2,24 +2,28 @@ module Hoogle.DataBase.TypeSearch.EntryInfo where -import Data.Binary.Defer -import Data.Binary.Defer.Index +import Hoogle.Store.All import Hoogle.Type.All import Data.Typeable -- the information about an entry, including the arity data EntryInfo = EntryInfo - {entryInfoEntries :: [Link Entry] + {entryInfoKey :: Int -- allow cheap equality + ,entryInfoEntries :: [Once Entry] ,entryInfoArity :: Int ,entryInfoContext :: TypeContext ,entryInfoAlias :: [String] - } deriving (Eq,Show,Typeable) + } deriving (Show,Typeable) instance Ord EntryInfo where - compare (EntryInfo [] x1 x2 x3) (EntryInfo [] y1 y2 y3) = compare (x1,x2,x3) (y1,y2,y3) + compare (EntryInfo _ [] x1 x2 x3) (EntryInfo _ [] y1 y2 y3) = compare (x1,x2,x3) (y1,y2,y3) compare _ _ = error "Ord EntryInfo, can't compare EntryInfo's with items in them" -instance BinaryDefer EntryInfo where - put (EntryInfo a b c d) = put4 a b c d - get = get4 EntryInfo +instance Eq EntryInfo where + EntryInfo _ [] x1 x2 x3 == EntryInfo _ [] y1 y2 y3 = (x1,x2,x3) == (y1,y2,y3) + _ == _ = error "Eq EntryInfo, can't compare EntryInfo's with items in them" + +instance Store EntryInfo where + put (EntryInfo a b c d e) = put5 a b c d e + get = get5 EntryInfo diff --git a/src/Hoogle/DataBase/TypeSearch/Graph.hs b/src/Hoogle/DataBase/TypeSearch/Graph.hs --- a/src/Hoogle/DataBase/TypeSearch/Graph.hs +++ b/src/Hoogle/DataBase/TypeSearch/Graph.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-| Search for a type signature and context through a graph. @@ -14,8 +15,7 @@ import Hoogle.DataBase.TypeSearch.Result import Hoogle.Type.All import Data.Generics.Uniplate -import Data.Binary.Defer -import Data.Binary.Defer.Index +import Hoogle.Store.All import qualified Data.Map as Map import General.Base import General.Util @@ -25,7 +25,8 @@ newtype Graph = Graph (Map.Map Type [Node]) -- the Type's are stored in reverse, to make box/unbox computations quicker -data Node = Node [Type] [(Link EntryInfo,ArgPos)] +data Node = Node [Type] [(Once EntryInfo,ArgPos)] + deriving Typeable instance Show Graph where @@ -34,14 +35,14 @@ g x = if x == TVar "" then TVar "_" else x instance Show Node where - show (Node t xs) = unwords $ map show t ++ "=" : [show (linkKey a) ++ "." ++ show b | (a,b) <- xs] + show (Node t xs) = unwords $ map show t ++ "=" : ["?." ++ show b | (a,b) <- xs] -instance BinaryDefer Graph where +instance Store Graph where put (Graph a) = put1 a get = get1 Graph -instance BinaryDefer Node where +instance Store Node where put (Node a b) = put2 a b get = get2 Node @@ -58,12 +59,12 @@ typeUnstructure = reverse . filter (\x -> isTLit x || isTVar x) . universe -newGraph :: [(Link EntryInfo, ArgPos, Type)] -> Graph +newGraph :: [(Once EntryInfo, ArgPos, Type)] -> Graph newGraph = Graph . Map.map newNode . foldl' f Map.empty where f mp x = Map.insertWith (++) (typeStructure $ thd3 x) [x] mp -newNode :: [(Link EntryInfo, ArgPos, Type)] -> [Node] +newNode :: [(Once EntryInfo, ArgPos, Type)] -> [Node] newNode = map (uncurry Node) . sortGroupFsts . map (\(a,b,c) -> (typeUnstructure c,(a,b))) @@ -85,7 +86,7 @@ f bind x = mapMaybe (graphCheck bind u) $ Map.findWithDefault [] x mp -graphCheck :: Binding -> [Type] -> Node -> Maybe (Binding, [(Link EntryInfo,ArgPos)]) +graphCheck :: Binding -> [Type] -> Node -> Maybe (Binding, [(Once EntryInfo,ArgPos)]) graphCheck b xs (Node ys res) = do b <- f b (zip xs ys) return (b, res) diff --git a/src/Hoogle/DataBase/TypeSearch/Graphs.hs b/src/Hoogle/DataBase/TypeSearch/Graphs.hs --- a/src/Hoogle/DataBase/TypeSearch/Graphs.hs +++ b/src/Hoogle/DataBase/TypeSearch/Graphs.hs @@ -9,8 +9,7 @@ import Hoogle.DataBase.TypeSearch.TypeScore import Hoogle.Type.All hiding (Result) -import Data.Binary.Defer -import Data.Binary.Defer.Index +import Hoogle.Store.All import qualified Data.IntMap as IntMap import qualified Data.Heap as Heap import General.Base @@ -21,39 +20,38 @@ -- for resGraph, the associated ArgPos is the arity of the function data Graphs = Graphs - {entryInfo :: Index EntryInfo - ,argGraph :: Graph -- the arguments + {argGraph :: Graph -- the arguments ,resGraph :: Graph -- the results } instance Show Graphs where - show (Graphs a b c) = "== Arguments ==\n\n" ++ show b ++ - "\n== Results ==\n\n" ++ show c + show (Graphs a b) = "== Arguments ==\n\n" ++ show a ++ + "\n== Results ==\n\n" ++ show b -instance BinaryDefer Graphs where - put (Graphs a b c) = put3 a b c - get = get3 Graphs +instance Store Graphs where + put (Graphs a b) = put2 a b + get = get2 Graphs --------------------------------------------------------------------- -- GRAPHS CONSTRUCTION -newGraphs :: Aliases -> Instances -> [(TypeSig, Link Entry)] -> Graphs -newGraphs as is xs = Graphs (newIndex $ map snd entries) argGraph resGraph +newGraphs :: Aliases -> Instances -> [(TypeSig, Once Entry)] -> Graphs +newGraphs as is xs = Graphs argGraph resGraph where - entries = [ (t2, e2{entryInfoEntries = sortOn linkKey $ map snd ys}) - | ys@(((t2,e2),_):_) <- sortGroupFst $ map (\(t,e) -> (normType as is t, e)) xs] + entries = [ (t2, e2{entryInfoKey=i, entryInfoEntries=map snd ys}) + | (i, ys@(((t2,e2),_):_)) <- zip [0..] $ sortGroupFst $ map (\(t,e) -> (normType as is t, e)) xs] argGraph = newGraph (concat args) resGraph = newGraph res (args,res) = unzip [ initLast $ zipWith (\i t -> (lnk, i, t)) [0..] $ fromTFun t - | (i, (t, e)) <- zip [0..] entries, let lnk = newLink i e] + | (t, e) <- entries, let lnk = once e] normType :: Aliases -> Instances -> TypeSig -> (Type, EntryInfo) -normType as is t = (t3, EntryInfo [] (length (fromTFun t3) - 1) c2 a) +normType as is t = (t3, EntryInfo 0 [] (length (fromTFun t3) - 1) c2 a) where TypeSimp c2 t2 = normInstances is t (a,t3) = normAliases as t2 @@ -75,7 +73,7 @@ data S = S - {infos :: IntMap.IntMap (Maybe ResultAll) -- Int = Link EntryInfo + {infos :: IntMap.IntMap (Maybe ResultAll) -- Int = Once EntryInfo ,pending :: Heap.Heap Int Result ,todo :: [(Maybe ArgPos, ResultArg)] ,instances :: Instances @@ -106,7 +104,7 @@ f r = do infos <- gets infos (Just res,infos) <- return $ IntMap.updateLookupWithKey - (\_ _ -> Just Nothing) (linkKey $ fst3 r) infos + (\_ _ -> Just Nothing) (entryInfoKey $ fromOnce $ fst3 r) infos if isNothing res then return [] else do modify $ \s -> s{infos=infos} return [r] @@ -115,7 +113,7 @@ -- todo -> heap/info addResult :: Maybe ArgPos -> ResultArg -> State S () addResult arg val = do - let entId = linkKey $ resultArgEntry val + let entId = entryInfoKey $ fromOnce $ resultArgEntry val infs <- gets infos is <- gets instances query <- gets query diff --git a/src/Hoogle/DataBase/TypeSearch/Result.hs b/src/Hoogle/DataBase/TypeSearch/Result.hs --- a/src/Hoogle/DataBase/TypeSearch/Result.hs +++ b/src/Hoogle/DataBase/TypeSearch/Result.hs @@ -8,9 +8,9 @@ import Hoogle.DataBase.TypeSearch.Binding import Hoogle.DataBase.TypeSearch.EntryInfo import Hoogle.DataBase.Instances -import Data.Binary.Defer.Index import Hoogle.Type.All hiding (Result) import General.Base +import Hoogle.Store.All import qualified Data.IntSet as IntSet @@ -18,37 +18,37 @@ -- the return from searching a graph, nearly -type Result = (Link EntryInfo,[EntryView],TypeScore) +type Result = (Once EntryInfo,[EntryView],TypeScore) -type ResultReal = (Link Entry, [EntryView], TypeScore) +type ResultReal = (Once Entry, [EntryView], TypeScore) -flattenResults :: [Result] -> [(Link Entry, [EntryView], TypeScore)] -flattenResults xs = [(a,b,c) | (as,b,c) <- xs, a <- entryInfoEntries $ fromLink as] +flattenResults :: [Result] -> [(Once Entry, [EntryView], TypeScore)] +flattenResults xs = [(a,b,c) | (as,b,c) <- xs, a <- entryInfoEntries $ fromOnce as] -- the result information from a whole type (many ResultArg) -- number of lacking args, entry data, info (result:args) -data ResultAll = ResultAll Int (Link EntryInfo) [[ResultArg]] +data ResultAll = ResultAll Int (Once EntryInfo) [[ResultArg]] deriving Show -- the result information from one single type graph (argument/result) -- this result points at entry.id, argument, with such a score data ResultArg = ResultArg - {resultArgEntry :: Link EntryInfo + {resultArgEntry :: Once EntryInfo ,resultArgPos :: ArgPos ,resultArgBind :: Binding } deriving Show -newResultAll :: EntryInfo -> Link EntryInfo -> Maybe ResultAll +newResultAll :: EntryInfo -> Once EntryInfo -> Maybe ResultAll newResultAll query e | bad < 0 || bad > 2 = Nothing | otherwise = Just $ ResultAll bad e $ replicate (arityResult + 1) [] where arityQuery = entryInfoArity query - arityResult = entryInfoArity $ fromLink e + arityResult = entryInfoArity $ fromOnce e bad = arityResult - arityQuery @@ -78,11 +78,11 @@ , rs <- f bad (IntSet.insert rp set) xs] -newGraphsResults :: Instances -> EntryInfo -> Link EntryInfo -> [ResultArg] -> ResultArg -> Maybe Result +newGraphsResults :: Instances -> EntryInfo -> Once EntryInfo -> [ResultArg] -> ResultArg -> Maybe Result newGraphsResults is query e args res = do b <- mergeBindings $ map resultArgBind $ args ++ [res] let aps = map resultArgPos args - s = newTypeScore is query (fromLink e) (aps == sort aps) b + s = newTypeScore is query (fromOnce e) (aps == sort aps) b view = zipWith ArgPosNum [0..] aps -- need to fake at least one ArgPosNum, so we know we have some highlight info view2 = [ArgPosNum (-1) (-1) | null view] ++ view diff --git a/src/Hoogle/Language/Haskell.hs b/src/Hoogle/Language/Haskell.hs --- a/src/Hoogle/Language/Haskell.hs +++ b/src/Hoogle/Language/Haskell.hs @@ -107,12 +107,12 @@ pkg2 = maybe "" itemName pkg -setModuleURL pkg _ x - | isJust pkg && itemLevel x == 1 = x{itemURL=if null $ itemURL x then f $ itemName x else itemURL x} - | otherwise = x - where f = if "http:" `isPrefixOf` itemURL (fromJust pkg) then modHackage else modLocal - modHackage xs = "http://hackage.haskell.org/packages/archive/" ++ itemName (fromJust pkg) ++ "/latest/doc/html/" ++ reps '.' '-' xs ++ ".html" - modLocal xs = takeDirectory (itemURL $ fromJust pkg) ++ "/" ++ reps '.' '-' xs ++ ".html" +setModuleURL (Just pkg) _ x | itemLevel x == 1 = x{itemURL=if null $ itemURL x then f $ itemName x else itemURL x} + where f xs = if "http://hackage.haskell.org/package/" `isPrefixOf` itemURL pkg + then "http://hackage.haskell.org/packages/archive/" ++ itemName pkg ++ "/latest/doc/html/" ++ file + else takeDirectory (itemURL pkg) ++ "/" ++ file + where file = reps '.' '-' xs ++ ".html" +setModuleURL _ _ x = x --------------------------------------------------------------------- diff --git a/src/Hoogle/Query/Parser.hs b/src/Hoogle/Query/Parser.hs --- a/src/Hoogle/Query/Parser.hs +++ b/src/Hoogle/Query/Parser.hs @@ -49,7 +49,7 @@ (do xs <- keyword `sepBy1` (char '.') ; spaces return $ case xs of [x] -> mempty{names=[x]} - xs -> mempty{names=[last xs],scope=[PlusModule (init xs)]} + xs -> mempty{names=[last xs],scope=[PlusModule $ intercalate "." $ init xs]} ) operator = between (char '(') (char ')') op <|> op @@ -78,8 +78,8 @@ modname = keyword `sepBy1` (char '.') modu <- modname case modu of - [x] -> return $ mempty{scope=[if isLower (head x) then aPackage x else aModule [x]]} - xs -> return $ mempty{scope=[aModule xs]} + [x] -> return $ mempty{scope=[if isLower (head x) then aPackage x else aModule x]} + xs -> return $ mempty{scope=[aModule $ intercalate "." xs]} keyword = do diff --git a/src/Hoogle/Query/Render.hs b/src/Hoogle/Query/Render.hs --- a/src/Hoogle/Query/Render.hs +++ b/src/Hoogle/Query/Render.hs @@ -25,8 +25,8 @@ scp = [Str $ unwords $ map f $ scope x | scope x /= []] f (PlusPackage x) = "+" ++ x f (MinusPackage x) = "-" ++ x - f (PlusModule xs) = "+" ++ intercalate "." xs - f (MinusModule xs) = "-" ++ intercalate "." xs + f (PlusModule x) = "+" ++ x + f (MinusModule x) = "-" ++ x renderTypeSig :: TypeSig -> TagStr diff --git a/src/Hoogle/Query/Type.hs b/src/Hoogle/Query/Type.hs --- a/src/Hoogle/Query/Type.hs +++ b/src/Hoogle/Query/Type.hs @@ -38,6 +38,26 @@ "(map > 1)" is total garbage... i think parse errors are still needed Should try and autocomplete at the end where possible + +Also need to support OR, AND and NOT. + +Perhaps have a tree: + +data Prop = Or Bool Prop Prop -- True is explicit OR + | And Bool Prop Prop -- True is explicit AND + | Not Bool Prop -- True is explicit NOT, otherwise is a "-" of the one after you + | Module Prefix String -- prefix is a string - "" for Foo.bar, otherwise "+" or "module:" + | Package Prefix String -- prefix is a string, "+" or "package" + | Name String -- just the name + | Type Bool TypeSig -- TypeSig needs extending to be full information, but otherwise the same. True is explicit "::" + | Bracket Prop -- explicit brackets + | Whitespace Int Prop Int -- explicit whitespace on either side + +Can now decompse parts easily and move more logic info the query. Also retain perfect information. + +Name and type searches are done separately and merged. Then traverse the tree applying everything else. + +Will need some pass at the start to decide which databases to use. That needs to impove anyway. -} @@ -57,8 +77,8 @@ data Scope = PlusPackage String | MinusPackage String - | PlusModule [String] - | MinusModule [String] + | PlusModule String + | MinusModule String deriving (Eq, Show, Read, Data, Typeable) diff --git a/src/Hoogle/Search/All.hs b/src/Hoogle/Search/All.hs --- a/src/Hoogle/Search/All.hs +++ b/src/Hoogle/Search/All.hs @@ -5,6 +5,7 @@ import Hoogle.Query.All import Hoogle.Search.Results import Hoogle.Type.All +import Hoogle.Store.All -- return all the results, lazily @@ -20,10 +21,10 @@ nameSearch :: DataBase -> String -> [Result] -nameSearch db query = [Result e [v] s +nameSearch db query = [Result (fromOnce e) [v] s | (e,v,s) <- searchName db query] typeSearch :: DataBase -> TypeSig -> [Result] -typeSearch db query = [Result e v s +typeSearch db query = [Result (fromOnce e) v s | (e,v,s) <- searchType db query] diff --git a/src/Hoogle/Search/Results.hs b/src/Hoogle/Search/Results.hs --- a/src/Hoogle/Search/Results.hs +++ b/src/Hoogle/Search/Results.hs @@ -5,8 +5,8 @@ import General.Base import General.Util -import qualified Data.IntMap as IntMap -import Data.Binary.Defer.Index +import qualified Data.Map as Map +import Hoogle.Store.All import Hoogle.Type.All import Hoogle.Query.All @@ -33,7 +33,7 @@ mergeDataBaseResults :: [[Result]] -> [Result] mergeDataBaseResults = map fromKey . fold [] merge . map (map $ toKey f) - where f r = (resultScore r, entryScore $ fromLink $ resultEntry r) + where f r = (resultScore r, entryScore $ resultEntry r) --------------------------------------------------------------------- @@ -45,19 +45,19 @@ -- join the results of multiple searches +-- FIXME: this looks like a disaster - fully strict joinResults :: [[Result]] -> [Result] joinResults [] = [] joinResults [x] = x -joinResults xs = sortWith scr $ IntMap.elems $ - fold1 (IntMap.intersectionWith join) $ +joinResults xs = sortWith resultScore $ Map.elems $ + fold1 (Map.intersectionWith join) $ map asSet xs where - asSet = IntMap.fromList . map (linkKey . resultEntry &&& id) + asSet = Map.fromList . map (entryUnique . resultEntry &&& id) join r1 r2 = r1{resultScore = mappend (resultScore r1) (resultScore r2) - ,resultView = resultView r1 ++ resultView r2} - - scr = resultScore &&& linkKey . resultEntry + ,resultView = resultView r1 ++ resultView r2 + ,resultEntry = resultEntry r1 `entryJoin` resultEntry r2} --------------------------------------------------------------------- @@ -68,7 +68,7 @@ filterResults q = f mods correctModule . f pkgs correctPackage where f [] act = id - f xs act = filter (act xs . fromLink . resultEntry) + f xs act = filter (act xs . resultEntry) mods = filter isMod $ scope q pkgs = [x | MinusPackage x <- scope q] @@ -80,23 +80,22 @@ -- pkgs is a non-empty list of MinusPackage values correctPackage :: [String] -> Entry -> Bool -correctPackage pkgs x = null myPkgs || any (maybe True (`notElem` pkgs)) myPkgs - where myPkgs = map (fmap (entryName . fromLink) . listToMaybe . snd) $ entryLocations x +correctPackage pkgs x = null myPkgs || any (maybe True (`notElem` map (map toLower) pkgs)) myPkgs + where myPkgs = map (fmap (map toLower . entryName . fromOnce) . listToMaybe . snd) $ entryLocations x -- mods is a non-empty list of PlusModule/MinusModule correctModule :: [Scope] -> Entry -> Bool -correctModule mods x = null myMods || any (maybe True (f base mods . split '.')) myMods +correctModule mods x = null myMods || any (maybe True (f base mods)) myMods where - myMods = map (fmap (entryName . fromLink) . listToMaybe . drop 1 . snd) $ entryLocations x + myMods = map (fmap (map toLower . entryName . fromOnce) . listToMaybe . drop 1 . snd) $ + entryLocations x base = case head mods of MinusModule{} -> True; _ -> False f z [] y = z - f z (PlusModule x:xs) y | doesMatch x y = f True xs y - f z (MinusModule x:xs) y | doesMatch x y = f False xs y + f z (PlusModule x:xs) y | doesMatch (map toLower x) y = f True xs y + f z (MinusModule x:xs) y | doesMatch (map toLower x) y = f False xs y f z (x:xs) y = f z xs y - -- match if x is further up the tree than y - doesMatch [] y = True - doesMatch (x:xs) (y:ys) = x == y && doesMatch xs ys - doesMatch _ _ = False + -- match if x is a module starting substring of y + doesMatch x y = x `isPrefixOf` y || ('.':x) `isInfixOf` y diff --git a/src/Hoogle/Store/All.hs b/src/Hoogle/Store/All.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Store/All.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Hoogle.Store.All( + SPut, SGet, runSPut, runSGet, + Once, fromOnce, once, getDefer, putDefer, + module Hoogle.Store.All + ) where + +import General.Base +import Foreign(sizeOf) +import Hoogle.Store.Type +import qualified Data.Map as Map +import qualified Data.ByteString as BS +import Data.Array + + +class Store a where + put :: a -> SPut () + get :: SGet a + + + -- FIXME: unnecessary, just do an accumulator building up in reverse + getList :: Int -> SGet [a] + getList n = replicateM n get + + putList :: [a] -> SPut () + putList = mapM_ put + + size :: a -> Maybe Int -- may not look at the size argument + size _ = Nothing + + +newtype Defer a = Defer {fromDefer :: a} + +instance Eq a => Eq (Defer a) where a == b = fromDefer a == fromDefer b +instance Ord a => Ord (Defer a) where compare a b = compare (fromDefer a) (fromDefer b) +instance Show a => Show (Defer a) where show = show . fromDefer + +instance (Typeable a, Store a) => Store (Defer a) where + put = putDefer . put . fromDefer + get = fmap Defer $ getDefer get + size _ = Just 4 + + +instance Eq a => Eq (Once a) where a == b = fromOnce a == fromOnce b +instance Ord a => Ord (Once a) where compare a b = compare (fromOnce a) (fromOnce b) +instance Show a => Show (Once a) where show = show . fromOnce + +instance (Typeable a, Store a) => Store (Once a) where + put = putOnce put + get = getOnce get + size _ = Just 4 + + +errorSGet :: String -> SGet a +errorSGet typ = error $ "Store.get(" ++ typ ++ "), corrupt database" + + +get0 f = return f +get1 f = do x1 <- get; return (f x1) +get2 f = do x1 <- get; x2 <- get; return (f x1 x2) +get3 f = do x1 <- get; x2 <- get; x3 <- get; return (f x1 x2 x3) +get4 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; return (f x1 x2 x3 x4) +get5 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; return (f x1 x2 x3 x4 x5) +get6 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; return (f x1 x2 x3 x4 x5 x6) +get7 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; x7 <- get; return (f x1 x2 x3 x4 x5 x6 x7) +get8 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; x7 <- get; x8 <- get; return (f x1 x2 x3 x4 x5 x6 x7 x8) +get9 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; x7 <- get; x8 <- get; x9 <- get; return (f x1 x2 x3 x4 x5 x6 x7 x8 x9) + + +put0 = return () :: SPut () +put1 x1 = put x1 +put2 x1 x2 = put x1 >> put x2 +put3 x1 x2 x3 = put x1 >> put x2 >> put x3 +put4 x1 x2 x3 x4 = put x1 >> put x2 >> put x3 >> put x4 +put5 x1 x2 x3 x4 x5 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 +put6 x1 x2 x3 x4 x5 x6 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 +put7 x1 x2 x3 x4 x5 x6 x7 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 +put8 x1 x2 x3 x4 x5 x6 x7 x8 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8 +put9 x1 x2 x3 x4 x5 x6 x7 x8 x9 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 >> put x8 >> put x9 + + +putByte :: Word8 -> SPut (); putByte = put +getByte :: SGet Word8; getByte = get +putWord32 :: Word32 -> SPut (); putWord32 = put +getWord32 :: SGet Word32; getWord32 = get + + +instance Store Word8 where + put = putStorable + get = getStorable + size = Just . sizeOf + +instance Store Word32 where + put = putStorable + get = getStorable + size = Just . sizeOf + +instance Store Int32 where + put = putStorable + get = getStorable + size = Just . sizeOf + +instance Store Int where + put x = putStorable (fromIntegral x :: Int32) + get = fmap fromIntegral (getStorable :: SGet Int32) + size _ = size (0 :: Int32) + +instance Store Char where + put = putByte . fromIntegral . ord + get = fmap (chr . fromIntegral) getByte + size _ = size (0 :: Word8) + + getList = fmap bsUnpack . getByteString . fromIntegral + + +instance Store Bool where + put x = put $ if x then '1' else '0' + get = fmap (== '1') get + size _ = size '1' + +instance Store () where + put () = return () + get = return () + size _ = Just 0 + +instance (Store a, Store b) => Store (a,b) where + put (a,b) = put2 a b + get = get2 (,) + size ~(a,b) = liftM2 (+) (size a) (size b) + +instance (Store a, Store b, Store c) => Store (a,b,c) where + put (a,b,c) = put3 a b c + get = get3 (,,) + size ~(a,b,c) = liftM3 (\a b c -> a + b + c) (size a) (size b) (size c) + +instance Store a => Store (Maybe a) where + put Nothing = putByte 0 + put (Just a) = putByte 1 >> put a + + get = do i <- getByte + case i of + 0 -> get0 Nothing + 1 -> get1 Just + _ -> errorSGet "Maybe" + +instance (Store a, Store b) => Store (Either a b) where + put (Left a) = putByte 0 >> put a + put (Right a) = putByte 1 >> put a + + get = do i <- getByte + case i of + 0 -> get1 Left + 1 -> get1 Right + _ -> errorSGet "Either" + + +-- strategy: write out a byte, 255 = length is an int, anything else = len +instance Store a => Store [a] where + put xs = do + let n = fromIntegral (length xs) + let mx = maxBound :: Word8 + if n >= fromIntegral mx then putByte mx >> putWord32 n else putByte (fromIntegral n) + putList xs + + get = do + n <- getByte + n <- if n == maxBound then getWord32 else return $ fromIntegral n + getList $ fromIntegral n + + +instance Store BS.ByteString where + put x = do + putWord32 $ fromIntegral $ BS.length x + putByteString x + get = do + n <- getWord32 + getByteString n + + +instance (Ix i, Store i, Store e) => Store (Array i e) where + put x = do + put $ bounds x + putList $ elems x + + get = do + bnd <- get + fmap (listArray bnd) $ case size (undefined :: e) of + Nothing -> getList $ rangeSize bnd + Just sz -> getLazyList get sz (rangeSize bnd) + + +instance (Typeable k, Typeable v, Ord k, Store k, Store v) => Store (Map.Map k v) where + put = putDefer . put . Prelude.map (second Defer) . Map.toAscList + + get = getDefer $ fmap (Map.fromAscList . Prelude.map (second fromDefer)) get diff --git a/src/Hoogle/Store/ReadBuffer.hs b/src/Hoogle/Store/ReadBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Store/ReadBuffer.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} + +module Hoogle.Store.ReadBuffer( + Buffer, newBuffer, + setPos, getPos, + getStorable, getByteString, + ) where + +import General.Base +import General.System +import Foreign +import qualified Data.ByteString as BS + + +bufferSize = 100 :: Int + +data Buffer = Buffer {handle :: Handle, fptr :: ForeignPtr ()} + +newBuffer :: Handle -> IO Buffer +newBuffer handle = do + ptr <- mallocForeignPtrBytes bufferSize + return $ Buffer handle ptr + + +getPos :: Buffer -> IO Word32 +getPos Buffer{..} = fmap fromIntegral $ hTell handle + +setPos :: Buffer -> Word32 -> IO () +setPos b@Buffer{..} pos = do + hSeek handle AbsoluteSeek $ fromIntegral pos + + +getStorable :: forall a . Storable a => Buffer -> IO a +getStorable Buffer{..} = do + let n = sizeOf (undefined :: a) + when (n > bufferSize) $ error $ "Buffer size overflow in getStorable" + withForeignPtr fptr $ \ptr -> do + hGetBuf handle ptr $ sizeOf (undefined :: a) + peek $ castPtr ptr + + +getByteString :: Buffer -> Int -> IO BString +getByteString Buffer{..} n = BS.hGet handle n diff --git a/src/Hoogle/Store/Type.hs b/src/Hoogle/Store/Type.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Store/Type.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} + +module Hoogle.Store.Type( + Once, once, fromOnce, putOnce, getOnce, + SPut, runSPut, putByteString, putStorable, putDefer, + SGet, runSGet, getByteString, getStorable, getDefer, getLazyList + ) where + +import General.Base +import General.System +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import qualified Data.IntMap as IntMap +import Data.IORef +import Data.Typeable +import Foreign +import System.IO.Unsafe +import qualified Hoogle.Store.ReadBuffer as R +import qualified Hoogle.Store.WriteBuffer as W + + +-- | Turn on to see file statistics +stats = False + + +-- | All once values are equal with respect to keyOnce +-- If you create it with 'once' it will have the same key. +-- If two are loaded from a file they are equal. +data Once a = Once {_onceKey :: Int, valueOnce :: a} + deriving Typeable + +fromOnce :: Once a -> a +fromOnce = valueOnce + +-- | Given how many you would like to allocate, return your base address +onceKeys :: Int -> IO Int +onceKeys = unsafePerformIO $ do + ref <- newIORef 0 + return $ \n -> atomicModifyIORef ref $ \x -> (x+n, x) + + +--------------------------------------------------------------------- +-- PUT + +data SPutS = SPutS + {putBuffer :: W.Buffer + ,putOnces :: IORef (IntMap.IntMap PutOnce) + ,putPending :: IORef [SPut ()] + } + +type SPut a = ReaderT SPutS IO a + +modifyRef f x = liftIO . (`modifyIORef` x) =<< asks f +readPos = liftIO . W.getPos =<< asks putBuffer + + +runSPut :: FilePath -> SPut () -> IO () +runSPut file act = withBinaryFile file WriteMode $ \h -> do + pending <- newIORef [act] + once <- newIORef IntMap.empty + + W.withBuffer h $ \buffer -> do + let flush = do + xs <- liftIO $ readIORef pending + liftIO $ writeIORef pending [] + forM_ xs $ \x -> do + x + flush + runReaderT flush $ SPutS buffer once pending + + +putByteString :: BString -> SPut () +putByteString x = do + buf <- asks putBuffer + liftIO $ W.putByteString buf x + +putStorable :: Storable a => a -> SPut () +putStorable x = do + buf <- asks putBuffer + liftIO $ W.putStorable buf x + + +putDefer :: SPut () -> SPut () +putDefer act = do + pos <- readPos + putStorable (0 :: Word32) + modifyRef putPending $ (:) $ do + val <- readPos + buf <- asks putBuffer + liftIO $ W.patch buf pos val + act + + +{-# NOINLINE once #-} +once :: a -> Once a +once x = unsafePerformIO $ do + key <- onceKeys 1 + return $ Once key x + + +type PutOnce = Either [Word32] Word32 + +putOnce :: (a -> SPut ()) -> Once a -> SPut () +putOnce act (Once key x) = do + ref <- asks putOnces + mp <- liftIO $ readIORef ref + case fromMaybe (Left []) $ IntMap.lookup key mp of + -- written out at this address + Right val -> putStorable val + + -- [] is has not been added to the defer list + -- (:) is on defer list but not yet written, these are places that need back patching + Left poss -> do + pos <- readPos + liftIO $ writeIORef ref $ IntMap.insert key (Left $ pos:poss) mp + putStorable (0 :: Word32) + when (null poss) $ modifyRef putPending $ (:) $ do + val <- readPos + mp <- liftIO $ readIORef ref + let Left poss = mp IntMap.! key + buf <- asks putBuffer + liftIO $ forM_ poss $ \pos -> W.patch buf pos val + liftIO $ writeIORef ref $ IntMap.insert key (Right val) mp + act x + + +--------------------------------------------------------------------- +-- GET + +-- getPtr is the pointer you have, how much is left valid, +data SGetS = SGetS {getBuffer :: R.Buffer, onceBase :: Int} + +type SGet a = ReaderT SGetS IO a + + +runSGet :: Typeable a => FilePath -> SGet a -> IO a +runSGet 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 + + +getStorable :: Typeable a => Storable a => SGet a +getStorable = do + buf <- asks getBuffer + res <- liftIO $ R.getStorable buf + when stats $ liftIO $ putStrLn $ "Reading storable " ++ show (sizeOf res) + return res + + +getByteString :: Word32 -> SGet BString +getByteString len = do + buf <- asks getBuffer + when stats $ liftIO $ putStrLn $ "Reading bytestring " ++ show len + liftIO $ R.getByteString buf $ fromIntegral len + + +getDefer :: Typeable a => SGet a -> SGet a +getDefer get = do + pos :: Word32 <- getStorable + getDeferFrom pos get + + +getDeferFrom :: forall a . Typeable a => Word32 -> SGet a -> SGet a +getDeferFrom pos get = do + s <- ask + liftIO $ unsafeInterleaveIO $ do + when stats $ putStrLn $ "Read at " ++ show (typeOf (undefined :: a)) + R.setPos (getBuffer s) pos + runReaderT get s + + +getOnce :: Typeable a => SGet a -> SGet (Once a) +getOnce get = do + pos :: Word32 <- getStorable + x <- getDeferFrom pos get + one <- asks onceBase + return $ Once (fromIntegral pos + one) x + + +getLazyList :: SGet a -> Int -> Int -> SGet [a] +getLazyList get size n = do + s <- ask + pos <- liftIO $ R.getPos $ getBuffer s + liftIO $ forM [0..n-1] $ \i -> unsafeInterleaveIO $ do + R.setPos (getBuffer s) (pos + fromIntegral (i * size)) + runReaderT get s diff --git a/src/Hoogle/Store/WriteBuffer.hs b/src/Hoogle/Store/WriteBuffer.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Store/WriteBuffer.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} + +-- I tried switching to blaze-builder, but this buffer is massively faster +module Hoogle.Store.WriteBuffer( + Buffer, withBuffer, + putStorable, putByteString, + patch, getPos + ) where + +import General.Base +import General.System +import Data.IORef +import Foreign +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BS +import General.Util + + +bufferSize = 10000 :: Word32 + + +-- (number in file, number in buffer) +data Buffer = Buffer + {handle :: Handle -- the handle we are writing to + ,ptr :: Ptr () -- the current buffer + ,inFile :: IORef Word32 -- the number of bytes on the disk + ,inBuffer :: IORef Word32 -- the number of bytes in the buffer + ,patchup :: IORef [Patchup] + } + +data Patchup = !Word32 := !Word32 + +writeRef ref v = v `seq` writeIORef ref v +modifyRef ref f = writeRef ref . f =<< readIORef ref + + +withBuffer :: Handle -> (Buffer -> IO a) -> IO a +withBuffer handle f = do + inFile <- newIORef . fromInteger =<< hTell handle + inBuffer <- newIORef 0 + patchup <- newIORef [] + allocaBytes (fromIntegral bufferSize) $ \ptr -> do + res <- f $ Buffer handle ptr inFile inBuffer patchup + inBuf <- readIORef inBuffer + when (inBuf > 0) $ hPutBuf handle ptr (fromIntegral inBuf) + xs <- fmap (sortOn $ \(a := b) -> a) $ readIORef patchup + forM_ xs $ \(pos := val) -> do + hSeek handle AbsoluteSeek $ toInteger pos + poke (castPtr ptr) val + hPutBuf handle ptr $ sizeOf val + return res + + +put :: Buffer -> Word32 -> (Handle -> IO ()) -> (Ptr a -> Int -> IO ()) -> IO () +put _ 0 _ _ = return () +put Buffer{..} sz toFile toBuffer = do + inBuf <- readIORef inBuffer + if inBuf + sz >= bufferSize then do + when (inBuf > 0) $ hPutBuf handle ptr $ fromIntegral inBuf + if sz >= bufferSize `div` 2 then do + toFile handle + modifyRef inFile (+ (inBuf+sz)) + writeRef inBuffer 0 + else do + toBuffer (castPtr ptr) 0 + modifyRef inFile (+inBuf) + writeRef inBuffer sz + else do + toBuffer (castPtr ptr) $ fromIntegral inBuf + writeIORef inBuffer (inBuf+sz) + + +putStorable :: Storable a => Buffer -> a -> IO () +putStorable buf x = put buf (fromIntegral sz) + (\h -> allocaBytes (sizeOf x) $ \ptr -> poke ptr x >> hPutBuf h ptr sz) + (\ptr pos -> pokeByteOff ptr pos x) + where sz = sizeOf x + + +putByteString :: Buffer -> BS.ByteString -> IO () +putByteString buf x = put buf (fromIntegral $ BS.length x) (`BS.hPut` x) $ + \ptr pos -> let (fp,offset,len) = BS.toForeignPtr x in + withForeignPtr fp $ \p -> BS.memcpy (plusPtr ptr pos) (plusPtr p offset) (fromIntegral len) + + +getPos :: Buffer -> IO Word32 +getPos Buffer{..} = liftM2 (+) (readIORef inFile) (readIORef inBuffer) + + +-- Patch at position p, with value v. p must be in the past. +-- Return True if you succeeded, False if that is already on disk +patch :: Buffer -> Word32 -> Word32 -> IO () +patch Buffer{..} p v = do + i <- readIORef inFile + if p >= i then + pokeByteOff ptr (fromIntegral $ p-i) v + else + modifyRef patchup $ (:) (p := v) diff --git a/src/Hoogle/Type/All.hs b/src/Hoogle/Type/All.hs --- a/src/Hoogle/Type/All.hs +++ b/src/Hoogle/Type/All.hs @@ -1,10 +1,10 @@ module Hoogle.Type.All(module X) where -import Hoogle.Type.Documentation as X -import Hoogle.Type.Item as X -import Hoogle.Type.Language as X -import Hoogle.Type.ParseError as X -import Hoogle.Type.Result as X -import Hoogle.Type.TagStr as X -import Hoogle.Type.TypeSig as X +import Hoogle.Type.Docs as X +import Hoogle.Type.Item as X +import Hoogle.Type.Language as X +import Hoogle.Type.ParseError as X +import Hoogle.Type.Result as X +import Hoogle.Type.TagStr as X +import Hoogle.Type.TypeSig as X diff --git a/src/Hoogle/Type/Docs.hs b/src/Hoogle/Type/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Type/Docs.hs @@ -0,0 +1,78 @@ + +module Hoogle.Type.Docs( + Docs, readDocsHTML, renderDocs + ) where + +import General.Base +import Hoogle.Type.TagStr +import Hoogle.Store.All +import Data.ByteString.Char8(ByteString,pack,unpack) + + +newtype Docs = Docs ByteString + deriving (Eq,Ord) + + +instance Store Docs where + put (Docs x) = put1 x + get = get1 Docs + + +readDocsHTML :: String -> Docs +readDocsHTML = Docs . pack + + +renderDocs :: Docs -> TagStr +renderDocs (Docs xs) = tags $ f False $ parseHTML $ unpack xs + where + nl = Char '\n' + + -- boolean, are you in a pre block + f False (Char '\n':Char '\n':xs) = Str "\n\n" : f False (dropWhile (== nl) xs) + f False (Char '\n':xs) = Str " " : f False xs + + f True (Char '\n':xs) = Str "\n" : Str "> " : f True xs + + -- TODO: tt is ignored, add a TagMonospage? + f pre (Tag "tt" x:xs) = f pre (x++xs) + f pre (Tag [t,'l'] x:xs) | t `elem` "ou" = tail $ f pre (filter (/= nl) x ++ xs) + f pre (Tag "pre" x:xs) = init (init $ tail $ f True x) ++ f pre xs + f pre (Tag "li" x:xs) = Str "\n" : Str "* " : f pre x ++ f pre xs + f pre (Tag "a" x:xs) = TagLink "" (tags $ f pre x) : f pre xs + f pre (Tag "i" x:xs) = TagEmph (tags $ f pre x) : f pre xs + f pre (Tag "em" x:xs) = TagEmph (tags $ f pre x) : f pre xs + f pre (Tag "b" x:xs) = TagBold (tags $ f pre x) : f pre xs + + f pre (Tag n x:xs) = Str (show (Tag n x)) : f pre xs + f pre (Char x:xs) = Str [x] : f pre xs + f pre [] = [] + + + +--------------------------------------------------------------------- +-- PARSER + +type Tags = [Tag] +data Tag = Char Char | Tag String Tags + deriving (Eq,Show) + +parseHTML :: String -> Tags +parseHTML = fst . readHTML ">" + + +readHTML :: String -> String -> (Tags, String) +readHTML name = f + where + f ('&':'a':'m':'p':';':xs) = g xs $ Char '&' + f ('&':'g':'t':';':xs) = g xs $ Char '>' + f ('&':'l':'t':';':xs) = g xs $ Char '<' + f ('<':'/':xs) | a == name = ([], drop 1 b) + where (a,b) = break (== '>') xs + f ('<':xs) | not $ "/" `isPrefixOf` xs = g d $ Tag a c + where (a,b) = break (== '>') xs + (c,d) = readHTML a $ drop 1 b + f (x:xs) = g xs $ Char x + f [] = ([],[]) + + g rest add = (add:a,b) + where (a,b) = f rest diff --git a/src/Hoogle/Type/Documentation.hs b/src/Hoogle/Type/Documentation.hs deleted file mode 100644 --- a/src/Hoogle/Type/Documentation.hs +++ /dev/null @@ -1,77 +0,0 @@ - -module Hoogle.Type.Documentation( - Documentation, htmlDocumentation, renderDocumentation - ) where - -import General.Base -import Hoogle.Type.TagStr -import Data.Binary.Defer -import Data.ByteString.Char8(ByteString,pack,unpack) - - -newtype Documentation = Documentation ByteString - deriving (Eq,Ord) - - -instance BinaryDefer Documentation where - put (Documentation x) = putByteString x - get = fmap Documentation getByteString - - -htmlDocumentation :: String -> Documentation -htmlDocumentation = Documentation . pack - - -renderDocumentation :: Documentation -> TagStr -renderDocumentation (Documentation xs) = Tags $ f False $ parseHTML $ unpack xs - where - nl = Char '\n' - - -- boolean, are you in a pre block - f False (Char '\n':Char '\n':xs) = Str "\n\n" : f False (dropWhile (== nl) xs) - f False (Char '\n':xs) = Str " " : f False xs - - f True (Char '\n':xs) = Str "\n" : Str "> " : f True xs - - -- TODO: tt is ignored, add a TagMonospage? - f pre (Tag "tt" x:xs) = f pre (x++xs) - f pre (Tag [t,'l'] x:xs) | t `elem` "ou" = tail $ f pre (filter (/= nl) x ++ xs) - f pre (Tag "pre" x:xs) = init (init $ tail $ f True x) ++ f pre xs - f pre (Tag "li" x:xs) = Str "\n" : Str "* " : f pre x ++ f pre xs - f pre (Tag "a" x:xs) = TagLink "" (Tags $ f pre x) : f pre xs - f pre (Tag "i" x:xs) = TagEmph (Tags $ f pre x) : f pre xs - f pre (Tag "b" x:xs) = TagBold (Tags $ f pre x) : f pre xs - - f pre (Tag n x:xs) = Str (show (Tag n x)) : f pre xs - f pre (Char x:xs) = Str [x] : f pre xs - f pre [] = [] - - - ---------------------------------------------------------------------- --- PARSER - -type Tags = [Tag] -data Tag = Char Char | Tag String Tags - deriving (Eq,Show) - -parseHTML :: String -> Tags -parseHTML = fst . readHTML ">" - - -readHTML :: String -> String -> (Tags, String) -readHTML name = f - where - f ('&':'a':'m':'p':';':xs) = g xs $ Char '&' - f ('&':'g':'t':';':xs) = g xs $ Char '>' - f ('&':'l':'t':';':xs) = g xs $ Char '<' - f ('<':'/':xs) | a == name = ([], drop 1 b) - where (a,b) = break (== '>') xs - f ('<':xs) | not $ "/" `isPrefixOf` xs = g d $ Tag a c - where (a,b) = break (== '>') xs - (c,d) = readHTML a $ drop 1 b - f (x:xs) = g xs $ Char x - f [] = ([],[]) - - g rest add = (add:a,b) - where (a,b) = f rest diff --git a/src/Hoogle/Type/Item.hs b/src/Hoogle/Type/Item.hs --- a/src/Hoogle/Type/Item.hs +++ b/src/Hoogle/Type/Item.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-} module Hoogle.Type.Item where import General.Base -import Data.Binary.Defer -import Data.Binary.Defer.Index -import Hoogle.Type.Documentation +import General.Util +import Hoogle.Store.All +import Hoogle.Type.Docs import Hoogle.Type.TagStr import Hoogle.Type.TypeSig import Data.Generics.Uniplate @@ -37,16 +37,28 @@ -- Invariant: locations will not be empty data Entry = Entry - {entryLocations :: [(URL, [Link Entry])] + {entryLocations :: [(URL, [Once Entry])] ,entryName :: String ,entryText :: TagStr - ,entryDocs :: Documentation + ,entryDocs :: Docs ,entryPriority :: Int ,entryKey :: String -- used only for rebuilding combined databases ,entryType :: Maybe TypeSig -- used only for rebuilding combined databases } - deriving (Typeable) + deriving Typeable + +-- | Figure out what makes this entry different from others +entryUnique Entry{..} = (entryName, entryText, entryDocs, entryKey, entryType) + + +-- | Join two entries that are equal under entryUnique +entryJoin e1 e2 = e1 + {entryPriority = min (entryPriority e1) (entryPriority e2) + ,entryLocations = nubOn (map (entryName . fromOnce) . snd) $ concatMap entryLocations $ + if entryScore e1 < entryScore e2 then [e1,e2] else [e2,e1]} + + entryURL e = head $ map fst (entryLocations e) ++ [""] @@ -88,6 +100,6 @@ instance Show Entry where show = showTagText . entryText -instance BinaryDefer Entry where +instance Store Entry where put (Entry a b c d e f g) = put7 a b c d e f g get = get7 Entry diff --git a/src/Hoogle/Type/Result.hs b/src/Hoogle/Type/Result.hs --- a/src/Hoogle/Type/Result.hs +++ b/src/Hoogle/Type/Result.hs @@ -4,11 +4,10 @@ import Hoogle.Type.TagStr import Hoogle.Type.Item import Hoogle.Score.All -import Data.Binary.Defer.Index data Result = Result - {resultEntry :: Link Entry + {resultEntry :: Entry ,resultView :: [EntryView] ,resultScore :: Score } @@ -17,5 +16,4 @@ -- return the entry rendered with respect to the EntryView renderResult :: Result -> TagStr -renderResult r = renderEntryText (resultView r) $ entryText e - where e = fromLink $ resultEntry r +renderResult r = renderEntryText (resultView r) $ entryText $ resultEntry r diff --git a/src/Hoogle/Type/TagStr.hs b/src/Hoogle/Type/TagStr.hs --- a/src/Hoogle/Type/TagStr.hs +++ b/src/Hoogle/Type/TagStr.hs @@ -2,7 +2,7 @@ -- | A module representing strings with formatting. module Hoogle.Type.TagStr( - TagStr(..), + TagStr(..), tags, showTagText, showTagANSI, showTagHTML, showTagHTMLWith, formatTags @@ -11,7 +11,7 @@ import General.Base import General.Web import Data.Generics.Uniplate -import Data.Binary.Defer +import Hoogle.Store.All data TagStr @@ -26,8 +26,8 @@ instance Monoid TagStr where mempty = Str "" - mappend x y = Tags [x,y] - mconcat = Tags + mappend x y = tags [x,y] + mconcat = tags instance Uniplate TagStr where @@ -39,7 +39,7 @@ uniplate x = ([], const x) -instance BinaryDefer TagStr where +instance Store TagStr where put (Str x) = putByte 0 >> put1 x put (Tags x) = putByte 1 >> put1 x put (TagBold x) = putByte 2 >> put1 x @@ -56,28 +56,16 @@ 4 -> get2 TagLink 5 -> get2 TagColor -{- -instance BD.BinaryDefer TagStr where - put x = BD.putLazyByteString $ encode x - get = fmap decode BD.getLazyByteString -instance Binary TagStr where - put (Str x) = putWord8 0 >> put x - put (Tags x) = putWord8 1 >> put x - put (TagBold x) = putWord8 2 >> put x - put (TagEmph x) = putWord8 3 >> put x - put (TagLink x y) = putWord8 4 >> put x >> put y - put (TagColor x y) = putWord8 5 >> put x >> put y - - get = do i <- getWord8 - case i of - 0 -> fmap Str get - 1 -> fmap Tags get - 2 -> fmap TagBold get - 3 -> fmap TagEmph get - 4 -> fmap TagLink get get - 5 -> fmap TagColor get get --} +-- | Smart constructor for 'Tags' +tags :: [TagStr] -> TagStr +tags xs = case f xs of + [x] -> x + xs -> Tags xs + where + f (Str a:Str b:xs) = f $ Str (a++b):xs + f (x:xs) = x : f xs + f [] = [] -- | Show a 'TagStr' as a string, without any formatting. diff --git a/src/Hoogle/Type/TypeSig.hs b/src/Hoogle/Type/TypeSig.hs --- a/src/Hoogle/Type/TypeSig.hs +++ b/src/Hoogle/Type/TypeSig.hs @@ -2,7 +2,7 @@ module Hoogle.Type.TypeSig where -import Data.Binary.Defer +import Hoogle.Store.All import Data.List import Data.Data import Data.Generics.UniplateOn @@ -100,13 +100,13 @@ --------------------------------------------------------------------- --- BINARYDEFER INSTANCES +-- STORE INSTANCES -instance BinaryDefer TypeSig where +instance Store TypeSig where put (TypeSig a b) = put2 a b get = get2 TypeSig -instance BinaryDefer Type where +instance Store Type where put (TApp a b) = putByte 0 >> put2 a b put (TLit a) = putByte 1 >> put1 a put (TVar a) = putByte 2 >> put1 a diff --git a/src/Recipe/Cabal.hs b/src/Recipe/Cabal.hs --- a/src/Recipe/Cabal.hs +++ b/src/Recipe/Cabal.hs @@ -12,6 +12,7 @@ import Distribution.Text import Distribution.Verbosity import Distribution.Version +import Recipe.Haddock ghcVersion = [7,0,1] @@ -35,5 +36,5 @@ return $ Cabal (display $ pkgName $ package pkg) (display $ pkgVersion $ package pkg) - (lines $ description pkg) + (haddockToHTML $ description pkg) [display x | Just l <- [library pkg], Dependency x _ <- targetBuildDepends $ libBuildInfo l] diff --git a/src/Recipe/Download.hs b/src/Recipe/Download.hs --- a/src/Recipe/Download.hs +++ b/src/Recipe/Download.hs @@ -11,19 +11,31 @@ download opt = do createDirectoryIfMissing True "download" wget opt keywords "http://haskell.org/haskellwiki/Keywords" - wget opt platform "http://code.haskell.org/haskell-platform/haskell-platform.cabal" + wget opt platform "http://code.galois.com/darcs/haskell-platform/haskell-platform.cabal" wget opt inputBase "http://haskell.org/hoogle/base.txt" downloadTarball opt cabals "http://hackage.haskell.org/packages/archive/00-index.tar.gz" downloadTarball opt inputs "http://hackage.haskell.org/packages/archive/00-hoogle.tar.gz" +check :: String -> URL -> IO () +check name url | isWindows = do + res <- findExecutable name + when (isNothing res) $ putStrLn $ + "WARNING: Could not find command line program " ++ name ++ ".\n" ++ + " You may be able to install it from:\n " ++ url +check _ _ = return () + + wgetMay :: CmdLine -> FilePath -> URL -> IO Bool wgetMay opt fil url = do b <- doesFileExist fil when (not b || redownload opt) $ do + check "wget" "http://gnuwin32.sourceforge.net/packages/wget.htm" res <- system $ "wget " ++ url ++ " -O " ++ fil let b = res == ExitSuccess - unless b $ removeFile fil + unless b $ do + b <- doesFileExist fil + when b $ removeFile fil doesFileExist fil @@ -39,6 +51,9 @@ unless b $ do wget opt (out <.> "tar.gz") url createDirectoryIfMissing True out - withDirectory out $ - system_ $ "tar -xzf .." takeFileName out <.> "tar.gz" + withDirectory out $ do + check "gzip" "http://gnuwin32.sourceforge.net/packages/gzip.htm" + check "tar" "http://gnuwin32.sourceforge.net/packages/gtar.htm" + system_ $ "gzip -d .." takeFileName out <.> "tar.gz" + system_ $ "tar -xf .." takeFileName out <.> "tar" writeFile (out <.> "txt") "" diff --git a/src/Recipe/Haddock.hs b/src/Recipe/Haddock.hs new file mode 100644 --- /dev/null +++ b/src/Recipe/Haddock.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE PatternGuards #-} + +module Recipe.Haddock( + haddockToHTML + ) where + +import General.Base +import General.Web +import qualified Text.Read as R + + +data Chunk = Verb [String] | Blk [String] | Li [String] | Numb [String] | Defn [(String,String)] | Para String deriving (Ord,Eq) + +haddockToHTML :: String -> [String] +haddockToHTML = intercalate [""] . map (concatMap linewrap . convert) . join . map classify . paragraphs . lines + where + empty = all isSpace + para = unwords . map trim + + paragraphs = filter (not . all empty) . groupBy (\x y -> not (empty x) && not (empty y)) + + classify xs = case trim (head xs) of + "@" | trim (last xs) == "@", length xs > 1 -> Blk $ tail $ init xs + + '>':_ | all ((">" `isPrefixOf`) . ltrim) xs -> Verb $ map (tail . ltrim) xs + + '[':ys | (cs, ']':zs) <- break (==']') ys -> Defn [(trim cs, para $ zs : tail xs)] + + '*':ys -> Li [para $ ys : tail xs] + '-':ys -> Li [para $ ys : tail xs] + + '(':ys | (cs, ')':zs) <- break (==')') ys + , all isDigit cs -> Numb [para $ zs : tail xs] + c:ys | isDigit c + , '.':zs <- dropWhile isDigit ys -> Numb [para $ zs : tail xs] + + _ -> Para $ para xs + + join (Li xs : Li ys : zs) = join $ Li (xs ++ ys) : zs + join (Numb xs : Numb ys : zs) = join $ Numb (xs ++ ys) : zs + join (Defn xs : Defn ys : zs) = join $ Defn (xs ++ ys) : zs + join (x : ys) = x : join ys + join [] = [] + + convert (Verb xs) = [""] ++ map escapeHTML xs ++ [""] + convert (Blk xs) = ["
"] ++ map parseInline xs ++ [""] + convert (Li xs) = ["
\n Hoogle is a Haskell API search engine, which allows you to search many standard Haskell libraries\n by either function name, or by approximate type signature.\n
\n\n Example searches:
\n map\n
\n (a -> b) -> [a] -> [b]\n
\n Ord a => [a] -> [a]\n
\n Data.Map.insert\n
\n\t
Enter your own search at the top of the page.\n
\n The Hoogle manual contains more details,\n including further details on search queries, how to install Hoogle as a command line application\n and how to integrate Hoogle with Firefox/Emacs/Vim etc.\n
\n\n I am very interested in any feedback you may have. Please\n email me, or add an entry to my\n bug tracker.\n
\n" -welcome = - ["" - ," Hoogle is a Haskell API search engine, which allows you to search many standard Haskell libraries" - ," by either function name, or by approximate type signature." - ,"
" - ,""
- ," Example searches:
"
- ," " ++ search "map"
- ," " ++ search "(a -> b) -> [a] -> [b]"
- ," " ++ search "Ord a => [a] -> [a]"
- ," " ++ search "Data.Map.insert"
- ,"
Enter your own search at the top of the page."
- ,"
" - ," The Hoogle manual contains more details," - ," including further details on search queries, how to install Hoogle as a command line application" - ," and how to integrate Hoogle with Firefox/Emacs/Vim etc." - ,"
" - ,"" - ," I am very interested in any feedback you may have. Please " - ," email me, or add an entry to my" - ," bug tracker." - ,"
" - ] - where - search x = "" ++& x ++ "\n\tParse error: " + ++ escapeHTML errMessage + ++ "\n
\n\tFor information on what queries should look like, see the\n\tuser manual.\n
\n" diff --git a/src/Web/Response.hs b/src/Web/Response.hs --- a/src/Web/Response.hs +++ b/src/Web/Response.hs @@ -1,12 +1,11 @@ {-# LANGUAGE RecordWildCards #-} -module Web.Response(response) where +module Web.Response(response, ResponseArgs(..), responseArgs) where import CmdLine.All import Hoogle import General.Base import General.System -import General.Util import General.Web import Web.Page import Data.Generics.Uniplate @@ -15,16 +14,29 @@ import Data.Time.Format import System.Locale import Network.Wai +import Network.HTTP.Types(headerContentType) import System.IO.Unsafe(unsafeInterleaveIO) +import qualified Paths_hoogle(version) +import Data.Version(showVersion) logFile = "log.txt" +version = showVersion Paths_hoogle.version -response :: FilePath -> CmdLine -> IO Response -response resources q = do +data ResponseArgs = ResponseArgs + {updatedCss :: String + ,updatedJs :: String + ,templates :: Templates + } + +responseArgs = ResponseArgs version version defaultTemplates + + +response :: ResponseArgs -> CmdLine -> IO Response +response ResponseArgs{..} q = do logMessage q - let response x ys z = responseOK ((hdrContentType,fromString x) : ys) (fromString z) + let response x ys = responseOK (headerContentType (fromString x) : ys) . fromString dbs <- unsafeInterleaveIO $ case queryParsed q of Left _ -> return mempty @@ -32,12 +44,12 @@ case web q of Just "suggest" -> fmap (response "application/json" []) $ runSuggest q - Just "embed" -> return $ response "text/html" [hdr] $ unlines $ runEmbed dbs q + Just "embed" -> return $ response "text/html" [hdr] $ runEmbed dbs q where hdr = (fromString "Access-Control-Allow-Origin", fromString "*") - Just "ajax" -> return $ response "text/html" [] $ unlines $ runQuery True dbs q - Just "web" -> return $ response "text/html" [] $ unlines $ - header resources (escapeHTML $ queryText q) ++ - runQuery False dbs q ++ footer + Just "ajax" -> return $ response "text/html" [] $ runQuery templates True dbs q + Just "web" -> return $ response "text/html" [] $ + header templates updatedCss updatedJs (queryText q) ['-' | queryText q /= ""] ++ + runQuery templates False dbs q ++ footer templates version mode -> return $ response "text/html" [] $ "Unknown webmode: " ++ fromMaybe "none" mode @@ -61,11 +73,11 @@ runSuggest _ = return "" -runEmbed :: Database -> CmdLine -> [String] -runEmbed dbs Search{queryParsed = Left err} = ["Parse error: " ++& errorMessage err ++ ""] +runEmbed :: Database -> CmdLine -> String +runEmbed dbs Search{queryParsed = Left err} = "Parse error: " ++& errorMessage err ++ "" runEmbed dbs cq@Search{queryParsed = Right q} - | null now = ["No results found"] - | otherwise = + | null now = "No results found" + | otherwise = unlines ["" ++ showTagHTML (transform f $ self $ snd x) ++ "" | x <- now, let url = fromList "" $ map fst $ locations $ snd x] where @@ -75,28 +87,21 @@ f x = x -runQuery :: Bool -> Database -> CmdLine -> [String] -runQuery ajax dbs Search{queryParsed = Left err} = - ["" - ," Parse error: " ++& errorMessage err - ,"
" - ," For information on what queries should look like, see the" - ," user manual." - ,"
" - ] +runQuery :: Templates -> Bool -> Database -> CmdLine -> String +runQuery templates ajax dbs Search{queryParsed = Left err} = + parseError templates (showTagHTMLWith f $ parseInput err) (errorMessage err) where f (TagEmph x) = Just $ "" ++ showTagHTMLWith f x ++ "" f _ = Nothing -runQuery ajax dbs q | fromRight (queryParsed q) == mempty = welcome +runQuery templates ajax dbs q | fromRight (queryParsed q) == mempty = welcome templates -runQuery ajax dbs cq@Search{queryParsed = Right q, queryText = qt} = +runQuery templates ajax dbs cq@Search{queryParsed = Right q, queryText = qt} = unlines $ (if prefix then ["" ++ showTag sug ++ "
" | Just sug <- [suggestions dbs q]] ++ if null res then ["No results found
"] @@ -115,7 +120,7 @@ (pre,res2) = splitAt start2 res (now,post) = splitAt count2 res2 - also = "