hoogle 4.2.16 → 4.2.17
raw patch · 40 files changed
+596/−167 lines, 40 filesdep +HUnitdep +aesondep +deepseqdep ~basedep ~bytestringdep ~conduit
Dependencies added: HUnit, aeson, deepseq, hoogle, hspec, hspec-expectations, system-fileio, text
Dependency ranges changed: base, bytestring, conduit, haskell-src-exts, wai
Files
- datadir/resources/hoogle.css +76/−13
- datadir/resources/template.html +10/−6
- docs/LICENSE +1/−1
- hoogle.cabal +44/−7
- src/CmdLine/All.hs +11/−1
- src/CmdLine/Type.hs +3/−1
- src/Console/Log.hs +1/−1
- src/General/Base.hs +1/−0
- src/Hoogle.hs +10/−2
- src/Hoogle/DataBase/Aliases.hs +6/−0
- src/Hoogle/DataBase/All.hs +6/−0
- src/Hoogle/DataBase/Instances.hs +3/−0
- src/Hoogle/DataBase/Items.hs +4/−1
- src/Hoogle/DataBase/SubstrSearch.hs +65/−11
- src/Hoogle/DataBase/Suggest.hs +6/−0
- src/Hoogle/DataBase/Type.hs +2/−0
- src/Hoogle/DataBase/TypeSearch/All.hs +4/−0
- src/Hoogle/DataBase/TypeSearch/EntryInfo.hs +4/−1
- src/Hoogle/DataBase/TypeSearch/Graph.hs +6/−0
- src/Hoogle/DataBase/TypeSearch/Graphs.hs +3/−0
- src/Hoogle/Language/Haskell.hs +12/−8
- src/Hoogle/Query/Parser.hs +13/−8
- src/Hoogle/Query/Type.hs +11/−4
- src/Hoogle/Score/All.hs +1/−1
- src/Hoogle/Score/Type.hs +11/−8
- src/Hoogle/Search/All.hs +14/−10
- src/Hoogle/Search/Results.hs +13/−11
- src/Hoogle/Store/All.hs +18/−4
- src/Hoogle/Store/Type.hs +3/−0
- src/Hoogle/Type/Docs.hs +2/−1
- src/Hoogle/Type/Item.hs +64/−4
- src/Hoogle/Type/Result.hs +1/−1
- src/Hoogle/Type/TagStr.hs +7/−0
- src/Hoogle/Type/TypeSig.hs +9/−2
- src/Recipe/Download.hs +57/−42
- src/Recipe/Keyword.hs +1/−1
- src/Web/Page.hs +4/−3
- src/Web/Response.hs +24/−13
- src/Web/Template.hs +2/−1
- test/HoogleSpec.hs +63/−0
datadir/resources/hoogle.css view
@@ -2,11 +2,17 @@ * GENERAL ELEMENTS */ +html {+ height: 100%;+}+ body { margin: 0px; padding: 0px; font-family: sans-serif; font-size: 13px;+ position: relative;+ min-height: 100%; } a img {@@ -19,16 +25,56 @@ background-color: #ffb; } +a {+ color: #C4451D;+ text-decoration: none;+}++.push {+ height: 4em;+}+ /******************************************************************** * TOP - LINKS AND SEARCH */ #links {- float: right;- margin-right: 10px;- margin-top: 5px;+ position: relative;+ background: none repeat scroll 0 0 #293845;+ border-top: 5px solid #4E6272;+ color: #DDDDDD;+ text-align: right;+ padding: 0.2em; } +#top-menu {+ display: inline-table;+ list-style: none outside none;+ margin: 0 0 0 1em;+ text-align: left;+}++#top-menu li {+ border-left: 1px solid #D5D5D5;+ display: inline;+ padding: 0;+ white-space: nowrap;+}++#top-menu li a,+#top-menu li a:link, +#top-menu li a:visited {+ font-size: 85%;+ color: white;+ text-decoration: none;+ padding: 0.2em 0.5em;+}++#top-menu li a:hover {+ background-color: #4e6272;+ text-decoration: underline;+}+ form { margin-bottom: 0px; }@@ -64,7 +110,6 @@ width: 140px; margin: 0px; padding: 0px;- margin-top: 7px; margin-left: 10px; } @@ -76,7 +121,7 @@ } #left a {- color: #0E7700;+ color: #C4451D; text-decoration: none; background-repeat: no-repeat; }@@ -85,6 +130,7 @@ padding-right: 16px; background-image: url(more_small.png); background-position: center right;+ color: #0E774A; } #left .pad {@@ -104,6 +150,13 @@ */ #footer {+ background: none repeat scroll 0 0 #DDDDDD;+ border-top: 1px solid #AAAAAA;+ color: #666666;+ width: 100%;+ padding: 1.3em 0;+ position: absolute;+ bottom: 0; text-align: center; } @@ -116,10 +169,6 @@ padding: 5px; margin-top: 0px; font-weight: normal;- /* background for the heading must be gray,- to make type searching visisble */- background-color: #e4e4e4;- border-top: 1px solid #999; padding-left: 170px; font-size: 16px; }@@ -148,7 +197,8 @@ padding: 3px; width: 400px; border: 2px solid #cc0;- background-color: #ffc;+ background-color: #F5F5F5;+ border: 1px solid #E5E5E5; text-align: left; } @@ -166,8 +216,11 @@ margin-right: 20px; } +.from, .doc {+ margin-top: 0.4em;+}+ a.dull, a.dull:hover {- background-color: white; text-decoration: none; } @@ -179,12 +232,22 @@ } .ans {+ background: none repeat scroll 0 0 #F0F0F0;+ border-top: 1px solid #CCCCCC; font-size: 16px;- margin-top: 15px;+ padding: 0.2em 0.5em; } +.from + .ans {+ margin-top: 1.5em;+}++.doc + .ans {+ margin-top: 1.5em;+}+ .ans .a {- color: #2200C1;+ color: #C4451D; } .ans a.dull {
datadir/resources/template.html view
@@ -15,11 +15,14 @@ </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="https://github.com/ndmitchell/hoogle/blob/master/README.md">Manual</a> |- $#homepage$+ <ul id="top-menu">+ <li id="instant" style="display:none;">+ <a href="javascript:setInstant()">Instant is <span id="instantVal">off</span></a>+ </li>+ <li id="plugin" style="display:none;"><a href="javascript:searchPlugin()">Search plugin</a></li>+ <li><a href="https://github.com/ndmitchell/hoogle/blob/master/README.md">Manual</a></li>+ <li>$#homepage$</li>+ </ul> </div> <form action="." method="get" id="search"> <a id="logo" href="http://haskell.org/hoogle/">@@ -36,8 +39,9 @@ #export footer version+ <div class="push"></div> </div>- <p id="footer">© <a href="http://community.haskell.org/~ndm/">Neil Mitchell</a> 2004-2012, version $&version$</p>+ <div id="footer">© <a href="http://community.haskell.org/~ndm/">Neil Mitchell</a> 2004-2013, version $&version$</div> </body> </html>
docs/LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2004-2012.+Copyright Neil Mitchell 2004-2013. All rights reserved. Redistribution and use in source and binary forms, with or without
hoogle.cabal view
@@ -1,7 +1,7 @@-cabal-version: >= 1.6+cabal-version: >= 1.10 build-type: Simple name: hoogle-version: 4.2.16+version: 4.2.17 license: BSD3 license-file: docs/LICENSE category: Development@@ -32,16 +32,26 @@ location: http://code.haskell.org/hoogle/ library- hs-source-dirs: src+ hs-source-dirs: src+ default-language: Haskell98+ build-depends: base > 4 && < 5,- array, bytestring, containers, directory, filepath, process, random,+ array, containers, directory, filepath, process, random, safe, binary,+ bytestring >= 0.10,+ conduit >= 0.2, parsec >= 2.1,+ deepseq >= 1.1,+ text >= 0.11, transformers >= 0.2, uniplate >= 1.6,- haskell-src-exts >= 1.12 && < 1.14+ blaze-builder >= 0.2,+ case-insensitive >= 0.2,+ http-types >= 0.7,+ wai >= 1.1,+ haskell-src-exts >= 1.14 && < 1.15 if !os(mingw32) build-depends: unix@@ -103,18 +113,29 @@ executable hoogle main-is: Main.hs hs-source-dirs: src+ default-language: Haskell98 build-depends:- time, old-time, old-locale,+ base > 4 && < 5,+ hoogle, bytestring, filepath, unix, directory, process, random,+ array, containers, time, old-time, old-locale,+ safe,+ aeson >= 0.6.1, cmdargs >= 0.7,+ deepseq >= 1.1, tagsoup >= 0.11, blaze-builder >= 0.2, http-types >= 0.7, case-insensitive >= 0.2,+ text >= 0.11,+ transformers >= 0.2,+ uniplate >= 1.6, conduit >= 0.2,+ parsec >= 2.1, wai >= 1.1, warp >= 1.1,- Cabal >= 1.8+ Cabal >= 1.8,+ haskell-src-exts >= 1.12 && < 1.14 other-modules: CmdLine.All@@ -144,3 +165,19 @@ Web.Response Web.Server Web.Template++test-suite hoogle-test+ main-is: HoogleSpec.hs+ hs-source-dirs: test+ default-language: Haskell98++ type: exitcode-stdio-1.0+ build-depends:+ base >=3,+ hoogle,+ conduit >= 0.2,+ system-fileio >= 0.3.11,+ transformers >= 0.2,+ HUnit >= 1.2.5,+ hspec >= 1.4.4,+ hspec-expectations >= 0.3
src/CmdLine/All.hs view
@@ -23,6 +23,7 @@ import General.Web import System.Console.CmdArgs import Hoogle+import Hoogle.Query.Type import GHC.Conc(numCapabilities) import Paths_hoogle import Safe@@ -34,7 +35,15 @@ cmdLineExpand :: CmdLine -> IO CmdLine cmdLineExpand x@Search{} = do db <- expandDatabases $ databases x- return $ x{queryText = s, queryParsed = parseQuery Haskell s, databases = db}+ return $ x { queryText = s+ , queryParsed =+ (\q -> q { exactSearch =+ if exact x+ then Just UnclassifiedItem+ else Nothing })+ `fmap` parseQuery Haskell s+ , databases = db+ } where s = unwords $ queryChunks x @@ -97,6 +106,7 @@ cmdLineWeb args = cmdLineExpand $ blankSearch {web=Just $ fromMaybe "web" $ ask ["mode"] ,start=askInt ["start"], count=askInt ["count"]+ ,exact=fromMaybe 0 (askInt ["exact"]) == 1 ,queryChunks = mapMaybe ask [["prefix"],["q","hoogle"],["suffix"]]} where ask x = listToMaybe [b | (a,b) <- args, a `elem` x] askInt x = readMay =<< ask x
src/CmdLine/Type.hs view
@@ -21,6 +21,7 @@ {color :: Bool ,link :: Bool ,info :: Bool+ ,exact :: Bool ,databases :: [FilePath] ,start :: Maybe Int ,count :: Maybe Int@@ -42,7 +43,7 @@ deriving (Data,Typeable,Show) emptyParseError = ParseError 0 0 "" $ Str ""-blankSearch = Search False False False [] Nothing Nothing Nothing 1 [] (Left emptyParseError) ""+blankSearch = Search False False False False [] Nothing Nothing Nothing 1 [] (Left emptyParseError) "" cmdLineMode = cmdArgsMode $ modes [search_ &= auto,data_,server,combine,convert,test,dump,rank,log_] &= verbosity &= program "hoogle"@@ -54,6 +55,7 @@ ,count = def &= name "n" &= help "Maximum number of results to return" ,queryChunks = def &= args &= typ "QUERY" ,info = def &= help "Give extended information about the first result"+ ,exact = def &= help "Match names exactly when searching" ,link = def &= help "Give URL's for each result" ,color = def &= name "colour" &= help "Use colored output (requires ANSI terminal)" ,databases = ["."] &= typDir &= help "Directories to search for databases"
src/Console/Log.hs view
@@ -67,7 +67,7 @@ ,unique :: Maybe String -- maybe a uniquely identifying string ,instant :: Maybe Int -- number of times you hit with instant for this query ,suggest :: Maybe Int -- number of times you hit with suggest for this query- } deriving Show+ } deriving (Eq, Show) entry = Entry LBS.empty [] Nothing Nothing Nothing Nothing Nothing
src/General/Base.hs view
@@ -5,6 +5,7 @@ module General.Base(module General.Base, module X) where import Control.Arrow as X+import Control.DeepSeq as X import Control.Monad as X import Data.Char as X import Data.Data as X (Data,Typeable)
src/Hoogle.hs view
@@ -15,7 +15,7 @@ -- * Score Score, H.scoring, -- * Search- Result(..), search, suggestions, completions+ Result(..), search, suggestions, completions, queryExact, H.ItemKind(..) ) where import Hoogle.Store.All@@ -30,7 +30,7 @@ import qualified Hoogle.Type.All as H import qualified Hoogle.Language.Haskell as H -import Hoogle.Query.All(Query)+import Hoogle.Query.All(Query, exactSearch) import Hoogle.Score.All(Score) @@ -50,6 +50,9 @@ toDataBase (Database x) = H.combineDataBase x fromDataBase x = Database [x] +instance NFData Database where+ rnf (Database a) = rnf a+ instance Monoid Database where mempty = Database [] mappend (Database xs) (Database ys) = Database $ xs ++ ys@@ -105,6 +108,7 @@ ,self :: TagStr -- ^ Rendered view for the entry, including name/keywords/type as appropriate, colors matching 'renderQuery' ,docs :: TagStr -- ^ Documentation for the entry }+ deriving (Eq, Show) toResult :: H.Result -> (Score,Result) toResult r@(H.Result ent view score) = (score, Result parents self docs)@@ -127,3 +131,7 @@ -- | Given a query string and a database return a list of the possible completions for the search. completions :: Database -> String -> [String] completions x = H.completions (toDataBase x)++-- | Given a query, set whether it is an exact query.+queryExact :: Maybe H.ItemKind -> Query -> Query+queryExact kind q = q { exactSearch = kind }
src/Hoogle/DataBase/Aliases.hs view
@@ -14,6 +14,9 @@ newtype Aliases = Aliases {fromAliases :: Map.Map String Alias} +instance NFData Aliases where+ rnf (Aliases a) = rnf a+ instance Store Aliases where put = put . fromAliases get = get1 Aliases@@ -28,6 +31,9 @@ ,rhs :: Type -- the resulting type } deriving Typeable++instance NFData Alias where+ rnf (Alias a b) = rnf (a,b) instance Store Alias where put (Alias a b) = put2 a b
src/Hoogle/DataBase/All.hs view
@@ -45,6 +45,12 @@ searchName :: DataBase -> String -> [(Once Entry,EntryView,Score)] searchName db = searchSubstrSearch (nameSearch db) +searchExactName :: ItemKind -> DataBase -> String -> [(Once Entry,EntryView,Score)]+searchExactName kind db = filter' . searchExactSearch (nameSearch db)+ where filter' = if kind == UnclassifiedItem+ then id+ else filter (\(ent,_,_) -> kind == entryKind (fromOnce ent))+ searchType :: DataBase -> TypeSig -> [(Once Entry,[EntryView],Score)] -- although aliases and instances are given, they are usually not used
src/Hoogle/DataBase/Instances.hs view
@@ -13,6 +13,9 @@ -- Map type [classes] newtype Instances = Instances {fromInstances :: Map.Map String [String]} +instance NFData Instances where+ rnf (Instances a) = rnf a+ instance Show Instances where show (Instances mp) = unlines $ map f $ Map.toList mp where f (v,cs) = "instance " ++ v ++ " <= " ++ unwords cs
src/Hoogle/DataBase/Items.hs view
@@ -12,6 +12,9 @@ -- Invariant: items are by order of EntryScore newtype Items = Items {fromItems :: Defer [Once Entry]} +instance NFData Items where+ rnf (Items a) = rnf a+ entriesItems :: Items -> [Once Entry] entriesItems = fromDefer . fromItems @@ -40,7 +43,7 @@ pkg2 = if itemLevel x == 0 then Just r else pkg mod2 = if itemLevel x == 1 then Just r else mod - f pkg mod TextItem{..} = once $ Entry [(url, catMaybes [pkg,mod])] itemName itemDisp+ f pkg mod TextItem{..} = once $ Entry [(url, catMaybes [pkg,mod])] itemKind itemLevel 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
src/Hoogle/DataBase/SubstrSearch.hs view
@@ -3,6 +3,7 @@ module Hoogle.DataBase.SubstrSearch (SubstrSearch, createSubstrSearch ,searchSubstrSearch+ ,searchExactSearch ,completionsSubstrSearch ) where @@ -11,6 +12,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import qualified Data.ByteString.Char8 as BSC+import qualified Data.Char as C import General.Base import Data.Array import Hoogle.Type.All@@ -66,6 +68,8 @@ } deriving Typeable +instance NFData a => NFData (SubstrSearch a) where+ rnf (SubstrSearch a b c) = rnf (a,b,c) -- | Create a substring search index. Values are returned in order where possible. createSubstrSearch :: [(String,a)] -> SubstrSearch a@@ -74,7 +78,7 @@ (BS.pack $ map fromIntegral ls2) (listArray (0,length is-1) is) where- (ts,is) = unzip $ map (first $ map toLower) xs+ (ts,is) = unzip xs (ts2,ls2) = f "" ts f x (y:ys) = first (y:) $ second (length y:) $ f y ys@@ -89,16 +93,25 @@ } +toChar :: Word8 -> Char+toChar = C.chr . fromIntegral++-- | Unsafe version of 'fromChar'+ascii :: Char -> Word8+ascii = fromIntegral . C.ord+{-# INLINE ascii #-}+ searchSubstrSearch :: SubstrSearch a -> String -> [(a, EntryView, Score)] searchSubstrSearch x y = reverse (sPrefix sN) ++ reverse (sInfix sN) where view = FocusOn y- match = bsMatch (BSC.pack $ map toLower y)+ match = bsMatch (BSC.pack y) sN = BS.foldl f s0 $ lens x s0 = S 0 (text x) [] [] f s ii = addCount $ moveFocus i $ maybe id addMatch t s- where t = match i $ BS.unsafeTake i $ sFocus s+ where t = match i $ BS.map (ascii . toChar)+ $ BS.unsafeTake i $ sFocus s i = fromIntegral ii addCount s = s{sCount=sCount s+1}@@ -106,7 +119,24 @@ 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} +searchExactSearch :: SubstrSearch a -> String -> [(a, EntryView, Score)]+searchExactSearch x y = reverse (sPrefix sN)+ where+ view = FocusOn y+ match = bsMatch (BSC.pack y)+ sN = BS.foldl f s0 $ lens x+ s0 = S 0 (text x) [] [] + f s ii = addCount $ moveFocus i $ maybe id addMatch t s+ where t = match i $ BS.unsafeTake i $ sFocus s+ i = fromIntegral ii++ addCount s = s{sCount=sCount s+1}+ moveFocus i s = s{sFocus=BS.unsafeDrop i $ sFocus s}+ addMatch MatchExact s = s{sPrefix=(inds x ! sCount s,view,textScore MatchExact):sPrefix s}+ addMatch _ s = s++ data S2 = S2 {_s2Focus :: !BS.ByteString -- where we are in the string ,s2Result :: Set.Set BS.ByteString@@ -119,7 +149,7 @@ ny = length 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+ where x = BS.map (ascii . toLower . toChar) $ BS.unsafeTake i foc i = fromIntegral ii @@ -138,10 +168,34 @@ bsMatch :: BS.ByteString -> Int -> BS.ByteString -> Maybe TextMatch bsMatch x | nx == 0 = \ny _ -> Just $ if ny == 0 then MatchExact else MatchPrefix- | nx == 1 = let c = BS.head x in \ny y -> case BS.elemIndex c y of- Nothing -> Nothing- Just 0 -> Just $ if ny == 1 then MatchExact else MatchPrefix- Just _ -> Just MatchSubstr- | otherwise = \ny y -> if BS.isPrefixOf x y then Just (if nx == nx then MatchExact else MatchPrefix)- else if BS.isInfixOf x y then Just MatchSubstr else Nothing- where nx = BS.length x+ | nx == 1 = let c = BS.head x+ in \ny y ->+ maybe (bsCharMatch MatchExactCI MatchPrefixCI False+ (BS.head (bsLower x)) ny (bsLower y))+ Just (bsCharMatch MatchExact MatchPrefix True+ (BS.head x) ny y)+ | otherwise = \ny y ->+ maybe (bsWordMatch MatchExactCI MatchPrefixCI False+ (bsLower x) ny (bsLower y))+ Just (bsWordMatch MatchExact MatchPrefix True x ny y)+ where+ nx = BS.length x++ bsLower = BS.map (ascii . toLower . toChar)++ bsCharMatch exactKind prefixKind ignoreSubstr c ny y =+ case BS.elemIndex c y of+ Nothing -> Nothing+ Just 0 -> Just $ if ny == 1+ then exactKind+ else prefixKind+ Just _+ | ignoreSubstr -> Nothing+ | otherwise -> Just MatchSubstr++ bsWordMatch exactKind prefixKind ignoreSubstr x' ny y =+ if BS.isPrefixOf x' y+ then Just (if nx == ny then exactKind else prefixKind)+ else if not ignoreSubstr && BS.isInfixOf x' y+ then Just MatchSubstr+ else Nothing
src/Hoogle/DataBase/Suggest.hs view
@@ -21,6 +21,12 @@ deriving Typeable +instance NFData Suggest where+ rnf (Suggest a) = rnf a++instance NFData SuggestItem where+ rnf (SuggestItem a b c) = rnf (a,b,c)+ instance Show Suggest where show (Suggest x) = show x
src/Hoogle/DataBase/Type.hs view
@@ -25,6 +25,8 @@ } deriving Typeable +instance NFData DataBase where+ rnf (DataBase a b c d e f) = rnf (a,b,c,d,e,f) instance Store DataBase where put (DataBase a b c d e f) = put6 a b c d e f
src/Hoogle/DataBase/TypeSearch/All.hs view
@@ -14,9 +14,13 @@ import Hoogle.Store.All import Hoogle.Type.All import Hoogle.Score.All+import General.Base newtype TypeSearch = TypeSearch Graphs++instance NFData TypeSearch where+ rnf (TypeSearch a) = rnf a instance Show TypeSearch where show (TypeSearch x) = show x
src/Hoogle/DataBase/TypeSearch/EntryInfo.hs view
@@ -4,7 +4,7 @@ import Hoogle.Store.All import Hoogle.Type.All-import Data.Typeable+import General.Base -- the information about an entry, including the arity@@ -15,6 +15,9 @@ ,entryInfoContext :: TypeContext ,entryInfoAlias :: [String] } deriving (Show,Typeable)++instance NFData EntryInfo where+ rnf (EntryInfo a b c d e) = rnf (a,b,c,d,e) instance Ord EntryInfo where compare (EntryInfo _ [] x1 x2 x3) (EntryInfo _ [] y1 y2 y3) = compare (x1,x2,x3) (y1,y2,y3)
src/Hoogle/DataBase/TypeSearch/Graph.hs view
@@ -29,6 +29,12 @@ deriving Typeable +instance NFData Graph where+ rnf (Graph a) = rnf a++instance NFData Node where+ rnf (Node a b) = rnf (a,b)+ instance Show Graph where show (Graph mp) = unlines $ concatMap f $ Map.toList mp where f (t,ns) = show (transform g t) : map ((" "++) . show) ns
src/Hoogle/DataBase/TypeSearch/Graphs.hs view
@@ -24,6 +24,9 @@ ,resGraph :: Graph -- the results } +instance NFData Graphs where+ rnf (Graphs a b) = rnf (a,b)+ instance Show Graphs where show (Graphs a b) = "== Arguments ==\n\n" ++ show a ++ "\n== Results ==\n\n" ++ show b
src/Hoogle/Language/Haskell.hs view
@@ -62,8 +62,9 @@ ParseOk y -> transDecl x $ fmap (subtractCols 16) y _ -> Nothing -exts = [EmptyDataDecls,TypeOperators,ExplicitForAll,GADTs,KindSignatures,MultiParamTypeClasses- ,TypeFamilies,FlexibleContexts,FunctionalDependencies,ImplicitParams,MagicHash,UnboxedTuples]+exts = map EnableExtension+ [EmptyDataDecls,TypeOperators,ExplicitForAll,GADTs,KindSignatures,MultiParamTypeClasses+ ,TypeFamilies,FlexibleContexts,FunctionalDependencies,ImplicitParams,MagicHash,UnboxedTuples] subtractCols :: Int -> SrcSpanInfo -> SrcSpanInfo@@ -71,11 +72,12 @@ where f x = x{srcSpanStartColumn=srcSpanStartColumn x - n, srcSpanEndColumn=srcSpanEndColumn x - n} -textItem = TextItem 2 "" "" Nothing (Str "") "" "" 0+textItem = TextItem 2 UnclassifiedItem "" "" Nothing (Str "") "" "" 0 fact x y = (x,[y]) itemPackage x = fact [] $ textItem{itemLevel=0, itemKey="", itemName=x,+ itemKind=PackageItem, itemURL="http://hackage.haskell.org/package/" ++ x ++ "/", itemDisp=Tags [emph "package",space,bold x]} @@ -84,7 +86,7 @@ where y = if null xs then x else unwords xs itemModule xs = fact [] $ textItem{itemLevel=1, itemKey=last xs, itemName=intercalate "." xs,- itemURL="",+ itemURL="", itemKind=ModuleItem, itemDisp=Tags [emph "module",Str $ " " ++ concatMap (++".") (init xs),bold $ last xs]} @@ -124,7 +126,7 @@ transDecl x (GDataDecl _ _ _ _ _ [GadtDecl s name ty] _) = transDecl x $ HSE.TypeSig s [name] ty transDecl x (HSE.TypeSig _ [name] tyy) = Just $ fact (ctr++kinds False typ) $ textItem{itemName=nam,itemKey=nam,- itemType=Just typ,+ itemType=Just typ, itemKind=kind, itemURL="#v:" ++ esc nam, itemDisp=formatTags x $ (cols snam,TagBold) : zipWith (\i a -> (cols a,TagColor i)) [1..] as ++ [(cols b,TagColor 0)]} where (snam,nam) = findName name@@ -133,15 +135,17 @@ typ@(TypeSig _ ty) = transTypeSig tyy ctorStart x = isUpper x || x `elem` ":("+ kind | ctorStart $ head nam = DataCtorItem+ | otherwise = FunctionItem transDecl x (ClassDecl s ctxt hd _ _) = Just $ fact (kinds True $ transDeclHead ctxt hd) $ textItem- {itemName=nam, itemKey=nam+ {itemName=nam, itemKey=nam, itemKind=ClassItem ,itemURL="#t:" ++ esc nam ,itemDisp=x `formatTags` [(cols $ head $ srcInfoPoints s, TagEmph),(cols snam,TagBold)]} where (snam,nam) = findName hd transDecl x (TypeDecl s hd ty) = Just $ fact (FactAlias from to:kinds False from++kinds False to) $ textItem- {itemName=nam, itemKey=nam+ {itemName=nam, itemKey=nam, itemKind=TypeSynonymItem ,itemURL="#t:" ++ esc nam ,itemDisp=x `formatTags` [(cols $ head $ srcInfoPoints s, TagEmph),(cols snam,TagBold)]} where (snam,nam) = findName hd@@ -149,7 +153,7 @@ to = transTypeSig ty transDecl x (DataDecl _ dat ctxt hd _ _) = Just $ fact (kinds False $ transDeclHead ctxt hd) $ textItem- {itemName=nam, itemKey=nam+ {itemName=nam, itemKey=nam, itemKind=TypeCtorItem ,itemURL="#t:" ++ esc nam ,itemDisp=x `formatTags` [(cols $ srcInfoSpan $ ann dat, TagEmph),(cols snam,TagBold)]} where (snam,nam) = findName hd
src/Hoogle/Query/Parser.hs view
@@ -1,6 +1,7 @@ module Hoogle.Query.Parser(parseQuery) where +import Control.Applicative ((*>)) import General.Base import Hoogle.Query.Type import Hoogle.Type.All as Hoogle@@ -43,13 +44,19 @@ if op /= [] && nop /= [] then fail "Combination of operators and names" else return res- - name = (do x <- operator ; spaces ; return mempty{names=[x]})++ handleMatch xs = case xs of+ [x] -> mempty{names=[x]}+ xs -> mempty{names=[last xs]+ ,scope=[Scope True Module $ intercalate "." $ init xs]}++ name = (do xs <- char '*' *> keyword `sepBy1` (char '.') ; spaces+ return $ (handleMatch xs) { invertResults = True } <|>+ do x <- operator ; spaces ; return mempty{names=[x]})+ <|> (do xs <- keyword `sepBy1` (char '.') ; spaces- return $ case xs of- [x] -> mempty{names=[x]}- xs -> mempty{names=[last xs],scope=[Scope True Module $ intercalate "." $ init xs]}+ return $ handleMatch xs ) operator = between (char '(') (char ')') op <|> op@@ -75,9 +82,7 @@ pm <- fmap (== '+') $ oneOf "+-" modu <- keyword `sepBy1` (char '.') let typ = case modu of [x] | isLower (head x) -> Package; _ -> Module- return $ if modu == ["exact"]- then mempty{exact=True}- else mempty{scope=[Scope pm typ $ intercalate "." modu]}+ return mempty{scope=[Scope pm typ $ intercalate "." modu]} keyword = do
src/Hoogle/Query/Type.hs view
@@ -11,14 +11,21 @@ {names :: [String] ,typeSig :: Maybe TypeSig ,scope :: [Scope]- ,exact :: Bool+ ,exactSearch :: Maybe ItemKind+ ,invertResults :: Bool } deriving (Data,Typeable,Show,Eq) instance Monoid Query where- mempty = Query [] Nothing [] False- mappend (Query x1 x2 x3 x4) (Query y1 y2 y3 y4) =- Query (x1++y1) (x2 `mplus` y2) (x3++y3) (x4||y4)+ mempty = Query [] Nothing [] Nothing False+ mappend (Query x1 x2 x3 x4 x5) (Query y1 y2 y3 y4 y5) =+ Query (x1++y1) (x2 `mplus` y2) (x3++y3) (merge x4 y4) (x5 || y5)+ where merge Nothing Nothing = Nothing+ merge (Just x) Nothing = Just x+ merge Nothing (Just y) = Just y+ merge (Just UnclassifiedItem) (Just y) = Just y+ merge (Just x) (Just UnclassifiedItem) = Just x+ merge (Just x) (Just _) = Just x data Scope = Scope Bool Category String deriving (Data,Typeable,Show,Eq) data Category = Module | Package deriving (Data,Typeable,Show,Eq)
src/Hoogle/Score/All.hs view
@@ -1,7 +1,7 @@ module Hoogle.Score.All( module Hoogle.Score.Scoring,- Score, TypeCost(..), TextMatch(..), textScore, typeScore, scoreCosts, scoreExact, cost+ Score, TypeCost(..), TextMatch(..), textScore, typeScore, scoreCosts, cost ) where import Hoogle.Score.Scoring
src/Hoogle/Score/Type.hs view
@@ -2,7 +2,7 @@ module Hoogle.Score.Type( Score, TypeCost(..), TextMatch(..), textScore, typeScore,- scoreCosts, scoreExact, cost+ scoreCosts, cost ) where import Data.List@@ -42,6 +42,8 @@ data TextMatch = MatchExact | MatchPrefix+ | MatchExactCI -- exact letter match, but case mismatch+ | MatchPrefixCI | MatchSubstr deriving (Show,Eq,Ord,Enum,Bounded) @@ -51,7 +53,8 @@ instance Monoid Score where mempty = Score 0 [] []- mappend (Score x1 x2 x3) (Score y1 y2 y3) = Score (x1+y1) (sort $ x2++y2) (sort $ x3++y3)+ mappend (Score x1 x2 x3) (Score y1 y2 y3) =+ Score (x1+y1) (sort $ x2++y2) (sort $ x3++y3) textScore :: TextMatch -> Score textScore x = Score 0 [] [x]@@ -62,15 +65,15 @@ scoreCosts :: Score -> [TypeCost] scoreCosts (Score _ x _) = x -scoreExact :: Score -> Bool-scoreExact (Score _ ty txt) = null ty && null (filter (/= MatchExact) txt) - instance Show Score where- show (Score _ a b) = intercalate "+" $ map (drop 4 . show) a ++ map (drop 5 . show) b+ show (Score _ a b) =+ intercalate "+" $ map (drop 4 . show) a ++ map (drop 5 . show) b instance Eq Score where- Score x1 x2 x3 == Score y1 y2 y3 = x1 == y1 && x3 == y3+ Score x1 x2 [] == Score y1 y2 y3 = [] == y3 || x1 == y1+ Score x1 x2 x3 == Score y1 y2 [] = x3 == [] || x1 == y1+ Score x1 x2 x3 == Score y1 y2 y3 = head x3 == head y3 || x1 == y1 instance Ord Score where- compare (Score x1 x2 x3) (Score y1 y2 y3) = compare (x1,x3) (y1,y3)+ compare (Score x1 x2 x3) (Score y1 y2 y3) = compare (x3,x1) (y3,y1)
src/Hoogle/Search/All.hs view
@@ -1,31 +1,35 @@ module Hoogle.Search.All(search) where +import Data.List (sortBy)+import Data.Maybe+import Data.Ord (comparing) import Hoogle.DataBase.All import Hoogle.Query.All import Hoogle.Search.Results import Hoogle.Type.All import Hoogle.Store.All-import Hoogle.Score.All -- return all the results, lazily search :: [DataBase] -> Query -> [Result]-search databases query =- (if exact query then takeWhile (scoreExact . resultScore) else id) $- getResults query databases+search databases query = getResults query databases getResults :: Query -> [DataBase] -> [Result]-getResults query = mergeDataBaseResults . map (mergeQueryResults query . f)+getResults query = sortBy ((if invertResults query then flip else id)+ $ comparing resultScore) .+ mergeDataBaseResults . map (mergeQueryResults query . f) where- f d = [typeSearch d q | Just q <- [typeSig query]] ++- map (nameSearch d) (names query)+ f d = [ typeSearch d q+ | Just q <- [typeSig query], isNothing (exactSearch query) ] +++ map (nameSearch d (exactSearch query)) (names query) -nameSearch :: DataBase -> String -> [Result]-nameSearch db query = [Result (fromOnce e) [v] s- | (e,v,s) <- searchName db query]+nameSearch :: DataBase -> Maybe ItemKind -> String -> [Result]+nameSearch db kind query =+ [ Result (fromOnce e) [v] s+ | (e,v,s) <- (maybe searchName searchExactName kind) db query ] typeSearch :: DataBase -> TypeSig -> [Result]
src/Hoogle/Search/Results.hs view
@@ -25,7 +25,6 @@ toKey f v = Key (f v) v fromKey (Key k v) = v-sortWith f = map fromKey . sort . map (toKey f) ---------------------------------------------------------------------@@ -49,13 +48,12 @@ joinResults :: [[Result]] -> [Result] joinResults [] = [] joinResults [x] = x-joinResults xs = sortWith resultScore $ Map.elems $- fold1 (Map.intersectionWith join) $+joinResults xs = Map.elems $ fold1 (Map.intersectionWith join) $ map asSet xs where asSet = Map.fromList . map (entryUnique . resultEntry &&& id) - join r1 r2 = r1{resultScore = mappend (resultScore r1) (resultScore r2)+ join r1 r2 = r1{resultScore = resultScore r1 <> resultScore r2 ,resultView = resultView r1 ++ resultView r2 ,resultEntry = resultEntry r1 `entryJoin` resultEntry r2} @@ -65,7 +63,7 @@ -- | Apply the PlusModule, MinusModule and MinusPackage modes filterResults :: Query -> [Result] -> [Result]-filterResults q = f mods correctModule . f pkgs correctPackage+filterResults q = f mods (correctModule (exactSearch q)) . f pkgs correctPackage where f [] act = id f xs act = filter (act xs . resultEntry)@@ -81,16 +79,20 @@ -- mods is a non-empty list of PlusModule/MinusModule-correctModule :: [Scope] -> Entry -> Bool-correctModule mods x = null myMods || any (maybe True (f base mods)) myMods+correctModule :: Maybe ItemKind -> [Scope] -> Entry -> Bool+correctModule kind mods x = null myMods || any (maybe True (f base mods)) myMods where- myMods = map (fmap (map toLower . entryName . fromOnce) . listToMaybe . drop 1 . snd) $- entryLocations x+ myMods = map (fmap (map (if isJust kind then id else toLower)+ . entryName . fromOnce)+ . listToMaybe . drop 1 . snd) $ entryLocations x base = case head mods of Scope False Module _ -> True; _ -> False f z [] y = z- f z (Scope b Module x:xs) y | doesMatch (map toLower x) y = f b xs y+ f z (Scope b Module x:xs) y+ | doesMatch (map (if isJust kind then id else toLower) x) y = f b xs y f z (x:xs) y = f z xs y -- match if x is a module starting substring of y- doesMatch x y = x `isPrefixOf` y || ('.':x) `isInfixOf` y+ doesMatch x y = if isJust kind+ then x == y+ else x `isPrefixOf` y || ('.':x) `isInfixOf` y
src/Hoogle/Store/All.hs view
@@ -11,6 +11,8 @@ import Hoogle.Store.Type import qualified Data.Map as Map import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T import Data.Array @@ -32,6 +34,7 @@ newtype Defer a = Defer {fromDefer :: a} +instance NFData a => NFData (Defer a) where rnf = rnf . fromDefer 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@@ -107,12 +110,23 @@ size _ = size (0 :: Int32) instance Store Char where- put = putByte . fromIntegral . ord- get = fmap (chr . fromIntegral) getByte- size _ = size (0 :: Word8)+ put x | x < '\x80' = putByte . fromIntegral . ord $ x -- ASCII+ | otherwise = putByteString . T.encodeUtf8 . T.singleton $ x+ get = do c0 <- getByte+ n <- case c0 of+ _ | c0 < 0x80 -> return 0 -- ASCII+ _ | c0 < 0xc0 -> fail "invalid UTF8 sequence"+ _ | c0 < 0xe0 -> return 1+ _ | c0 < 0xf0 -> return 2+ _ | c0 < 0xf8 -> return 3+ _ | c0 < 0xfc -> return 4+ _ | c0 < 0xfe -> return 5 - getList = fmap bsUnpack . getByteString . fromIntegral+ if n > 0+ then fmap (T.head . T.decodeUtf8 . BS.cons c0) $ getByteString n+ else return $ chr $ fromIntegral $ c0 -- ASCII + putList = putByteString . T.encodeUtf8 . T.pack instance Store Bool where put x = put $ if x then '1' else '0'
src/Hoogle/Store/Type.hs view
@@ -29,6 +29,9 @@ data Once a = Once {_onceKey :: Int, valueOnce :: a} deriving Typeable +instance NFData a => NFData (Once a) where+ rnf (Once a b) = rnf (a,b)+ fromOnce :: Once a -> a fromOnce = valueOnce
src/Hoogle/Type/Docs.hs view
@@ -36,7 +36,8 @@ -- 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 "pre" x:xs) = let ys = init $ tail $ f True x+ in if null ys then ys else init ys ++ 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
src/Hoogle/Type/Item.hs view
@@ -13,9 +13,23 @@ type Input = ([Fact], [TextItem]) +data ItemKind = PackageItem+ | ModuleItem+ | FunctionItem+ | DataCtorItem+ | TypeCtorItem+ | TypeSynonymItem+ | ClassItem+ | InstanceItem+ | UnclassifiedItem+ deriving (Data,Typeable,Show,Eq,Enum) +instance NFData ItemKind where+ rnf = rnf . fromEnum+ data TextItem = TextItem {itemLevel :: Int -- 0 = package, 1 = module, >2 = entry+ ,itemKind :: ItemKind ,itemKey :: String -- how i should be searched for (name for most things, last module component for modules) ,itemName :: String -- what is the full text representation of me (key for most things, A.B.C for modules) ,itemType :: Maybe TypeSig@@ -38,6 +52,8 @@ -- Invariant: locations will not be empty data Entry = Entry {entryLocations :: [(URL, [Once Entry])]+ ,entryKind :: ItemKind+ ,entryLevel :: Int ,entryName :: String ,entryText :: TagStr ,entryDocs :: Docs@@ -45,9 +61,13 @@ ,entryKey :: String -- used only for rebuilding combined databases ,entryType :: Maybe TypeSig -- used only for rebuilding combined databases }- deriving Typeable+ deriving (Eq, Typeable) +instance NFData Entry where+ rnf ent@(Entry a b c d e f g h i) = rnf (map (second $ map (f . fromOnce)) a,b,c,d,e,f,g,h,i)+ where f ent2 = if entryUnique ent == entryUnique ent2 then () else rnf ent2 + -- | Figure out what makes this entry different from others entryUnique Entry{..} = (entryName, entryText, entryDocs, entryKey, entryType) @@ -64,7 +84,7 @@ data EntryView = FocusOn String -- characters in the range should be focused | ArgPosNum Int Int -- argument a b, a is remapped to b- deriving Show+ deriving (Eq, Show) renderEntryText :: [EntryView] -> TagStr -> TagStr@@ -101,5 +121,45 @@ show = showTagText . entryText instance Store Entry where- put (Entry a b c d e f g) = put7 a b c d e f g- get = get7 Entry+ put (Entry a b c d e f g h i) = put9 a b c d e f g h i+ get = get9 Entry+++instance Store Fact where+ put (FactAlias x y) = putByte 0 >> put2 x y+ put (FactInstance x) = putByte 1 >> put1 x+ put (FactDataKind x y) = putByte 2 >> put2 x y+ put (FactClassKind x y) = putByte 3 >> put2 x y+ put (FactCtorType x y) = putByte 4 >> put2 x y++ get = do i <- getByte+ case i of+ 0 -> get2 FactAlias+ 1 -> get1 FactInstance+ 2 -> get2 FactDataKind+ 3 -> get2 FactClassKind+ 4 -> get2 FactCtorType++instance Store ItemKind where+ put PackageItem = putByte 0+ put ModuleItem = putByte 1+ put FunctionItem = putByte 2+ put DataCtorItem = putByte 4+ put TypeCtorItem = putByte 5+ put TypeSynonymItem = putByte 6+ put ClassItem = putByte 7+ put InstanceItem = putByte 8+ put UnclassifiedItem = putByte 9++ get = do i <- getByte+ case i of+ 0 -> get0 PackageItem+ 1 -> get0 ModuleItem+ 2 -> get0 FunctionItem+ 3 -> get0 FunctionItem+ 4 -> get0 DataCtorItem+ 5 -> get0 TypeCtorItem+ 6 -> get0 TypeSynonymItem+ 7 -> get0 ClassItem+ 8 -> get0 InstanceItem+ 9 -> get0 UnclassifiedItem
src/Hoogle/Type/Result.hs view
@@ -11,7 +11,7 @@ ,resultView :: [EntryView] ,resultScore :: Score }- deriving Show+ deriving (Eq, Show) -- return the entry rendered with respect to the EntryView
src/Hoogle/Type/TagStr.hs view
@@ -23,6 +23,13 @@ | TagColor Int TagStr -- ^ Colored text. Index into a 0-based palette. Text without any 'TagColor' should be black. deriving (Data,Typeable,Ord,Show,Eq) +instance NFData TagStr where+ rnf (Str a) = rnf a+ rnf (Tags a) = rnf a+ rnf (TagBold a) = rnf a+ rnf (TagEmph a) = rnf a+ rnf (TagLink a b) = rnf (a,b)+ rnf (TagColor a b) = rnf (a,b) instance Monoid TagStr where mempty = Str ""
src/Hoogle/Type/TypeSig.hs view
@@ -3,8 +3,7 @@ module Hoogle.Type.TypeSig where import Hoogle.Store.All-import Data.List-import Data.Data+import General.Base import Data.Generics.UniplateOn @@ -16,6 +15,9 @@ data TypeSig = TypeSig Constraint Type deriving (Eq,Ord,Data,Typeable) +instance NFData TypeSig where+ rnf (TypeSig a b) = rnf (a,b)+ type Constraint = [Type] @@ -38,6 +40,11 @@ | TFun [Type] deriving (Eq,Ord,Data,Typeable) +instance NFData Type where+ rnf (TApp a b) = rnf (a,b)+ rnf (TLit a) = rnf a+ rnf (TVar a) = rnf a+ rnf (TFun a) = rnf a tApp :: Type -> [Type] -> Type tApp t [] = t
src/Recipe/Download.hs view
@@ -5,59 +5,74 @@ import General.System import Recipe.Type +type Downloader = FilePath -> URL -> String +wget :: Downloader+wget fp url = "wget -nv " ++ url ++ " --output-document=" ++ fp+curl :: Downloader+curl fp url = "curl -sSL " ++ url ++ " --output " ++ fp++findDownloader :: IO Downloader+findDownloader = do+ dl <- liftM2 mplus (check "wget") (check "curl")+ when (isNothing dl) $ error "Could not find downloader, neither curl nor wget are on the $PATH."+ return $ matchDl (fromJust dl)+ where matchDl d | "wget" `isInfixOf` d = wget+ | "curl" `isInfixOf` d = curl++withDownloader :: CmdLine -> Downloader -> [(FilePath, FilePath, URL)] -> IO ()+withDownloader opt downloader items =+ let sys = fmap (== ExitSuccess) . system+ download (f, f', u) = do+ b <- doesFileExist f+ when (not b || redownload opt) $ do+ res <- sys (downloader f' u)+ unless res $ do+ b <- doesFileExist f'+ when b $ removeFile f'+ error $ "Failed to download: " ++ u+ doesFileExist f'+ in forM_ items download+ -- download everything required for the recipes download :: CmdLine -> IO () download opt = do createDirectoryIfMissing True "download"- wget opt keywords "http://www.haskell.org/haskellwiki/Keywords"- wget opt platform "http://code.galois.com/darcs/haskell-platform/haskell-platform.cabal"- wget opt "download/base.txt" "http://www.haskell.org/hoogle/base.txt"- wget opt "download/ghc.txt" "http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/ghc.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"+ downloader <- findDownloader+ let items = [ (keywords, keywords, "http://www.haskell.org/haskellwiki/Keywords")+ , (platform, platform, "http://code.galois.com/darcs/haskell-platform/haskell-platform.cabal")+ , ("download/base.txt", "download/base.txt", "http://www.haskell.org/hoogle/base.txt")+ , ("download/ghc.txt", "download/ghc.txt", "http://www.haskell.org/ghc/docs/latest/html/libraries/ghc/ghc.txt")+ , (cabals <.> "txt", cabals <.> "tar.gz", "http://hackage.haskell.org/packages/archive/00-index.tar.gz")+ , (inputs <.> "txt", inputs <.> "tar.gz", "http://hackage.haskell.org/packages/archive/00-hoogle.tar.gz")+ ]+ withDownloader opt downloader items+ extractTarball cabals+ extractTarball inputs -check :: String -> URL -> IO ()-check name url | isWindows = do+check :: String -> IO (Maybe FilePath)+check name = 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"- let sys cmd = do- res <- fmap (== ExitSuccess) $ system cmd- unless res $ do- b <- doesFileExist fil- when b $ removeFile fil- return res- b <- sys $ "wget " ++ url ++ " --output-document=" ++ fil- unless b $ do sys $ "curl " ++ url ++ " --output " ++ fil; return ()- doesFileExist fil---wget :: CmdLine -> FilePath -> URL -> IO ()-wget opt fil url = do- b <- wgetMay opt fil url- unless b $ error $ "Failed to download " ++ url-+ when (isNothing res) $ do+ putStrLn $ "WARNING: Could not find command line program " ++ name ++ "."+ when isWindows $ putStrLn $ " You may be able to install it from:\n " ++ url+ return res+ where+ srcList = [ ("gzip", "http://gnuwin32.sourceforge.net/packages/gzip.htm")+ , ("tar", "http://gnuwin32.sourceforge.net/packages/gtar.htm")+ , ("wget", "http://gnuwin32.sourceforge.net/packages/wget.htm")+ , ("curl", "http://curl.haxx.se/download.html")+ ]+ url = fromJust . lookup name $ srcList -downloadTarball :: CmdLine -> FilePath -> URL -> IO ()-downloadTarball opt out url = do- b <- doesFileExist $ out <.> "txt"- when (not b || redownload opt) $ do- wget opt (out <.> "tar.gz") url+extractTarball :: FilePath -> IO ()+extractTarball out = do createDirectoryIfMissing True out withDirectory out $ do- check "gzip" "http://gnuwin32.sourceforge.net/packages/gzip.htm"- check "tar" "http://gnuwin32.sourceforge.net/packages/gtar.htm"+ hasGzip <- check "gzip"+ hasTar <- check "tar"+ when (any isNothing [hasGzip, hasTar]) $ error "Could not extract tarball(s), could not find either gzip or tar on the $PATH." putStrLn "Extracting tarball... " system_ $ "gzip --decompress --force .." </> takeFileName out <.> "tar.gz" system_ $ "tar -xf .." </> takeFileName out <.> "tar"
src/Recipe/Keyword.hs view
@@ -9,7 +9,7 @@ makeKeyword :: IO () makeKeyword = do- convertSrc noDeps "keyword" . translate =<< readFile' keywords+ convertSrc noDeps "keyword" . translate =<< readFileUtf8' keywords translate :: String -> String
src/Web/Page.hs view
@@ -1,3 +1,4 @@+-- AUTO GENERATED - do not modify module Web.Page(Templates(..), defaultTemplates, loadTemplates) where import Web.Template @@ -38,14 +39,14 @@ ++ escapeURL 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=\""+ ++ "\"> </script>\n </head>\n <body>\n<div id=\"links\">\n <ul id=\"top-menu\">\n <li id=\"instant\" style=\"display:none;\">\n <a href=\"javascript:setInstant()\">Instant is <span id=\"instantVal\">off</span></a>\n </li>\n <li id=\"plugin\" style=\"display:none;\"><a href=\"javascript:searchPlugin()\">Search plugin</a></li>\n <li><a href=\"https://github.com/ndmitchell/hoogle/blob/master/README.md\">Manual</a></li>\n <li><a href=\"http://www.haskell.org/\">haskell.org</a>\n</li>\n </ul>\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 version = ""- ++ " </div>\n <p id=\"footer\">© <a href=\"http://community.haskell.org/~ndm/\">Neil Mitchell</a> 2004-2012, version "+ ++ " <div class=\"push\"></div>\n </div>\n <div id=\"footer\">© <a href=\"http://community.haskell.org/~ndm/\">Neil Mitchell</a> 2004-2013, version " ++ escapeHTML version- ++ "</p>\n </body>\n</html>\n"+ ++ "</div>\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"
src/Web/Response.hs view
@@ -10,6 +10,8 @@ import Web.Page import Data.Generics.Uniplate +import qualified Data.Aeson as J+import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Time.Clock import Data.Time.Format import System.Locale@@ -47,7 +49,7 @@ Just "embed" -> return $ response "text/html" [hdr] $ runEmbed dbs q where hdr = (fromString "Access-Control-Allow-Origin", fromString "*") Just "ajax" -> return $ response "text/html" [] $ runQuery templates True dbs q- Just "json" -> return $ response "application/json" [] $ "{\"version\":" ++ show version ++ "," ++ runJson dbs q ++ "}"+ Just "json" -> return $ responseOK [(hContentType, fromString "application/json")] $ runJson dbs q Just "web" -> return $ response "text/html" [] $ header templates updatedCss updatedJs (queryText q) ['-' | queryText q /= ""] ++ runQuery templates False dbs q ++ footer templates version@@ -88,19 +90,28 @@ f x = x -runJson :: Database -> CmdLine -> String-runJson dbs Search{queryParsed = Left err} = "\"parseError\": " ++ show err-runJson dbs cq@Search{queryParsed = Right q}- | q == mempty = "\"results\": []"- | otherwise = "\"results\": [" ++ intercalate "," now ++ "]"- where- start2 = maybe 0 (subtract 1 . max 0) $ start cq- count2 = maybe 20 (max 1) $ count cq- now = map (f . snd) $ take count2 $ drop start2 $ search dbs q+runJson :: Database -> CmdLine -> LBS.ByteString+runJson dbs Search{queryParsed = Left err} =+ J.encode $ J.object [ fromString "version" J..= version+ , fromString "parseError" J..= show err+ ]+runJson dbs cq@Search{queryParsed = Right q} =+ J.encode $ J.object [ fromString "version" J..= version+ , fromString "results" J..= results+ ]+ where+ results | q == mempty = []+ | otherwise = now - f Result{..} = "{\"location\":" ++ show (head $ map fst locations ++ [""]) ++- ",\"self\":" ++ show (showTagText self) ++- ",\"docs\":" ++ show (showTagText docs) ++ "}"+ start2 = maybe 0 (subtract 1 . max 0) $ start cq+ count2 = maybe 20 (max 1) $ count cq+ now = map (f . snd) $ take count2 $ drop start2 $ search dbs q++ f Result{..} = J.object+ [ fromString "location" J..= (head $ map fst locations ++ [""])+ , fromString "self" J..= showTagText self+ , fromString "docs" J..= showTagText docs+ ] runQuery :: Templates -> Bool -> Database -> CmdLine -> String
src/Web/Template.hs view
@@ -83,7 +83,8 @@ generate :: String -> [Template] -> String generate name xs = unlines $- ["module " ++ name ++ "(Templates(..), defaultTemplates, loadTemplates) where"+ ["-- AUTO GENERATED - do not modify"+ ,"module " ++ name ++ "(Templates(..), defaultTemplates, loadTemplates) where" ,"import Web.Template" ,"" ,"data Templates = Templates"] ++
+ test/HoogleSpec.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad+import Control.Monad.IO.Class+import Data.Monoid+import Filesystem (isDirectory, isFile)+import qualified Hoogle as H+import System.Environment+import System.Exit+import System.IO+import Test.HUnit+import Test.Hspec (Spec, describe, it, hspec)+import Test.Hspec.Expectations+import Test.Hspec.HUnit ()+import Test.Hspec.Runner++main :: IO ()+main = do+ env <- getEnvironment+ hoogledb <- liftIO $+ readFileUtf8 "datadir/testdata.txt"+ >>= return . snd . H.createDatabase H.Haskell []+ hspec $ hoogleSpec hoogledb++readFileUtf8 x = do+ h <- openFile x ReadMode+ hSetEncoding h utf8+ hGetContents h++hoogleSpec :: H.Database -> Spec+hoogleSpec db = do+ describe "Basic functionality" $ do+ it "finds 'snd'" $ do+ let q = H.parseQuery undefined "snd"+ map (H.self . snd) (H.search db (either mempty id q))+ @?= [H.Tags [ H.TagBold (H.Tags [H.TagEmph (H.Str "snd")])+ , H.Str " :: "+ , H.Str "(a,b)"+ , H.Str " -> "+ , H.Str "b" ]]++ it "finds four instances of 'fst'" $ do+ let q = H.parseQuery undefined "fst"+ length (H.search db (either mempty id q)) @?= 4++ it "finds two 'Foo.Bar.fst*' inexactly" $ do+ let q = H.parseQuery undefined "fst +Foo.Bar"+ length (H.search db (either mempty id q)) @?= 2++ it "finds 'Foo.Bar.fst' exactly" $ do+ let q = H.parseQuery undefined "fst +Foo.Bar"+ map (H.self . snd)+ (H.search db (H.queryExact (Just H.UnclassifiedItem)+ (either mempty id q)))+ @?= [H.Tags [ H.TagBold (H.Tags [H.TagEmph (H.Str "fst")])+ , H.Str " :: "+ , H.Str "(Unit,Unit)"+ , H.Str " -> "+ , H.Str "Unit" ]]++-- Smoke.hs ends here