hoogle 4.2.1 → 4.2.2
raw patch · 59 files changed
+1578/−1256 lines, 59 filesdep +case-insensitivedep +http-typesdep +old-timedep ~blaze-builderdep ~parsecdep ~waibinary-addedPVP ok
version bump matches the API change (PVP)
Dependencies added: case-insensitive, http-types, old-time
Dependency ranges changed: blaze-builder, parsec, wai, warp
API changes (from Hackage documentation)
Files
- datadir/resources/favicon57.png binary
- datadir/resources/hoogle.css +23/−30
- datadir/resources/hoogle.js +64/−28
- datadir/resources/template.html +89/−0
- datadir/resources/template_example.html +11/−0
- hoogle.cabal +17/−13
- src/CmdLine/Type.hs +3/−1
- src/Data/Binary/Defer.hs +0/−18
- src/Data/Binary/Defer/Array.hs +0/−57
- src/Data/Binary/Defer/Class.hs +0/−223
- src/Data/Binary/Defer/Index.hs +0/−94
- src/Data/Binary/Defer/Monad.hs +0/−233
- src/Data/Binary/Raw.hs +0/−59
- src/General/Base.hs +7/−2
- src/General/System.hs +7/−0
- src/General/Util.hs +1/−1
- src/General/Web.hs +11/−11
- src/Hoogle.hs +4/−5
- src/Hoogle/DataBase/Aliases.hs +5/−3
- src/Hoogle/DataBase/All.hs +7/−7
- src/Hoogle/DataBase/Instances.hs +2/−2
- src/Hoogle/DataBase/Items.hs +20/−40
- src/Hoogle/DataBase/Serialise.hs +25/−27
- src/Hoogle/DataBase/SubstrSearch.hs +44/−45
- src/Hoogle/DataBase/Suggest.hs +5/−3
- src/Hoogle/DataBase/Type.hs +5/−4
- src/Hoogle/DataBase/TypeSearch/All.hs +4/−5
- src/Hoogle/DataBase/TypeSearch/EntryInfo.hs +12/−8
- src/Hoogle/DataBase/TypeSearch/Graph.hs +10/−9
- src/Hoogle/DataBase/TypeSearch/Graphs.hs +16/−18
- src/Hoogle/DataBase/TypeSearch/Result.hs +11/−11
- src/Hoogle/Language/Haskell.hs +6/−6
- src/Hoogle/Query/Parser.hs +3/−3
- src/Hoogle/Query/Render.hs +2/−2
- src/Hoogle/Query/Type.hs +22/−2
- src/Hoogle/Search/All.hs +3/−2
- src/Hoogle/Search/Results.hs +19/−20
- src/Hoogle/Store/All.hs +196/−0
- src/Hoogle/Store/ReadBuffer.hs +43/−0
- src/Hoogle/Store/Type.hs +189/−0
- src/Hoogle/Store/WriteBuffer.hs +98/−0
- src/Hoogle/Type/All.hs +7/−7
- src/Hoogle/Type/Docs.hs +78/−0
- src/Hoogle/Type/Documentation.hs +0/−77
- src/Hoogle/Type/Item.hs +20/−8
- src/Hoogle/Type/Result.hs +2/−4
- src/Hoogle/Type/TagStr.hs +14/−26
- src/Hoogle/Type/TypeSig.hs +4/−4
- src/Recipe/Cabal.hs +2/−1
- src/Recipe/Download.hs +19/−4
- src/Recipe/Haddock.hs +108/−0
- src/Test/All.hs +2/−0
- src/Test/Docs.hs +12/−0
- src/Test/Parse_Query.hs +2/−2
- src/Web/All.hs +1/−3
- src/Web/Page.hs +47/−83
- src/Web/Response.hs +40/−35
- src/Web/Server.hs +66/−10
- src/Web/Template.hs +170/−0
+ datadir/resources/favicon57.png view
binary file changed (absent → 1272 bytes)
datadir/resources/hoogle.css view
@@ -6,7 +6,7 @@ margin: 0px; padding: 0px; font-family: sans-serif;- font-size: 10pt;+ font-size: 13px; } a img {@@ -62,16 +62,12 @@ #left { float: left; width: 140px;+ margin: 0px;+ padding: 0px; margin-top: 7px; margin-left: 10px;- font-size: 13px; } -#left ul {- padding: 0px;- margin: 0px;-}- #left li { list-style-type: none; margin-bottom: 7px;@@ -80,12 +76,12 @@ } #left a {+ color: #0E7700; text-decoration: none; background-repeat: no-repeat; } #left .plus {- color: #0E7700; padding-right: 16px; background-image: url(more_small.png); background-position: center right;@@ -109,7 +105,6 @@ #footer { text-align: center;- font-size: 13px; } @@ -125,7 +120,7 @@ to make type searching visisble */ background-color: #e4e4e4; border-top: 1px solid #999;- text-indent: 165px;+ padding-left: 170px; font-size: 16px; } @@ -168,7 +163,7 @@ .ans, .doc, .from { margin-left: 170px;- margin-right: 10px;+ margin-right: 20px; } a.dull, a.dull:hover {@@ -214,39 +209,37 @@ /** PARENTS **/ .p1, .p2 {- font-size: 13px; white-space: nowrap; text-decoration: none; color: #0E774A; } /** DOCS **/+/*+docs may be in one of three states:+ .doc - shut and no icon+ .doc.shut - shut with an icon to expand+ .doc.open - open with an icon to collapse+*/ .doc {- vertical-align: top;- font-size: 8pt;+ font-size: 11px;+ background-repeat: no-repeat;+ background-position: 2px left; } .doc, .doc a { color: #888; } -.docs {- margin: 2px;- margin-right: 4px;- width: 10px;- height: 10px;- display: block;- float: left;- background-repeat: no-repeat;- background-position: center center;-}--.shut .docs {background-image: url(more_gray.png);}-.open .docs {background-image: url(less_gray.png);}+.open, .shut {padding-left: 13px;}+.open {background-image: url(less_gray.png);}+.shut {background-image: url(more_gray.png);} -.shut {+.doc, .shut { max-height: 1.5em; overflow: hidden;- color: #888; }-.shut br {display: none;}+.open {+ max-height: 100%;+ white-space: pre-wrap;+}
datadir/resources/hoogle.js view
@@ -75,7 +75,7 @@ return { showWaiting: function(){$("h1").text("Still working...");}, showError: function(status,text){$body.html("<h1><b>Error:</b> status " + status + "</h1><p>" + text + "</p>")},- 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 <input type=search />+$.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) {
+ datadir/resources/template.html view
@@ -0,0 +1,89 @@++#export header css js query+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">+ <head profile="http://a9.com/-/spec/opensearch/1.1/">+ <meta http-equiv="Content-Type" content="text/html; charset=iso-8859-1" />+ <title>$&query$ $&queryHyphen$ Hoogle</title>+ <link type="text/css" rel="stylesheet" href="res/hoogle.css?version=$%css$" />+ <link type="image/png" rel="icon" href="res/favicon.png" />+ <link type="image/png" rel="apple-touch-icon" href="res/favicon57.png" />+ <link type="application/opensearchdescription+xml" rel="search" href="res/search.xml" title="Hoogle" />+ <script type="text/javascript" src="res/jquery-1.4.2.js"> </script>+ <script type="text/javascript" src="res/jquery.cookie.js"> </script>+ <script type="text/javascript" src="res/hoogle.js?version=$%js$"> </script>+ </head>+ <body>+<div id="links">+ <span id="instant" style="display:none;"><a href="javascript:setInstant()">+ Instant is <span id="instantVal">off</span></a> |</span>+ <span id="plugin" style="display:none;"><a href="javascript:searchPlugin()">Search plugin</a> |</span>+ <a href="http://www.haskell.org/haskellwiki/Hoogle">Manual</a> |+ $#homepage$+</div>+<form action="." method="get" id="search">+ <a id="logo" href="http://haskell.org/hoogle/">+ <img src="res/hoogle.png" width="160" height="58" alt="Hoogle"+ /></a>+ <input name="hoogle" id="hoogle" class="HOOGLE_REAL" type="text" autocomplete="off" accesskey="1" value="$&query$" />+ <input id="submit" type="submit" value="Search" />+</form>+<div id="body">+++#homepage+<a href="http://www.haskell.org/">haskell.org</a>+++#export footer version+ </div>+ <p id="footer">© <a href="http://community.haskell.org/~ndm/">Neil Mitchell</a> 2004-2011, version $&version$</p>+ </body>+</html>+++#search+<a href="?hoogle=$%query$">$&query$</a>+++#export welcome+<h1><b>Welcome to Hoogle</b></h1>+<ul id="left">+<li><b>Links</b></li>+<li><a href="http://haskell.org/">Haskell.org</a></li>+<li><a href="http://hackage.haskell.org/">Hackage</a></li>+<li><a href="http://www.haskell.org/ghc/docs/latest/html/users_guide/">GHC Manual</a></li>+<li><a href="http://www.haskell.org/ghc/docs/latest/html/libraries/">Libraries</a></li>+</ul>+<p>+ 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.+</p>+<p id="example">+ Example searches:<br/>+ $query=map$ $#search$<br/>+ $query=(a -> b) -> [a] -> [b]$ $#search$<br/>+ $query=Ord a => [a] -> [a]$ $#search$<br/>+ $query=Data.Map.insert$ $#search$<br/>+ <br/>Enter your own search at the top of the page.+</p>+<p>+ The <a href="http://www.haskell.org/haskellwiki/Hoogle">Hoogle manual</a> 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.+</p>+<p>+ I am very interested in any feedback you may have. Please+ <a href="http://community.haskell.org/~ndm/contact/">email me</a>, or add an entry to my+ <a href="http://code.google.com/p/ndmitchell/issues/list">bug tracker</a>.+</p>+++#export parseError+<h1>$!errFormat$</h1>+<p>+ <b>Parse error:</b> $&errMessage$+</p><p>+ For information on what queries should look like, see the+ <a href="http://www.haskell.org/haskellwiki/Hoogle">user manual</a>.+</p>
+ datadir/resources/template_example.html view
@@ -0,0 +1,11 @@++#homepage+<a href='http://www.example.com/'>example.com</a>+++#export welcome+<h1><b>Welcome to Hoogle</b></h1>+<p>+ This copy of Hoogle overrides a few example settings, to allow you to better integrate it+ in any local installations.+</p>
hoogle.cabal view
@@ -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
src/CmdLine/Type.hs view
@@ -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
− src/Data/Binary/Defer.hs
@@ -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
− src/Data/Binary/Defer/Array.hs
@@ -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
− src/Data/Binary/Defer/Class.hs
@@ -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
− src/Data/Binary/Defer/Index.hs
@@ -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
− src/Data/Binary/Defer/Monad.hs
@@ -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
− src/Data/Binary/Raw.hs
@@ -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-
src/General/Base.hs view
@@ -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
src/General/System.hs view
@@ -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)
src/General/Util.hs view
@@ -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
src/General/Web.hs view
@@ -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]
src/Hoogle.hs view
@@ -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.
src/Hoogle/DataBase/Aliases.hs view
@@ -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
src/Hoogle/DataBase/All.hs view
@@ -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)
src/Hoogle/DataBase/Instances.hs view
@@ -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
src/Hoogle/DataBase/Items.hs view
@@ -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
src/Hoogle/DataBase/Serialise.hs view
@@ -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
src/Hoogle/DataBase/SubstrSearch.hs view
@@ -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
src/Hoogle/DataBase/Suggest.hs view
@@ -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
src/Hoogle/DataBase/Type.hs view
@@ -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
src/Hoogle/DataBase/TypeSearch/All.hs view
@@ -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]
src/Hoogle/DataBase/TypeSearch/EntryInfo.hs view
@@ -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
src/Hoogle/DataBase/TypeSearch/Graph.hs view
@@ -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)
src/Hoogle/DataBase/TypeSearch/Graphs.hs view
@@ -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
src/Hoogle/DataBase/TypeSearch/Result.hs view
@@ -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
src/Hoogle/Language/Haskell.hs view
@@ -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 ---------------------------------------------------------------------
src/Hoogle/Query/Parser.hs view
@@ -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
src/Hoogle/Query/Render.hs view
@@ -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
src/Hoogle/Query/Type.hs view
@@ -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)
src/Hoogle/Search/All.hs view
@@ -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]
src/Hoogle/Search/Results.hs view
@@ -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
+ src/Hoogle/Store/All.hs view
@@ -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
+ src/Hoogle/Store/ReadBuffer.hs view
@@ -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
+ src/Hoogle/Store/Type.hs view
@@ -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
+ src/Hoogle/Store/WriteBuffer.hs view
@@ -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)
src/Hoogle/Type/All.hs view
@@ -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
+ src/Hoogle/Type/Docs.hs view
@@ -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
− src/Hoogle/Type/Documentation.hs
@@ -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
src/Hoogle/Type/Item.hs view
@@ -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
src/Hoogle/Type/Result.hs view
@@ -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
src/Hoogle/Type/TagStr.hs view
@@ -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.
src/Hoogle/Type/TypeSig.hs view
@@ -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
src/Recipe/Cabal.hs view
@@ -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]
src/Recipe/Download.hs view
@@ -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") ""
+ src/Recipe/Haddock.hs view
@@ -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) = ["<pre>"] ++ map escapeHTML xs ++ ["</pre>"]+ convert (Blk xs) = ["<pre>"] ++ map parseInline xs ++ ["</pre>"]+ convert (Li xs) = ["<ul>"] ++ ["<li>" ++ x ++ "</li>" | x <- map parseInline xs] ++ ["</ul>"]+ convert (Numb xs) = convert $ Li xs+ convert (Defn xs) = intersperse "" [parseInline a ++ ": " ++ parseInline b | (a,b) <- xs]+ convert (Para s) = [parseInline s]++ linewrap x | length x > 80 = (a ++ c) : linewrap (drop 1 d)+ where (a,b) = splitAt 60 x+ (c,d) = break (== ' ') b+ linewrap x = [x | x /= ""]+++parseInline :: String -> String+parseInline = concat . bits+ where+ tag x y = "<" ++ x ++ ">" ++ y ++ "</" ++ x ++ ">"++ table = [("@", "@", Just . tag "tt" . parseInline)+ ,("/", "/", Just . tag "i" . parseInline)+ ,("<", ">", check (not . any isSpace) (tag "a"))+ ,("\"","\"", check isModuleName (tag "a"))+ ,("\'","\'", check isQName (tag "a"))]++ check f g s = if f s then Just (g s) else Nothing+ sel1 (a,_,_) = a++ bits :: String -> [String]+ bits xs | (st,end,mk):_ <- filter (flip isPrefixOf xs . sel1) table+ , xs <- drop (length st) xs+ , Just (now,next) <- close "" end xs+ , Just r <- mk (reverse now)+ = r : bits next+ bits ('\\':x:xs) = escapeHTML [x] : bits xs+ bits (x:xs) = escapeHTML [x] : bits xs+ bits [] = []++ close acc end xs | end `isPrefixOf` xs = Just (acc, drop (length end) xs)+ close acc end ('\\':x:xs) = close (x:'\\':acc) end xs+ close acc end (x:xs) = close (x:acc) end xs+ close acc end "" = Nothing+++isModuleName :: String -> Bool+isModuleName = all ok . splitModuleString+ where+ ok s | [(R.Ident (y:ys), "")] <- R.readPrec_to_S R.lexP 0 s = isUpper y+ ok _ = False++splitModuleString :: String -> [String]+splitModuleString = wordsBy (== '.')++wordsBy :: (a -> Bool) -> [a] -> [[a]]+wordsBy f xs = case dropWhile f xs of+ [] -> []+ ys -> w : wordsBy f zs+ where (w, zs) = break f ys++isQName :: String -> Bool+isQName xs = case R.readPrec_to_S R.lexP 0 xs of+ [(R.Ident (y:ys), '.':zs)] | isUpper y -> isQName zs+ [(R.Ident ys, "")] -> True+ [(R.Symbol ys, "")] -> True+ _ -> False
src/Test/All.hs view
@@ -3,9 +3,11 @@ import Test.Parse_TypeSig import Test.Parse_Query+import Test.Docs test :: IO () test = print $ do parse_TypeSig parse_Query+ docs
+ src/Test/Docs.hs view
@@ -0,0 +1,12 @@++module Test.Docs(docs) where++import Test.General+import Hoogle.Type.TagStr+import Hoogle.Type.Docs+++docs = do+ let a === b = if renderDocs (readDocsHTML a) == b then pass else error $ "differences in docs " ++ show (renderDocs (readDocsHTML a))+ "foo" === Str "foo"+ "foo <i>bar</i> baz" === Tags [Str "foo ", TagEmph (Str "bar"), Str " baz"]
src/Test/Parse_Query.hs view
@@ -23,10 +23,10 @@ "a -> b" === q{typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} "(a b)" === q{typeSig = Just (TypeSig [] (TApp (TVar "a") [TVar "b"]))} "map :: a -> b" === q{names = ["map"], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))}- "+Data.Map map" === q{scope = [PlusModule ["Data","Map"]], names = ["map"]}+ "+Data.Map map" === q{scope = [PlusModule "Data.Map"], names = ["map"]} "a -> b +foo" === q{scope = [PlusPackage "foo"], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} "a -> b +foo-bar" === q{scope = [PlusPackage "foo-bar"], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))}- "Data.Map.map" === q{scope = [PlusModule ["Data","Map"]], names = ["map"]}+ "Data.Map.map" === q{scope = [PlusModule "Data.Map"], names = ["map"]} "[a]" === q{typeSig = Just (TypeSig [] (TApp (TLit "[]") [TVar "a"]))} "++" === q{names = ["++"]} "(++)" === q{names = ["++"]}
src/Web/All.hs view
@@ -9,6 +9,4 @@ action :: CmdLine -> IO () action q@Server{} = server q---- FIXME: Should use datadir, but not sure how-action q = cgiResponse =<< response "datadir/resources" q+action q = cgiResponse =<< response responseArgs q
src/Web/Page.hs view
@@ -1,90 +1,54 @@--module Web.Page(searchLink, header, footer, welcome) where--import General.Web-import General.Util-import qualified Paths_hoogle(version)-import Data.Version(showVersion)---version = showVersion Paths_hoogle.version---searchLink :: String -> URL-searchLink x = "?hoogle=" ++% x---header resources query =- ["<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"- ,"<html xmlns='http://www.w3.org/1999/xhtml' xml:lang='en' lang='en'>"- ," <head profile='http://a9.com/-/spec/opensearch/1.1/'>"- ," <meta http-equiv='Content-Type' content='text/html; charset=iso-8859-1' />"- ," <title>" ++ (query ++? " - ") ++ "Hoogle</title>"- ," <link type='text/css' rel='stylesheet' href='" ++ resources ++ "/hoogle.css?version=" ++% version ++ "' />"- ," <link type='image/png' rel='icon' href='" ++ resources ++ "/favicon.png' />"- ," <link type='application/opensearchdescription+xml' rel='search' href='" ++ resources ++ "/search.xml' title='Hoogle' />"- ," <script type='text/javascript' src='" ++ resources ++ "/jquery-1.4.2.js'> </script>"- ," <script type='text/javascript' src='" ++ resources ++ "/jquery.cookie.js'> </script>"- ," <script type='text/javascript' src='" ++ resources ++ "/hoogle.js?version=" ++% version ++ "'> </script>"- ," </head>"- ," <body>"- ] ++ links ++ search resources query ++- ["<div id='body'>"]+module Web.Page(Templates(..), defaultTemplates, loadTemplates) where+import Web.Template +data Templates = Templates+ {header :: String -> String -> String -> String -> String+ ,footer :: String -> String+ ,welcome :: String+ ,parseError :: String -> String -> String+ } -links =- ["<div id='links'>"- ," <span id='instant' style='display:none;'><a href='javascript:setInstant()'>" ++- "Instant is <span id='instantVal'>off</span></a> |</span>"- ," <span id='plugin' style='display:none;'><a href='javascript:searchPlugin()'>Search plugin</a> |</span>"- ," <a href='http://www.haskell.org/haskellwiki/Hoogle'>Manual</a> |"- ," <a href='http://www.haskell.org/'>haskell.org</a>"- ,"</div>"- ]+defaultTemplates :: Templates+defaultTemplates = Templates _header _footer _welcome _parseError -search resources query =- ["<form action='.' method='get' id='search'>"- ," <a id='logo' href='http://haskell.org/hoogle/'>" ++- "<img src='" ++ resources ++ "/hoogle.png' width='160' height='58' alt='Hoogle' />" ++- "</a>"- ," <input name='hoogle' id='hoogle' class='HOOGLE_REAL' type='text' autocomplete='off' value=\"" ++ query ++ "\" />"- ," <input id='submit' type='submit' value='Search' />"- ,"</form>"- ]+loadTemplates :: String -> Templates+loadTemplates x = Templates _header _footer _welcome _parseError+ where+ [__header,__footer,__welcome,__parseError] = reload x $+ ("header",["css","js","query","queryHyphen"]) :+ ("footer",["version"]) :+ ("welcome",[]) :+ ("parseError",["errFormat","errMessage"]) :+ []+ _header css js query queryHyphen = __header [css,js,query,queryHyphen]+ _footer version = __footer [version]+ _welcome = __welcome []+ _parseError errFormat errMessage = __parseError [errFormat,errMessage] +_header css js query queryHyphen = ""+ ++ "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">\n <head profile=\"http://a9.com/-/spec/opensearch/1.1/\">\n <meta http-equiv=\"Content-Type\" content=\"text/html; charset=iso-8859-1\" />\n <title>"+ ++ escapeHTML query+ ++ " "+ ++ escapeHTML queryHyphen+ ++ " Hoogle</title>\n <link type=\"text/css\" rel=\"stylesheet\" href=\"res/hoogle.css?version="+ ++ escapeURL css+ ++ "\" />\n <link type=\"image/png\" rel=\"icon\" href=\"res/favicon.png\" />\n <link type=\"application/opensearchdescription+xml\" rel=\"search\" href=\"res/search.xml\" title=\"Hoogle\" />\n <script type=\"text/javascript\" src=\"res/jquery-1.4.2.js\"> </script>\n <script type=\"text/javascript\" src=\"res/jquery.cookie.js\"> </script>\n <script type=\"text/javascript\" src=\"res/hoogle.js?version="+ ++ escapeURL js+ ++ "\"> </script>\n </head>\n <body>\n<div id=\"links\">\n <span id=\"instant\" style=\"display:none;\"><a href=\"javascript:setInstant()\">\n Instant is <span id=\"instantVal\">off</span></a> |</span>\n <span id=\"plugin\" style=\"display:none;\"><a href=\"javascript:searchPlugin()\">Search plugin</a> |</span>\n <a href=\"http://www.haskell.org/haskellwiki/Hoogle\">Manual</a> |\n <a href=\"http://www.haskell.org/\">haskell.org</a>\n\n</div>\n<form action=\".\" method=\"get\" id=\"search\">\n <a id=\"logo\" href=\"http://haskell.org/hoogle/\">\n <img src=\"res/hoogle.png\" width=\"160\" height=\"58\" alt=\"Hoogle\"\n /></a>\n <input name=\"hoogle\" id=\"hoogle\" class=\"HOOGLE_REAL\" type=\"text\" autocomplete=\"off\" accesskey=\"1\" value=\""+ ++ escapeHTML query+ ++ "\" />\n <input id=\"submit\" type=\"submit\" value=\"Search\" />\n</form>\n<div id=\"body\">\n" -footer =- ["</div>"- ," <p id='footer'>© <a href='http://community.haskell.org/~ndm/'>Neil Mitchell</a> 2004-2011, version " ++& version ++ "</p>"- ," </body>"- ,"</html>"- ]+_footer version = ""+ ++ " </div>\n <p id=\"footer\">© <a href=\"http://community.haskell.org/~ndm/\">Neil Mitchell</a> 2004-2011, version "+ ++ escapeHTML version+ ++ "</p>\n </body>\n</html>\n" +_welcome = ""+ ++ "<h1><b>Welcome to Hoogle</b></h1>\n<ul id=\"left\">\n<li><b>Links</b></li>\n<li><a href=\"http://haskell.org/\">Haskell.org</a></li>\n<li><a href=\"http://hackage.haskell.org/\">Hackage</a></li>\n<li><a href=\"http://www.haskell.org/ghc/docs/latest/html/users_guide/\">GHC Manual</a></li>\n<li><a href=\"http://www.haskell.org/ghc/docs/latest/html/libraries/\">Libraries</a></li>\n</ul>\n<p>\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</p>\n<p id=\"example\">\n Example searches:<br/>\n <a href=\"?hoogle=map\">map</a>\n<br/>\n <a href=\"?hoogle=%28a+-%3e+b%29+-%3e+%5ba%5d+-%3e+%5bb%5d\">(a -> b) -> [a] -> [b]</a>\n<br/>\n <a href=\"?hoogle=Ord+a+%3d%3e+%5ba%5d+-%3e+%5ba%5d\">Ord a => [a] -> [a]</a>\n<br/>\n <a href=\"?hoogle=Data%2eMap%2einsert\">Data.Map.insert</a>\n<br/>\n\t<br/>Enter your own search at the top of the page.\n</p>\n<p>\n The <a href=\"http://www.haskell.org/haskellwiki/Hoogle\">Hoogle manual</a> 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</p>\n<p>\n I am very interested in any feedback you may have. Please\n <a href=\"http://community.haskell.org/~ndm/contact/\">email me</a>, or add an entry to my\n <a href=\"http://code.google.com/p/ndmitchell/issues/list\">bug tracker</a>.\n</p>\n" -welcome =- ["<h1><b>Welcome to Hoogle</b></h1>"- ,"<p>"- ," 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."- ,"</p>"- ,"<p id='example'>"- ," Example searches:<br/>"- ," " ++ search "map"- ," " ++ search "(a -> b) -> [a] -> [b]"- ," " ++ search "Ord a => [a] -> [a]"- ," " ++ search "Data.Map.insert"- ," <br/>Enter your own search at the top of the page."- ,"</p>"- ,"<p>"- ," The <a href='http://www.haskell.org/haskellwiki/Hoogle'>Hoogle manual</a> 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."- ,"</p>"- ,"<p>"- ," I am very interested in any feedback you may have. Please "- ," <a href='http://community.haskell.org/~ndm/contact/'>email me</a>, or add an entry to my"- ," <a href='http://code.google.com/p/ndmitchell/issues/list'>bug tracker</a>."- ,"</p>"- ]- where- search x = "<a href='" ++ searchLink x ++ "'>" ++& x ++ "</a><br/>"+_parseError errFormat errMessage = ""+ ++ "<h1>"+ ++ errFormat+ ++ "</h1>\n<p>\n\t<b>Parse error:</b> "+ ++ escapeHTML errMessage+ ++ "\n</p><p>\n\tFor information on what queries should look like, see the\n\t<a href=\"http://www.haskell.org/haskellwiki/Hoogle\">user manual</a>.\n</p>\n"
src/Web/Response.hs view
@@ -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} = ["<i>Parse error: " ++& errorMessage err ++ "</i>"]+runEmbed :: Database -> CmdLine -> String+runEmbed dbs Search{queryParsed = Left err} = "<i>Parse error: " ++& errorMessage err ++ "</i>" runEmbed dbs cq@Search{queryParsed = Right q}- | null now = ["<i>No results found</i>"]- | otherwise =+ | null now = "<i>No results found</i>"+ | otherwise = unlines ["<a href='" ++ url ++ "'>" ++ showTagHTML (transform f $ self $ snd x) ++ "</a>" | 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} =- ["<h1>" ++ showTagHTMLWith f (parseInput err) ++ "</h1>"- ,"<p>"- ," <b>Parse error:</b> " ++& errorMessage err- ,"</p><p>"- ," For information on what queries should look like, see the"- ," <a href='http://www.haskell.org/haskellwiki/Hoogle'>user manual</a>."- ,"</p>"- ]+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 $ "<span class='error'>" ++ showTagHTMLWith f x ++ "</span>" 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 ["<h1>" ++ qstr ++ "</h1>"] ++- ["<div id='left'>" ++ also ++ "</div>" | not $ null pkgs] +++ ["<ul id='left'><li><b>Packages</b></li>" ++ also ++ "</ul>" | not $ null pkgs] ++ ["<p>" ++ showTag sug ++ "</p>" | Just sug <- [suggestions dbs q]] ++ if null res then ["<p>No results found</p>"]@@ -115,7 +120,7 @@ (pre,res2) = splitAt start2 res (now,post) = splitAt count2 res2 - also = "<ul><li><b>Packages</b></li>" ++ concatMap f (take (5 + length minus) $ nub $ minus ++ pkgs) ++ "</ul>"+ also = concatMap f (take (5 + length minus) $ nub $ minus ++ pkgs) where minus = [x | (False,x) <- queryPackages q] f x | (True,lx) `elem` queryPackages q = let q2 = showTagText $ renderQuery $ querySetPackage Nothing lx q in@@ -139,17 +144,13 @@ ["<a name='more'></a>" | more] ++ ["<div class='ans'>" ++ href selfUrl (showTagHTMLWith url self) ++ "</div>"] ++ ["<div class='from'>" ++ intercalate ", " [unwords $ zipWith (f u) [1..] ps | (u,ps) <- locations] ++ "</div>" | not $ null locations] ++- ["<div class='doc'>" ++ docs2 ++ "</div>" | showTagText docs /= ""]+ ["<div class='doc " ++ (if '\n' `elem` s then " newline" else "") ++ "'><span>" ++ showTag docs ++ "</span></div>"+ | let s = showTagText docs, s /= ""] where selfUrl = head $ map fst locations ++ [""] f u cls (url,text) = "<a class='p" ++ show cls ++ "' href='" ++ url2 ++ "'>" ++ text ++ "</a>" where url2 = if url == takeWhile (/= '#') u then u else url - docs2 = ("<div id='d" ++ show i ++ "' class='shut'>" ++- "<a class='docs' onclick='return docs(" ++ show i ++ ")' href='" ++& selfUrl ++ "'></a>") ++?- showTag docs ++?- "</div>"- url (TagBold x) | null selfUrl = Just $ "<span class='a'>" ++ showTagHTML (transform g x) ++ "</span>" | otherwise = Just $ "</a><a class='a' href='" ++& selfUrl ++ "'>" ++ showTagHTML (transform g x) ++@@ -165,6 +166,10 @@ showTag :: TagStr -> String showTag = showTagHTML . transform f where- f (TagLink "" x) = TagLink (if "http:" `isPrefixOf` str then str else searchLink str) x+ f (TagLink "" x) = TagLink (if any (`isPrefixOf` str) ["http:","https:"] then str else searchLink str) x where str = showTagText x f x = x+++searchLink :: String -> URL+searchLink x = "?hoogle=" ++% x
src/Web/Server.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards, ScopedTypeVariables, PatternGuards #-} module Web.Server(server) where @@ -6,9 +6,15 @@ import General.Web import CmdLine.All import Web.Response+import Network.HTTP.Types+import Web.Page+import System.IO.Unsafe(unsafeInterleaveIO) import Control.Monad.IO.Class import General.System import Control.Concurrent+import Control.Exception+import System.Time+import Data.Time.Clock import Network.Wai import Network.Wai.Handler.Warp@@ -18,20 +24,70 @@ server :: CmdLine -> IO () server q@Server{..} = do+ resp <- respArgs q v <- newMVar () putStrLn $ "Starting Hoogle Server on port " ++ show port- run port $ \r -> liftIO $ do- withMVar v $ const $ putStrLn $ bsUnpack (pathInfo r) ++ bsUnpack (queryString r)- talk q r+ runSettings defaultSettings{settingsOnException=exception, settingsPort=port} $ \r -> liftIO $ do+ start <- getCurrentTime+ res <- talk resp q r+ responseEvaluate res+ stop <- getCurrentTime+ let t = floor $ diffUTCTime stop start * 1000+ withMVar v $ const $ putStrLn $ bsUnpack (rawPathInfo r) ++ bsUnpack (rawQueryString r) ++ " ms:" ++ show t+ talk resp q r +exception :: SomeException -> IO ()+exception e | Just (_ :: InvalidRequest) <- fromException e = return ()+ | otherwise = putStrLn $ "Error: " ++ show e+++respArgs :: CmdLine -> IO (IO ResponseArgs)+respArgs Server{..} = do+ t <- getTemplate+ if dynamic+ then return $ args t+ else do x <- args t; return $ return x+ where+ getTemplate+ | null template = return $ return defaultTemplates+ | otherwise = do+ let get = do x <- fmap (loadTemplates . unlines) $ mapM readFile' template+ putStrLn "Templates loaded"+ return x+ if dynamic then buffer template get else return get++ modTime ext = unsafeInterleaveIO $ do+ TOD a _ <- getModificationTime $ resources </> "hoogle" <.> ext+ return $ show a++ args t = do+ css <- modTime "css"; js <- modTime "js"+ t <- t+ return $ responseArgs{updatedCss=css, updatedJs=js, templates=t}+++-- | Given a set of paths something relies on, and a value to generate it, return something that generates it minimally+buffer :: [FilePath] -> IO a -> IO (IO a)+buffer files act = do+ val <- act+ ts <- mapM getModificationTime files+ ref <- newMVar (ts,val)+ return $ modifyMVar ref $ \(ts,val) -> do+ ts2 <- mapM getModificationTime files+ if ts == ts2 then return ((ts,val),val) else do+ val <- act+ return ((ts2,val),val)++ -- FIXME: Avoid all the conversions to/from LBS-talk :: CmdLine -> Request -> IO Response-talk Server{..} Request{pathInfo=path_, queryString=query_}+talk :: IO ResponseArgs -> CmdLine -> Request -> IO Response+talk resp Server{..} Request{rawPathInfo=path_, rawQueryString=query_} | path `elem` ["/","/hoogle"] = do let args = parseHttpQueryArgs $ drop 1 query cmd <- cmdLineWeb args- r <- response "/res" cmd{databases=databases}+ resp <- resp+ r <- response resp cmd{databases=databases} if local_ then rewriteFileLinks r else return r | takeDirectory path == "/res" = serveFile True $ resources </> takeFileName path | local_ && "/file/" `isPrefixOf` path = serveFile False $ drop 6 path@@ -44,9 +100,9 @@ b <- doesFileExist file return $ if not b then responseNotFound file- else ResponseFile statusOK hdr file- where hdr = [(hdrContentType, fromString $ contentExt $ takeExtension file)] ++- [(hdrCacheControl, fromString "max-age=604800" {- 1 week -}) | cache]+ else ResponseFile statusOK hdr file Nothing+ where hdr = [headerContentType $ fromString $ contentExt $ takeExtension file] +++ [headerCacheControl $ fromString "max-age=604800" {- 1 week -} | cache] rewriteFileLinks :: Response -> IO Response
+ src/Web/Template.hs view
@@ -0,0 +1,170 @@+{-# LANGUAGE PatternGuards, RecordWildCards #-}++module Web.Template(+ main,+ escapeURL, escapeHTML,+ reload+ ) where++import General.Base+import General.System+import General.Web+++main :: IO ()+main = do+ [from,to,modname] <- getArgs+ src <- readFile from+ writeFileBinary to $ generate modname $ resolve $ parse src+++---------------------------------------------------------------------+-- TYPE++data Template = Template+ {templateName :: String+ ,templateArgs :: [String]+ ,templateExport :: Bool+ ,templateContents :: [Fragment]+ }++data Fragment+ = Out String -- ^ Output some text+ | Att Esc String -- ^ Output an attribute (and how to escape it)+ | Set String String -- ^ Set an attribute to a value+ | Call String -- ^ Call another template++data Esc = EscNone | EscHtml | EscUrl deriving Eq++escapeStr e = case e of EscHtml -> "escapeHTML "; EscUrl -> "escapeURL "; _ -> ""+escape e = case e of EscHtml -> escapeHTML; EscUrl -> escapeURL; _ -> id+++joinOut (Out x:Out y:zs) = joinOut $ Out (x++y) : zs+joinOut (x:xs) = x : joinOut xs+joinOut [] = []+++getTemplate :: [Template] -> String -> Template+getTemplate ts x = case find ((==) x . templateName) ts of+ Nothing -> error $ "Could not find template " ++ x+ Just y -> y+++---------------------------------------------------------------------+-- OUTPUT++-- Given a set of templates/args you need available, and a piece of sour+reload+ :: String -- ^ The source code+ -> [(String,[String])] -- ^ A set of templates/args you need avaialble+ -> [[String] -> String] -- ^ A list of functions which match the templates/args+reload src want = map f want+ where+ ts = resolve $ parse src++ f (name,args)+ | templateArgs t /= args = error $+ "Arguments for template " ++ name ++ " differ, expected " ++ show args ++ ", got " ++ show (templateArgs t)+ | otherwise = reloadTemplate t+ where t = getTemplate ts name+++reloadTemplate :: Template -> ([String] -> String)+reloadTemplate t as = concatMap f $ templateContents t+ where+ atts = zip (templateArgs t) as+ f (Out x) = x+ f (Att e x) = escape e $ fromJust $ lookup x atts+++---------------------------------------------------------------------+-- OUTPUT++generate :: String -> [Template] -> String+generate name xs = unlines $+ ["module " ++ name ++ "(Templates(..), defaultTemplates, loadTemplates) where"+ ,"import Web.Template"+ ,""+ ,"data Templates = Templates"] +++ zipWith (++) (" {":repeat " ,")+ [templateName t ++ " :: " ++ intercalate " -> " (replicate (length (templateArgs t) + 1) "String") | t <- ts] +++ [" }"+ ,""+ ,"defaultTemplates :: Templates"+ ,"defaultTemplates = Templates" ++ concatMap ((++) " _" . templateName) ts+ ,""+ ,"loadTemplates :: String -> Templates"+ ,"loadTemplates x = Templates" ++ concatMap ((++) " _" . templateName) ts+ ," where"+ ," [" ++ intercalate "," (map ((++) "__" . templateName) ts) ++ "] = reload x $"] +++ [" " ++ show (templateName t, templateArgs t) ++ " :" | t <- ts] +++ [" []"] +++ [" _" ++ unwords (templateName t:templateArgs t) +++ " = __" ++ templateName t ++ " [" ++ intercalate "," (templateArgs t) ++ "]" | t <- ts] +++ concatMap generateTemplate ts+ where+ ts = nubBy ((==) `on` templateName) $ filter templateExport xs++generateTemplate :: Template -> [String]+generateTemplate Template{..} = "" :+ (unwords (('_':templateName) : templateArgs) ++ " = \"\"") :+ map ((++) " " . f) templateContents+ where+ f (Out x) = "++ " ++ show x+ f (Att e x) = "++ " ++ escapeStr e ++ x+++---------------------------------------------------------------------+-- RESOLVE++-- | Eliminate Set and Call, fill in the template arguments+resolve :: [Template] -> [Template]+resolve xs = map (resolveFree . resolveSet . resolveCall xs) xs++resolveFree t = t{templateArgs=args}+ where seen = nub [x | Att _ x <- templateContents t]+ args = nub $ filter (`elem` seen) (templateArgs t) ++ seen++resolveSet t = t{templateContents = joinOut $ f [] $ templateContents t}+ where+ f seen (Set x y:xs) = f ((x,y):seen) xs+ f seen (Att e y:xs) | Just v <- lookup y seen = Out (escape e v) : f seen xs+ f seen (x:xs) = x : f seen xs+ f seen [] = []++resolveCall args t = t{templateContents = concatMap f $ templateContents t}+ where+ f (Call x) = concatMap f $ templateContents $ getTemplate args x+ f x = [x]+++---------------------------------------------------------------------+-- PARSING++parse :: String -> [Template]+parse = f . dropWhile (not . isPrefixOf "#") . filter (not . all isSpace) . lines+ where+ f (x:xs) = Template name args exp (parseTemplate $ unlines a) : f b+ where (a,b) = break ("#" `isPrefixOf`) xs+ ys = words $ dropWhile (== '#') x+ exp = ["export"] `isPrefixOf` ys+ name:args = if exp then tail ys else ys+ f [] = []+++parseTemplate :: String -> [Fragment]+parseTemplate = f + where+ f [] = []+ f ('$':xs) = g a : f (drop 1 b)+ where (a,b) = break (== '$') xs+ f xs = Out a : f b+ where (a,b) = break (== '$') xs++ g ('!':xs) = Att EscNone xs+ g ('&':xs) = Att EscHtml xs+ g ('%':xs) = Att EscUrl xs+ g ('#':xs) = Call xs+ g xs | (a,'=':b) <- break (== '=') xs = Set a b+ g x = error $ "Templating error, perhaps you forgot the escape format? $" ++ x ++ "$"