packages feed

hoogle 4.0.7 → 4.1

raw patch · 133 files changed

+3433/−3517 lines, 133 filesdep +HTTPdep +binarydep +cmdargsdep −mtldep ~basedep ~parsecdep ~uniplate

Dependencies added: HTTP, binary, cmdargs, haskell-src-exts, network, random, tagsoup, transformers

Dependencies removed: mtl

Dependency ranges changed: base, parsec, uniplate

Files

README.txt view
@@ -1,13 +1,22 @@-README FOR HOOGLE
-=================
+Hoogle - a Haskell API search.
 
-A Haskell API search. To invoke it type
+Command Line Version
+--------------------
 
+To invoke Hoogle type:
+
     hoogle "[a] -> [b]"
 
 Note the quotes, otherwise you will redirect the output to the file [b].
 
+To ensure you have data files for the Hackage modules, you will first need to
+type:
 
+    hoogle data
+
+Which will download and build Hoogle databases.
+
+
 Web Version
 -----------
 
@@ -16,15 +25,6 @@ All the appropriate documentation/credits/reference material is on the
 Haskell wiki at http://www.haskell.org/haskellwiki/Hoogle
 
-
-Building
---------
-
-To build the source type follow the standard Cabal procedure:
-
-$ runhaskell Setup configure
-$ runhaskell Setup build
-$ runhaskell Setup install
 
 Folders
 -------
− database/array.hoo

binary file changed (55340 → absent bytes)

− database/base.hoo

binary file changed (601365 → absent bytes)

− database/bytestring.hoo

binary file changed (178686 → absent bytes)

− database/cabal.hoo

binary file changed (418169 → absent bytes)

− database/containers.hoo

binary file changed (171856 → absent bytes)

− database/default.hoo

file too large to diff

− database/directory.hoo

binary file changed (47172 → absent bytes)

− database/filepath.hoo

binary file changed (66087 → absent bytes)

− database/ghc.hoo

binary file changed (75900 → absent bytes)

− database/hackage.hoo

binary file changed (573525 → absent bytes)

− database/haskell-src.hoo

binary file changed (105102 → absent bytes)

− database/hunit.hoo

binary file changed (37023 → absent bytes)

− database/keyword.hoo

binary file changed (20307 → absent bytes)

− database/mtl.hoo

binary file changed (74072 → absent bytes)

− database/parallel.hoo

binary file changed (43831 → absent bytes)

− database/parsec.hoo

binary file changed (190281 → absent bytes)

− database/pretty.hoo

binary file changed (38647 → absent bytes)

− database/process.hoo

binary file changed (43356 → absent bytes)

− database/quickcheck.hoo

binary file changed (48732 → absent bytes)

− database/random.hoo

binary file changed (31118 → absent bytes)

− database/stm.hoo

binary file changed (34850 → absent bytes)

− database/syb.hoo

binary file changed (48720 → absent bytes)

− database/template-haskell.hoo

binary file changed (130341 → absent bytes)

− database/time.hoo

binary file changed (68144 → absent bytes)

− database/xhtml.hoo

binary file changed (110050 → absent bytes)

hoogle.cabal view
@@ -1,13 +1,13 @@-cabal-version:      >= 1.2+cabal-version:      >= 1.6 build-type:         Simple name:               hoogle-version:            4.0.7+version:            4.1 license:            GPL license-file:       docs/LICENSE category:           Development author:             Neil Mitchell <ndmitchell@gmail.com> maintainer:         Neil Mitchell <ndmitchell@gmail.com>-copyright:          Neil Mitchell 2004-2008+copyright:          Neil Mitchell 2004-2010 synopsis:           Haskell API Search description:     Hoogle is a Haskell API search engine, which allows you to@@ -16,119 +16,103 @@ homepage:           http://www.haskell.org/hoogle/ stability:          Beta extra-source-files: README.txt-data-dir:           database-data-files:-    array.hoo-    base.hoo-    bytestring.hoo-    cabal.hoo-    containers.hoo-    default.hoo-    directory.hoo-    filepath.hoo-    ghc.hoo-    hackage.hoo-    haskell-src.hoo-    hunit.hoo-    keyword.hoo-    mtl.hoo-    parallel.hoo-    parsec.hoo-    pretty.hoo-    process.hoo-    quickcheck.hoo-    random.hoo-    stm.hoo-    syb.hoo-    template-haskell.hoo-    time.hoo-    xhtml.hoo -flag splitBase-    Description: Choose the new smaller, split-up base package.+library+    hs-source-dirs:     src+    build-depends:+        base > 4 && < 4.4,+        array, bytestring, containers, directory, filepath, process, random,+        safe,+        binary,+        parsec == 2.1.*,+        transformers == 0.2.*,+        uniplate == 1.6.*,+        haskell-src-exts == 1.9.* -executable hoogle-    build-depends: parsec, filepath, safe, uniplate, mtl, time-    if flag(splitBase)-        build-depends: base >= 3 && < 4, directory, process, containers, array, bytestring-    else-        build-depends: base >= 2 && < 3+    exposed-modules:+        Hoogle -    main-is:            Main.hs-    hs-source-dirs:     src+    -- modules that I would conditionally expose, were it not for+    -- http://hackage.haskell.org/trac/hackage/ticket/776     other-modules:-        CmdLine.Action-        CmdLine.All-        CmdLine.Files-        CmdLine.Flag-        CmdLine.Query-        CmdLine.Search-        CmdLine.Test+        Hoogle.DataBase.All+        Hoogle.Type.All+        Hoogle.Query.All+        Hoogle.Score.All+        Hoogle.Search.All+        Hoogle.Language.Haskell++    other-modules:         Data.Binary.Defer         Data.Binary.Defer.Array         Data.Binary.Defer.Class         Data.Binary.Defer.Index-        Data.Binary.Defer.Map         Data.Binary.Defer.Monad-        Data.Binary.Defer.Trie-        Data.Binary.Defer.Vector         Data.Binary.Raw         Data.Heap-        Data.Key-        Data.Range-        Data.TagStr         Data.TypeMap-        General.CGI-        General.Code-        General.Glob-        General.TextUtil+        General.Base+        General.System         General.Util-        Hoogle.All+        General.Web         Hoogle.DataBase.Aliases-        Hoogle.DataBase.All         Hoogle.DataBase.Instances         Hoogle.DataBase.Items-        Hoogle.DataBase.NameSearch         Hoogle.DataBase.Serialise+        Hoogle.DataBase.SubstrSearch         Hoogle.DataBase.Suggest         Hoogle.DataBase.Type-        Hoogle.DataBase.TypeSearch.All         Hoogle.DataBase.TypeSearch.Binding-        Hoogle.DataBase.TypeSearch.Cost         Hoogle.DataBase.TypeSearch.EntryInfo         Hoogle.DataBase.TypeSearch.Graph         Hoogle.DataBase.TypeSearch.Graphs         Hoogle.DataBase.TypeSearch.Result         Hoogle.DataBase.TypeSearch.TypeScore-        Hoogle.Item.All-        Hoogle.Item.Haddock-        Hoogle.Item.Item-        Hoogle.Item.URL-        Hoogle.Operations.All-        Hoogle.Operations.Combine-        Hoogle.Operations.Convert-        Hoogle.Operations.Rank-        Hoogle.Operations.RankSolve-        Hoogle.Query.All+        Hoogle.DataBase.TypeSearch.All+        Hoogle.Type.Documentation+        Hoogle.Type.Item+        Hoogle.Type.TagStr+        Hoogle.Type.TypeSig+        Hoogle.Type.ParseError+        Hoogle.Type.Result         Hoogle.Query.Parser         Hoogle.Query.Render         Hoogle.Query.Suggest         Hoogle.Query.Type-        Hoogle.Search.All-        Hoogle.Search.Result+        Hoogle.Score.Scoring+        Hoogle.Score.Type         Hoogle.Search.Results-        Hoogle.TextBase.All-        Hoogle.TextBase.Parser-        Hoogle.TextBase.Type-        Hoogle.TypeSig.All-        Hoogle.TypeSig.Parser-        Hoogle.TypeSig.Type++executable hoogle+    main-is:            Main.hs+    hs-source-dirs:     src++    build-depends:+        time,+        cmdargs == 0.6.*,+        tagsoup == 0.11.*,+        network >= 2.2 && <= 2.4,+        HTTP == 4000.0.*++    other-modules:+        CmdLine.All+        CmdLine.Load+        CmdLine.Type+        Console.All+        Console.Rank+        Console.Search+        Console.Test+        Recipe.All+        Recipe.Download+        Recipe.General+        Recipe.Hackage+        Recipe.Keyword+        Recipe.Type         Test.All         Test.General         Test.Parse_Query-        Test.Parse_TextBase         Test.Parse_TypeSig-        Web.Action         Web.All         Web.Page-        Web.Text+        Web.Response+        Web.Server
− src/CmdLine/Action.hs 
@@ -1,112 +0,0 @@--module CmdLine.Action(actionCmdLine) where--import CmdLine.Flag-import CmdLine.Query-import CmdLine.Search-import CmdLine.Files-import CmdLine.Test-import General.Code-import Hoogle.All-import Test.All-import Text.ParserCombinators.Parsec--import Paths_hoogle(version)-import Data.Version(showVersion)---actionCmdLine :: CmdQuery -> IO ()--actionCmdLine CmdQuery{queryText = text, query = Left err} =-    exitMessage ["Parse error:", "  " ++ text-                ,replicate (sourceColumn (errorPos err) + 1) ' ' ++ "^"-                ,show err]---actionCmdLine q | not $ null $ queryBadFlags q =-    exitMessage $ "Unrecognised or malformed flags:":-                  map ("  "++) (queryBadFlags q) ++-                  ["For details on correct flags pass --help"]---actionCmdLine q | Version `elem` queryFlags q = putStr $ unlines-    ["Hoogle - (C) Neil Mitchell 2004-2008, University of York, UK"-    ,"Version " ++ showVersion version]---actionCmdLine q | Help `elem` queryFlags q =-    putStr $ "Go to the website for full help, http://haskell.org/hoogle/\n" ++-             "\n" ++-             "Flag reference:\n" ++-             flagsHelp---actionCmdLine q | Test `elem` queryFlags q = test---actionCmdLine q | TestFile{} `elemEnum` queryFlags q =-    mapM_ (actionTest q) [x | TestFile x <- queryFlags q]---actionCmdLine q | Rank{} `elemEnum` queryFlags q =-    mapM_ rank [x | Rank x <- queryFlags q]---actionCmdLine q | Convert{} `elemEnum` queryFlags q =-    mapM_ (actionConvert q) [x | Convert x <- queryFlags q]---actionCmdLine q | Combine{} `elemEnum` queryFlags q = do-    -- TODO: Work around a bug in CmdLine.Flags, try /merge=t1;t2-    --       and you get [t1,t1,t2,t2]-    let files = nub [x | Combine x <- queryFlags q]-        outfile = headDef "default.hoo" [x | Output x <- queryFlags q]-    putStrLn $ "Combining " ++ show (length files) ++ " databases"-    combine files outfile-    when (Dump{} `elemEnum` queryFlags q) $ do-        putStrLn ""-        actionDump q outfile---actionCmdLine q | Dump{} `elemEnum` queryFlags q = do-    dbs <- getDataBaseFiles (queryFlags q) (fromRight $ query q)-    mapM_ (actionDump q) dbs---actionCmdLine q | not $ usefulQuery $ fromRight $ query q =-    exitMessage ["No query entered"-                ,"Try --help for command line options"]---actionCmdLine q = actionSearch (queryFlags q) (fromRight $ query q)--------------------------------------------------------------------------- SPECIFIC ACTIONS--actionDump :: CmdQuery -> FilePath -> IO ()-actionDump q file = do-    let part = head [x | Dump x <- queryFlags q]-    d <- loadDataBase file-    putStrLn $ "File: " ++ file-    putStr $ showDataBase part d---actionConvert :: CmdQuery -> FilePath -> IO FilePath-actionConvert q infile = do-    let outfile = headDef (replaceExtension infile "hoo") [x | Output x <- queryFlags q]-    putStrLn $ "Converting " ++ infile-    deps <- getDataBaseFilesNoDefault (queryFlags q) (fromRight $ query q)-    convert (Debug `elem` queryFlags q) deps infile outfile-    putStrLn $ "Written " ++ outfile-    -    when (Dump{} `elemEnum` queryFlags q) $ do-        putStrLn ""-        actionDump q outfile-    return outfile---actionTest :: CmdQuery -> FilePath -> IO ()-actionTest q infile = do-    outfile <- actionConvert q{queryFlags = Debug : queryFlags q} infile-    testFile infile outfile
src/CmdLine/All.hs view
@@ -1,10 +1,99 @@+{-|+    Parse a query, that may have come from either a CGI variable+    or the command line arguments. +    Need to return the following pieces of information:++    * Was there a query, or was nothing entered++    * Are you wanting to operate in Web mode or Command Line mode. Adding a+    Web parameter to Command Line gives you Web mode.++    * Which flags were specified, and which were erroneous.+-} module CmdLine.All(-    module CmdLine.Query,-    module CmdLine.Flag,-    module CmdLine.Action+    cmdLine, cmdLineWeb, CmdLine(..), isWebCmdLine,+    module CmdLine.Load     ) where -import CmdLine.Query-import CmdLine.Flag-import CmdLine.Action+import General.Base+import General.System+import CmdLine.Type+import CmdLine.Load+import General.Web+import System.Console.CmdArgs+import Hoogle+import GHC.Conc(numCapabilities)+import Paths_hoogle+import Safe+++---------------------------------------------------------------------+-- CMDLINE EXPANSION++cmdLineExpand :: CmdLine -> IO CmdLine+cmdLineExpand x@Search{} = do+    db <- expandDatabases $ databases x+    return $ x{queryText = s, queryParsed = parseQuery Haskell s, databases = db}+    where s = unwords $ queryChunks x+++cmdLineExpand x@Server{} = do+    dat <- getDataDir+    db <- expandDatabases $ databases x+    let res = if null $ resources x then dat </> "resources" else resources x+    return $ x{databases=db, resources=res}++cmdLineExpand x@Test{} = do+    dat <- getDataDir+    let files1 = if null $ testFiles x then [dat </> "tests.txt"] else testFiles x+        files2 = [dat </> "examples.txt" | example x]+    return x{testFiles = files1 ++ files2}++cmdLineExpand x@Rank{} = do+    file <- if null $ srcfile x then fmap (</> "rank.txt") getDataDir else return $ srcfile x+    return x{srcfile=file}++cmdLineExpand x@Data{} = do+    dir <- if null $ datadir x then fmap (</> "databases") getDataDir else return $ datadir x+    let thrd = if threads x == 0 then numCapabilities else threads x+    loc <- if all null (local x) && not (null $ local x) then guessLocal else return $ local x+    return x{datadir=dir, threads=thrd, local=loc}++cmdLineExpand x = return x+++expandDatabases x = do+    d <- getDataDir+    return $ x ++ [d </> "databases"]+++guessLocal = do+    ghc <- findExecutable "ghc"+    lib <- getLibDir+    let xs = [takeDirectory (takeDirectory lib) </> "doc"] +++             [takeDirectory (takeDirectory ghc) </> "doc/html/libraries" | Just ghc <- [ghc]]+    filterM doesDirectoryExist xs+++---------------------------------------------------------------------+-- QUERY CONVERSION++cmdLine :: IO CmdLine+cmdLine = do+    r <- cgiArgs+    case r of+        Just y -> cmdLineWeb y+        Nothing -> cmdLineArgs+++cmdLineArgs :: IO CmdLine+cmdLineArgs = cmdLineExpand =<< cmdArgsRun cmdLineMode+++cmdLineWeb :: [(String,String)] -> IO CmdLine+cmdLineWeb args = cmdLineExpand $ blankSearch{web=True,+        start=askInt ["start"], count=askInt ["count"], webmode=ask ["mode"],+        queryChunks = maybeToList $ ask ["q","hoogle"]}+    where ask x = listToMaybe [b | (a,b) <- args, a `elem` x]+          askInt x = readMay =<< ask x
− src/CmdLine/Files.hs 
@@ -1,34 +0,0 @@--module CmdLine.Files(getDataBaseFiles, getDataBaseFilesNoDefault) where--import CmdLine.Flag-import General.Glob-import General.Code-import Hoogle.Query.All-import Paths_hoogle(getDataDir)----- pick "default" if there are not ones specified--- otherwise use the CmdFlag and any +package query flags-getDataBaseFiles :: [CmdFlag] -> Query -> IO [FilePath]-getDataBaseFiles flags q = do-    xs <- getDataBaseFilesNoDefault flags q-    if null xs-        then liftM (:[]) $ resolve flags "default"-        else return xs---getDataBaseFilesNoDefault :: [CmdFlag] -> Query -> IO [FilePath]-getDataBaseFilesNoDefault flags q = do-    let dataFil = [x | DataFile x <- flags]-        plusPkg = [x | PlusPackage x <- scope q]-    rs <- mapM (resolve flags) plusPkg-    return $ dataFil ++ rs---resolve :: [CmdFlag] -> String -> IO FilePath-resolve flags x = do-    let inc = [x | Include x <- flags]-    dataDir <- getDataDir-    [x] <- globFile (inc++[dataDir]) ["hoo"] x-    return x
− src/CmdLine/Flag.hs 
@@ -1,261 +0,0 @@-{-|-    Parse a list of flags supported in any of the front ends.--    Returns the flags in a data structure, along with any invalid flags.-    -    Deal with any files/include files in this stage.--}--module CmdLine.Flag(-    CmdFlag(..), flagsHelp,-    flagsWebArgs, flagsWebQuery, flagsCmdLine-    ) where--import General.Code-import General.Glob-------------------------------------------------------------------------- The flags--data CmdFlag = Version           -- ^ Version information-             | Web               -- ^ Operate as a CGI process-             | Help              -- ^ Help text-             | Test              -- ^ Run the regression tests-             | Color Bool        -- ^ Colors on the console-             | Start Int         -- ^ First result to show-             | Count Int         -- ^ Number of results to show-             | Convert FilePath  -- ^ Convert a database-             | Output FilePath   -- ^ Output file-             | Dump String       -- ^ Dump a database to a file (optional section)-             | DataFile FilePath -- ^ Database location-             | Verbose           -- ^ Display verbose information-             | Info              -- ^ Display as much information as you can-             | Debug             -- ^ Do debugging activities-             | Include FilePath  -- ^ Include directory-             | TestFile FilePath -- ^ Run tests in a file-             | Rank FilePath     -- ^ Generate rankings-             | Combine FilePath  -- ^ Merge a set of databases-             | Mode String       -- ^ Web modes-               deriving (Show,Eq {-! Enum !-} )----- | In which circumstances are you allowed to pass this command-data Permission = PWebArgs | PWebQuery | PCmdLine | PMultiple-                  deriving (Show,Eq)--data Argument = ArgNone CmdFlag-              | ArgBool (Bool     -> CmdFlag)-              | ArgInt  (Int      -> CmdFlag)-              | ArgNat  (Int      -> CmdFlag)-              | ArgPos  (Int      -> CmdFlag)-              | ArgFileIn (FilePath -> CmdFlag) [String]-              | ArgFileOut (FilePath -> CmdFlag)-              | ArgDir (FilePath -> CmdFlag)-              | ArgStr  (String   -> CmdFlag)--instance Show Argument where-    show (ArgNone _) = ""-    show (ArgInt  _) = "INT"-    show (ArgNat  _) = "NAT"-    show (ArgPos  _) = "POS"-    show (ArgBool _) = "BOOL"-    show (ArgFileIn _ _) = "FILE"-    show (ArgFileOut _) = "FILE"-    show (ArgDir _) = "DIR"-    show (ArgStr  _) = "STR"---data FlagInfo = FlagInfo {-    argument :: Argument,-    names :: [String],-    permissions :: [Permission],-    description :: String-    }--flagInfo =-    [f (ArgNone Version) ["version","ver"] [PCmdLine] "Print out version information"-    ,f (ArgNone Help) ["?","help","h"] [PCmdLine] "Show help message"-    ,f (ArgNone Web) ["w","web"] [PCmdLine] "Run as though it was a CGI script"-    ,f (ArgBool Color) ["c","color","col","colour"] [PCmdLine] "Show color output (default=false)"-    ,f (ArgPos  Start) ["s","start"] [PCmdLine,PWebArgs] "First result to show (default=1)"-    ,f (ArgPos  Count) ["n","count","length","len"] [PCmdLine,PWebArgs] "Number of results to show (default=all)"-    ,f (ArgNone Test) ["test"] [PCmdLine] "Run the regression tests"-    ,f (ArgFileIn Convert ["txt"]) ["convert"] [PCmdLine,PMultiple] "Convert a database"-    ,f (ArgFileOut Output) ["output"] [PCmdLine] "Output file for convert"-    ,f (ArgStr  Dump) ["dump"] [PCmdLine] "Dump a database for debugging"-    ,f (ArgFileIn DataFile ["hoo"]) ["d","data"] [PCmdLine,PMultiple] "Database file"-    ,f (ArgNone Verbose) ["v","verbose"] [PCmdLine] "Display verbose information"-    ,f (ArgNone Info) ["info"] [PCmdLine] "Display full information on an entry"-    ,f (ArgNone Debug) ["debug"] [PCmdLine] "Debugging only"-    ,f (ArgDir Include) ["i","include"] [PCmdLine,PMultiple] "Include directories"-    ,f (ArgFileIn TestFile ["txt"]) ["testfile"] [PCmdLine,PMultiple] "Run tests from a file"-    ,f (ArgFileIn Rank ["txt"]) ["rank"] [PCmdLine,PMultiple] "Generate ranking scores"-    ,f (ArgFileIn Combine ["hoo"]) ["combine"] [PCmdLine,PMultiple] "Combine multiple databases"-    ,f (ArgStr Mode) ["mode"] [PCmdLine,PWebArgs] "Web mode"-    ]-    where f = FlagInfo---cmdFlagBadArg flag typ "" = "Missing argument to flag " ++ flag ++ ", expected argument of type " ++ typ-cmdFlagBadArg flag "" x = "Unexpected argument to flag " ++ flag ++ ", got \"" ++ x ++ "\""-cmdFlagBadArg flag typ x = "Bad argument to flag " ++ flag ++ ", expected argument of type " ++ typ ++ ", got \"" ++ x ++ "\""--cmdFlagPermission flag = "Flag not allowed when running in this mode, flag " ++ flag--cmdFlagUnknown flag = "Unknown flag " ++ flag--cmdFlagDuplicate flag = "The flag " ++ flag ++ " may only occur once, but occured multiple times"--------------------------------------------------------------------------- Operations on Flags---- | flags that are passed in through web arguments,---   i.e. ?foo=bar&...-flagsWebArgs :: [(String,String)] -> IO ([CmdFlag],[String])-flagsWebArgs = parseFlags PWebArgs----- | flags that are given in the web query string-flagsWebQuery :: [(String,String)] -> IO ([CmdFlag],[String])-flagsWebQuery = parseFlags PWebQuery----- | flags that are given in a query on the command line-flagsCmdLine :: [(String,String)] -> IO ([CmdFlag],[String])-flagsCmdLine = parseFlags PCmdLine---flagsHelp :: String-flagsHelp = unlines . map concat . tabulate $ map f res-    where-        f (a,b,c) = ["  ", "--" <+ a, " --" ++ b, "  " ++ c]--        res = [ (shortOpt (names i) +> typ (argument i), longOpt (names i) ++ typ (argument i), description i)-              | i <- flagInfo, PCmdLine `elem` permissions i]--        shortOpt ([x]:_) = [x]-        shortOpt _ = ""-        -        longOpt ([_]:x:_) = x-        longOpt (x:_) = x--        typ x = ['='|s/=""] ++ s-            where s = show x-        -        x +> y = if null x then "" else x ++ y-        x <+ y = if null y then "" else x ++ y---tabulate :: [[String]]                -- rectangular matrix per lines-         -> [[String]]                -- nicely padded-tabulate = transpose . map sameLen . transpose-   where sameLen xs     = flushLeft ((maximum . map length) xs) xs-         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]--------------------------------------------------------------------------- Parsing Flags---- TODO: check no flag is specified twice--- TODO: Fix a bug, try /merge=t1;t2 and you get [t1,t1,t2,t2]-parseFlags :: Permission -> [(String,String)] -> IO ([CmdFlag],[String])-parseFlags perm xs = do-    let args = concatMap (parseFlag perm) xs-        inc = [x | Right (_,_,_,Include x) <- args]-    incs <- mapM globDir $ ["."|null inc] ++ inc-    (a,b) <- mapAndUnzipM (f incs) args-    return ([Include "."|null inc] ++ concat a, concat b)-    where-        f inc (Right (_,val,FlagInfo{argument=ArgFileIn gen exts},_)) = do-            let vals = parseFile val-            files <- concatMapM (globFile inc exts) vals-            return (map gen files, [])-        f inc (Left v) = return ([],[v])-        f inc (Right (_,_,_,v)) = return ([v],[])----- does all validity checks apart from checking for duplicate flags-parseFlag :: Permission -> (String, String) -> [Either String (String,String,FlagInfo,CmdFlag)]-parseFlag perm (key,val)-        | isNothing m = [Left $ cmdFlagUnknown key]-        | perm `notElem` permissions flg = [Left $ cmdFlagPermission key]-        | null arg = [Left $ cmdFlagBadArg key (show $ argument flg) val]-        | otherwise = [Right (key,val,flg,a) | a <- arg]-    where-        key2 = lower key-        m@ ~(Just flg) = listToMaybe [i | i <- flagInfo, key2 `elem` names i]-        arg = parseArg (argument flg) val---parseArg :: Argument -> String -> [CmdFlag]-parseArg (ArgNone v) xs = [v | null xs]-parseArg (ArgStr  v) xs = [v xs]-parseArg (ArgBool v) xs = map v $ parseBool xs-parseArg (ArgNat  v) xs = map v $ parseNat  xs-parseArg (ArgInt  v) xs = map v $ parseInt  xs-parseArg (ArgPos  v) xs = map v $ parsePos  xs-parseArg (ArgFileIn v _) xs = map v $ parseFile xs-parseArg (ArgFileOut v) xs = map v $ parseFile xs-parseArg (ArgDir v) xs = map v $ parseFile xs---parseNat, parsePos, parseInt :: String -> [Int]-parseNat = filter (>= 0) . parseInt-parsePos = filter (> 0) . parseInt-parseInt x = [a | (a,"") <- reads x]--parseFile :: String -> [String]-parseFile = splitSearchPath--parseBool :: String -> [Bool]-parseBool v | v2 `elem` ["","on","yes","1","true","meep"] = [True]-            | v2 `elem` ["off","no","0","false","moop"] = [False]-            | otherwise = []-    where v2 = lower v--------------------------------------------------------------- DERIVES GENERATED CODE--- DO NOT MODIFY BELOW THIS LINE--- CHECKSUM: 1401092643--instance Enum CmdFlag-    where toEnum 0 = Version{}-          toEnum 1 = Web{}-          toEnum 2 = Help{}-          toEnum 3 = Test{}-          toEnum 4 = Color{}-          toEnum 5 = Start{}-          toEnum 6 = Count{}-          toEnum 7 = Convert{}-          toEnum 8 = Output{}-          toEnum 9 = Dump{}-          toEnum 10 = DataFile{}-          toEnum 11 = Verbose{}-          toEnum 12 = Info{}-          toEnum 13 = Debug{}-          toEnum 14 = Include{}-          toEnum 15 = TestFile{}-          toEnum 16 = Rank{}-          toEnum 17 = Combine{}-          toEnum n = error ((++) "toEnum " ((++) (show n) ", not defined for CmdFlag"))-          fromEnum (Version {}) = 0-          fromEnum (Web {}) = 1-          fromEnum (Help {}) = 2-          fromEnum (Test {}) = 3-          fromEnum (Color {}) = 4-          fromEnum (Start {}) = 5-          fromEnum (Count {}) = 6-          fromEnum (Convert {}) = 7-          fromEnum (Output {}) = 8-          fromEnum (Dump {}) = 9-          fromEnum (DataFile {}) = 10-          fromEnum (Verbose {}) = 11-          fromEnum (Info {}) = 12-          fromEnum (Debug {}) = 13-          fromEnum (Include {}) = 14-          fromEnum (TestFile {}) = 15-          fromEnum (Rank {}) = 16-          fromEnum (Combine {}) = 17
+ src/CmdLine/Load.hs view
@@ -0,0 +1,39 @@++module CmdLine.Load(loadQueryDatabases, availableDatabases) where++import Hoogle+import General.Base+import General.Util+import General.System+++-- | Given a list of search directories, and a query, load the databases you+--   need, and return a list of those that you couldn't find+loadQueryDatabases :: [FilePath] -> Query -> IO ([String],Database)+loadQueryDatabases paths q = do+    let xs = queryDatabases q+    fmap (second mconcat . partitionEithers) $ forM xs $ \x -> do+        r <- findFile [p </> x <.> "hoo" | p <- paths]+        case r of+            Nothing -> do+                r <- findFile [p </> x <.> "txt" | p <- paths]+                case r of+                    Nothing -> return $ Left x+                    Just x -> do+                        src <- readFile x+                        return $ Right $ snd $ createDatabase Haskell [] src+            Just x -> fmap Right $ loadDatabase x+++findFile :: [FilePath] -> IO (Maybe FilePath)+findFile [] = return Nothing+findFile (x:xs) = do+    b <- doesFileExist x+    if b then return $ Just x else findFile xs+++availableDatabases :: [FilePath] -> IO [String]+availableDatabases xs = fmap (sortBy compareString . nub . concat) $ forM xs $ \x -> do+    b <- doesDirectoryExist x+    ys <- if b then getDirectoryContents x else return []+    return [dropExtension y | y <- ys, takeExtension y == ".hoo"]
− src/CmdLine/Query.hs 
@@ -1,76 +0,0 @@-{-|-    Parse a query, that may have come from either a CGI variable-    or the command line arguments.--    Need to return the following pieces of information:--    * Was there a query, or was nothing entered--    * Are you wanting to operate in Web mode or Command Line mode. Adding a-    Web parameter to Command Line gives you Web mode.--    * Which flags were specified, and which were erroneous.--}--module CmdLine.Query(cmdQuery, CmdQuery(..)) where--import General.Code-import Text.ParserCombinators.Parsec--import CmdLine.Flag-import General.CGI-import Hoogle.Query.All---data CmdQuery = CmdQuery {-    queryWeb :: Bool, -- ^ Are you operating from the web (via CGI)-    queryText :: String, -- ^ The string the user entered, @\"\"@ for no string-    query :: Either ParseError Query, -- ^ The actual query-    queryFlags :: [CmdFlag], -- ^ The flags from the query-    queryBadFlags :: [String] -- ^ The bad flags-    } deriving Show----- | Left (query text, error message), null query text = no query given---   Right (query, command line flags, unparsable/unsupported flags)-cmdQuery :: IO CmdQuery-cmdQuery = do-    r <- cgiArgs-    case r of-        Just y -> cmdQueryCGI y-        Nothing -> cmdQueryArgs =<< getArgs---cmdQueryCGI :: [(String,String)] -> IO CmdQuery-cmdQueryCGI [("",x)] = cmdQueryCGI [("q",x)]-cmdQueryCGI xs = do-    (flags1,bad1) <- flagsWebArgs notq-    case parseQuery str of-        Left err -> return $ CmdQuery True str (Left err) flags1 bad1-        Right res -> do-            (flags2,bad2) <- flagsWebQuery $ queryArgs res-            return $ CmdQuery True str (Right res) (flags2++flags1) (bad2++bad1)-    where-        (q,notq) = partition ((`elem` ["q","hoogle"]) . fst) xs-        str = unwords $ map snd q----- TODO: Checking for web and debug specifically are both hacks---       Should parse any arguments it can separately-cmdQueryArgs :: [String] -> IO CmdQuery-cmdQueryArgs xs = case parseCmdLineQuery xs of-    Left err -> return $ CmdQuery (hasFlag ["w","web"]) orig (Left err) [Debug | hasFlag ["debug"]] []-    Right res -> do-        (flags,bad) <- flagsCmdLine $ queryArgs res-        return $ CmdQuery (Web `elem` flags) orig (Right res) flags bad-    where orig = unwords $ map quote xs-          hasFlag names = or [(a++b) `elem` xs | a <- ["/","--"], b <- names]---quote :: String -> String-quote x | any isSpace x = "\"" ++ x ++ "\""-        | otherwise = x---queryArgs :: Query -> [(String,String)]-queryArgs q = [(a,b) | Flag a b <- flags q]
− src/CmdLine/Search.hs 
@@ -1,65 +0,0 @@--module CmdLine.Search(actionSearch) where--import CmdLine.Flag-import CmdLine.Files-import Data.Range-import Data.TagStr-import General.Code-import Hoogle.Query.All-import Hoogle.Search.All-import Hoogle.DataBase.All-import Hoogle.Item.All-import Hoogle.All-import Data.Binary.Defer.Index---actionSearch :: [CmdFlag] -> Query -> IO ()-actionSearch flags q = do-    db <- getDataBaseFiles flags q-    when verbose $-        putStr $ unlines $ "= DATABASES =" : map ("  "++) db--    dbs <- mapM loadDataBase db-    let sug = suggestQuery dbs q-    when (isJust sug) $-        putStrLn $ showTag $ fromJust sug-    when verbose $ putStrLn "= ANSWERS ="--    when (isJust (typeSig q) && color) $ do-        let view = [ArgPosNum i i | i <- [0..10]]-            tags = renderEntryText view $ renderTypeSig $ fromJust $ typeSig q-        putStrLn $ "Searching for: " ++ showTag tags--    let res = search dbs q-    if null res then-        putStrLn "No results found"-     else if Info `elemEnum` flags then do-        let ent = fromLink $ resultEntry $ head res-            pkg = fromLink $ entryPackage ent-        putStrLns 2 $ f $ renderResult $ head res-        putStrLns 2 $ showTag $ renderHaddock $ entryDocs ent-        putStrLn $ "From package " ++ packageName pkg ++ ", version " ++ packageVersion pkg-        putStrLns 1 $ entryURL ent-     else-        putStr $ unlines $ map (f . renderResult) res-    where-        search | start == 0 && count == maxBound = searchAll-               | otherwise = searchRange (rangeStartCount start count)-            where start = headDef 0 [i-1 | Start i <- flags]-                  count = headDef maxBound [i | Count i <- flags]--        verbose = Verbose `elem` flags-        color = Color True `elem` flags-        showTag = if color then showTagConsole else showTagText--        f (m,r,v) = maybe "" (\m -> showModule m ++ " ") m ++-                    showTag r ++ (if verbose then "  -- " ++ v else "")----- Put out a string with some blank links following--- Do not put out the blank lines if no text output-putStrLns :: Int -> String -> IO ()-putStrLns n xs = when (xs /= "") $ do-                     putStr xs-                     putStr $ replicate n '\n'
− src/CmdLine/Test.hs 
@@ -1,60 +0,0 @@--module CmdLine.Test(testFile) where--import Hoogle.All-import Hoogle.Item.All-import General.Code-import Data.Binary.Defer.Index---testFile :: FilePath -> FilePath -> IO ()-testFile srcfile dbfile = do-    putStrLn $ "Testing " ++ srcfile-    db <- loadDataBase dbfile-    src <- readFile srcfile-    let bad = filter (not . runTest db) $ catMaybes $ zipWith parseTest [1..] $ lines src-    if null bad then-        putStrLn "All tests passed"-     else do-        putStr $ unlines $ map failedTest bad-        putStrLn $ show (length bad) ++ " tests failed"----- LineNo Query NoResults YesResults--- NoResults is a list of results that are not allowed to appear--- YesResults are sets of results, which must be in order, and within a set must---            have the same Score-data Test = Test Int String Query [String] [[String]]-            deriving Show---parseTest :: Int -> String -> Maybe Test-parseTest line str | "@test " `isPrefixOf` str =-    case reads $ drop 5 str of-        [(x,rest)] -> case parseQuery x of-            Right q -> let (no,yes) = partition ("!" `isPrefixOf`) $ words rest-                       in Just $ Test line x q (map tail no) (map (split ',') yes)-            _ -> err-        _ -> err-    where err = error $ "Couldn't parse @test on line " ++ show line-parseTest line str = Nothing---runTest :: DataBase -> Test -> Bool-runTest db (Test _ _ q bad ans) =-        ordered (group $ map resultScore res) &&         -- all results are in order-        all (`elem` map fst items) (concat ans) &&       -- all items are present-        ordered (map (map (`lookupJust` items)) ans) &&  -- all items are in order-        all (`notElem` map fst items) bad                -- all the bad items are absent-    where-        res = searchAll [db] q-        items = map (entryName . fromLink . resultEntry &&& resultScore) res--        ordered ((x:xs):(y:ys):zs) = x < y && all (== x) xs && ordered ((y:ys):zs)-        ordered [x:xs] = all (== x) xs-        ordered [] = True---failedTest :: Test -> String-failedTest (Test line str _ _ _) = "Line " ++ show line ++ ", " ++ str-
+ src/CmdLine/Type.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-}++module CmdLine.Type(+    CmdLine(..), cmdLineMode, isWebCmdLine, blankSearch+    ) where++import System.Console.CmdArgs+import Paths_hoogle(version)+import Data.Version(showVersion)+import Hoogle+++isWebCmdLine Search{web=True} = True+isWebCmdLine Server{} = True+isWebCmdLine _ = False+++data CmdLine+    = Search+        {web :: Bool                        -- ^ Are you operating from the web (via CGI)+        ,start :: Maybe Int+        ,count :: Maybe Int+        ,webmode :: Maybe String+        ,info :: Bool+        ,link :: Bool+        ,color :: Bool+        ,repeat_ :: Int+        ,databases :: [FilePath]+        ,queryChunks :: [String]+        +        ,queryParsed :: Either ParseError Query+        ,queryText :: String+        }+    | Test {testFiles :: [String], example :: Bool}+    | Server {port :: Int, databases :: [FilePath], resources :: FilePath, local_ :: Bool}+    | Dump {database :: String, section :: [String]}+    | Rank {srcfile :: FilePath}+    | Combine {srcfiles :: [FilePath], outfile :: String}+    | Convert {srcfile :: String, outfile :: String}+    | Data {datadir :: FilePath, threads :: Int, haddock :: Bool, redownload :: Bool, actions :: [String], local :: [String]}+      deriving (Data,Typeable,Show)++blankSearch = Search False Nothing Nothing Nothing False False False 1 [] [] (Left emptyParseError) ""++cmdLineMode = cmdArgsMode $ modes [search &= auto,test,server,dump,rank,combine,convert,dataa]+    &= verbosity &= program "hoogle"+    &= summary ("Hoogle v" ++ showVersion version ++ ", (C) Neil Mitchell 2004-2010\nhttp://haskell.org/hoogle")++search = Search+    {web = def &= help "Operate as a web tool"+    ,start = def+    ,count = def+    ,webmode = def+    ,queryChunks = def &= args+    ,info = def+    ,link = def+    ,color = def+    ,databases = ["."] &= typDir &= help "Which directories to find databases"+    ,repeat_ = 1+    ,queryParsed = Left emptyParseError &= ignore+    ,queryText = "" &= ignore+    }++test = Test+    {testFiles = def &= typFile &= args+    ,example = def &= help "Test the full examples"+    } &= help "Run tests over a list of files"++server = Server+    {port = 80 &= typ "INT" &= help "Port number"+    ,resources = ""+    ,local_ = def &= help "Rewrite file:/// links and serve them, can be a security hole"+    } &= help "Start a Hoogle server"++dump = Dump+    {database = def &= argPos 0 &= typ "DATABASE"+    ,section = def &= args &= typ "SECTION"+    } &= help "Dump sections of the database to stdout"++rank = Rank+    {srcfile = def &= argPos 0 &= typ "RANKFILE" &= opt ""+    } &= help "Generate ranking information"++combine = Combine+    {srcfiles = def &= args &= typ "DATABASE"+    ,outfile = "default.hoo" &= typFile &= help "Output file (defaults to default.hoo)"+    } &= help "Combine multiple inputs to produce one output"++convert = Convert+    {srcfile = def &= argPos 0 &= typ "TEXTBASE"+    ,outfile = def &= argPos 1 &= typ "DATABASE" &= opt ""+    } &= help "Convert a textbase to a database"++dataa = Data+    {datadir = def &= typDir &= help "Database directory"+    ,haddock = def &= help "Get haddock documentation directly from Hackage"+    ,redownload = def &= help "Always redownload files from the web"+    ,threads = def &= typ "INT" &= name "j" &= help "Number of threads to use"+    ,actions = def &= args &= typ "RULE"+    ,local = def &= opt "" &= typ "FILEPATH" &= help "Use local documentation where found"+    } &= help "Generate Hoogle databases"+      &= details ["Each argument should be the name of a database you want to generate"+                 ,"optionally followed by which files to combine. Common options:"+                 ,""+                 ,"  data default -- equialent to no arguments"+                 ,"  data all"+                 ]
+ src/Console/All.hs view
@@ -0,0 +1,60 @@++module Console.All(action) where++import CmdLine.All+import Recipe.All+import Console.Search+import Console.Test+import Console.Rank+import General.Base+import General.System+import Hoogle+++action :: CmdLine -> IO ()++action x@Search{repeat_=i} | i /= 1 = replicateM_ i $ action x{repeat_=1}++action x@Search{queryParsed = Left err} =+    exitMessage ["Parse error:", "  " ++ showTag (parseInput err)+                ,replicate (columnNo err) ' ' ++ " ^"+                ,errorMessage err]+    where showTag = if color x then showTagANSI else showTagText+++action (Test files _) = do+    testPrepare+    fails <- fmap sum $ mapM (testFile action) files+    if fails == 0+        then putStrLn "Tests passed"+        else putStrLn $ "TEST FAILURES (" ++ show fails ++ ")"++action (Rank file) = rank file++action x@Data{} = recipes x++action (Convert from to) = do+    to <- return $ if null to then replaceExtension from "hoo" else to+    putStrLn $ "Converting " ++ from+    src <- readFile from+    let (err,db) = createDatabase Haskell [] src+    unless (null err) $ putStr $ unlines $ "Warning: parse errors" : map show err+    saveDatabase to db+    putStrLn $ "Written " ++ to++action (Combine from to) = do+    putStrLn $ "Combining " ++ show (length from) ++ " databases"+    xs <- mapM loadDatabase from+    saveDatabase to $ mconcat xs++action (Dump file sections) = do+    d <- loadDatabase file+    putStrLn $ "File: " ++ file+    putStr $ showDatabase d $ if null sections then Nothing else Just sections++action q@Search{} | isBlankQuery $ fromRight $ queryParsed q =+    exitMessage ["No query entered"+                ,"Try --help for command line options"]++action q@Search{} = actionSearch q (fromRight $ queryParsed q)+
+ src/Console/Rank.hs view
@@ -0,0 +1,34 @@++module Console.Rank(rank) where++import General.Base+import Hoogle+++rank :: FilePath -> IO ()+rank file = do+    src <- readFile' file+    res <- scoring $ scores $ parse $ lines src+    putStrLn res+++scores :: ([String], [(String,[String])]) -> [(Score,Score)]+scores (pre,xs) = concatMap trans+    [+        [ fst $ head $ searchAll db q ++ [error $ "Did not find in " ++ query ++ ", " ++ y]+        | y <- ys , let (err,db) = createDatabase Haskell [] $ unlines $ pre ++ ["a::" ++ y]+        , null err || error "Errors while converting rank database"+        ]+    | (query,ys) <- xs, let q = right ("Could not parse query: " ++ query) $ parseQuery Haskell query]+    where right msg = either (\e -> error $ msg ++ "\n" ++ show e) id++trans (x:xs) = map ((,) x) xs ++ trans xs+trans [] = []+++parse :: [String] -> ([String], [(String,[String])])+parse src = (db, [(drop 6 x, filter isReal $ takeWhile (not . isRank) xs) | x:xs <- tails rest, isRank x])+    where+        isReal x = not $ all isSpace x || "--" `isPrefixOf` x+        isRank = isPrefixOf "@rank "+        (db,rest) = break isRank src
+ src/Console/Search.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE RecordWildCards #-}++module Console.Search(actionSearch) where++import CmdLine.All+import General.Base+import General.System+import Hoogle+++actionSearch :: CmdLine -> Query -> IO ()+actionSearch flags q = do+    (missing,dbs) <- loadQueryDatabases (databases flags) q+    unless (null missing) $ do+        n <- availableDatabases (databases flags)+        exitMessage $+            ("Could not find some databases: " ++ unwords missing) :+            "Searching in:" : map ("  "++) (databases flags) ++ [""] +++            (if null n then ["There are no available databases, generate them with: hoogle data"]+             else ["Either the package does not exist or has not been generated"] +++                  ["Generate more databases with: hoogle data all" | length n < 100] +++                  ["Found " ++ show (length n) ++ " databases, including: " ++ unwords (take 5 n) | not $ null n])++    let sug = querySuggestions dbs q+    when (isJust sug) $+        putStrLn $ showTag $ fromJust sug+    when verbose $ putStrLn "= ANSWERS ="++    when (color flags) $+        putStrLn $ "Searching for: " ++ showTag (renderQuery q)++    let res = search dbs q+    if null res then+        putStrLn "No results found"+     else if info flags then do+        let Result{self=self,docs=docs,package=package} = snd $ head res+        putStrLns 2 $ f $ head res+        putStrLns 2 $ showTag docs+        when (isJust package) $ putStrLn $ "From package " ++ snd (fromJust package)+        putStrLns 1 $ showTag $ snd self+     else+        putStr $ unlines $ map f res+    where+        search | start2 == 0 && count2 == maxBound = searchAll+               | otherwise = searchRange (start2,start2+count2-1)+            where start2 = maybe 0 (subtract 1) $ start flags+                  count2 = fromMaybe maxBound $ count flags++        showTag = if color flags then showTagANSI else showTagText+        verbose = False++        f (s,Result{..}) = maybe "" (\m -> snd m ++ " ") modul +++                           showTag (snd self) +++                           (if verbose then "  -- " ++ show s else "") +++                           (if link flags then " -- " ++ fst self else "")+++-- Put out a string with some blank links following+-- Do not put out the blank lines if no text output+putStrLns :: Int -> String -> IO ()+putStrLns n xs = when (xs /= "") $ do+                     putStr xs+                     putStr $ replicate n '\n'
+ src/Console/Test.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE RecordWildCards,PatternGuards,ScopedTypeVariables #-}++-- | Standalone tests are dependent only on themselves, example tests+--   require a fully build Hoogle database.+module Console.Test(testPrepare, testFile) where++import Hoogle+import General.Base+import General.System+import Paths_hoogle+import CmdLine.All+import Test.All+import Control.Exception+import System.Console.CmdArgs+++testPrepare :: IO ()+testPrepare = do+    putStrLn "Running static tests"+    test++    putStrLn "Converting testdata"+    performGC -- clean up the databases+    dat <- getDataDir+    src <- readFile $ dat </> "testdata.txt"+    let (errs, dbOld) = createDatabase Haskell [] src+    unless (null errs) $ error $ unlines $ "Couldn't convert testdata database:" : map show errs+    let dbfile = dat </> "databases/testdata.hoo"+    saveDatabase dbfile dbOld+    db <- loadDatabase dbfile+    when (show dbOld /= show db) $ error "Database did not save properly"+++testFile :: (CmdLine -> IO ()) -> FilePath -> IO Int+testFile run srcfile = do+    putStrLn $ "Testing " ++ srcfile+    src <- readFile' srcfile+    xs <- mapM (runTest run) $ parseTests src+    return $ length $ filter not xs+++data Testcase = Testcase+    {testLine :: Int+    ,testQuery :: String+    ,testResults :: [String]+    }+++parseTests :: String -> [Testcase]+parseTests = f . zip [1..] . lines+    where+        f ((i,x):xs)+            | "--" `isPrefixOf` x = f xs+            | all isSpace x = f xs+            | otherwise = Testcase i x (map snd a) : f b+            where (a,b) = break (all isSpace . snd) xs+        f [] = []+++parseArgs :: String -> [String]+parseArgs "" = []+parseArgs ('\"':xs) = a : parseArgs (drop 1 b)+    where (a,b) = break (== '\"') xs+parseArgs xs = a : parseArgs (dropWhile isSpace b)+    where (a,b) = break isSpace xs+++runTest :: (CmdLine -> IO ()) -> Testcase -> IO Bool+runTest run Testcase{..} = do+    whenLoud $ putStrLn $ "Testing: " ++ testQuery+    args <- withArgs (parseArgs testQuery) cmdLine+    res <- try $ captureOutput $ run args+    case res of+        Left (x :: SomeException) -> putStrLn ("Error, test crashed: " ++ testQuery ++ ", with " ++ show x) >> return False+        Right Nothing -> putStrLn "Can't run tests on GHC < 6.12" >> return False+        Right (Just x) -> case matchOutput testResults (lines x) of+            Nothing -> return True+            Just x -> do+                putStrLn $ "Failed test on line " ++ show testLine ++ "\n" ++ x+                return False+++-- support @reoder, @not, @exact, @now+matchOutput :: [String] -> [String] -> Maybe String -- Nothing is success+matchOutput want got = f want ([],got)+    where+        f [] _ = Nothing+        f (x:xs) a = case match (code x) a of+            Nothing -> Just $ "Failed to match: " ++ x+            Just a -> f xs a++        code ('@':xs) = second (drop 1) $ break (== ' ') xs+        code xs = ("",xs)++        -- given (code,match) (past,future) return Nothing for failure or a new (past,future)+        match :: (String,String) -> ([String],[String]) -> Maybe ([String],[String])+        match ("not",x) (past,future)+            | Just (a,b) <- find x future = Nothing+            | otherwise = Just ([],future)+        match ("reorder",x) (past,future)+            | Just (a,b) <- find x past = Just (a++b, future)+            | Just (a,b) <- find x future = Just (past++a, b)+            | otherwise = Nothing+        match ("now",x) (past,future)+            | Just ([],b) <- find x future = Just ([],b)+            | otherwise = Nothing+        match ("",x) (past,future)+            | Just (a,b) <- find x future = Just (a,b)+            | otherwise = Nothing+        match (code,x) _ = error $ "Unknown test code: " ++ code++        -- given a needle, return Maybe the bits before and after+        find :: String -> [String] -> Maybe ([String],[String])+        find x ys = if null b then Nothing else Just (a,tail b)+            where (a,b) = break (\y -> words x `isInfixOf` words y) ys
src/Data/Binary/Defer.hs view
@@ -1,8 +1,18 @@  module Data.Binary.Defer(     module Data.Binary.Defer.Monad,-    module Data.Binary.Defer.Class+    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 view
@@ -8,7 +8,8 @@ import Data.Binary.Defer import Data.Binary.Raw import System.IO.Unsafe-import Control.Monad.Reader+import Control.Monad.IO.Class+import Control.Monad.Trans.Reader   newtype Array a = Array (A.Array Int a)@@ -46,7 +47,7 @@                 n <- getInt                 h <- asks fst                 s <- ask-                i <- lift $ hGetPos h+                i <- liftIO $ hGetPos h                 let f j = unsafePerformIO $ do                              hSetPos h (i + toInteger (sz*j))                              runReaderT getFixed s
src/Data/Binary/Defer/Class.hs view
@@ -1,10 +1,12 @@  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)  ---------------------------------------------------------------------@@ -36,6 +38,8 @@ 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@@ -55,6 +59,8 @@ 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 ()@@ -70,7 +76,7 @@ putEnumByte x = putByte $ fromIntegral $ fromEnum x  getEnumByte :: Enum a => DeferGet a-getEnumByte = liftM (toEnum . fromIntegral) getByte+getEnumByte = fmap (toEnum . fromIntegral) getByte   instance BinaryDefer Int where@@ -89,7 +95,7 @@  instance BinaryDefer Bool where     put x = putChr (if x then '1' else '0')-    get = liftM (== '1') getChr+    get = fmap (== '1') getChr     size _ = 1     putFixed = put     getFixed = get@@ -198,8 +204,20 @@  instance BinaryDefer a => BinaryDefer (Defer a) where     put (Defer x) = putDefer $ put x-    get = getDefer $ liftM Defer get+    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 view
@@ -1,18 +1,17 @@+{-# LANGUAGE DeriveDataTypeable #-}  module Data.Binary.Defer.Index(     Id,     Index, newIndex,-    Lookup, newLookup, lookupKey, lookupIndex,-    Link, newLink, fromLink, linkKey, indexLinks,-    Index_, newIndex_, getLink, getLookup, indexFreeze+    Link, newLink, fromLink, linkKey, indexLinks     ) where -import General.Util+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 qualified Data.Map as Map-import Data.Maybe-import Data.List+import Data.Ord import Data.Typeable  type Id = Int@@ -22,11 +21,7 @@ -- INDEX  newtype Index a = Index (Array a)---typename_Index = mkTyCon "Data.Binary.Defer.Index.Index"-instance Typeable1 Index where typeOf1 _ = mkTyConApp typename_Index []-instance Typeable a => Typeable (Index a) where typeOf = typeOfDefault+                  deriving Typeable   -- | Items will obtain the Id's 0..length-1@@ -34,9 +29,9 @@ newIndex = Index . array  -instance BinaryDefer a => BinaryDefer (Index a) where+instance (Typeable a, BinaryDefer a) => BinaryDefer (Index a) where     put (Index x) = put x-    get = get1 Index+    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)@@ -45,36 +40,8 @@                 where si = show i             width = length $ show $ arraySize xs -instance Functor Index where-    fmap f (Index x) = Index $ fmap f x - ------------------------------------------------------------------------ LOOKUP--newtype Lookup a = Lookup {lookupKey :: Id}-                   deriving (Eq,Ord)--newLookup :: Id -> Lookup a-newLookup = Lookup--lookupIndex :: Lookup a -> Index a -> a-lookupIndex (Lookup i) (Index xs) = xs ! i---instance BinaryDefer (Lookup a) where-    put (Lookup key) = put key-    get = get1 Lookup-    size _ = size (0 :: Id)-    putFixed (Lookup key) = putFixed key-    getFixed = getFixed1 Lookup---instance Show (Lookup a) where-    show (Lookup key) = "#" ++ show key------------------------------------------------------------------------ -- LINK  data Link a = Link Id a@@ -109,32 +76,19 @@     getFixed = get  -indexLinks :: Index a -> [Link a]-indexLinks (Index x) = zipWith newLink [0..] $ elems x--------------------------------------------------------------------------- INDEXMUTABLE--newtype Index_ a = Index_ (Map.Map a Id)--instance Show a => Show (Index_ a) where-    show = show . indexFreeze---newIndex_ :: Index_ a-newIndex_ = Index_ Map.empty---getLookup :: Ord a => a -> Index_ a -> (Index_ a, Lookup a)-getLookup x y = (a, Lookup $ linkKey b)-    where (a,b) = getLink x y+instance Bin.Binary (Link a) where+    put = Bin.putWord32host . fromIntegral . linkKey+    get = error "Can't implement Data.Binary.Get on Link" -getLink :: Ord a => a -> Index_ a -> (Index_ a, Link a)-getLink x (Index_ mp) = (Index_ mp2, newLink (fromMaybe n res) x)-    where (res,mp2) = Map.insertLookupWithKey (\_ _ a -> a) x n mp-          n = Map.size mp+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 -indexFreeze :: Index_ a -> Index a-indexFreeze (Index_ mp) = newIndex $ map fst $ sortBy (compare `on` snd) $ Map.toList mp+indexLinks :: Index a -> [Link a]+indexLinks (Index x) = zipWith newLink [0..] $ elems x
− src/Data/Binary/Defer/Map.hs 
@@ -1,21 +0,0 @@-{-|-    Provides a BinaryDefer instance for Data.Map--    Defers the entire thing, and every element, but not any keys-    which should give just about the right balance of laziness--}--module Data.Binary.Defer.Map(-    module Data.Map-    ) where--import Control.Monad-import Control.Arrow-import Data.Map-import Data.Binary.Defer-import Data.Binary.Defer.Vector as Vector---instance (Ord k, BinaryDefer k, BinaryDefer v) => BinaryDefer (Data.Map.Map k v) where-    put = putDefer . put . Vector.fromList . Prelude.map (second Defer) . Data.Map.toAscList-    get = getDefer $ liftM (Data.Map.fromAscList . Prelude.map (second fromDefer) . Vector.toList) get
src/Data/Binary/Defer/Monad.hs view
@@ -1,18 +1,22 @@  module Data.Binary.Defer.Monad(     DeferPut, putDefer, runDeferPut,-    putInt, putByte, putChr, putByteString,+    putInt, putByte, putChr, putByteString, putLazyByteString,     DeferGet, getDefer, runDeferGet,-    getInt, getByte, getChr, getByteString,-    getDeferGet, getDeferPut+    getInt, getByte, getChr, getByteString, getLazyByteString,+    getDeferGet, getDeferPut,+    unwrapDeferGet     ) where  import System.IO import System.IO.Unsafe import Data.Binary.Raw-import Control.Monad.Reader+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@@ -26,6 +30,7 @@ -- 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@@ -33,7 +38,7 @@ putValue :: Storable a => a -> DeferPut () putValue x = do     (buf,_,_) <- ask-    lift $ bufferAdd buf x+    liftIO $ bufferAdd buf x  putInt :: Int -> DeferPut () putInt x = putValue (fromIntegral x :: Int32)@@ -48,12 +53,18 @@ putByteString x = do     (buf,_,_) <- ask     putInt $ BS.length x-    lift $ bufferAddByteString buf 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-    lift $ do+    liftIO $ do         p <- bufferPos buf         bufferAdd buf (0 :: Int32) -- to backpatch         modifyIORef ref (DeferPending p x :)@@ -72,15 +83,15 @@ runDeferPendings :: DeferPut () runDeferPendings = do     (_,ref,back) <- ask-    todo <- lift $ readIORef ref-    lift $ writeIORef ref []+    todo <- liftIO $ readIORef ref+    liftIO $ writeIORef ref []     mapM_ runDeferPending todo   runDeferPending :: DeferPending -> DeferPut () runDeferPending (DeferPending pos act) = do     (buf,_,back) <- ask-    lift $ do+    liftIO $ do         p <- bufferPos buf         b <- bufferPatch buf pos (fromIntegral p :: Int32)         unless b $ modifyIORef back (DeferPatchup pos p :)@@ -131,6 +142,17 @@     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@@ -161,26 +183,29 @@ type DeferGet a = ReaderT (Handle, IORef TypeMap.TypeMap) IO a  getInt :: DeferGet Int-getInt  = do h <- asks fst; lift $ hGetInt  h+getInt  = do h <- asks fst; liftIO $ hGetInt  h  getByte :: DeferGet Word8-getByte = do h <- asks fst; lift $ liftM fromIntegral $ hGetByte h+getByte = do h <- asks fst; liftIO $ fmap fromIntegral $ hGetByte h  getChr :: DeferGet Char-getChr  = do h <- asks fst; lift $ hGetChar h+getChr  = do h <- asks fst; liftIO $ hGetChar h  getByteString :: DeferGet BS.ByteString getByteString = do     h <- asks fst-    len <- lift $ hGetInt h-    lift $ BS.hGet h len+    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 <- lift $ hGetInt h+    i <- liftIO $ hGetInt h     s <- ask-    lift $ unsafeInterleaveIO $ do+    liftIO $ unsafeInterleaveIO $ do         hSetPos h (toInteger i)         runReaderT x s @@ -193,10 +218,16 @@ getDeferGet :: Typeable a => DeferGet a getDeferGet = do     ref <- asks snd-    mp <- lift $ readIORef ref+    mp <- liftIO $ readIORef ref     return $ TypeMap.find mp  getDeferPut :: Typeable a => a -> DeferGet () getDeferPut x = do     ref <- asks snd-    lift $ modifyIORef ref $ TypeMap.insert x+    liftIO $ modifyIORef ref $ TypeMap.insert x+++unwrapDeferGet :: DeferGet a -> DeferGet (IO a)+unwrapDeferGet act = do+    s <- ask+    return $ runReaderT act s
− src/Data/Binary/Defer/Trie.hs 
@@ -1,68 +0,0 @@--module Data.Binary.Defer.Trie(-    Trie, newTrie, lookupTrie, unionsWith-    ) where--import Data.Binary.Defer-import Data.List-import Data.Maybe-import General.Code----- Keep simple first, can move to an Array later if necessary--- the second list is always ordered-data Trie a = Trie (Maybe a) [(Char,Trie a)]-              deriving Eq---newTrie :: [(String,a)] -> Trie a-newTrie = newTrieOrdered . sortBy (compare `on` fst)---newTrieOrdered :: [(String,a)] -> Trie a-newTrieOrdered xs = Trie-        (fmap snd $ listToMaybe as)-        (map f $ groupBy ((==) `on` (head . fst)) bs)-    where-        (as,bs) = span (null . fst) xs-        f xs = (head $ fst $ head xs, newTrieOrdered [(a,b) | (_:a,b) <- xs])---lookupTrie :: String -> Trie a -> Maybe a-lookupTrie [] (Trie a b) = a-lookupTrie (x:xs) (Trie a b) = lookup x b >>= lookupTrie xs---unionsWith :: (a -> a -> a) -> [Trie a] -> Trie a-unionsWith f [] = newTrie []-unionsWith f [x] = x-unionsWith f (x:xs) = foldl (unionWith f) x xs---unionWith :: (a -> a -> a) -> Trie a -> Trie a -> Trie a-unionWith merge (Trie x xs) (Trie y ys) = Trie xy $ f xs ys-    where-        xy = case (x,y) of-                  (Just x, Nothing) -> Just x-                  (Nothing, Just y) -> Just y-                  (Just x,  Just y) -> Just $ merge x y-                  (Nothing,Nothing) -> Nothing--        f ((x1,x2):xs) ((y1,y2):ys) = case compare x1 y1 of-            EQ -> (x1,unionWith merge x2 y2) : f xs ys-            LT -> (x1,x2) : f xs ((y1,y2):ys)-            GT -> (y1,y2) : f ((x1,x2):xs) ys-        f xs [] = xs-        f [] ys = ys---instance BinaryDefer a => BinaryDefer (Trie a) where-    put (Trie a b) = putDefer $ put2 a b-    get = getDefer $ get2 Trie--instance Show a => Show (Trie a) where-    show = unlines . f ""-        where-            f str (Trie res xs) =-                [show str ++ " = " ++ show r | Just r <- [res]] ++-                concat [f (str ++ [c]) t | (c,t) <- xs]
− src/Data/Binary/Defer/Vector.hs 
@@ -1,30 +0,0 @@---- TODO: Should probably use ByteString instead?--module Data.Binary.Defer.Vector(-    Vector, toList, fromList-    ) where--import Control.Monad-import Data.Binary.Defer---newtype Vector a = Vector [a]---instance BinaryDefer a => BinaryDefer (Vector a) where-    put (Vector xs) = putDefer $ do-        putInt (length xs)-        mapM_ put xs--    get = getDefer $ do-        i <- getInt-        liftM Vector $ replicateM i get---toList :: Vector a -> [a]-toList (Vector xs) = xs---fromList :: [a] -> Vector a-fromList = Vector
src/Data/Binary/Raw.hs view
@@ -10,7 +10,6 @@     ) where  import System.IO-import Control.Monad import Data.Bits import Data.Word import Data.Char@@ -52,9 +51,9 @@     return $! (w4 `shiftL` 24) .|.               (w3 `shiftL` 16) .|.               (w2 `shiftL`  8) .|.-              (w1)+              w1   hGetByte :: Handle -> IO Int-hGetByte hndl = liftM ord $ hGetChar hndl+hGetByte hndl = fmap ord $ hGetChar hndl
src/Data/Heap.hs view
@@ -9,7 +9,6 @@  import Prelude import qualified Data.Map as Map-import Data.Maybe   -- (k,v) pairs are stored in reverse order
− src/Data/Key.hs 
@@ -1,40 +0,0 @@--module Data.Key(-    Key, keyPair, toKey, fromKey,-    sortKeys, sortWith-    ) where--import Data.List-import General.Code---data Key k v = Key k v---instance Eq k => Eq (Key k v) where-    Key k1 v1 == Key k2 v2 = k1 == k2--instance Ord k => Ord (Key k v) where-    compare (Key k1 v1) (Key k2 v2) = compare k1 k2---keyPair :: k -> v -> Key k v-keyPair = Key---toKey :: (v -> k) -> v -> Key k v-toKey f v = Key (f v) v---fromKey :: Key k v -> v-fromKey (Key k v) = v---sortKeys :: Ord k => [Key k v] -> [v]-sortKeys = map fromKey . sort----- | @sort f == sortBy (compare `on` f)@---   but @f@ will only be applied to each element once-sortWith :: Ord k => (v -> k) -> [v] -> [v]-sortWith f = sortKeys . map (toKey f)
− src/Data/Range.hs 
@@ -1,59 +0,0 @@-{-|-    Invariants: Count >= 0, End >= Start, Start >= 0--    Start/End are 0-based indicies--    Count may be maxBound::Int!--    The rangeStartCount and rangeStartEnd methods ensure the invariants,-    modifying the range if necessary--}--module Data.Range(-    Range,-    rangeStart, rangeCount, rangeEnd,-    rangeStartCount, rangeStartEnd,-    listRange, mergeRanges-    ) where--import Data.List-import General.Code---data Range = Range {rangeStart :: Int, rangeCount :: Int}---instance Show Range where-    show r = "Range {rangeStart = " ++ show (rangeStart r) ++-                  ", rangeCount = " ++ show (rangeCount r) ++-                  ", rangeEnd = " ++ show (rangeEnd r) ++ "}"---nat = max (0::Int)---rangeEnd :: Range -> Int-rangeEnd r = rangeStart r + rangeCount r - 1---rangeStartCount :: Int -> Int -> Range-rangeStartCount start count = Range (nat start) (nat count)---rangeStartEnd :: Int -> Int -> Range-rangeStartEnd start end = Range start2 (nat $ end - start2 + 1)-    where start2 = nat start---listRange :: Range -> [a] -> [a]-listRange r = take (rangeCount r) . drop (rangeStart r)----- make sure in the resultant range--- end r_{n} < (start r_{n+1} - 1)-mergeRanges :: [Range] -> [Range]-mergeRanges = foldr f [] . sortOn rangeStart-    where-        f (Range s1 c1) (Range s2 c2 : rs) | s2 <= s1+c1 = r12 : rs-            where r12 = Range s1 (max c1 (s2-s1 + c2))-        f r rs = [r | rangeCount r > 0] ++ rs
− src/Data/TagStr.hs 
@@ -1,49 +0,0 @@--module Data.TagStr where--import Data.Char-import Data.List-import Data.Generics.Uniplate---data TagStr = Str String-            | Tags [TagStr]-            | TagBold TagStr-            | TagUnderline TagStr-            | TagHyperlink String TagStr-            | TagColor Int TagStr-              deriving Show---instance Uniplate TagStr where-    uniplate (Tags xs) = (xs, Tags)-    uniplate (TagBold x) = ([x], \[x] -> TagBold x)-    uniplate (TagUnderline x) = ([x], \[x] -> TagUnderline x)-    uniplate (TagHyperlink i x) = ([x], \[x] -> TagHyperlink i x)-    uniplate (TagColor i x) = ([x], \[x] -> TagColor i x)-    uniplate x = ([], const x)---showTagText :: TagStr -> String-showTagText x = concat [y | Str y <- universe x]---showTagConsole :: TagStr -> String-showTagConsole x = f [] x-    where-        f a (Str x) = x--        f a t =-            case getCode t of-                Nothing -> g a-                Just val -> tag (val:a) ++ g (val:a) ++ tag a-            where g a = concatMap (f a) (children t)-        -        getCode (TagBold _) = Just "1"-        getCode (TagHyperlink url _) = if null url then Nothing else Just "4"-        getCode (TagUnderline _) = Just "4"-        getCode (TagColor n _) | n <= 5 && n >= 0 = Just ['3', intToDigit (n + 1)]-        getCode _ = Nothing--        tag stack = chr 27 : '[' : (concat $ intersperse ";" $ "0":reverse stack) ++ "m"-
src/Data/TypeMap.hs view
@@ -5,7 +5,6 @@     ) where  import Prelude hiding (lookup)-import Control.Monad import Data.Dynamic import Data.Maybe import qualified Data.Map as Map@@ -19,7 +18,7 @@  lookup :: Typeable a => TypeMap -> Maybe a lookup (TypeMap mp) = res-    where res = liftM (fromJust . fromDynamic) $ Map.lookup (typeOf $ fromJust res) mp+    where res = fmap (fromJust . fromDynamic) $ Map.lookup (typeOf $ fromJust res) mp   find :: Typeable a => TypeMap -> a
+ src/General/Base.hs view
@@ -0,0 +1,69 @@+-- | Module for "pure" things in the base, and things I think should+--   have been in base, or could plausibly be added.+module General.Base(module General.Base, module X) where++import Control.Arrow as X+import Control.Monad as X+import Data.Char as X+import Data.Data as X (Data,Typeable)+import Data.Either as X+import Data.Function as X+import Data.List as X+import Data.Maybe as X+import Data.Monoid as X+import Data.Ord as X+import Debug.Trace as X (trace)+import Numeric as X (readHex,showHex)+import System.FilePath as X hiding (combine)+++type URL = String++fst3 (a,b,c) = a+snd3 (a,b,c) = b+thd3 (a,b,c) = c+++fromLeft (Left x) = x+fromRight (Right x) = x++isLeft Left{} = True; isLeft _ = False+isRight Right{} = True; isRight _ = False+++concatMapM f = liftM concat . mapM f+++unzipEithers :: [Either a b] -> ([a],[b])+unzipEithers [] = ([],[])+unzipEithers (Left x:xs) = (x:a,b)+    where (a,b) = unzipEithers xs+unzipEithers (Right x:xs) = (a,x:b)+    where (a,b) = unzipEithers xs+++initLast :: [a] -> ([a], a)+initLast [] = error "initLast, empty list []"+initLast [x] = ([], x)+initLast (x:xs) = (x:a, b)+    where (a,b) = initLast xs+++lower = map toLower+upper = map toUpper+++readFile' x = do+    src <- readFile x+    length src `seq` return src+++ltrim = dropWhile isSpace+rtrim = reverse . ltrim . reverse+trim = ltrim . rtrim+++chop :: ([a] -> (b, [a])) -> [a] -> [b]+chop _ [] = []+chop f as = b : chop f as'+    where (b, as') = f as
− src/General/CGI.hs 
@@ -1,101 +0,0 @@--{- |-    Parse the CGI arguments--}---module General.CGI(cgiArgs, escape, escapeUpper, escapeLower, asCgi, escapeHTML, escapeAttrib) where--import General.TextUtil-import System.Environment-import Control.Monad-import Data.Maybe-import Data.Char-import Numeric-import Data.List----- The BOA server does not set QUERY_STRING if it would be blank.--- However, it does always set REQUEST_URI.-cgiVariable :: IO (Maybe String)-cgiVariable = do-    str <- envVariable "QUERY_STRING"-    if isJust str-        then return str-        else liftM (liftM $ const "") $ envVariable "REQUEST_URI"---envVariable :: String -> IO (Maybe String)-envVariable x = catch (liftM Just $ getEnv x) (const $ return Nothing)---cgiArgs :: IO (Maybe [(String, String)])-cgiArgs = do x <- cgiVariable-             return $ case x of-                Nothing -> Nothing-                Just y -> Just $ parseArgs $ ['=' | '=' `notElem` y] ++ y---asCgi :: [(String, String)] -> String-asCgi x = concat $ intersperse "&" $ map f x-    where-        f (a,b) = a ++ "=" ++ escape b---parseArgs :: String -> [(String, String)]-parseArgs xs = mapMaybe (parseArg . splitPair "=") $ splitList "&" xs--parseArg Nothing = Nothing-parseArg (Just (a,b)) = Just (unescape a, unescape b)----- | Take an escape encoded string, and return the original-unescape :: String -> String-unescape ('+':xs) = ' ' : unescape xs-unescape ('%':a:b:xs) = unescapeChar a b : unescape xs-unescape (x:xs) = x : unescape xs-unescape [] = []----- | Takes two hex digits and returns the char-unescapeChar :: Char -> Char -> Char-unescapeChar a b = chr $ (f a * 16) + f b-    where-        f x | isDigit x = ord x - ord '0'-            | otherwise = ord (toLower x) - ord 'a' + 10----- | Decide how you want to encode individual characters---   i.e. upper or lower case-escapeWith :: (Char -> Char) -> String -> String-escapeWith f (x:xs) | isAlphaNum x = x : escapeWith f xs-                    | otherwise    = '%' : escapeCharWith f x ++ escapeWith f xs-escapeWith f [] = []---escapeCharWith :: (Char -> Char) -> Char -> String-escapeCharWith f x = case map f $ showHex (ord x) "" of-                          [x] -> ['0',x]-                          x   -> x--escapeUpper = escapeWith toUpper-escapeLower = escapeWith toLower-escape = escapeLower------ | Take a piece of text and escape all the HTML special bits-escapeHTML :: String -> String-escapeHTML = concatMap f-    where-        f '<' = "&lt;"-        f '>' = "&gt;"-        f '&' = "&amp;"-        f  x  = [x]---escapeAttrib :: String -> String-escapeAttrib = concatMap f . escapeHTML-    where-        f '\"' = "&quot;"-        f x = [x]
− src/General/Code.hs 
@@ -1,26 +0,0 @@--module General.Code(-    module General.Util, module Safe,-    module Control.Arrow, module Control.Monad,-    module Data.Char, module Data.Maybe, module Data.List,-    module Debug.Trace, module Control.Exception,-    module System.Cmd, module System.Directory, module System.Environment,-    module System.Exit, module System.FilePath, module System.IO-    ) where--import General.Util-import Safe--import Control.Arrow-import Control.Monad-import Data.Char-import Data.Maybe-import Data.List-import Debug.Trace(trace)-import Control.Exception(assert)-import System.Cmd-import System.Directory-import System.Environment-import System.Exit-import System.FilePath hiding (FilePath,combine)-import System.IO
− src/General/Glob.hs 
@@ -1,62 +0,0 @@--module General.Glob(globFile, globDir) where--import General.Code----- Find the file given directories, extensions, search--- supports * glob key-globFile :: [FilePath] -> [String] -> FilePath -> IO [FilePath]-globFile dirs exts file = f poss-    where-        f [] = exitMessage $ ["Could not find file:"-                             , "    " ++ file-                             ,"Searched:"] ++-                             map ("    " ++) poss-        f (x:xs) = do-            y <- globFileTest x-            if null y then f xs else return y--        exts2 = "" : if hasExtension file then [] else exts-        poss = [d </> file <.> e | d <- dirs, e <- exts2]---globFileTest :: FilePath -> IO [FilePath]-globFileTest file = do-    (dir,fil) <- return $ splitFileName file-    if '*' `notElem` fil then do-        b <- doesFileExist file-        return [file | b]-     else do-        s <- getDirectoryContents $ dropTrailingPathSeparator dir-        concatMapM (f dir fil) s-    where-        f dir fil x = do-            let dirx = dir </> x-            b <- doesFileExist dirx-            return [dirx | b && globMatch fil x]---globMatch :: String -> String -> Bool-globMatch glob s | null glob = False-                 | otherwise =-        head matches `isPrefixOf` s2 && last matches `isSuffixOf` s2 && f matches s2-    where-        norm = if searchPathSeparator == ';' then lower else id-        s2 = norm s-        matches = split '*' $ norm glob--        f []     s  = True-        f (m:ms) [] = False-        f (m:ms) s  | m `isPrefixOf` s = f ms $ drop (length m) s-                    | otherwise = f (m:ms) (tail s)----- check for existence and crash if not-globDir :: FilePath -> IO FilePath-globDir x = do-    x <- canonicalizePath x-    b <- doesDirectoryExist x-    if b then return x else-        exitMessage ["Could not find directory:"-                    , "    " ++ x]
+ src/General/System.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE CPP #-}++-- | Module for system like things in base/directory/etc, or could plausibly be added.+module General.System(module General.System, module X) where++import System.Cmd as X+import System.Directory as X+import System.Environment as X+import System.Exit as X+import System.IO as X+import System.Mem as X (performGC)+++import General.Base+import qualified Control.Exception as E++#if __GLASGOW_HASKELL__ >= 612+import GHC.IO.Handle(hDuplicate,hDuplicateTo)+#endif+++withDirectory dir cmd = E.bracket+    (do x <- getCurrentDirectory; setCurrentDirectory dir; return x)+    setCurrentDirectory+    (const cmd)+++-- FIXME: This could use a lot more bracket calls!+captureOutput :: IO () -> IO (Maybe String)+#if __GLASGOW_HASKELL__ < 612+captureOutput act = return Nothing+#else+captureOutput act = do+    tmp <- getTemporaryDirectory+    (f,h) <- openTempFile tmp "hlint"+    sto <- hDuplicate stdout+    ste <- hDuplicate stderr+    hDuplicateTo h stdout+    hDuplicateTo h stderr+    hClose h+    act+    hDuplicateTo sto stdout+    hDuplicateTo ste stderr+    res <- readFile' f+    removeFile f+    return $ Just res+#endif+++system_ :: String -> IO ()+system_ x = do+    res <- system x+    when (res /= ExitSuccess) $ error $ "System command failed: " ++ x+++exitMessage :: [String] -> IO a+exitMessage msg = putStr (unlines msg) >> exitFailure
− src/General/TextUtil.hs 
@@ -1,64 +0,0 @@-{-|-    General text utility functions--}--module General.TextUtil where--import Prelude-import Data.Maybe-import Data.Char-import Data.List---trim :: String -> String-trim = trimLeft . trimRight-trimLeft = dropWhile isSpace-trimRight = reverse . trimLeft . reverse---isSubstrOf :: Eq a => [a] -> [a] -> Bool-isSubstrOf find list = any (isPrefixOf find) (tails list)---splitList :: Eq a => [a] -> [a] -> [[a]]-splitList find str = if isJust q then a : splitList find b else [str]-    where-        q = splitPair find str-        Just (a, b) = q---splitPair :: Eq a => [a] -> [a] -> Maybe ([a], [a])-splitPair find str = f str-    where-        f [] = Nothing-        f x  | isPrefixOf find x = Just ([], drop (length find) x)-             | otherwise = if isJust q then Just (head x:a, b) else Nothing-                where-                    q = f (tail x)-                    Just (a, b) = q---indexOf find str = length $ takeWhile (not . isPrefixOf (lcase find)) (tails (lcase str))---lcase = map toLower-ucase = map toUpper---replace find with [] = []-replace find with str | find `isPrefixOf` str = with ++ replace find with (drop (length find) str)-                      | otherwise = head str : replace find with (tail str)------- 0 based return-findNext :: Eq a => [[a]] -> [a] -> Maybe Int-findNext finds str = if null maxs then Nothing else Just (fst (head (sortBy compSnd maxs)))-    where-        maxs = mapMaybe f (zip [0..] finds)-        -        f (id, find) = if isJust q then Just (id, length (fst (fromJust q))) else Nothing-            where q = splitPair find str-        -        compSnd (_, a) (_, b) = compare a b
src/General/Util.hs view
@@ -1,115 +1,14 @@  module General.Util where -import Control.Monad-import Data.Char-import Data.List-import Debug.Trace-import System.Directory-import System.Exit-import qualified Data.IntSet as IntSet-import qualified Data.Map as Map-import Control.Arrow-import System.IO.Unsafe--infixl 0 `on`--fst3 (a,b,c) = a-snd3 (a,b,c) = b-thd3 (a,b,c) = c--on f g x y = f (g x) (g y)--swap (a,b) = (b,a)---fix :: Eq a => (a -> a) -> a -> a-fix f x = if x == x2 then x else fix f x2-    where x2 = f x------ | If anyone of them returns Nothing, the whole thing does-mapMaybeAll :: (a -> Maybe b) -> [a] -> Maybe [b]-mapMaybeAll f xs = g [] xs-    where-        g acc [] = Just (reverse acc)-        g acc (x:xs) = case f x of-                           Just a -> g (a:acc) xs-                           Nothing -> Nothing---concatMapMaybeAll :: (a -> Maybe [b]) -> [a] -> Maybe [b]-concatMapMaybeAll f xs = case mapMaybeAll f xs of-                             Just a -> Just $ concat a-                             Nothing -> Nothing---idMaybeAll = mapMaybeAll id-concatIdMaybeAll = concatMapMaybeAll id------ | pick all subsets (maintaining order) with a length of n---   n must be greater or equal to the length of the list passed in-selection :: Int -> [a] -> [[a]]-selection n xs = remove (len-n) len [] xs-    where-        len = length xs-        -        remove lrem lxs done todo =-                if lrem == lxs then [reverse done]-                else if null todo then []-                else remove lrem (lxs-1) (t:done) odo ++ remove (lrem-1) (lxs-1) done odo-            where (t:odo) = todo------ | all permutations of a list-permute :: [a] -> [[a]]-permute [] = [[]]-permute (x:xs) = concatMap (\a -> zipWith f (inits a) (tails a)) (permute xs)-    where-        f a b = a ++ [x] ++ b----catLefts :: [Either a b] -> [a]-catLefts (Left x:xs) = x : catLefts xs-catLefts (_:xs) = catLefts xs-catLefts [] = []---fromLeft (Left x) = x-fromRight (Right x) = x---iff :: Bool -> a -> Maybe a-iff b a = if b then Just a else Nothing---setEq :: Eq a => [a] -> [a] -> Bool-setEq xs ys = all (`elem` ys) xs && all (`elem` xs) ys---elemEnum :: Enum a => a -> [a] -> Bool-elemEnum x ys = fromEnum x `elem` map fromEnum ys----data FileType = File | Directory | NotFound-                deriving (Eq,Show)--fileType :: FilePath -> IO FileType-fileType x = do-    b <- doesFileExist x-    if b then return File else do-        b <- doesDirectoryExist x-        return $ if b then Directory else NotFound+import General.Base  +-- | Only append strings if neither one is empty+(++?) :: String -> String -> String+a ++? b = if null a || null b then [] else a ++ b -sortOn f = sortBy (compare `on` f)+sortOn f = sortBy (comparing f) groupOn f = groupBy ((==) `on` f)  @@ -124,16 +23,6 @@ sortGroupFst mr = groupFst . sortFst $ mr  --nubIntOn :: (v -> Int) -> [v] -> [v]-nubIntOn f = g IntSet.empty-    where-        g m [] = []-        g m (x:xs) | IntSet.member i m = g m xs-                   | otherwise = x : g (IntSet.insert i m) xs-            where i = f x-- fold :: a -> (a -> a -> a) -> [a] -> a fold x f [] = x fold x f xs = fold1 f xs@@ -174,87 +63,14 @@ mergesBy f = fold [] (mergeBy f)  -concatMapM f = liftM concat . mapM f---unzipEithers :: [Either a b] -> ([a],[b])-unzipEithers [] = ([],[])-unzipEithers (Left x:xs) = (x:a,b)-    where (a,b) = unzipEithers xs-unzipEithers (Right x:xs) = (a,x:b)-    where (a,b) = unzipEithers xs---dropEnd :: (a -> Bool) -> [a] -> [a]-dropEnd f = reverse . dropWhile f . reverse--dropEnds :: (a -> Bool) -> [a] -> [a]-dropEnds f = dropWhile f . dropEnd f---initLast :: [a] -> ([a], a)-initLast [] = error "initLast, empty list []"-initLast [x] = ([], x)-initLast (x:xs) = (x:a, b)-    where (a,b) = initLast xs---(!!+) :: [a] -> (Int,a) -> [a]-(!!+) (x:xs) (0,a) = a:xs-(!!+) (x:xs) (n,a) = x : (!!+) xs (n-1,a)---disjoint :: Eq a => [a] -> Bool-disjoint xs = xs == nub xs----- useful command line auxiliary-exitMessage :: [String] -> IO a-exitMessage msg = putStr (unlines msg) >> exitFailure---lower = map toLower-upper = map toUpper-- split :: Eq a => a -> [a] -> [[a]] split x [] = [] split x xs = if null b then [a] else a : split x (tail b)     where (a,b) = break (== x) xs  -traceM :: Monad m => String -> m ()-traceM msg = trace msg $ return ()---traceShow :: Show s => s -> a -> a-traceShow x = trace (show x)---fromListMany :: Ord k => [(k,v)] -> Map.Map k [v]-fromListMany = Map.fromAscList . groupFsts . sortFst---consNub :: Eq a => a -> [a] -> [a]-consNub x xs = [x | x `notElem` xs] ++ xs---showLines :: Show a => [a] -> String-showLines = unlines . map show---traceInline :: String -> a -> a-traceInline msg x = unsafePerformIO $ do-    putStr msg-    return x---errorLines :: [String] -> b-errorLines [] = error "errorLines, finished"-errorLines (x:xs) = trace x $ errorLines xs-- rep from to x = if x == from then to else x+reps from to = map (rep from to)   -- | Like splitAt, but also return the number of items that were split.@@ -267,3 +83,27 @@         f i (x:xs) = (a,x:b,c)             where (a,b,c) = f (i-1) xs ++rbreak f xs = case break f $ reverse xs of+    (_, []) -> (xs, [])+    (as, b:bs) -> (reverse bs, b:reverse as)+++compareCaseless :: String -> String -> Ordering+compareCaseless x = compare (map toLower x) . map toLower+++-- compare strings, but with an ordering that puts 'a' < 'A' < 'b' < 'B'+compareString :: String -> String -> Ordering+compareString (x:xs) (y:ys) = case compareChar x y of+    EQ -> compareString xs ys+    x -> x+compareString [] [] = EQ+compareString xs ys = if null xs then LT else GT+++compareChar :: Char -> Char -> Ordering+compareChar x y = case (compare x y, compare (toLower x) (toLower y)) of+    (EQ, _) -> EQ+    (x, EQ) -> if x == GT then LT else GT+    (_, x ) -> x
+ src/General/Web.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE PatternGuards #-}++{- |+    General web utility functions.+-}++module General.Web(+    filePathToURL, combineURL, escapeURL, (++%), unescapeURL,+    escapeHTML, (++&), htmlTag,+    cgiArgs,+    parseHttpQueryArgs+    ) where++import General.System+import General.Base+import Network.HTTP++instance Functor Response where+    fmap f x = x{rspBody = f $ rspBody x}+++---------------------------------------------------------------------+-- HTML STUFF++-- | Take a piece of text and escape all the HTML special bits+escapeHTML :: String -> String+escapeHTML = concatMap f+    where+        f '<' = "&lt;"+        f '>' = "&gt;"+        f '&' = "&amp;"+        f  x  = [x]+++-- | Escape the second argument as HTML before appending+(++&) :: String -> String -> String+a ++& b = a ++ escapeHTML b+++htmlTag :: String -> String -> String+htmlTag x y = "<" ++ x ++ ">" ++ y ++ "</" ++ x ++ ">"+++---------------------------------------------------------------------+-- URL STUFF++filePathToURL :: FilePath -> URL+filePathToURL xs = "file://" ++ ['/' | not $ "/" `isPrefixOf` ys] ++ ys+    where ys = map (\x -> if isPathSeparator x then '/' else x) xs+++combineURL :: String -> String -> String+combineURL a b+    | any (`isPrefixOf` b) ["http:","https:","file:"] = b+    | otherwise = a ++ b+++-- | Take an escape encoded string, and return the original+unescapeURL :: String -> String+unescapeURL ('+':xs) = ' ' : unescapeURL xs+unescapeURL ('%':a:b:xs) | [(v,"")] <- readHex [a,b] = chr v : unescapeURL xs+unescapeURL (x:xs) = x : unescapeURL xs+unescapeURL [] = []+++escapeURL :: String -> String+escapeURL = concatMap f+    where+        f x | isAlphaNum x || x `elem` "-" = [x]+            | x == ' ' = "+"+            | otherwise = '%' : ['0'|length s == 1] ++ s+            where s = showHex (ord x) ""+++-- | Escape the second argument as a CGI query string before appending+(++%) :: String -> String -> String+a ++% b = a ++ escapeURL b++---------------------------------------------------------------------+-- CGI STUFF++-- The BOA server does not set QUERY_STRING if it would be blank.+-- However, it does always set REQUEST_URI.+cgiVariable :: IO (Maybe String)+cgiVariable = do+    str <- envVariable "QUERY_STRING"+    if isJust str+        then return str+        else fmap (fmap $ const "") $ envVariable "REQUEST_URI"+++envVariable :: String -> IO (Maybe String)+envVariable x = catch (fmap Just $ getEnv x) (const $ return Nothing)+++cgiArgs :: IO (Maybe [(String, String)])+cgiArgs = do+    x <- cgiVariable+    return $ case x of+        Nothing -> Nothing+        Just y -> Just $ parseHttpQueryArgs $ ['=' | '=' `notElem` y] ++ y+++---------------------------------------------------------------------+-- HTTP STUFF++parseHttpQueryArgs :: String -> [(String, String)]+parseHttpQueryArgs xs = mapMaybe (f . splitPair "=") $ splitList "&" xs+    where f Nothing = Nothing+          f (Just (a,b)) = Just (unescapeURL a, unescapeURL b)+++splitList :: Eq a => [a] -> [a] -> [[a]]+splitList find str = if isJust q then a : splitList find b else [str]+    where+        q = splitPair find str+        Just (a, b) = q+++splitPair :: Eq a => [a] -> [a] -> Maybe ([a], [a])+splitPair find str = f str+    where+        f [] = Nothing+        f x  | isPrefixOf find x = Just ([], drop (length find) x)+             | otherwise = if isJust q then Just (head x:a, b) else Nothing+                where+                    q = f (tail x)+                    Just (a, b) = q
+ src/Hoogle.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- The plan, over time, is to make this module simply reexport things, integrating the wrapper+-- layer back into Hoogle proper++-- | The Hoogle API.+module Hoogle(+    -- * Utility types+    module Hoogle.Type.TagStr,+    H.ParseError(..), H.emptyParseError,+    URL,+    Language(..),+    -- * Database+    Database, loadDatabase, saveDatabase, createDatabase, showDatabase,+    -- * Query+    Query, parseQuery, H.renderQuery, H.isBlankQuery,+    queryDatabases, querySuggestions, queryCompletions,+    -- * Score+    Score, H.scoring,+    -- * Search+    Result(..), searchAll, searchRange+    ) where++import Data.Binary.Defer.Index+import Data.Data+import General.Base+import General.System++import Hoogle.Type.TagStr+import qualified Hoogle.DataBase.All as H+import qualified Hoogle.Query.All as H+import qualified Hoogle.Score.All as H+import qualified Hoogle.Search.All as H+import qualified Hoogle.Type.All as H+import qualified Hoogle.Language.Haskell as H++import Hoogle.Query.All(Query)+import Hoogle.Score.All(Score)+++-- * Utility types++data Language = Haskell+    deriving (Enum,Read,Show,Eq,Ord,Bounded,Data,Typeable)++-- * Database++newtype Database = Database [H.DataBase]++toDataBase (Database x) = H.combineDataBase x+fromDataBase x = Database [x]++instance Monoid Database where+    mempty = Database []+    mappend (Database xs) (Database ys) = Database $ xs ++ ys++instance Show Database where+    show = show . toDataBase+++loadDatabase :: FilePath -> IO Database+loadDatabase = fmap fromDataBase . H.loadDataBase+++showDatabase :: Database -> Maybe [String] -> String+showDatabase x sects = concatMap (`H.showDataBase` toDataBase x) $ fromMaybe [""] sects+++-- | From a textbase lines we have currently+createDatabase :: Language -> [Database] -> String -> ([H.ParseError], Database)+createDatabase _ dbs src = (err, fromDataBase $ H.createDataBase xs res)+    where+        (err,res) = H.parseInputHaskell src+        xs = concat [x | Database x <- dbs]+++saveDatabase :: FilePath -> Database -> IO ()+saveDatabase file x = do+    performGC+    H.saveDataBase file $ toDataBase x+++-- Hoogle.Query+parseQuery :: Language -> String -> Either H.ParseError Query+parseQuery _ = H.parseQuery++queryDatabases :: Query -> [String]+queryDatabases x = if null ps then ["default"] else ps+    where ps = [p | H.PlusPackage p <- H.scope x]++querySuggestions :: Database -> Query -> Maybe TagStr+querySuggestions (Database dbs) q = H.suggestQuery dbs q++queryCompletions :: Database -> String -> [String]+queryCompletions x = H.completions (toDataBase x)+++-- Hoogle.Search++data Result = Result+    {package :: Maybe (URL, String)+    ,modul :: Maybe (URL, String)+    ,self :: (URL, TagStr)+    ,docs :: TagStr+    }++toResult :: H.Result -> (Score,Result)+toResult r@(H.Result entry view score) = (score, Result package modul self docs)+    where+        ent = fromLink entry+        (text,_) = H.renderResult r++        package = fmap ((H.entryURL &&& H.entryName) . fromLink) $ H.entryPackage ent+        modul = fmap ((H.entryURL &&& H.entryName) . fromLink) $ H.entryModule ent+        self = (H.entryURL ent, text)+        docs = H.renderDocumentation $ H.entryDocs ent+++searchAll :: Database -> Query -> [(Score,Result)]+searchAll (Database xs) q = map toResult $ H.searchAll xs q+++-- | A pair of bounds. These bounds are the lowest and highest indices in the array, in that order.+--   For example, the first 10 elements are (0,9) and the next 10 are (10,19)+searchRange :: (Int,Int) -> Database -> Query -> [(Score,Result)]+searchRange (a,b) (Database xs) q = map toResult $ H.searchRange (a,b) xs q
− src/Hoogle/All.hs 
@@ -1,14 +0,0 @@--module Hoogle.All(-    Query(..), parseQuery, renderQuery, suggestQuery, usefulQuery,-    Flag(..),-    DataBase, loadDataBase, showDataBase,-    convert, rank, combine,-    searchAll, searchRange, Result(..),-    completions-    ) where--import Hoogle.Query.All-import Hoogle.DataBase.All-import Hoogle.Search.All-import Hoogle.Operations.All
src/Hoogle/DataBase/Aliases.hs view
@@ -1,14 +1,14 @@  module Hoogle.DataBase.Aliases(-    Aliases, createAliases, normAliases, mergeAliases+    Aliases, createAliases, normAliases     ) where -import Hoogle.TextBase.All-import Hoogle.TypeSig.All-import qualified Data.Binary.Defer.Map as Map+import Hoogle.Type.All+import qualified Data.Map as Map import Data.Binary.Defer import Data.Generics.Uniplate-import General.Code+import General.Base+import Safe   newtype Aliases = Aliases {fromAliases :: Map.Map String Alias}@@ -23,7 +23,7 @@   data Alias = Alias-    {args :: [String] -- the free variables+    {_args :: [String] -- the free variables     ,rhs :: Type -- the resulting type     } @@ -32,16 +32,22 @@     get = get2 Alias  -createAliases :: [Aliases] -> [TextItem] -> Aliases+createAliases :: [Aliases] -> [Fact] -> Aliases createAliases deps ti = mergeAliases (a:deps)     where         a = Aliases $ transitiveClosure $ Map.fromList             [ (name, Alias [v | TVar v <- args] rhs)-            | ItemAlias (TypeSig _ lhs) (TypeSig _ rhs) <- ti+            |  FactAlias (TypeSig _ lhs) (TypeSig _ rhs) <- ti             , let (TLit name, args) = fromTApp lhs]   -- the first is the most important+instance Monoid Aliases where+    mempty = mergeAliases []+    mappend x y = mergeAliases [x,y]+    mconcat = mergeAliases++ mergeAliases :: [Aliases] -> Aliases mergeAliases [x] = x mergeAliases xs = Aliases $ transitiveClosure $ Map.unions $ map fromAliases xs
src/Hoogle/DataBase/All.hs view
@@ -1,49 +1,51 @@  module Hoogle.DataBase.All     (DataBase, showDataBase-    ,TextScore, TypeScore     ,module Hoogle.DataBase.All     ,module Hoogle.DataBase.Serialise     ) where  import Data.Binary.Defer.Index-import Hoogle.TextBase.All-import Hoogle.TypeSig.All+import Data.Monoid import Hoogle.DataBase.Type-import Hoogle.Item.All+import Hoogle.Type.All+import Hoogle.Score.All import Hoogle.DataBase.Serialise-import General.Code  -createDataBase :: [DataBase] -> TextBase -> DataBase-createDataBase deps xs = DataBase items-        (createNameSearch ys) (createTypeSearch as is ys)-        (createSuggest (map suggest deps) zs) as is+createDataBase :: [DataBase] -> Input -> DataBase+createDataBase deps (facts,xs) = DataBase items+        ns (createTypeSearch as is tys)+        (createSuggest (map suggest deps) facts) as is     where         items = createItems xs         ys = entriesItems items-        zs = map fst xs-        as = createAliases (map aliases deps) zs-        is = createInstances (map instances deps) zs+        ns = createSubstrSearch [(entryKey $ fromLink y, y) | y <- ys]+        as = createAliases (map aliases deps) facts+        is = createInstances (map instances deps) facts+        tys = [(sig, x) | x <- ys, Just sig <- [entryType $ fromLink x]]  + combineDataBase :: [DataBase] -> DataBase combineDataBase dbs = DataBase items_-        (createNameSearch ys) (createTypeSearch as is ys)+        ns (createTypeSearch as is tys)         ss as is     where-        items_ = mergeItems $ map items dbs+        items_ = mconcat $ map items dbs         ys = entriesItems items_-        ss = mergeSuggest $ map suggest dbs-        as = mergeAliases $ map aliases dbs-        is = mergeInstances $ map instances dbs+        ns = createSubstrSearch [(entryKey $ fromLink 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]]  -searchName :: DataBase -> String -> [(Link Entry,EntryView,TextScore)]-searchName db = searchNameSearch (nameSearch db)+searchName :: DataBase -> String -> [(Link Entry,EntryView,Score)]+searchName db = searchSubstrSearch (nameSearch db)  -searchType :: DataBase -> TypeSig -> [(Link Entry,[EntryView],TypeScore)]+searchType :: DataBase -> TypeSig -> [(Link Entry,[EntryView],Score)] -- although aliases and instances are given, they are usually not used searchType db = searchTypeSearch (aliases db) (instances db) (typeSearch db) @@ -53,4 +55,4 @@   completions :: DataBase -> String -> [String]-completions db = completionsNameSearch (nameSearch db)+completions db = completionsSubstrSearch (nameSearch db)
src/Hoogle/DataBase/Instances.hs view
@@ -1,15 +1,13 @@  module Hoogle.DataBase.Instances(-    Instances, createInstances, mergeInstances,+    Instances, createInstances,     normInstances, hasInstance     ) where -import General.Code-import Hoogle.TextBase.All-import Hoogle.TypeSig.All+import General.Base+import Hoogle.Type.All import Data.Binary.Defer-import qualified Data.Binary.Defer.Map as Map-import Data.Generics.Uniplate+import qualified Data.Map as Map   -- Map type [classes]@@ -25,13 +23,18 @@     get = get1 Instances  -createInstances :: [Instances] -> [TextItem] -> Instances+createInstances :: [Instances] -> [Fact] -> Instances createInstances deps xs = mergeInstances (i:deps)     where         i = Instances $ foldl f Map.empty ys-        ys = [(v, c) | ItemInstance (TypeSig [] (TApp (TLit c) vs)) <- xs, TLit v <- vs]+        ys = [(v, c) | FactInstance (TypeSig [] (TApp (TLit c) vs)) <- xs, TLit v <- vs]         f mp (v,c) = Map.insertWith (++) v [c] mp ++instance Monoid Instances where+    mempty = mergeInstances []+    mappend x y = mergeInstances [x,y]+    mconcat = mergeInstances  mergeInstances :: [Instances] -> Instances mergeInstances = Instances . Map.unionsWith (\x y -> nub $ x ++ y) . map fromInstances
src/Hoogle/DataBase/Items.hs view
@@ -1,108 +1,63 @@+{-# LANGUAGE RecordWildCards, PatternGuards #-} -module Hoogle.DataBase.Items where+module Hoogle.DataBase.Items(Items, createItems, entriesItems) where -import Control.Monad.State import Data.Binary.Defer.Index-import General.Code-import Hoogle.TextBase.All-import Hoogle.TypeSig.All-import Hoogle.Item.All+import 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  -- Invariant: Index Entry is by order of EntryScore+newtype Items = Items (Index Entry) -data Items = Items-    {packages :: Index Package-    ,modules :: Index Module-    ,entries :: Index Entry-    }+entriesItems :: Items -> [Link Entry]+entriesItems (Items x) = indexLinks x + instance BinaryDefer Items where-    put (Items a b c) = put3 a b c-    get = do-        res@(Items a b c) <- get3 Items-        getDeferPut a-        getDeferPut b-        getDeferPut c-        return res+    put (Items a) = put1 a+    get = get1 Items   instance Show Items where-    show (Items a b c) = f "Packages" a ++ "\n" ++ f "Modules" b ++ "\n" ++ f "Entries" c-        where f header x = "== " ++ header ++ " ==\n\n" ++ show x----- temporary state structure-data S a = S {count :: Int, values :: [a]}--newS = S (-1) []-newIndexS = newIndex . reverse . values-addS x (S i xs) = S (i+1) (x:xs)-getS (S i (x:xs)) = newLink i x-getS _ = error "DataBase.Items.getS, lacking a package/module?"---entriesItems :: Items -> [Link Entry]-entriesItems = indexLinks . entries+    show (Items x) = "== Entries ==\n\n" ++ show x  -createItems :: [(TextItem,String)] -> Items-createItems xs = Items (newIndexS pkgs) (newIndexS mods)-                       (newIndex $ sortOn entryScore ents)-    where-        (ents, (pkgs,mods)) = flip runState (newS,newS) $ concatMapM addTextItem $ init $ tails xs+instance Monoid Items where+    mempty = mergeItems []+    mappend x y = mergeItems [x,y]+    mconcat = mergeItems  --- add a TextItem to the state S-addTextItem :: [(TextItem,String)] -> State (S Package, S Module) [Entry]-addTextItem ((ti,doc):rest) = case ti of-    ItemInstance{} -> return []--    ItemAttribute "keyword" name ->-        add False EntryKeyword [Keyword "keyword",Text " ",Focus name]--    ItemAttribute "package" name -> do-        modify $ \(ps,ms) -> (addS (addPkg (Package name "" "" "") rest) ps, ms)-        add False EntryPackage [Keyword "package",Text " ",Focus name]--    ItemAttribute _ _ -> return []--    ItemModule xs -> do-        modify $ \(ps,ms) -> (ps, addS (Module xs) ms)-        add True EntryModule [Keyword "module", Text $ ' ' : concatMap (++ ".") (init xs), Focus (last xs)]--    _ -> add True EntryOther (renderTextItem ti)+createItems :: [TextItem] -> Items+createItems xs = mergeItems [Items $ newIndex $ fs Nothing Nothing $ zip [0..] xs]     where-        add modu typ txt = do-            (ps,ms) <- get-            let sig = case ti of ItemFunc _ s -> Just (Defer s); _ -> Nothing-            return [Entry (if modu then Just $ getS ms else Nothing) (getS ps)-                          (headDef "" [i | Focus i <- txt])-                          txt typ (newHaddock doc) sig]+        fs pkg mod [] = []+        fs pkg mod ((i,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 -        addPkg pkg ((ItemAttribute "version" x,_) : xs) = addPkg pkg{packageVersion=x} xs-        addPkg pkg ((ItemAttribute "haddock" x,_) : xs) = addPkg pkg{haddockURL    =x} xs-        addPkg pkg ((ItemAttribute "hackage" x,_) : xs) = addPkg pkg{hackageURL    =x} xs-        addPkg pkg _ = pkg+        f pkg mod TextItem{..} = Entry pkg mod itemName itemDisp+            (htmlDocumentation itemDocs) url 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+                      | 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 mergeItems :: [Items] -> Items-mergeItems [x] = x-mergeItems xs = Items-        (newIndex $ concat $ reverse ps)-        (newIndex $ concat $ reverse ms)-        (newIndex $ sortOn entryScore $ concat $ reverse es)+mergeItems xs = Items $ newIndex $ map ren ijv     where-        (pi,ps,mi,ms,ei,es) = foldl' f (0,[],0,[],0,[]) xs--        f (pi,ps,mi,ms,ei,es) (Items p m e) =-                (pi+length p3,p3:ps, mi+length m3,m3:ms, ei+length e3,e3:es)-            where-                (p2,p3) = add pi p id-                (m2,m3) = add mi m id-                (e2,e3) = add ei e $ \x -> x{entryModule = liftM (\x -> m2 !! linkKey x) $ entryModule x-                                            ,entryPackage = p2 !! linkKey (entryPackage x)}+        -- xs are sets of items, vs are sets of values, is index xs, js index vs+        mp = Map.fromList [(ij, newLink n v) | (n,(ij,v)) <- zip [0..] ijv]+        ijv = sortOn (entryScore . snd) [((i,linkKey jv),fromLink jv) | (i,Items vs) <- zip [0..] xs, jv <- indexLinks vs] -                add i xs f = (zipWith newLink [i..] xs2, xs2)-                    where xs2 = map (f . fromLink) $ indexLinks xs+        ren (ij,v) = v{entryPackage = f ij $ entryPackage v, entryModule = f ij $ entryModule v}+        f _ Nothing = Nothing+        f (i,j) (Just e) = Just $ mp Map.! (i,linkKey e)
− src/Hoogle/DataBase/NameSearch.hs 
@@ -1,229 +0,0 @@--module Hoogle.DataBase.NameSearch-    (NameSearch, createNameSearch-    ,TextScore, searchNameSearch-    ,completionsNameSearch-    ) where--import Data.Binary.Defer-import Data.Binary.Defer.Array-import Data.Binary.Defer.Index-import qualified Data.Map as Map-import Data.Range-import General.Code-import Hoogle.Item.All-import Hoogle.TextBase.All--------------------------------------------------------------------------- DATA TYPES--{--The idea is that NameItem's are sorted by name, so exact/start matching-is done by binary searching this list.--The rest of the results are taken by unioning all the suggestions in the-second element, and searching in order. All the results will end up-sorted by name (since they have identical names)--The original code was based around a Trie, gave fast performance, but-didn't merge common strings and consumed about 10x the disk space.--}---data NameSearch = NameSearch (Array NameItem) [(Char, IntList)]--data NameItem = NameItem {key :: String-                         ,rest :: Defer [(String, [Link Entry])]}---instance Show NameSearch where-    show (NameSearch a b) =-            concat (zipWith (\a b -> show a ++ " " ++ show b) [0..] (elems a)) ++-            unlines [c : " = " ++ show d | (c,d) <- b]--instance Show NameItem where-    show (NameItem a b) = unlines $ a : map f (fromDefer b)-        where f (a,b) = unwords $ " " : a : ['#' : show (linkKey x) | x <- b]--instance BinaryDefer NameSearch where-    put (NameSearch a b) = put2 a b-    get = get2 NameSearch--instance BinaryDefer NameItem where-    put (NameItem a b) = put2 a b-    get = get2 NameItem--------------------------------------------------------------------------- CREATION--createNameSearch :: [Link Entry] -> NameSearch-createNameSearch xs = NameSearch (array $ Map.elems items) (Map.toList shortcuts)-    where-        items = buildItems xs-        shortcuts = buildShortcuts items---buildShortcuts :: Map.Map String NameItem -> Map.Map Char IntList-buildShortcuts = Map.map (toIntList . sort) . foldl' add Map.empty . zip [0..] . Map.keys-    where-        add mp (i,s) = foldl' g mp $ nub s-            where g mp x = Map.insertWith (++) x [i] mp---buildItems :: [Link Entry] -> Map.Map String NameItem-buildItems = Map.map norm . foldl' add Map.empty-    where-        add mp e = Map.insertWith f ltext (NameItem ltext $ Defer [(text, [e])]) mp-            where-                text = entryName $ fromLink e-                ltext = map toLower text--                f _ (NameItem a b) = NameItem a $ Defer $ g $ fromDefer b-                g [] = [(text, [e])]-                g ((x1,x2):xs) | x1 == text = (x1, e : x2) : xs-                               | otherwise = (x1,x2) : g xs--        norm (NameItem a b) = NameItem a $ Defer $ f $ fromDefer b-            where f x = sortFst [(a, sortOn linkKey b) | (a,b) <- x]--------------------------------------------------------------------------- SEARCHING---- lower is better-data TextScore = TSExact | TSStart | TSNone-                 deriving (Eq,Ord)--instance Show TextScore where-    show TSExact = "exact"-    show TSStart = "start"-    show TSNone = "_"---{--Step 1: Binary search for find the exact match-Step 2: Follow from that item finding ones which start-Step 3: Use the hint set to merge into a list of results--}--searchNameSearch :: NameSearch -> String -> [(Link Entry,EntryView,TextScore)]-searchNameSearch (NameSearch items shortcuts) str = step1 ++ step2 ++ step3-    where-        lstr = map toLower str-        nstr = length str-        rangePrefix = FocusOn $ rangeStartCount 0 nstr--        (exact,prefix) = startPos items lstr-        (prefixes,lastpre) = followPrefixes items lstr prefix---        step1 = if isJust exact then f TSExact yes ++ f TSStart no else []-            where-                (yes,no) = partition ((==) str . fst) $ fromDefer $ rest $ items ! fromJust exact-                f scr xs = [(x, rangePrefix, scr) | x <- concatMap snd xs]--        step2 = [(x, rangePrefix, TSStart) | x <- prefixes]--        seen i = fromMaybe prefix exact <= i && i <= lastpre-        step3 = [(e,view,TSNone) | i <- xs, let x = items ! i-                , Just p <- [testMatch lstr $ key x]-                , let view = FocusOn $ rangeStartCount p nstr-                , e <- concatMap snd $ fromDefer $ rest x]-            where xs = filter (not . seen) $ intersectOrds $-                       map (maybe [] fromIntList . flip lookup shortcuts) $ nub lstr----- Return the index of the string as the first component--- Return the first possible index of the prefix as the second-startPos :: Array NameItem -> String -> (Maybe Int, Int)-startPos xs x = f 0 (arraySize xs - 1)-    where-        f low high | high - low < 3 = g low high-                   | otherwise =-            case compare x (key $ xs ! mid) of-                    EQ -> (Just mid, mid+1)-                    GT -> f (mid+1) high-                    LT -> f low (mid-1)-            where-                mid = (high + low) `div` 2--        g low high | low > high = (Nothing, low)-        g low high = if k == x then (Just low, low+1)-                     else if x `isPrefixOf` k then (Nothing, low)-                     else g (low+1) high-            where k = key $ xs ! low----- Return all the items you can match following the prefix--- Plus the last item that was a valid prefix index-followPrefixes :: Array NameItem -> String -> Int -> ([Link Entry], Int)-followPrefixes xs x i = f i-    where-        n = arraySize xs-        f i | i < n && x `isPrefixOf` key xsi = (concatMap snd (fromDefer $ rest xsi) ++ res, end)-            | otherwise = ([],i-1)-            where xsi = xs ! i-                  (res,end) = f (i+1)---testMatch :: String -> String -> Maybe Int-testMatch find within = listToMaybe [i | (i,x) <- zip [0..] $ tails within, find `isPrefixOf` x]---intersectOrd :: [Int] -> [Int] -> [Int]-intersectOrd (x:xs) (y:ys) = case compare x y of-    EQ -> x : intersectOrd xs ys-    LT -> intersectOrd xs (y:ys)-    GT -> intersectOrd (x:xs) ys-intersectOrd _ _ = []---intersectOrds :: [[Int]] -> [Int]-intersectOrds = fold1 intersectOrd--------------------------------------------------------------------------- COMPLETIONS--completionsNameSearch :: NameSearch -> String -> [String]-completionsNameSearch (NameSearch items _) str =-        concatMap (map fst . fromDefer . rest) $-        takeWhile ((lstr `isPrefixOf`) . key) $-        map ((!) items) [start .. arraySize items - 1]-    where-        lstr = map toLower str-        nstr = length str--        (exact,prefix) = startPos items lstr-        start = fromMaybe prefix exact--------------------------------------------------------------------------- IntList TYPE--type IntList = [IntRange]-data IntRange = IntRange !Int !Int--instance Show IntRange where-    show (IntRange a b) = show a ++ ".." ++ show b--instance BinaryDefer IntRange where-    put (IntRange a b) = put2 a b-    get = get2 IntRange---toIntList :: [Int] -> IntList-toIntList [] = []-toIntList (x:xs) = f x xs-    where-        f i [] = [IntRange x i]-        f i (y:ys) | y == i+1 = f y ys-                   | otherwise = IntRange x i : toIntList (y:ys)---fromIntList :: IntList -> [Int]-fromIntList = concatMap (\(IntRange a b) -> [a..b])--
src/Hoogle/DataBase/Serialise.hs view
@@ -5,10 +5,10 @@  import Data.Binary.Defer import Data.Binary.Raw-import General.Code+import General.Base+import General.System  import Hoogle.DataBase.Type-import Paths_hoogle import Data.Version  @@ -42,7 +42,7 @@      let showVer = showVersion . flip Version []     ver <- replicateM 4 (hGetByte h)-    when (ver /= hooVersion && "hugs" `notElem` versionTags version) $+    when (ver /= hooVersion) $         error $ "Wrong hoogle database version: " ++ showVer ver ++                 " found, expected " ++ showVer hooVersion
+ src/Hoogle/DataBase/SubstrSearch.hs view
@@ -0,0 +1,147 @@++module Hoogle.DataBase.SubstrSearch+    (SubstrSearch, createSubstrSearch+    ,searchSubstrSearch+    ,completionsSubstrSearch+    ) where++import Data.Binary.Defer+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 General.Base+import Hoogle.Type.All+import Hoogle.Score.All+++-- 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+-- store the links in another bytestring with the lengths, but only unpack them when they are needed+-- can even make length==0 code for it's the same string as before, to compress it and reduce searching+-- was previously ~ 0.047 seconds++{-+Description:++The substring search is an array of (key,value) pairs. The keys are sorted case+sensitively.++To do a search we binary chop to find the range where the exact prefixes lie,+then we binary chop to find the range where the inexact prefixes lie, then we+scan linearly to find all substrings.++Data is stored flattened. For default we expect ~200Kb of disk usage.+-}++-- keys are sorted after being made lower case+data SubstrSearch a = SubstrSearch+    {text :: BS.ByteString -- all the bytestrings, lowercase, sorted+    ,lens :: BS.ByteString -- a list of lengths, 0 means the string was identical to the previous one+    ,inds :: Int -> a -- a way of retrieving each index+    }+++-- | Create a substring search index. Values are returned in order where possible.+createSubstrSearch :: [(String,a)] -> SubstrSearch a+createSubstrSearch xs = SubstrSearch+    (BSC.pack $ concat ts2)+    (BS.pack $ map fromIntegral ls2)+    (is !!)+    where+        (ts,is) = unzip $ sortBy (comparing fst) $ map (first $ map toLower) xs+        (ts2,ls2) = f "" ts++        f x (y:ys) | x == y = second (0:) $ f x ys+                   | otherwise = first (y:) $ second (length y:) $ f y ys+        f x [] = ([],[])+++data S a = S+    {sCount :: !Int -- which one are we on+    ,sFocus :: !BS.ByteString -- where we are in the string+    ,sLast :: !(Maybe TextMatch) -- the last result+    ,sPrefix :: ![(a,EntryView,Score)] -- the prefixes+    ,sInfix :: ![(a,EntryView,Score)] -- the infixes+    }+++searchSubstrSearch :: Eq a => 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)+        sN = BS.foldl f s0 $ lens x+        s0 = S 0 (text x) Nothing [] []++        f s 0 = addCount $ case sLast s of+            Nothing -> s+            Just x -> addMatch x s+        f s ii = addCount $ moveFocus i $ maybe id addMatch t $ s{sLast=t}+            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 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}+++completionsSubstrSearch :: SubstrSearch a -> String -> [String]+completionsSubstrSearch _ _ = []+++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++++-- if first word is empty, always return Exact/Prefix+-- if first word is a single letter, do elemIndex+-- if first word is multiple, do isPrefixOf's but only up until n from the end+-- partially apply on the first word+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
src/Hoogle/DataBase/Suggest.hs view
@@ -1,20 +1,15 @@ -module Hoogle.DataBase.Suggest where+module Hoogle.DataBase.Suggest(Suggest, createSuggest, askSuggest) where -import General.Code+import General.Base+import General.Util import Data.Binary.Defer-import Data.Binary.Defer.Trie as Trie-import Data.Binary.Defer.Index import qualified Data.Map as Map-import Hoogle.TextBase.All-import Hoogle.TypeSig.All-import Hoogle.Item.All+import Hoogle.Type.All import Data.Generics.Uniplate  --- TODO: Move to a Map, first benchmark how much this slows down the---       searching, versus how much space is saved-newtype Suggest = Suggest {fromSuggest :: Trie SuggestItem}+newtype Suggest = Suggest {fromSuggest :: Map.Map String SuggestItem}  -- if something is both a data and a ctor, no need to mention the ctor data SuggestItem = SuggestItem@@ -28,7 +23,7 @@     show (Suggest x) = show x  instance Show SuggestItem where-    show (SuggestItem a b c) = concat $ intersperse ", " $+    show (SuggestItem a b c) = intercalate ", " $         ["ctor " ++ x | Just x <- [a]] ++ f "data" b ++ f "class" c         where             f msg xs = [msg ++ " " ++ a ++ " " ++ show b | (a,b) <- xs]@@ -42,44 +37,32 @@     put (SuggestItem a b c) = put3 a b c     get = get3 SuggestItem +instance Monoid Suggest where+    mempty = mergeSuggest []+    mappend x y = mergeSuggest [x,y]+    mconcat = mergeSuggest  -- note: do not look inside class's for data type information --       as they may have higher-kinds and get it wrong-createSuggest :: [Suggest] -> [TextItem] -> Suggest+createSuggest :: [Suggest] -> [Fact] -> Suggest createSuggest deps xs = mergeSuggest (s:deps)     where-        s = Suggest $ newTrie $ Map.toList res+        s = Suggest res         res = foldl f Map.empty $ concatMap getTextItem xs             where f m (s,i) = Map.insertWith joinItem (map toLower s) i m          sData  c n = (c, SuggestItem Nothing [(c,n)] [])         sClass c n = (c, SuggestItem Nothing [] [(c,n)]) -        getTextItem :: TextItem -> [(String,SuggestItem)]-        getTextItem (ItemClass x   ) = getTypeSig True x-        getTextItem (ItemFunc n x  ) = getTypeSig False x ++ getCtor n x-        getTextItem (ItemAlias x y ) = getTypeSig False x ++ getTypeSig False y-        getTextItem (ItemData _ x  ) = getTypeSig False x-        getTextItem (ItemInstance x) = getTypeSig True x+        getTextItem :: Fact -> [(String,SuggestItem)]+        getTextItem (FactDataKind a b) = [sData a b]+        getTextItem (FactClassKind a b) = [sClass a b]+        getTextItem (FactCtorType a b) = [(a, SuggestItem (Just b) [] [])]         getTextItem _ = [] -        getTypeSig cls (TypeSig x y) = concatMap (getType True) x ++ getType cls y -        getType cls (TApp (TLit c) ys) = add cls c (length ys) ++-                                         if cls then [] else concatMap (getType False) ys-        getType cls (TLit c) = add cls c 0-        getType cls x = if cls then [] else concatMap (getType False) $ children x--        add cls c i = [(if cls then sClass else sData) c i | not (isTLitTuple c)]--        getCtor name (TypeSig _ x) =-            [ (name, SuggestItem (Just c) [] [])-            | n:_ <- [name], isUpper n-            , (TLit c,_) <- [fromTApp $ last $ fromTFun x]]-- mergeSuggest :: [Suggest] -> Suggest-mergeSuggest = Suggest . Trie.unionsWith joinItem . map fromSuggest+mergeSuggest = Suggest . Map.unionsWith joinItem . map fromSuggest   joinItem :: SuggestItem -> SuggestItem -> SuggestItem@@ -99,7 +82,7 @@         | otherwise = Nothing     where         tries = map fromSuggest sug-        get x = case catMaybes $ map (lookupTrie $ map toLower x) tries of+        get x = case mapMaybe (Map.lookup $ map toLower x) tries of                     [] -> Nothing                     xs -> Just $ foldr1 joinItem xs
src/Hoogle/DataBase/Type.hs view
@@ -1,29 +1,23 @@ -module Hoogle.DataBase.Type-    (module Hoogle.DataBase.Type-    ,module Hoogle.DataBase.Items-    ,module Hoogle.DataBase.Suggest-    ,module Hoogle.DataBase.Aliases-    ,module Hoogle.DataBase.Instances-    ,module Hoogle.DataBase.TypeSearch.All-    ,module Hoogle.DataBase.NameSearch-    ) where+module Hoogle.DataBase.Type(module Hoogle.DataBase.Type, module X) where -import Hoogle.DataBase.Items-import Hoogle.DataBase.Suggest-import Hoogle.DataBase.Aliases-import Hoogle.DataBase.Instances-import Hoogle.DataBase.TypeSearch.All-import Hoogle.DataBase.NameSearch+import Hoogle.DataBase.Items           as X+import Hoogle.DataBase.Suggest         as X+import Hoogle.DataBase.Aliases         as X+import Hoogle.DataBase.Instances       as X+import Hoogle.DataBase.SubstrSearch    as X+import Hoogle.DataBase.TypeSearch.All  as X import Data.Binary.Defer-import General.Code+import Data.Binary.Defer.Index+import Hoogle.Type.All+import General.Base   -- suggest, aliases and instances are used for linking with packages -- that depend on this database data DataBase = DataBase     {items :: Items-    ,nameSearch :: NameSearch+    ,nameSearch :: SubstrSearch (Link Entry)     ,typeSearch :: TypeSearch     ,suggest :: Suggest     ,aliases :: Aliases
src/Hoogle/DataBase/TypeSearch/All.hs view
@@ -13,9 +13,8 @@ import Hoogle.DataBase.Aliases import Data.Binary.Defer import Data.Binary.Defer.Index-import Hoogle.TextBase.All-import Hoogle.TypeSig.All-import Hoogle.Item.All+import Hoogle.Type.All+import Hoogle.Score.All   newtype TypeSearch = TypeSearch Graphs@@ -31,14 +30,13 @@ --------------------------------------------------------------------- -- CREATION -createTypeSearch :: Aliases -> Instances -> [Link Entry] -> TypeSearch-createTypeSearch aliases instances xs = TypeSearch $ newGraphs aliases instances types-    where types = [(x, fromDefer sig) | x <- xs, Just sig <- [entryTypesig $ fromLink x]]+createTypeSearch :: Aliases -> Instances -> [(TypeSig, Link Entry)] -> TypeSearch+createTypeSearch aliases instances xs = TypeSearch $ newGraphs aliases instances xs   --------------------------------------------------------------------- -- SEARCHING -searchTypeSearch :: Aliases -> Instances -> TypeSearch -> TypeSig -> [(Link Entry,[EntryView],TypeScore)]+searchTypeSearch :: Aliases -> Instances -> TypeSearch -> TypeSig -> [(Link Entry,[EntryView],Score)] searchTypeSearch as is (TypeSearch g) t =-    [(a, b, c) | (a,b,c) <- graphsSearch as is g t]+    [(a, b, typeScore $ costsTypeScore c) | (a,b,c) <- graphsSearch as is g t]
src/Hoogle/DataBase/TypeSearch/Binding.hs view
@@ -10,9 +10,10 @@     addBinding, costBinding, costsBinding, mergeBindings, bindings     ) where -import Hoogle.TypeSig.All-import General.Code-import Hoogle.DataBase.TypeSearch.Cost+import Hoogle.Type.All+import Hoogle.Score.All+import Data.Function+import General.Base import qualified Data.Map as Map import qualified Data.Set as Set @@ -38,7 +39,7 @@     (==) = (==) `on` costBinding  instance Ord Binding where-    compare = compare `on` costBinding+    compare = comparing costBinding   costBinding :: Binding -> Int@@ -92,14 +93,14 @@         (bl,br) = (Map.unionsWith f ls, Map.unionsWith f rs)         res i = Binding i (concat box) bl br     s <- costsBindingLocal (res 0)-    return $ res (score s)+    return $ res (sum $ map cost s)     where         f (l1,vs1) (l2,vs2)             | l1 /= l2 && isJust l1 && isJust l2 = (Just "", vs1)             | otherwise = (l1 `mplus` l2, Set.union vs1 vs2)  -costsBindingLocal :: Binding -> Maybe [Cost]+costsBindingLocal :: Binding -> Maybe [TypeCost] costsBindingLocal (Binding _ box l r) = do     let cb = [if b == Unbox then CostUnbox else CostRebox | b <- box]     cl <- f CostDupVarQuery  CostRestrict   l@@ -109,10 +110,10 @@         f var restrict = concatMapM g . Map.elems             where                 g (Just "", _) = Nothing-                g (l, vs) = Just $ [restrict|isJust l] ++ var *+ (max 0 $ Set.size vs - 1)+                g (l, vs) = Just $ [restrict|isJust l] ++ replicate (max 0 $ Set.size vs - 1) var  -costsBinding :: Binding -> [Cost]+costsBinding :: Binding -> [TypeCost] costsBinding = fromJust . costsBindingLocal
− src/Hoogle/DataBase/TypeSearch/Cost.hs 
@@ -1,44 +0,0 @@--module Hoogle.DataBase.TypeSearch.Cost(-    Cost(..), cost, score, (*+)-    ) where---infixl 7  *+ -- same as *--(*+) :: Cost -> Int -> [Cost]-(*+) = flip replicate---data Cost = CostAliasFwd-          | CostAliasBwd-          | CostUnbox-          | CostRebox-          | CostRestrict-          | CostUnrestrict-          | CostDupVarResult-          | CostDupVarQuery-          | CostInstanceDel-          | CostInstanceAdd-          | CostDeadArg-          | CostArgReorder-            deriving (Show,Eq,Ord,Enum,Bounded)---score :: [Cost] -> Int-score = sum . map cost---cost :: Cost -> Int-cost CostAliasFwd     =    1  -- 1..1000-cost CostAliasBwd     =    1  -- 1..997-cost CostUnbox        =    5  -- 5..1000-cost CostRebox        =    4  -- 4..999-cost CostRestrict     =    5  -- 5..1000-cost CostUnrestrict   =    4  -- 4..1000-cost CostDupVarResult =    4  -- 4..999-cost CostDupVarQuery  =    5  -- 5..1000-cost CostInstanceDel  =    4  -- 4..999-cost CostInstanceAdd  =    4  -- 4..999-cost CostDeadArg      =    3  -- 3..998-cost CostArgReorder   =    1  -- 1..1000
src/Hoogle/DataBase/TypeSearch/EntryInfo.hs view
@@ -1,10 +1,10 @@+{-# LANGUAGE DeriveDataTypeable #-}  module Hoogle.DataBase.TypeSearch.EntryInfo where  import Data.Binary.Defer import Data.Binary.Defer.Index-import Hoogle.TypeSig.All-import Hoogle.Item.All+import Hoogle.Type.All import Data.Typeable  @@ -14,16 +14,11 @@     ,entryInfoArity :: Int     ,entryInfoContext :: TypeContext     ,entryInfoAlias :: [String]-    } deriving (Eq,Show)+    } deriving (Eq,Show,Typeable)  instance Ord EntryInfo where     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"---typename_EntryInfo = mkTyCon "Hoogle.DataBase.TypeSearch.Result.EntryInfo"-instance Typeable EntryInfo-    where typeOf _ = mkTyConApp typename_EntryInfo []  instance BinaryDefer EntryInfo where     put (EntryInfo a b c d) = put4 a b c d
src/Hoogle/DataBase/TypeSearch/Graph.hs view
@@ -10,20 +10,15 @@     graphSearch     ) where -import Hoogle.DataBase.TypeSearch.TypeScore import Hoogle.DataBase.TypeSearch.Binding import Hoogle.DataBase.TypeSearch.Result-import Hoogle.DataBase.Aliases-import Hoogle.Item.All-import Hoogle.TypeSig.All+import Hoogle.Type.All import Data.Generics.Uniplate import Data.Binary.Defer import Data.Binary.Defer.Index-import qualified Data.IntMap as IntMap import qualified Data.Map as Map-import qualified Data.Heap as Heap-import General.Code-import Data.Key+import General.Base+import General.Util
src/Hoogle/DataBase/TypeSearch/Graphs.hs view
@@ -7,15 +7,15 @@ import Hoogle.DataBase.Instances import Hoogle.DataBase.Aliases import Hoogle.DataBase.TypeSearch.TypeScore-import Hoogle.Item.All-import Hoogle.TypeSig.All+import Hoogle.Type.All hiding (Result)  import Data.Binary.Defer import Data.Binary.Defer.Index import qualified Data.IntMap as IntMap import qualified Data.Heap as Heap-import General.Code-import Control.Monad.State+import General.Base+import General.Util+import Control.Monad.Trans.State   -- for resGraph, the associated ArgPos is the arity of the function@@ -32,20 +32,17 @@  instance BinaryDefer Graphs where     put (Graphs a b c) = put3 a b c-    get = do-        res@(Graphs a b c) <- get3 Graphs-        getDeferPut a-        return res+    get = get3 Graphs   --------------------------------------------------------------------- -- GRAPHS CONSTRUCTION -newGraphs :: Aliases -> Instances -> [(Link Entry, TypeSig)] -> Graphs+newGraphs :: Aliases -> Instances -> [(TypeSig, Link Entry)] -> Graphs newGraphs as is xs = Graphs (newIndex $ map snd entries) argGraph resGraph     where         entries = [ (t2, e2{entryInfoEntries = sortOn linkKey $ map snd ys})-                  | ys@(((t2,e2),_):_) <- sortGroupFst $ map (\(e,t) -> (normType as is t, e)) xs]+                  | ys@(((t2,e2),_):_) <- sortGroupFst $ map (\(t,e) -> (normType as is t, e)) xs]          argGraph = newGraph (concat args)         resGraph = newGraph res@@ -68,7 +65,7 @@ graphsSearch :: Aliases -> Instances -> Graphs -> TypeSig -> [ResultReal] graphsSearch as is gs t = resultsCombine is query ans     where-        ans = mergesBy (compare `on` resultArgBind . snd) $ +        ans = mergesBy (comparing $ resultArgBind . snd) $                f Nothing (resGraph gs) res :               zipWith (\i -> f (Just i) (argGraph gs)) [0..] args
src/Hoogle/DataBase/TypeSearch/Result.hs view
@@ -8,11 +8,9 @@ import Hoogle.DataBase.TypeSearch.Binding import Hoogle.DataBase.TypeSearch.EntryInfo import Hoogle.DataBase.Instances-import Data.Binary.Defer import Data.Binary.Defer.Index-import Hoogle.TypeSig.All-import Hoogle.Item.All-import General.Code+import Hoogle.Type.All hiding (Result)+import General.Base import qualified Data.IntSet as IntSet
src/Hoogle/DataBase/TypeSearch/TypeScore.hs view
@@ -4,13 +4,12 @@     TypeScore, newTypeScore, costTypeScore, costsTypeScore     ) where -import General.Code-import Hoogle.DataBase.TypeSearch.Cost+import General.Base+import Hoogle.Score.All import Hoogle.DataBase.TypeSearch.Binding import Hoogle.DataBase.TypeSearch.EntryInfo import Hoogle.DataBase.Instances-import Hoogle.TypeSig.All-import qualified Data.Set as Set+import Hoogle.Type.All   data TypeScore = TypeScore@@ -41,7 +40,7 @@     (==) = (==) `on` costTypeScore  instance Ord TypeScore where-    compare = compare `on` costTypeScore+    compare = comparing costTypeScore   newTypeScore :: Instances -> EntryInfo -> EntryInfo -> Bool -> Binding -> TypeScore@@ -61,10 +60,10 @@   calcScore :: TypeScore -> Int-calcScore t = costBinding (bind t) + score (costsTypeScoreLocal t)+calcScore t = costBinding (bind t) + sum (map cost $ costsTypeScoreLocal t)  -costsTypeScoreLocal :: TypeScore -> [Cost]+costsTypeScoreLocal :: TypeScore -> [TypeCost] costsTypeScoreLocal t =     CostDeadArg *+ badargs t ++     [CostArgReorder | badorder t] ++@@ -72,7 +71,8 @@     CostAliasBwd *+ length (snd $ badAlias t) ++     CostInstanceAdd *+ length (fst $ badInstance t) ++     CostInstanceDel *+ length (snd $ badInstance t)+    where (*+) = flip replicate  -costsTypeScore :: TypeScore -> [Cost]+costsTypeScore :: TypeScore -> [TypeCost] costsTypeScore t = costsBinding (bind t) ++ costsTypeScoreLocal t
− src/Hoogle/Item/All.hs 
@@ -1,10 +0,0 @@--module Hoogle.Item.All(-    module Hoogle.Item.Item,-    module Hoogle.Item.Haddock,-    module Hoogle.Item.URL-    ) where--import Hoogle.Item.Item-import Hoogle.Item.Haddock-import Hoogle.Item.URL
− src/Hoogle/Item/Haddock.hs 
@@ -1,75 +0,0 @@--module Hoogle.Item.Haddock(-    Haddock, newHaddock, renderHaddock-    ) where--import General.Code-import Data.TagStr-import Data.Binary.Defer-import Data.ByteString.Char8(ByteString,pack,unpack)---newtype Haddock = Haddock ByteString---instance BinaryDefer Haddock where-    put (Haddock x) = put x-    get = get1 Haddock---newHaddock = Haddock . pack---renderHaddock :: Haddock -> TagStr-renderHaddock (Haddock xs) = Tags $ f False $ parseHaddock $ 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) = TagHyperlink "" (Tags $ f pre x) : f pre xs-        f pre (Tag "i" x:xs) = TagUnderline (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)--parseHaddock :: String -> Tags-parseHaddock = fst . readHaddock ">"---readHaddock :: String -> String -> (Tags, String)-readHaddock 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) = readHaddock 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/Item/Item.hs 
@@ -1,187 +0,0 @@--module Hoogle.Item.Item where--import General.Code-import Data.Binary.Defer-import Data.Binary.Defer.Index-import Hoogle.Item.Haddock-import Hoogle.TextBase.All-import Hoogle.TypeSig.All-import Data.Range-import Data.TagStr-import Data.Typeable---data Package = Package-    {packageName :: String-    ,packageVersion :: String-    ,haddockURL :: String-    ,hackageURL :: String-    }--typename_Package = mkTyCon "Hoogle.DataBase.Item.Package"-instance Typeable Package where typeOf _ = mkTyConApp typename_Package []---data Module = Module-    {moduleName :: [String]-    }--typename_Module = mkTyCon "Hoogle.DataBase.Item.Module"-instance Typeable Module where typeOf _ = mkTyConApp typename_Module []----- TODO: Is entryName every used? Can it make use of the invariant?---       Perhaps just store the entryText, then regenerate entryName at load time---- invariant: entryName == head [i | Focus i <- entryText]-data Entry = Entry-    {entryModule :: Maybe (Link Module)-    ,entryPackage :: Link Package-    ,entryName :: String-    ,entryText :: [EntryText]-    ,entryType :: EntryType-    ,entryDocs :: Haddock-    ,entryTypesig :: Maybe (Defer TypeSig)-    }---typename_Entry = mkTyCon "Hoogle.DataBase.Item.Entry"-instance Typeable Entry where typeOf _ = mkTyConApp typename_Entry []---data EntryText = Keyword String-               | Text String-               | Focus String -- the bit text search starts from-               | ArgPos Int String-               | ArgRes String-                 deriving Show--data EntryView = FocusOn Range -- characters in the range should be focused-               | ArgPosNum Int Int -- argument a b, a is remapped to b-                 deriving Show--data EntryType = EntryModule-               | EntryPackage-               | EntryKeyword-               | EntryOther-                 deriving (Eq,Enum,Show)----- TODO: EntryScore is over-prescriptive, and not overly useful---       Have name and type scores to it themselves, using name only---       to break ties when merging--- the number of elements in the module name--- the name of the entry, in lower case--- the name of the entry--- the module-data EntryScore = EntryScore Int String String [String]-                  deriving (Eq,Ord)---entryScore :: Entry -> EntryScore-entryScore e = EntryScore-    (if entryType e == EntryOther then length m else 0)-    (map toLower $ entryName e) (entryName e) m-    where m = maybe [] (moduleName . fromLink) $ entryModule e---renderEntryText :: [EntryView] -> [EntryText] -> TagStr-renderEntryText view = Tags . map f-    where-        args = not $ null [() | ArgPosNum _ _ <- view]--        f (Keyword x) = TagUnderline $ Str x-        f (Text x) = Str x-        f (ArgPos i s) = (if null res then id else TagColor (head res)) $ Str s-            where res = [k+1 | ArgPosNum k j <- view, j == i]-        f (ArgRes s) = (if args then TagColor 0 else id) $ Str s-        f (Focus x) = TagHyperlink "" $ renderFocus [i | FocusOn i <- view] x---renderFocus :: [Range] -> String -> TagStr-renderFocus rs = Tags . f (mergeRanges rs) 0-    where-        str s = [Str s | s /= ""]--        f [] i s = str s-        f (r:rs) i s =-                str s1 ++ [TagBold $ Str s3] ++ f rs (rangeEnd r + 1) s4-            where-                (s1,s2) = splitAt (rangeStart r - i) s-                (s3,s4) = splitAt (rangeCount r) s2---renderTextItem :: TextItem -> [EntryText]-renderTextItem x = case x of-    ItemClass i -> [Keyword "class", Text " "] ++ typeHead i-    ItemFunc name typ -> operator name ++ [Text " :: "] ++ renderTypeSig typ-    ItemAlias a b -> [Keyword "type", Text " "] ++ typeHead a ++ [Text $ " = " ++ show b]-    ItemData d t -> [Keyword (show d), Text " "] ++ typeHead t-    where-        typeHead (TypeSig con sig) = [Text $ showConstraint con, Focus a, Text b]-            where (a,b) = break (== ' ') $ show sig--        operator xs@(x:_) | not $ isAlpha x || x `elem` "#_'" = [Text "(",Focus xs,Text ")"]-        operator xs = [Focus xs]---renderTypeSig :: TypeSig -> [EntryText]-renderTypeSig (TypeSig con sig) = Text (showConstraint con) :-    intersperse (Text " -> ") (zipWith ArgPos [0..] a ++ [ArgRes b])-    where (a,b) = initLast $ map showFun $ fromTFun sig---showModule = concat . intersperse "."--instance Show Package where-    show (Package a b c d) = unwords $ filter (/= "") [a,b,c,d]--instance Show Module where-    show (Module a) = showModule a--instance Show Entry where-    show e = unwords [concatMap f $ entryText e, m]-        where-            m = case entryModule e of-                    Nothing -> ""-                    Just y -> "{#" ++ show (linkKey y) ++ "}"--            f (Keyword x) = x-            f (Text x) = x-            f (Focus x) = x-            f (ArgPos _ x) = x-            f (ArgRes x) = x---instance BinaryDefer Package where-    put (Package a b c d) = put4 a b c d-    get = get4 Package--instance BinaryDefer Module where-    put (Module a) = put1 a-    get = get1 Module--instance BinaryDefer Entry where-    put (Entry a b c d e f g) = put7 a b c d e f g-    get = get7 Entry--instance BinaryDefer EntryText where-    put (Keyword a)  = putByte 0 >> put1 a-    put (Text a)     = putByte 1 >> put1 a-    put (Focus a)    = putByte 2 >> put1 a-    put (ArgPos a b) = putByte 3 >> put2 a b-    put (ArgRes a)   = putByte 4 >> put1 a--    get = do i <- getByte-             case i of-                0 -> get1 Keyword-                1 -> get1 Text-                2 -> get1 Focus-                3 -> get2 ArgPos-                4 -> get1 ArgRes--instance BinaryDefer EntryType where-    put = putEnumByte-    get = getEnumByte-
− src/Hoogle/Item/URL.hs 
@@ -1,33 +0,0 @@--module Hoogle.Item.URL where--import General.Code-import Hoogle.Item.Item-import Numeric-import Data.Binary.Defer.Index----entryURL :: Entry -> String-entryURL e@Entry{entryType=EntryModule} = entryModuleURL e-entryURL e@Entry{entryType=EntryPackage} = entryPackageURL e-entryURL e@Entry{entryType=EntryOther} = entryModuleURL e ++ "#v:" ++ entryName e-entryURL e@Entry{entryType=EntryKeyword} =-        "http://www.haskell.org/haskellwiki/Keywords#" ++ concatMap f (entryName e)-    where-        f x | isAlpha x || x `elem` "_-:" = [x]-            | otherwise = '.' : map toUpper (showHex (ord x) "")---entryModuleURL :: Entry -> String-entryModuleURL Entry{entryModule=Just m, entryPackage=p} | pkg /= "" =-        pkg ++ concat (intersperse "-" name) ++ ".html"-    where-        name = moduleName $ fromLink m-        pkg = haddockURL $ fromLink p-entryModuleURL _ = ""---entryPackageURL :: Entry -> String-entryPackageURL e = if a == "" then b else a-    where Package{hackageURL=a, haddockURL=b} = fromLink $ entryPackage e
+ src/Hoogle/Language/Haskell.hs view
@@ -0,0 +1,256 @@+{-# LANGUAGE PatternGuards #-}++module Hoogle.Language.Haskell(parseInputHaskell) where++import General.Base+import General.Util+import Hoogle.Type.All+import Language.Haskell.Exts.Annotated hiding (TypeSig,Type)+import qualified Language.Haskell.Exts.Annotated as HSE+import Data.Generics.Uniplate.Data+++type S = SrcSpanInfo+++parseInputHaskell :: String -> ([ParseError], Input)+parseInputHaskell = join . f [] "" . zip [1..] . lines+    where+        f com url [] = []+        f com url ((i,s):is)+            | "-- | " `isPrefixOf` s = f [drop 5 s] url is+            | "--" `isPrefixOf` s = f ([dropWhile isSpace $ drop 2 s | com /= []] ++ com) url is+            | "@url " `isPrefixOf` s =  f com (drop 5 s) is+            | all isSpace s = f [] "" is+            | otherwise = (case parseLine i s of+                               Left y -> Left y+                               Right (as,bs) -> Right (as,[b{itemURL=if null url then itemURL b else url, itemDocs=unlines $ reverse com} | b <- bs]))+                          : f [] "" is++        join xs = (err, (concat as, ripple setPriority $ ripple setModuleURL $ concat bs))+            where (err,items) = unzipEithers xs+                  (as,bs) = unzip items+++parseLine :: Int -> String -> Either ParseError ([Fact],[TextItem])+parseLine line x | "(##)" `isPrefixOf` x = Left $ parseErrorWith line 1 "Skipping due to HSE bug #206" "(##)"+parseLine line ('@':str) = case a of+        "keyword" -> Right $ itemKeyword $ dropWhile isSpace b+        "package" -> Right $ itemPackage $ dropWhile isSpace b+        _ -> Left $ parseErrorWith line 2 ("Unknown attribute: " ++ a) $ '@':str+    where (a,b) = break isSpace str+parseLine line x | a == "module" = Right $ itemModule $ split '.' $ dropWhile isSpace b+    where (a,b) = break isSpace x+parseLine line x+    | not continue = res+    | otherwise = fromMaybe res $ fmap Right $ parseTuple x `mappend` parseCtor x+    where (continue,res) = parseFunction line x++parseFunction line x = case parseDeclWithMode defaultParseMode{extensions=exts} $ x ++ ex of+    ParseOk y -> (,) False $ maybe (Left $ parseErrorWith line 1 "Can't translate" $ x ++ ex) Right $ transDecl x y+    ParseFailed pos msg -> (,) True $ Left $ parseErrorWith line (srcColumn pos) msg $ x ++ ex+    where ex = if "newtype " `isPrefixOf` x then " = N T" else " " -- space to work around HSE bug #205++parseTuple o@('(':xs) | ")" `isPrefixOf` rest+    , ParseOk y <- parseDeclWithMode defaultParseMode{extensions=exts} $ replicate (length com + 2) 'a' ++ drop 1 rest+    = transDecl o $ f y+    where+        (com,rest) = span (== ',') xs+        f (HSE.TypeSig sl [Ident sl2 _] ty) = HSE.TypeSig sl [Ident sl2 $ '(':com++")"] ty+parseTuple _ = Nothing++parseCtor x = case parseDeclWithMode defaultParseMode{extensions=exts} $ "data Data where " ++ x of+        ParseOk y -> transDecl x $ fmap (subtractCols 16) y+        _ -> Nothing++exts = [EmptyDataDecls,TypeOperators,ExplicitForall,GADTs,KindSignatures,MultiParamTypeClasses+       ,TypeFamilies,FlexibleContexts,FunctionalDependencies,ImplicitParams,MagicHash,UnboxedTuples]+++subtractCols :: Int -> SrcSpanInfo -> SrcSpanInfo+subtractCols n (SrcSpanInfo x xs) = SrcSpanInfo (f x) (map f xs)+    where f x = x{srcSpanStartColumn=srcSpanStartColumn x - n, srcSpanEndColumn=srcSpanEndColumn x - n}+++textItem = TextItem 2 "" "" Nothing (Str "") "" "" 0++fact x y = (x,[y])++itemPackage x = fact [] $ textItem{itemLevel=0, itemKey=x, itemName=x,+    itemURL="http://hackage.haskell.org/package/" ++ x ++ "/",+    itemDisp=Tags [emph "package",space,bold x]}++itemKeyword x = fact [] $ textItem{itemName=x, itemKey=x,+    itemDisp=Tags [emph "keyword",space,bold x]}++itemModule xs = fact [] $ textItem{itemLevel=1, itemKey=last xs, itemName=intercalate "." xs,+    itemURL="",+    itemDisp=Tags [emph "module",Str $ " " ++ concatMap (++".") (init xs),bold $ last xs]}+++-- apply things that need to ripple down, priorities and module URL's+ripple :: (Maybe TextItem -> Maybe TextItem -> TextItem -> TextItem) -> [TextItem] -> [TextItem]+ripple f = fs Nothing Nothing+    where+        fs a b [] = []+        fs a b (x:xs) = f a2 b2 x : fs a2 b2 xs+            where a2 = if itemLevel x == 0 then Just x else a+                  b2 = if itemLevel x == 1 then Just x else b+++-- base::Prelude is priority 0+-- base is priority 1+-- Everything else is priority 2+setPriority pkg mod x = x{itemPriority = pri}+    where pri = if base then (if prelude then 0 else 1) else 2+          prelude = maybe [] itemName mod == "Prelude"+          base = maybe [] itemName pkg == "base"+++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"+++---------------------------------------------------------------------+-- TRANSLATE THINGS+++transDecl :: String -> Decl S -> Maybe ([Fact],[TextItem])+transDecl x (GDataDecl s dat ctxt hd _ [] _) = transDecl x $ DataDecl s dat ctxt hd [] Nothing+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,+    itemURL="#v:" ++ 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+          (as,b) = initLast $ typeArgsPos tyy+          ctr = [FactCtorType nam y | ctorStart $ head nam, TLit y <- [fst $ fromTApp $ last $ fromTFun ty]]+          typ@(TypeSig _ ty) = transTypeSig tyy++          ctorStart x = isUpper x || x `elem` ":("++transDecl x (ClassDecl s ctxt hd _ _) = Just $ fact (kinds True $ transDeclHead ctxt hd) $ textItem+    {itemName=nam, itemKey=nam+    ,itemURL="#t:" ++ 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+    ,itemURL="#t:" ++ nam+    ,itemDisp=x `formatTags` [(cols $ head $ srcInfoPoints s, TagEmph),(cols snam,TagBold)]}+    where (snam,nam) = findName hd+          from = transDeclHead Nothing hd+          to = transTypeSig ty++transDecl x (DataDecl _ dat ctxt hd _ _) = Just $ fact (kinds False $ transDeclHead ctxt hd) $ textItem+    {itemName=nam, itemKey=nam+    ,itemURL="#t:" ++ nam+    ,itemDisp=x `formatTags` [(cols $ srcInfoSpan $ ann dat, TagEmph),(cols snam,TagBold)]}+    where (snam,nam) = findName hd++transDecl x (InstDecl _ ctxt hd _) = Just (FactInstance t:kinds True t, [])+    where t = transInstHead ctxt hd++transDecl _ _ = Nothing+++typeArgsPos :: HSE.Type S -> [SrcSpan]+typeArgsPos (TyForall _ _ _ x) = typeArgsPos x+typeArgsPos (TyFun _ x y) = srcInfoSpan (ann x) : typeArgsPos y+typeArgsPos (TyParen _ x) = typeArgsPos x+typeArgsPos x = [srcInfoSpan $ ann x]+++++cols :: SrcSpan -> (Int,Int)+cols x = (srcSpanStartColumn x - 1, srcSpanEndColumn x - 1)++findName :: Data a => a -> (SrcSpan,String)+findName x = case universeBi x of+        Ident s x : _ -> (srcInfoSpan s,x)+        Symbol s x : _ -> (srcInfoSpan s,x)++unbracket ('(':xs) | ")" `isSuffixOf` xs && nub ys `notElem` ["",","] = ys+    where ys = init xs+unbracket x = x+++transType :: HSE.Type S -> Type+transType (TyForall _ _ _ x) = transType x+transType (TyFun _ x y) = TFun $ transType x : fromTFun (transType y)+transType (TyTuple _ x xs) = tApp (TLit $ "(" ++ h ++ replicate (length xs - 1) ',' ++ h ++ ")") $ map transType xs+    where h = ['#' | x == Unboxed]+transType (TyList _ x) = TApp (TLit "[]") [transType x]+transType (TyApp _ x y) = tApp a (b ++ [transType y])+    where (a,b) = fromTApp $ transType x+transType (TyVar _ x) = TVar $ prettyPrint x+transType (TyCon _ x) = TLit $ unbracket $ prettyPrint x+transType (TyParen _ x) = transType x+transType (TyInfix _ y1 x y2) = TApp (TLit $ unbracket $ prettyPrint x) [transType y1, transType y2]+transType (TyKind _ x _) = transType x+++transContext :: Maybe (Context S) -> Constraint+transContext = maybe [] g+    where+        g (CxSingle _ x) = f x+        g (CxTuple _ xs) = concatMap f xs+        g (CxParen _ x) = g x+        g _ = []++        f (ClassA _ x ys) = [TApp (TLit $ unbracket $ prettyPrint x) $ map transType ys]+        f (InfixA s y1 x y2) = f $ ClassA s x [y1,y2]+        f _ = []+++transTypeSig :: HSE.Type S -> TypeSig+transTypeSig (TyParen _ x) = transTypeSig x+transTypeSig (TyForall _ _ con ty) = TypeSig (transContext con) $ transType ty+transTypeSig x = TypeSig [] $ transType x+++transDeclHead :: Maybe (Context S) -> DeclHead S -> TypeSig+transDeclHead x y = TypeSig (transContext x) $ f y+    where f (DHead _ name vars) = TApp (TLit $ unbracket $ prettyPrint name) $ map transVar vars+          f (DHParen _ x) = f x+          f (DHInfix s x y z) = f $ DHead s y [x,z]++transInstHead :: Maybe (Context S) -> InstHead S -> TypeSig+transInstHead x y = TypeSig (transContext x) $ f y+    where f (IHead _ name vars) = TApp (TLit $ unbracket $ prettyPrint name) $ map transType vars+          f (IHParen _ x) = f x+          f (IHInfix s x y z) = f $ IHead s y [x,z]+++transVar :: TyVarBind S -> Type+transVar (KindedVar _ nam _) = TVar $ prettyPrint nam+transVar (UnkindedVar _ nam) = TVar $ prettyPrint nam++++++---------------------------------------------------------------------++emph = TagEmph . Str+bold = TagBold . Str+space = Str " "+++-- collect the kind facts, True for the outer fact is about a class+kinds :: Bool -> TypeSig -> [Fact]+kinds cls (TypeSig x y) = concatMap (f True) x ++ f cls y+    where+        f cls (TApp (TLit c) ys) = add cls c (length ys) +++                                   if cls then [] else concatMap (f False) ys+        f cls (TLit c) = add cls c 0+        f cls x = if cls then [] else concatMap (f False) $ children x++        add cls c i = [(if cls then FactClassKind else FactDataKind) c i | not $ isTLitTuple c]
− src/Hoogle/Operations/All.hs 
@@ -1,10 +0,0 @@--module Hoogle.Operations.All(-    module Hoogle.Operations.Combine,-    module Hoogle.Operations.Convert,-    module Hoogle.Operations.Rank-    ) where--import Hoogle.Operations.Combine-import Hoogle.Operations.Convert-import Hoogle.Operations.Rank
− src/Hoogle/Operations/Combine.hs 
@@ -1,11 +0,0 @@--module Hoogle.Operations.Combine(combine) where--import General.Code-import Hoogle.DataBase.All---combine :: [FilePath] -> FilePath -> IO ()-combine infiles outfile = do-    dbs <- mapM loadDataBase infiles-    saveDataBase outfile $ combineDataBase dbs
− src/Hoogle/Operations/Convert.hs 
@@ -1,27 +0,0 @@--module Hoogle.Operations.Convert(convert) where--import General.Code-import Hoogle.TextBase.All-import Hoogle.DataBase.All----- error messages are given using trace and error-convert :: Bool -> [FilePath] -> FilePath -> FilePath -> IO ()-convert debugCheck deps tb db = do-    res <- parseTextBase tb-    case res of-        Left  x -> error $ show x-        Right x -> do-            dbs <- mapM loadDataBase deps-            let y = createDataBase dbs x-            saveDataBase db y--            when (debugCheck) $ do-                putStr "Validating... "-                hFlush stdout-                z <- loadDataBase db-                if show y == show z-                    then putStrLn "Success"-                    else exitMessage ["Failure, database did not match"]-
− src/Hoogle/Operations/Rank.hs 
@@ -1,75 +0,0 @@--module Hoogle.Operations.Rank(rank) where--import General.Code-import Hoogle.Query.All-import Hoogle.Search.All-import Hoogle.TextBase.All-import Hoogle.DataBase.All-import Hoogle.TypeSig.All-import Hoogle.Item.All-import Data.Binary.Defer.Index-import Hoogle.Operations.RankSolve---- Privilaged imports-import Hoogle.DataBase.TypeSearch.Cost(Cost(..))-import Hoogle.DataBase.TypeSearch.TypeScore(costsTypeScore)-import Hoogle.Search.Result(Score(TypeScore))---data RankTest = RankTest TypeSig [TypeSig]-                deriving Show---rank :: FilePath -> IO ()-rank file = do-    (tb,tests) <- liftM readRankTests $ readFile file-    let rel = concatMap (runRankTest tb) tests-    rankSolve rel----readRankTests :: String -> (TextBase,[RankTest])-readRankTests xs = (tb, join $ concatMap parse rest)-    where-        (pre,rest) = break ("@" `isPrefixOf`) $ lines xs-        tb = right $ parseTextBaseString $ unlines pre--        parse :: String -> [(Bool, TypeSig)]-        parse xs | null xs || "--" `isPrefixOf` xs = []-        parse ('@':xs) = [(True,f xs)]-        parse xs = [(False,f xs)]--        f = right . parseTypeSig -        right (Right x) = x-        right (Left x) = error $ "readRank failed to parse " ++ show x--        join ((_,t):xs) = RankTest t (map snd a) : join b-            where (a,b) = break fst xs-        join [] = []---runRankTest :: TextBase -> RankTest -> [Cmp]-runRankTest tb (RankTest t xs) = order $ map grab xs2-    where-        xs2 = zip ["f" ++ show i | i <- [1..]] xs--        res = searchAll [db] q-        db = createDataBase [] $ tb ++ [(ItemFunc a b, "") | (a,b) <- xs2]-        q = blankQuery{typeSig=Just t}--        grab :: (String,TypeSig) -> (TypeSig,[Cost])-        grab (name,typ) = (,) typ $-            headDef (err $ "Couldn't find result for " ++ show typ)-            [sort $ costsTypeScore c | r <- res, entryName (fromLink $ resultEntry r) == name-                                     , TypeScore c <- resultScore r]---        order ((at,a):xs@((bt,b):_))-            | isNothing match = (a :< b) : order xs-            | otherwise = err $ "Two items have the same score, " ++ show at ++-                                " AND " ++ show (fst $ fromJust match)-                where match = find ((==) a . snd) xs-        order _ = []--        err msg = error $ "Hoogle.Operations.runRankTest\nTest: " ++ show t ++ "\n" ++ msg
− src/Hoogle/Operations/RankSolve.hs 
@@ -1,73 +0,0 @@--module Hoogle.Operations.RankSolve(Cmp(..), rankSolve) where--import General.Code-import qualified Data.IntMap as IntMap---- Privilaged imports-import Hoogle.DataBase.TypeSearch.Cost(Cost(..))----- invariant, costs must remain sorted-data Cmp = [Cost] :< [Cost]-           deriving (Show,Eq)---rankSolve :: [Cmp] -> IO ()-rankSolve xs | missing /= [] = error $ "Missing costs: " ++ show missing-             | otherwise = putStr $ showBind res-    where-        res = fix (solve xs2) emptyBind-        xs2 = nub $ concatMap simplify xs-        missing = costs \\ concat [a ++ b | a :< b <- xs2]---costs = [minBound..maxBound] :: [Cost]--type Bind = IntMap.IntMap (Int,Int)--emptyBind :: Bind-emptyBind = IntMap.fromAscList [(fromEnum i, (1,1000)) | i <- costs]---showBind :: Bind -> String-showBind mp = unlines ["cost " ++ padR ncosts (show (toEnum a :: Cost)) ++-                       " = " ++ padL 4 (show b) ++ "  -- " ++ show b ++ ".." ++ show c -                      | (a,(b,c)) <- IntMap.toList mp]-    where ncosts = maximum $ map (length . show) costs--padL, padR :: Int -> String -> String-padL n xs = replicate (n - length xs) ' ' ++ xs-padR n xs = xs ++ replicate (n - length xs) ' '----simplify :: Cmp -> [Cmp]-simplify c@(xs :< ys)-        | null xs2 = []-        | null ys2 = error $ "rankSolve, contradiction exists: " ++ show c-        | otherwise = [xs2 :< ys2]-    where-        common = intersect xs ys-        xs2 = xs \\ common-        ys2 = ys \\ common---solve :: [Cmp] -> Bind -> Bind-solve xs mp = foldl' f mp xs-    where-        -- all x in xs, x.max = ys.max - 1-        -- all y in ys, y.min = xs.min + 1-        f mp (xs :< ys) = upd (second $ min (maxRhs - 1)) xs $-                          upd (first  $ max (minLhs + 1)) ys mp-            where-                minLhs = grab fst xs mp-                maxRhs = grab snd ys mp---        grab side xs mp = sum $ map (side . (mp IntMap.!) . fromEnum) xs--        -- TODO: does not deal well with multiple elements on either side-        --       some constraints may not be satisfied-        upd op [x] mp = IntMap.update (Just . op) (fromEnum x) mp-        upd op _ mp = mp
src/Hoogle/Query/All.hs view
@@ -1,10 +1,7 @@ -module Hoogle.Query.All (-        module Hoogle.Query.Type, module Hoogle.Query.Parser,-        module Hoogle.Query.Render, module Hoogle.Query.Suggest-    ) where+module Hoogle.Query.All(module X) where -import Hoogle.Query.Type-import Hoogle.Query.Parser-import Hoogle.Query.Render-import Hoogle.Query.Suggest+import Hoogle.Query.Type     as X+import Hoogle.Query.Parser   as X+import Hoogle.Query.Render   as X+import Hoogle.Query.Suggest  as X
src/Hoogle/Query/Parser.hs view
@@ -1,33 +1,40 @@ -module Hoogle.Query.Parser(parseQuery, parseCmdLineQuery, parsecQuery) where+module Hoogle.Query.Parser(parseQuery) where -import General.Code hiding (merge,merges)+import General.Base import Hoogle.Query.Type-import Hoogle.TypeSig.All-import Text.ParserCombinators.Parsec+import Hoogle.Type.All as Hoogle+import Text.ParserCombinators.Parsec hiding (ParseError)+import qualified Text.ParserCombinators.Parsec as Parsec  -ascSymbols = "!#$%&*+./<=>?@\\^|-~:"- parseQuery :: String -> Either ParseError Query-parseQuery input = parse parsecQuery "" input+parseQuery x = case bracketer x of+    Left err -> Left err+    Right _ -> case parse parsecQuery "" x of+        Left err -> Left $ toParseError x err+        Right x -> Right x  --- TODO: I don't think this handles spaces/quotes properly in the right---       places.-parseCmdLineQuery :: [String] -> Either ParseError Query-parseCmdLineQuery args = parseQuery $ unwords $ map f args-    where-        f x | any isSpace x && ("--" `isPrefixOf` x || "/" `isPrefixOf` x) = "\"" ++ x ++ "\""-            | otherwise = x+toParseError :: String -> Parsec.ParseError -> Hoogle.ParseError+toParseError src x = parseErrorWith (sourceLine pos) (sourceColumn pos) (show x) src+    where pos = errorPos x  -merge (Query a1 b1 c1 d1) (Query a2 b2 c2 d2) =-        Query (a1++a2) (b1++b2) (c1 `mplus` c2) (d1++d2)+ascSymbols = "->!#$%&*+./<=?@\\^|~:" -merges xs = foldr merge blankQuery xs +optionBool :: Parser a -> Parser Bool+optionBool p = (p >> return True) <|> return False ++joinQuery (Query a1 b1 c1) (Query a2 b2 c2) = Query (a1++a2) (b1 `mplus` b2) (c1++c2)+joinQueries = foldr joinQuery blankQuery+++---------------------------------------------------------------------+-- QUERY PARSEC+ parsecQuery :: Parser Query parsecQuery = do spaces ; try (end names) <|> (end types)     where@@ -35,7 +42,7 @@              names = do a <- many (flag <|> name)                    b <- option blankQuery (string "::" >> spaces >> types)-                   let res@Query{names=names} = merge (merges a) b+                   let res@Query{names=names} = joinQuery (joinQueries a) b                        (op,nop) = partition ((`elem` ascSymbols) . head) names                    if op /= [] && nop /= []                        then fail "Combination of operators and names"@@ -43,7 +50,7 @@                  name = (do x <- operator ; spaces ; return blankQuery{names=[x]})                <|>-               (do xs <- keyword False `sepBy1` (char '.') ; spaces+               (do xs <- keyword `sepBy1` (char '.') ; spaces                    return $ case xs of                        [x] -> blankQuery{names=[x]}                        xs -> blankQuery{names=[last xs],scope=[PlusModule (init xs)]}@@ -58,47 +65,163 @@         types = do a <- flags                    b <- parsecTypeSig                    c <- flags-                   return $ merges [a,blankQuery{typeSig=Just b},c]+                   return $ joinQueries [a,blankQuery{typeSig=Just b},c] -        flag = do x <- parseFlagScope ; spaces ; return x-        flags = many flag >>= return . merges-                   +        flag = try $ do x <- parseFlagScope ; spaces ; return x+        flags = fmap joinQueries $ many flag   -- deal with the parsing of:---     --count=30---     /module---     /?  (special case)---     +Data.Map+--     -package+--     +Module.Name parseFlagScope :: Parser Query-parseFlagScope = do x <- try scope <|> try flag-                    spaces-                    return x+parseFlagScope = do+    pm <- oneOf "+-"+    let aPackage = if pm == '+' then PlusPackage else MinusPackage+        aModule  = if pm == '+' then PlusModule  else MinusModule+        modname  = keyword `sepBy1` (char '.')+    modu <- modname+    case modu of+        [x] -> return $ blankQuery{scope=[if isLower (head x) then aPackage x else aModule [x]]}+        xs -> return $ blankQuery{scope=[aModule xs]}+++keyword = do+    x <- letter+    xs <- many $ satisfy $ \x -> isAlphaNum x || x `elem` "_'#-"+    return $ x:xs+++---------------------------------------------------------------------+-- TYPESIG PARSEC++parsecTypeSig :: Parser TypeSig+parsecTypeSig = do whites+                   c <- context+                   t <- typ0+                   return $ normaliseTypeSig $ TypeSig c t     where-        -- --n=30, --count=30, /flag, --flag-        -- either a flag or an itemType-        flag = do string "--" <|> string "/"-                  name <- many1 letter <|> string "?"-                  extra <- (do char '='; flagExtra) <|> (return "")-                  return blankQuery{flags=[Flag (map toLower name) extra]}+        -- all the parser must swallow up all trailing white space after them+        context = try acontext <|> return []+        +        acontext = do x <- conitems <|> fmap (:[]) conitem+                      white $ string "=>"+                      return x+        +        conitems = between (wchar '(') (wchar ')') $ conitem `sepBy1` wchar ','+        conitem = typ1+        +    +        typ0 = function+        typ1 = application+        typ2 = forAll <|> tuple <|> list <|> atom <|> bang++        bang = wchar '!' >> typ2+        +        forAll = do try (white $ string "forall")+                    many atom+                    wchar '.'+                    TypeSig con typ <- parsecTypeSig+                    return typ+++        -- match (a,b) and (,)+        -- also pick up ( -> )+        tuple = do char '('+                   hash <- optionBool $ char '#'+                   let close = white $ string $ ['#'|hash] ++ ")"+                   whites +                   (do wchar ','+                       xs <- many $ wchar ','+                       close+                       return $ tLit hash (length xs + 1)+                    ) <|>+                    (do sym <- white keysymbol+                        close+                        return $ TLit sym+                    ) <|>+                    (do xs <- typ0 `sepBy` wchar ','+                        close+                        return $ case xs of+                            [] -> TLit "()"+                            [x] -> x+                            xs -> TApp (tLit hash $ length xs - 1) xs+                    )             where-                flagExtra = quoteStr <|> spaceStr-                quoteStr = between (char '\"') (char '\"') (many anyChar)-                spaceStr = manyTill anyChar ((space >> return ()) <|> eof)+                tLit hash n = TLit $ "(" ++ h ++ replicate n ',' ++ h ++ ")"+                    where h = ['#'|hash]+            +            +        atom = do x <- satisfy (\x -> isAlpha x || x == '_')+                  xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#")+                  whites+                  return $ (if isLower x || x == '_' then TVar else TLit) (x:xs) -        scope = do pm <- oneOf "+-"-                   let aPackage = if pm == '+' then PlusPackage else MinusPackage-                       aModule  = if pm == '+' then PlusModule  else MinusModule-                   modu <- modname-                   case modu of-                       [x] -> return $ blankQuery{scope=[if isLower (head x) then aPackage x else aModule [x]]}-                       xs -> return $ blankQuery{scope=[aModule xs]}+        -- may be [a], or [] (then application takes the a after it)+        list = do char '['+                  colon <- optionBool $ char ':'+                  spaces+                  let close = white $ string $ [':'|colon] ++ "]"+                      lit = TLit $ if colon then "[::]" else "[]"+                  (close >> return lit) <|> (do+                      x <- typ0+                      close+                      return $ TApp lit [x]) -        modname = keyword True `sepBy1` (char '.')+        application = do (x:xs) <- many1 (white typ2)+                         return $ TApp x xs +        function = do lhs <- typ1+                      (do op <- white keysymbol; rhs <- function; return $ TApp (TLit op) [lhs,rhs])+                          <|> return lhs -keyword hyphen = do-    x <- letter-    xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#" || (hyphen && x == '-'))-    return (x:xs)+        wchar c = white $ char c+        white x = do y <- x ; whites ; return y +        whites = many whiteChar+        whiteChar = oneOf " \v\f\t\r"++        keysymbol = try $ do+            x <- many1 $ satisfy (\x -> isSymbol x || x `elem` ascSymbols)+            if x `elem` reservedSym then fail "Bad symbol" else return x+        reservedSym = ["::","=>",".","=","#",":","-","+","/","--"]+++--------------------------------------------------------------------+-- BRACKETER++openBrackets = "(["+shutBrackets = ")]"+++data Bracket = Bracket Char [Bracket] -- Char is one of '(' or '['+             | NoBracket Char+               deriving Show++bracketer :: String -> Either ParseError [Bracket]+bracketer xs = case readBracket (1,xs) of+    Left (msg,from,to) -> f msg from to+    Right (res,(i,_:_)) -> f "Unexpected closing bracket" i (length xs)+    Right (res,_) -> Right res+    where+        f msg from to = Left $ ParseError 1 from msg $ formatTags xs [((from-1,to-1),TagEmph)]+++type StrPos = (Int,String)++-- Given a list of pos/chars return either a failure (msg,start,end) or some bracket and the remaining chars+readBracket :: StrPos -> Either (String,Int,Int) ([Bracket], StrPos)+readBracket (i,"") = Right ([],(i,""))+readBracket (i, x:xs)+    | x `elem` shutBrackets = Right ([], (i,x:xs))+    | x `elem` openBrackets = case readBracket (i+1,xs) of+        Left e -> Left e+        Right (_, (j,[])) -> Left ("Closing bracket expected", i, j)+        Right (res, (j,y:ys))+            | elemIndex x openBrackets /= elemIndex y shutBrackets -> Left ("Bracket mismatch", i, j+1)+            | otherwise -> case readBracket (j+1,ys) of+                Left e -> Left e+                Right (a,b) -> Right (Bracket x res:a, b)+    | otherwise = case readBracket (i+1,xs) of+        Left e -> Left e+        Right (a,b) -> Right (NoBracket x:a, b)
src/Hoogle/Query/Render.hs view
@@ -1,15 +1,14 @@  module Hoogle.Query.Render(renderQuery) where -import General.Code-import Data.TagStr+import General.Base import Data.Generics.Uniplate import Hoogle.Query.Type-import Hoogle.TypeSig.All+import Hoogle.Type.All   renderQuery :: Query -> TagStr-renderQuery x = Tags $ namesig ++ scp ++ itms ++ flgs+renderQuery x = Tags $ namesig ++ [Str " " | namesig /= [] && scp /= []] ++ scp     where         namesig = case (null (names x), isNothing (typeSig x)) of                       (True, True) -> []@@ -20,20 +19,21 @@                                                          , y:ys <- [dropWhile isSpace xs]]                  showName = intersperse (Str " ") $ map (TagBold . Str) (names x)-        showType = Str (showConstraint con) :-                   intersperse (Str " -> ") -                       (zipWith TagColor [0..] (map (Str . show) finit) ++-                        [Str (show flast)])-            where-                Just (TypeSig con args) = typeSig x-                (finit, flast) = (init funcs, last funcs)-                funcs = splitFun args-        -        scp = []-        itms = []-        -        -        flgs = concatMap (\x -> [Str " ", Str (f x)]) (flags x)-            where-                f (Flag name extra) = "/" ++ name ++ ['='|not $ null extra] ++ q ++ extra ++ q-                    where q = ['\"' | any isSpace extra]+        showType = [renderTypeSig $ fromJust $ typeSig x]++        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+++renderTypeSig :: TypeSig -> TagStr+renderTypeSig (TypeSig con args) = Tags $+    Str (showConstraint con) :+    intersperse (Str " -> ")+       (zipWith TagColor [1..] (map (Str . showFun) finit) +++        [TagColor 0 $ Str $ showFun flast])+    where+        (finit, flast) = (init funcs, last funcs)+        funcs = splitFun args
src/Hoogle/Query/Suggest.hs view
@@ -1,19 +1,19 @@  module Hoogle.Query.Suggest(suggestQuery) where -import Data.TagStr-import General.Code+import General.Base+import General.Util import Hoogle.DataBase.All import Hoogle.Query.Type import Hoogle.Query.Render-import Hoogle.TypeSig.All+import Hoogle.Type.All   suggestQuery :: [DataBase] -> Query -> Maybe TagStr  -- They searched for Google (pay homage) suggestQuery db q | "google" `elem` map (map toLower) (names q) =-    Just $ Tags [TagHyperlink "http://www.google.com/" (Str "Google"), Str " rocks!"]+    Just $ Tags [TagLink "http://www.google.com/" (Str "Google"), Str " rocks!"]  -- They searched for ?oogle (mock) suggestQuery db q | any f (names q) = Just $ Str "Can't think of anything more interesting to search for?"@@ -41,7 +41,7 @@   didYouMean :: Query -> TagStr-didYouMean q = Tags [TagBold $ Str "Did you mean: ", TagHyperlink ("query:" ++ s) $ Str s]+didYouMean q = Tags [TagBold $ Str "Did you mean: ", TagLink ("query:" ++ s) $ Str s]     where s = showTagText $ renderQuery q
src/Hoogle/Query/Type.hs view
@@ -1,51 +1,32 @@+{-# LANGUAGE DeriveDataTypeable #-}  module Hoogle.Query.Type where  import Data.Maybe-import Data.Char-import Data.Generics.UniplateOn--import General.Code-import Hoogle.TypeSig.All---usefulQuery query = not (null (names query)) || isJust (typeSig query)+import Data.Data+import Hoogle.Type.All  -blankQuery = Query [] [] Nothing []--data Query = Query {-        scope :: [Scope],-        names :: [String],-        typeSig :: Maybe TypeSig,-        flags :: [Flag]+data Query = Query+    {names :: [String]+    ,typeSig :: Maybe TypeSig+    ,scope :: [Scope]     }-    deriving Show+    deriving (Data,Typeable,Show,Eq)  -instance Eq Query where-    (Query a1 b1 c1 d1) == (Query a2 b2 c2 d2) =-        and [a1 `setEq` a2, b1 `setEq` b2, c1 == c2, d1 `setEq` d2]+isBlankQuery :: Query -> Bool+isBlankQuery query = null (names query) && isNothing (typeSig query) +blankQuery :: Query+blankQuery = Query [] Nothing [] + data Scope = PlusPackage  String            | MinusPackage String            | PlusModule  [String]            | MinusModule [String]-           deriving (Eq, Show, Read)+           deriving (Eq, Show, Read, Data, Typeable)  isPlusModule  (PlusModule  _) = True; isPlusModule  _ = False isMinusModule (MinusModule _) = True; isMinusModule _ = False----- primarily for consoles, but some work on the web search--- first is the name, second is optional data-data Flag = Flag String String-            deriving (Eq, Show, Read)---transformQueryType :: (Type -> Type) -> Query -> Query-transformQueryType f q = q{typeSig = maybe Nothing (Just . transformOn onTypeSig f) (typeSig q)}--universeQueryType :: Query -> [Type]-universeQueryType = maybe [] (universeOn onTypeSig) . typeSig
+ src/Hoogle/Score/All.hs view
@@ -0,0 +1,8 @@++module Hoogle.Score.All(+    module Hoogle.Score.Scoring,+    Score, TypeCost(..), TextMatch(..), textScore, typeScore, scoreCosts, cost+    ) where++import Hoogle.Score.Scoring+import Hoogle.Score.Type
+ src/Hoogle/Score/Scoring.hs view
@@ -0,0 +1,70 @@++module Hoogle.Score.Scoring(scoring) where++import Hoogle.Score.Type+import Data.List+import Control.Arrow+import Data.Ord+import Data.Maybe+import Control.Monad+import System.Random+++-- | A list of scores where one is lower than the other, returns the score result.+--   In the 'IO' monad since it may require randomness, and it may output status messages while solving,+--   particularly if in Verbose mode.+scoring :: [(Score,Score)] -> IO String+scoring xs = do+    let cost ys = sum [max 0 $ 1 + vals a - vals b | (a,b) <- xs+                      ,let vals = sum . map (fromRange . fromJust . flip lookup ys) . scoreCosts]+    config <- solveConfig cost [(x::TypeCost, toRange [1..10]) | x <- [minBound..maxBound]]+    return $ unlines ["cost " ++ show a ++ " = " ++ show (fromRange b) | (a,b) <- config]+++---------------------------------------------------------------------+-- SOLVER++type Cost = Int++-- zipper on the value+data Range a = Range [a] a [a] deriving Show+toRange (x:xs) = Range [] x xs+fromRange (Range _ x _) = x++type Config = [(TypeCost,Range Int)]++bestConfig f = snd . minimumBy (comparing fst) . map (f &&& id)++nextRange (Range a b c) = [Range as a (b:c) | a:as <- [a]] ++ [Range (b:a) c cs | c:cs <- [c]]+nextConfig = perturb $ \(a,b) -> map ((,) a) $ nextRange b++randomRange (Range x y z) = do+    let xs = reverse x ++ y:z+    i <- randomRIO (0,length xs-1)+    let (x2,y2:z2) = splitAt i xs+    return $ Range (reverse x2) y2 z2++randomConfig = mapM $ \(a,b) -> fmap ((,) a) $ randomRange b+++-- | Greedy hill climbing to improve a config+improveConfig :: (Config -> Cost) -> Config -> Config+improveConfig f now | f next < f now = improveConfig f next+                    | otherwise = now+    where next = bestConfig f $ nextConfig now+++-- | Try and minimize the cost of the config+solveConfig :: (Config -> Cost) -> Config -> IO Config+solveConfig f x = fmap (bestConfig f) $ replicateM 25 $ do+    putChar '.'+    y <- randomConfig x+    let z = improveConfig f y+    print (f y,f z)+    return z+++-- | Perturb one value in the list+perturb :: (a -> [a]) -> [a] -> [[a]]+perturb f [] = [[]]+perturb f (x:xs) = map (:xs) (f x) ++ map (x:) (perturb f xs)
+ src/Hoogle/Score/Type.hs view
@@ -0,0 +1,72 @@++module Hoogle.Score.Type(+    Score, TypeCost(..), TextMatch(..),+    textScore, typeScore,+    scoreCosts, cost+    ) where++import Data.List+import Data.Monoid+++data TypeCost+    = CostAliasFwd+    | CostAliasBwd+    | CostUnbox+    | CostRebox+    | CostRestrict+    | CostUnrestrict+    | CostDupVarResult+    | CostDupVarQuery+    | CostInstanceDel+    | CostInstanceAdd+    | CostDeadArg+    | CostArgReorder+      deriving (Show,Eq,Ord,Enum,Bounded)++cost :: TypeCost -> Int+cost CostAliasFwd     =    1  -- 1..1000+cost CostAliasBwd     =    1  -- 1..997+cost CostUnbox        =    5  -- 5..1000+cost CostRebox        =    4  -- 4..999+cost CostRestrict     =    5  -- 5..1000+cost CostUnrestrict   =    4  -- 4..1000+cost CostDupVarResult =    4  -- 4..999+cost CostDupVarQuery  =    5  -- 5..1000+cost CostInstanceDel  =    4  -- 4..999+cost CostInstanceAdd  =    4  -- 4..999+cost CostDeadArg      =    3  -- 3..998+cost CostArgReorder   =    1  -- 1..1000+++data TextMatch+    = MatchExact+    | MatchPrefix+    | MatchSubstr+      deriving (Show,Eq,Ord,Enum,Bounded)+++data Score = Score Int [TypeCost] [TextMatch]++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)++textScore :: TextMatch -> Score+textScore x = Score 0 [] [x]++typeScore :: [TypeCost] -> Score+typeScore xs = Score (sum $ map cost xs) (sort xs) []++scoreCosts :: Score -> [TypeCost]+scoreCosts (Score _ x _) = x+++instance Show Score where+    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++instance Ord Score where+    compare (Score x1 x2 x3) (Score y1 y2 y3) = compare (x1,x3) (y1,y3)
src/Hoogle/Search/All.hs view
@@ -1,17 +1,12 @@  module Hoogle.Search.All(-    Result(..), renderResult,     searchAll, searchRange     ) where -import Data.Maybe-import Data.Range- import Hoogle.DataBase.All import Hoogle.Query.All-import Hoogle.Search.Result import Hoogle.Search.Results-import Hoogle.TypeSig.All+import Hoogle.Type.All   -- return all the results@@ -20,8 +15,9 @@   -- should be possible to fast-path certain searches, currently not done-searchRange :: Range -> [DataBase] -> Query -> [Result]-searchRange r databases query = listRange r $ getResults query databases+-- start index, end index+searchRange :: (Int,Int) -> [DataBase] -> Query -> [Result]+searchRange (from,to) databases query = take (to - from + 1) $ drop from $ getResults query databases   getResults :: Query -> [DataBase] -> [Result]@@ -32,10 +28,10 @@   nameSearch :: DataBase -> String -> [Result]-nameSearch db query = [Result e [v] [TextScore s]+nameSearch db query = [Result e [v] s                       | (e,v,s) <- searchName db query]   typeSearch :: DataBase -> TypeSig -> [Result]-typeSearch db query = [Result e v [TypeScore s]+typeSearch db query = [Result e v s                       | (e,v,s) <- searchType db query]
− src/Hoogle/Search/Result.hs 
@@ -1,36 +0,0 @@--module Hoogle.Search.Result where--import General.Code-import Data.TagStr-import Hoogle.DataBase.All-import Hoogle.Item.All-import Data.Binary.Defer.Index---data Result = Result-    {resultEntry :: Link Entry-    ,resultView :: [EntryView]-    ,resultScore :: [Score]-    }-    deriving Show---- TypeScore must be less than TextScore--- so that when name :: type is searched, type takes preference-data Score = TypeScore TypeScore-           | TextScore TextScore-             deriving (Eq,Ord)--instance Show Score where-    showList xs = showString $ concat $ intersperse " & " $ map show xs-    show (TypeScore x) = show x-    show (TextScore x) = show x----- return (module it is in, the text to go beside it, verbose scoring info)-renderResult :: Result -> (Maybe [String], TagStr, String)-renderResult r = (if entryType e == EntryModule then Nothing-                  else liftM (moduleName . fromLink) $ entryModule e-                 ,renderEntryText (resultView r) $ entryText e-                 ,show $ resultScore r)-    where e = fromLink $ resultEntry r
src/Hoogle/Search/Results.hs view
@@ -3,18 +3,32 @@     mergeDataBaseResults, mergeQueryResults     ) where -import General.Code-import Data.Key+import General.Base+import General.Util import qualified Data.IntMap as IntMap import Data.Binary.Defer.Index -import Hoogle.Item.All-import Hoogle.DataBase.All+import Hoogle.Type.All import Hoogle.Query.All-import Hoogle.Search.Result   ---------------------------------------------------------------------+-- KEYS++data Key k v = Key k v++instance Eq k => Eq (Key k v) where+    Key k1 v1 == Key k2 v2 = k1 == k2++instance Ord k => Ord (Key k v) where+    compare (Key k1 v1) (Key k2 v2) = compare k1 k2++toKey f v = Key (f v) v+fromKey (Key k v) = v+sortWith f = map fromKey . sort . map (toKey f)+++--------------------------------------------------------------------- -- MERGE DATABASE  mergeDataBaseResults :: [[Result]] -> [Result]@@ -22,12 +36,6 @@     where f r = (resultScore r, entryScore $ fromLink $ resultEntry r)  -entryScoreModule :: Maybe Module -> Entry -> EntryScore-entryScoreModule mod e = EntryScore-    (length m) (map toLower $ entryName e) (entryName e) m-    where m = maybe [] moduleName mod-- --------------------------------------------------------------------- -- MERGE QUERY @@ -46,7 +54,7 @@     where         asSet = IntMap.fromList . map (linkKey . resultEntry &&& id) -        join r1 r2 = r1{resultScore = sort $ resultScore r1 ++ resultScore r2+        join r1 r2 = r1{resultScore = mappend (resultScore r1) (resultScore r2)                        ,resultView = resultView r1 ++ resultView r2}          scr = resultScore &&& linkKey . resultEntry@@ -68,12 +76,12 @@  -- pkgs is a non-empty list of MinusPackage values correctPackage :: [String] -> Entry -> Bool-correctPackage pkgs = (`notElem` pkgs) . packageName . fromLink . entryPackage+correctPackage pkgs = maybe True ((`notElem` pkgs) . entryName . fromLink) . entryPackage   -- mods is a non-empty list of PlusModule/MinusModule correctModule :: [Scope] -> Entry -> Bool-correctModule mods = maybe True (f base mods . moduleName . fromLink) . entryModule+correctModule mods = maybe True (f base mods . split '.' . entryName . fromLink) . entryModule     where         base = isMinusModule $ head mods
− src/Hoogle/TextBase/All.hs 
@@ -1,7 +0,0 @@--module Hoogle.TextBase.All (-        module Hoogle.TextBase.Type, module Hoogle.TextBase.Parser-    ) where--import Hoogle.TextBase.Type-import Hoogle.TextBase.Parser
− src/Hoogle/TextBase/Parser.hs 
@@ -1,90 +0,0 @@--module Hoogle.TextBase.Parser(parseTextBase,parseTextBaseString) where--import General.Code-import Hoogle.TextBase.Type-import Hoogle.TypeSig.All-import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Error---parseTextBase :: FilePath -> IO (Either ParseError TextBase)-parseTextBase file = do-    src <- readFile file-    return $ parseTextItems file src---parseTextBaseString :: String -> Either ParseError TextBase-parseTextBaseString = parseTextItems ""---parseTextItems :: FilePath -> String -> Either ParseError TextBase-parseTextItems file = join . f [] . zip [1..] . lines-    where-        f com [] = []-        f com ((i,s):is)-            | "-- | " `isPrefixOf` s = f [drop 5 s] is-            | "--" `isPrefixOf` s = f ([drop 5 s | com /= []] ++ com) is-            | all isSpace s = f [] is-            | otherwise = (case parse parsecTextItem file s of-                               Left y -> Left $ setErrorPos (setSourceLine (errorPos y) i) y-                               Right y -> Right [(y, unlines $ reverse com)])-                          : f [] is--        join xs | null err = Right $ concat items-                | otherwise = Left $ head err-            where (err,items) = unzipEithers xs---isTextItem :: String -> Bool-isTextItem x = not $ null x2 || "--" `isPrefixOf` x2-    where x2 = dropWhile isSpace x---parsecTextItem :: Parser TextItem-parsecTextItem = attribute <|> item-    where-        attribute = do x <- try (char '@' >> satisfy isAlpha)-                       xs <- many (satisfy isAlpha)-                       spaces-                       ys <- many (noneOf "\n")-                       return $ ItemAttribute (x:xs) ys--        item = modu <|> clas <|> inst <|> newtyp <|> typ <|> dat <|> func-        -        begin x = try (string x >> many1 space)--        modu = begin "module" >> liftM ItemModule (keyword `sepBy1` char '.')-        clas = begin "class" >> liftM ItemClass parsecTypeSig-        inst = begin "instance" >> liftM ItemInstance parsecTypeSig-        -        typ = do begin "type"-                 a <- parsecTypeSig-                 char '='-                 b <- parsecTypeSig-                 return $ ItemAlias a b-        -        newtyp = begin "newtype" >> dataAny NewTypeKeyword-        dat = begin "data" >> dataAny DataKeyword-        -        dataAny d = liftM (ItemData d) parsecTypeSig--        -        func = do name <- rounds <|> keysymbol <|> keyword <|> string "[]"-                  spaces-                  string "::"-                  spaces-                  typ <- parsecTypeSig-                  return $ ItemFunc name typ--        -- handle both () and (op)-        rounds = char '(' >>-            ((do x <- keysymbol ; char ')' ; return x) <|>-             (do char ')'; return "()"))--        keysymbol = many1 $ satisfy (\x -> isSymbol x || x `elem` ascSymbol)-        ascSymbol = "!#$%&*+./<=>?@\\^|-~:"--        keyword = do x <- satisfy (\x -> isAlphaNum x || x == '_')-                     xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#")-                     return (x:xs)
− src/Hoogle/TextBase/Type.hs 
@@ -1,54 +0,0 @@--module Hoogle.TextBase.Type where--import Hoogle.TypeSig.All-import Data.Binary.Defer-import General.Code----- (the item, any haddock documentation)-type TextBase = [(TextItem,String)]--data TextItem = ItemModule [String]-              | ItemClass TypeSig-              | ItemFunc String TypeSig-              | ItemAlias TypeSig TypeSig-              | ItemData DataKeyword TypeSig-              | ItemInstance TypeSig-              | ItemAttribute String String-              deriving (Show,Eq)---data DataKeyword = NewTypeKeyword-                 | DataKeyword-                 deriving (Enum,Eq)--instance Show DataKeyword where-    show NewTypeKeyword = "newtype"-    show DataKeyword = "data"---instance BinaryDefer TextItem where-    put (ItemModule    a  ) = putByte 0 >> put1 a-    put (ItemClass     a  ) = putByte 1 >> put1 a-    put (ItemFunc      a b) = putByte 2 >> put2 a b-    put (ItemAlias     a b) = putByte 3 >> put2 a b-    put (ItemData      a b) = putByte 4 >> put2 a b-    put (ItemInstance  a  ) = putByte 5 >> put1 a-    put (ItemAttribute a b) = putByte 6 >> put2 a b--    get = do-        x <- getByte-        case x of-            0 -> get1 ItemModule-            1 -> get1 ItemClass-            2 -> get2 ItemFunc-            3 -> get2 ItemAlias-            4 -> get2 ItemData-            5 -> get1 ItemInstance-            6 -> get2 ItemAttribute---instance BinaryDefer DataKeyword where-    put = putEnumByte-    get = getEnumByte
+ src/Hoogle/Type/All.hs view
@@ -0,0 +1,9 @@++module Hoogle.Type.All(module X) where++import Hoogle.Type.Documentation  as X+import Hoogle.Type.Item           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/Documentation.hs view
@@ -0,0 +1,76 @@++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+++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
@@ -0,0 +1,98 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Hoogle.Type.Item where++import General.Base+import Data.Binary.Defer+import Data.Binary.Defer.Index+import Hoogle.Type.Documentation+import Hoogle.Type.TagStr+import Hoogle.Type.TypeSig+import Data.Generics.Uniplate+++type Input = ([Fact], [TextItem])+++data TextItem = TextItem+    {itemLevel :: Int -- 0 = package, 1 = module, >2 = entry+    ,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+    ,itemDisp :: TagStr -- TagColor 0 for result type, TagColor 1.. for arg types, TagBold for name+    ,itemURL :: URL+    ,itemDocs :: String+    ,itemPriority :: Int -- priority, 0 is highest priority+    }+    deriving Show++data Fact+    = FactAlias TypeSig TypeSig+    | FactInstance TypeSig+    | FactDataKind String Int+    | FactClassKind String Int+    | FactCtorType String String -- Ctor, Data+      deriving Show+++data Entry = Entry+    {entryPackage :: Maybe (Link Entry)+    ,entryModule :: Maybe (Link Entry)+    ,entryName :: String+    ,entryText :: TagStr+    ,entryDocs :: Documentation+    ,entryURL :: URL+    ,entryPriority :: Int+    ,entryKey :: String -- used only for rebuilding combined databases+    ,entryType :: Maybe TypeSig -- used only for rebuilding combined databases+    }+    deriving (Typeable)+++data EntryView = FocusOn String -- characters in the range should be focused+               | ArgPosNum Int Int -- argument a b, a is remapped to b+                 deriving Show+++renderEntryText :: [EntryView] -> TagStr -> TagStr+renderEntryText view = transform f+    where+        cols = [(b+1,a+1) | ArgPosNum a b <- view]+        strs = [map toLower x | FocusOn x <- view]++        f (TagColor i x) = maybe x (`TagColor` x) $ lookup i $ [(0,0)|cols/=[]] ++ cols+        f (TagBold (Str xs)) = TagBold $ Tags $ g xs+        f x = x++        g xs | ss /= [] = TagEmph (Str a) : g b+            where ss = filter (`isPrefixOf` map toLower xs) strs+                  (a,b) = splitAt (maximum $ map length ss) xs+        g (x:xs) = Str [x] : g xs+        g [] = []+++-- TODO: EntryScore is over-prescriptive, and not overly useful+--       Have name and type scores to it themselves, using name only+--       to break ties when merging+-- the entry priority+-- the name of the entry, in lower case+-- the name of the entry+-- the module+data EntryScore = EntryScore Int String String String+                  deriving (Eq,Ord)+++entryScore :: Entry -> EntryScore+entryScore e = EntryScore (entryPriority e) (map toLower $ entryName e) (entryName e) m+    where m = maybe [] (entryName . fromLink) $ entryModule e++instance Show Entry where+    show e = unwords [showTagText $ entryText e, m]+        where+            m = case entryModule e of+                    Nothing -> ""+                    Just y -> "{#" ++ show (linkKey y) ++ "}"++instance BinaryDefer Entry where+    put (Entry a b c d e f g h i) = put9 a b c d e f g h i+    get = get9 Entry
+ src/Hoogle/Type/ParseError.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Hoogle.Type.ParseError where++import Hoogle.Type.TagStr+import Data.Data++-- | 1 based+data ParseError = ParseError+    {lineNo :: Int+    ,columnNo :: Int+    ,errorMessage :: String+    ,parseInput :: TagStr+    } deriving (Ord,Eq,Data,Typeable)++instance Show ParseError where+    show (ParseError line col err _) = "Parse error " ++ show line ++ ":" ++ show col ++ ": " ++ err+++emptyParseError :: ParseError+emptyParseError = ParseError 0 0 "" $ Str ""+++parseErrorWith :: Int -> Int -> String -> String -> ParseError+parseErrorWith line col err text = ParseError line col err $ Tags [Str pre, TagEmph $ Str $ post ++ post2]+    where+        (pre,post) = splitAt (col-1) text+        post2 = if null post then "   " else ""
+ src/Hoogle/Type/Result.hs view
@@ -0,0 +1,22 @@++module Hoogle.Type.Result where++import Hoogle.Type.TagStr+import Hoogle.Type.Item+import Hoogle.Score.All+import Data.Binary.Defer.Index+++data Result = Result+    {resultEntry :: Link Entry+    ,resultView :: [EntryView]+    ,resultScore :: Score+    }+    deriving Show+++-- return (module it is in, the text to go beside it, verbose scoring info)+renderResult :: Result -> (TagStr, String)+renderResult r = (renderEntryText (resultView r) $ entryText e+                 ,show $ resultScore r)+    where e = fromLink $ resultEntry r
+ src/Hoogle/Type/TagStr.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | A module representing strings with formatting.+module Hoogle.Type.TagStr(+    TagStr(..),+    showTagText, showTagANSI,+    showTagHTML, showTagHTMLWith,+    formatTags+    ) where++import General.Base+import General.Web+import Data.Generics.Uniplate+import Data.Binary.Defer+++data TagStr+    = Str String -- ^ Plain text.+    | Tags [TagStr] -- ^ A list of tags one after another.+    | TagBold TagStr -- ^ Bold text.+    | TagEmph TagStr -- ^ Underlined/italic text.+    | TagLink String TagStr -- ^ A hyperlink to a URL.+    | TagColor Int TagStr -- ^ Colored text. Index into a 0-based palette.+      deriving (Data,Typeable,Ord,Show,Eq)+++instance Monoid TagStr where+    mempty = Str ""+    mappend x y = Tags [x,y]+    mconcat = Tags+++instance Uniplate TagStr where+    uniplate (Tags xs) = (xs, Tags)+    uniplate (TagBold x) = ([x], \[x] -> TagBold x)+    uniplate (TagEmph x) = ([x], \[x] -> TagEmph x)+    uniplate (TagLink i x) = ([x], \[x] -> TagLink i x)+    uniplate (TagColor i x) = ([x], \[x] -> TagColor i x)+    uniplate x = ([], const x)+++instance BinaryDefer TagStr where+    put (Str x)        = putByte 0 >> put1 x+    put (Tags x)       = putByte 1 >> put1 x+    put (TagBold x)    = putByte 2 >> put1 x+    put (TagEmph x)    = putByte 3 >> put1 x+    put (TagLink x y)  = putByte 4 >> put2 x y+    put (TagColor x y) = putByte 5 >> put2 x y++    get = do i <- getByte+             case i of+                0 -> get1 Str+                1 -> get1 Tags+                2 -> get1 TagBold+                3 -> get1 TagEmph+                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+-}+++-- | Show a 'TagStr' as a string, without any formatting.+showTagText :: TagStr -> String+showTagText x = concat [y | Str y <- universe x]+++-- | Show a 'TagStr' on a console with ANSI escape sequences.+showTagANSI :: TagStr -> String+showTagANSI x = f [] x+    where+        f a (Str x) = x++        f a t =+            case getCode t of+                Nothing -> g a+                Just val -> tag (val:a) ++ g (val:a) ++ tag a+            where g a = concatMap (f a) (children t)+        +        getCode (TagBold _) = Just "1"+        getCode (TagLink url _) = if null url then Nothing else Just "4"+        getCode (TagEmph _) = Just "4"+        getCode (TagColor n _) | n <= 5 && n >= 0 = Just ['3', intToDigit (n + 1)]+        getCode _ = Nothing++        tag stack = chr 27 : '[' : intercalate ";" ("0":reverse stack) ++ "m"+++-- | Show a 'TagStr' as HTML, using CSS classes for color styling.+showTagHTML :: TagStr -> String+showTagHTML = showTagHTMLWith (const Nothing)+++-- | Show TagStr with an override for specific tags.+showTagHTMLWith :: (TagStr -> Maybe String) -> TagStr -> String+showTagHTMLWith f x = g x+    where+        g x | isJust (f x) = fromJust $ f x+        g (Str x) = nbsp $ escapeHTML x+        g (Tags xs) = concatMap g xs+        g (TagBold x) = htmlTag "b" $ showTagHTML x+        g (TagEmph x) = htmlTag "i" $ showTagHTML x+        -- FIXME: this is overly specific!+        g (TagLink "" x) = g (TagLink url x)+            where str = showTagText x+                  url = if "http:" `isPrefixOf` str then str else "?hoogle=" ++% str+        g (TagLink url x) = "<a href=\"" ++& url ++ "\">" ++ showTagHTML x ++ "</a>"+        g (TagColor i x) = "<span class='c" ++ show i ++ "'>" ++ showTagHTML x ++ "</span>"++        nbsp (' ':' ':xs) = " &nbsp;" ++ nbsp xs+        nbsp (x:xs) = x : nbsp xs+        nbsp [] = []+++-- each position is a 0-based start and end index+-- currently not allowed to overlap+formatTags :: String -> [((Int,Int),TagStr -> TagStr)] -> TagStr+formatTags o y = tags $ f o 0 $ sortBy (comparing $ fst . fst) y+    where+        f x i [] = str x+        f x i (((from,to),op):ss)+            | i > from = error $ "TagStr.formatTags, not allowed overlapping formats on: " ++ o+            | otherwise = str a ++ [op $ Str c] ++ f d to ss+                where (a,b) = splitAt (from-i) x+                      (c,d) = splitAt (to-from) b++        tags [] = Str ""+        tags [x] = x+        tags xs = Tags xs+        str x = [Str x | x /= ""]
+ src/Hoogle/Type/TypeSig.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Hoogle.Type.TypeSig where++import Data.Binary.Defer+import Data.List+import Data.Data+import Data.Generics.UniplateOn+++---------------------------------------------------------------------+-- DATA TYPE WITH CONTEXT+++-- FULL TYPE+data TypeSig = TypeSig Constraint Type+               deriving (Eq,Ord,Data,Typeable)++type Constraint = [Type]+++-- CONSTRICTED TYPE+-- first argument is a list of contexts, (Context,Variable)+type TypeContext = [(String,String)]+data TypeSimp = TypeSimp TypeContext Type+                deriving (Eq,Ord,Data,Typeable)++instance Show TypeSimp where+    show (TypeSimp c t) = show $ TypeSig [TApp (TLit a) [TVar b] | (a,b) <- c] t+++---------------------------------------------------------------------+-- DATA TYPES++data Type = TApp Type [Type] -- a list of types, first one being the constructor+          | TLit String -- bound variables, Maybe, ":", "(,)", "(,,)" (tuple)+          | TVar String -- unbound variables, "a"+          | TFun [Type]+          deriving (Eq,Ord,Data,Typeable)+++tApp :: Type -> [Type] -> Type+tApp t [] = t+tApp t ts = TApp t ts+++fromTFun :: Type -> [Type]+fromTFun (TFun x) = x+fromTFun x = [x]+++isTLit, isTVar :: Type -> Bool+isTLit TLit{} = True; isTLit _ = False+isTVar TVar{} = True; isTVar _ = False+++fromTApp :: Type -> (Type, [Type])+fromTApp (TApp x y) = (x,y)+fromTApp x = (x,[])+++isTLitTuple :: String -> Bool+isTLitTuple x = ',' `elem` x+++insertTApp, removeTApp :: Type -> Type+insertTApp = transform f+    where+        f (TApp (TApp x []) y) = TApp x y+        f (TApp x y) = TApp x y+        f (TFun x) = TFun x+        f x = TApp x []++removeTApp = transform f+    where+        f (TApp x []) = x+        f x = x+++---------------------------------------------------------------------+-- UNIPLATE INSTANCES++instance Uniplate Type where+    uniplate (TApp x xs) = (x:xs, \(x:xs) -> TApp x xs)+    uniplate (TFun xs) = (xs, TFun)+    uniplate x = ([], \[] -> x)++onTypeSig :: BiplateType TypeSig Type+onTypeSig (TypeSig xs x) = (x:xs, \(x:xs) -> TypeSig xs x)++transformSig = transformOn onTypeSig+universeSig = universeOn onTypeSig+++variables :: Type -> [String]+variables x = [v | TVar v <- universe x]++variablesSig :: TypeSig -> [String]+variablesSig x = [v | TVar v <- universeSig x]+++---------------------------------------------------------------------+-- BINARYDEFER INSTANCES++instance BinaryDefer TypeSig where+    put (TypeSig a b) = put2 a b+    get = get2 TypeSig++instance BinaryDefer 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+    put (TFun a)   = putByte 3 >> put1 a++    get = do+        i <- getByte+        case i of+            0 -> get2 TApp+            1 -> get1 TLit+            2 -> get1 TVar+            3 -> get1 TFun+++---------------------------------------------------------------------+-- SHOW INSTANCES++showConstraint :: Constraint -> String+showConstraint [] = ""+showConstraint [x] = show x ++ " => "+showConstraint xs = "(" ++ intercalate ", " (map show xs) ++ ") => "+++-- TODO: show (TLit ":+:") should be "(:+:)"+instance Show Type where+    showsPrec i x = showString $ f i x+        where+            -- Show lists and tuples specially+            f i (TApp (TLit "[]") [x]) = "[" ++ show x ++ "]"+            f i (TApp (TLit ('(':tup)) xs)+                | not (null tup) && last tup == ')' && all (== ',') (init tup) && length tup == length xs+                = b True $ intercalate ", " $ map show xs++            -- Should parallel lists and unboxed tuples specially+            f i (TApp (TLit "[::]") [x]) = "[:" ++ show x ++ ":]"+            f i (TApp (TLit ('(':'#':tup)) xs)+                | "#)" `isSuffixOf` tup && all (== ',') (drop 2 $ reverse tup) && length tup - 1 == length xs+                = "(# " ++ intercalate ", " (map show xs) ++ " #)"++            +            f i (TLit x) = x+            f i (TVar x) = x+            +            f i (TApp x xs) = b (i > 1) $ unwords $ map (f 2) (x:xs)+            f i (TFun xs)   = b (i > 0) $ intercalate " -> " $ map (f 1) xs+            +            b True x = "(" ++ x ++ ")"+            b False x = x+++instance Show TypeSig where+    show (TypeSig x xs) = showConstraint x ++ show xs+++-- shows an element within a function+-- to get brackets right after splitFun+showFun :: Type -> String+showFun x = showsPrec 1 x ""+++---------------------------------------------------------------------+-- OPERATIONS++normaliseTypeSig :: TypeSig -> TypeSig+normaliseTypeSig = transformOn onTypeSig normaliseType+++normaliseType :: Type -> Type+normaliseType = transform f+    where+        f (TApp x []) = x+        f (TApp (TLit "->") xs) = f $ TFun xs+        f (TFun [x]) = x+        f (TFun xs) = TFun $ g xs+        f x = x++        g [] = []+        g [TFun xs] = g xs+        g (x:xs) = x : g xs+++splitFun :: Type -> [Type]+splitFun (TFun xs) = xs+splitFun x = [x]+++renameVars :: (String -> String) -> TypeSig -> TypeSig+renameVars f = transformOn onTypeSig g+    where+        g (TVar x) = TVar $ f x+        g x = x
− src/Hoogle/TypeSig/All.hs 
@@ -1,7 +0,0 @@--module Hoogle.TypeSig.All (-        module Hoogle.TypeSig.Type, module Hoogle.TypeSig.Parser-    ) where--import Hoogle.TypeSig.Type-import Hoogle.TypeSig.Parser
− src/Hoogle/TypeSig/Parser.hs 
@@ -1,108 +0,0 @@--module Hoogle.TypeSig.Parser(parsecTypeSig, parseTypeSig) where--import Hoogle.TypeSig.Type-import Text.ParserCombinators.Parsec-import General.Code---parseTypeSig :: String -> Either ParseError TypeSig-parseTypeSig input = parse (do x <- parsecTypeSig ; eof ; return x) "" input---parsecTypeSig :: Parser TypeSig-parsecTypeSig = do whites-                   c <- context-                   t <- typ0-                   return $ normaliseTypeSig $ TypeSig c t-    where-        -- all the parser must swallow up all trailing white space after them-        context = try acontext <|> return []-        -        acontext = do x <- conitems <|> (conitem >>= return . (:[]))-                      white $ char '=' >> oneOf "#>"-                      return x-        -        conitems = between (wchar '(') (wchar ')') $ conitem `sepBy1` (wchar ',')-        conitem = typ1-        -    -        typ0 = function-        typ1 = application-        typ2 = forAll <|> tuple <|> list <|> atom <|> bang--        bang = wchar '!' >> typ2-        -        forAll = do try (white $ string "forall")-                    many atom-                    wchar '.'-                    TypeSig con typ <- parsecTypeSig-                    return typ---        -- match (a,b) and (,)-        -- also pick up ( -> )-        tuple = do char '('-                   hash <- optionBool $ char '#'-                   let close = white $ string $ ['#'|hash] ++ ")"-                   whites -                   (do wchar ','-                       xs <- many $ wchar ','-                       close-                       return $ tLit hash (length xs + 1)-                    ) <|>-                    (do sym <- white keysymbol-                        close-                        return $ TLit sym-                    ) <|>-                    (do xs <- typ0 `sepBy` wchar ','-                        close-                        return $ case xs of-                            [] -> TLit "()"-                            [x] -> x-                            xs -> TApp (tLit hash $ length xs - 1) xs-                    )-            where-                tLit hash n = TLit $ "(" ++ h ++ replicate n ',' ++ h ++ ")"-                    where h = ['#'|hash]-            -            -        atom = do x <- satisfy (\x -> isAlpha x || x == '_')-                  xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#")-                  whites-                  return $ (if isLower x || x == '_' then TVar else TLit) (x:xs)--        -- may be [a], or [] (then application takes the a after it)-        list = do char '['-                  colon <- optionBool $ char ':'-                  spaces-                  let close = white $ string $ [':'|colon] ++ "]"-                      lit = TLit $ if colon then "[::]" else "[]"-                  (close >> return lit) <|> (do-                      x <- typ0-                      close-                      return $ TApp lit [x])--        application = do (x:xs) <- many1 (white typ2)-                         return $ TApp x xs--        function = do lhs <- typ1-                      (do op <- white keysymbol; rhs <- function; return $ TApp (TLit op) [lhs,rhs])-                          <|> return lhs--        wchar c = white $ char c-        white x = do y <- x ; whites ; return y--        whites = many whiteChar-        whiteChar = oneOf " \v\f\t\r"--        keysymbol = try $ do-            x <- many1 $ satisfy (\x -> isSymbol x || x `elem` ascSymbol)-            if x `elem` ["->","-#"] then return "->" -- fast shortcut for arrows-             else if x `elem` reservedSym then fail "Bad symbol"-             else return x-        ascSymbol = "->#!$%&*+./<=?@\\^|-~:"-        reservedSym = ["::","=>","=#",".","=","#",":","-","+","/","--"]---optionBool p = (p >> return True) <|> return False
− src/Hoogle/TypeSig/Type.hs 
@@ -1,200 +0,0 @@--module Hoogle.TypeSig.Type where--import Data.Binary.Defer-import Data.List-import Data.Generics.UniplateOn--------------------------------------------------------------------------- DATA TYPE WITH CONTEXT----- FULL TYPE-data TypeSig = TypeSig Constraint Type-               deriving (Eq,Ord)--type Constraint = [Type]----- CONSTRICTED TYPE--- first argument is a list of contexts, (Context,Variable)-type TypeContext = [(String,String)]-data TypeSimp = TypeSimp TypeContext Type-                deriving (Eq,Ord)--instance Show TypeSimp where-    show (TypeSimp c t) = show $ TypeSig [TApp (TLit a) [TVar b] | (a,b) <- c] t--------------------------------------------------------------------------- DATA TYPES---- TODO: Add TForAll and treat it properly throughout---       Add TBang to handle bangs properly-data Type = TApp Type [Type] -- a list of types, first one being the constructor-          | TLit String -- bound variables, Maybe, ":", "(,)", "(,,)" (tuple)-          | TVar String -- unbound variables, "a"-          | TFun [Type]-          deriving (Eq,Ord)---tApp :: Type -> [Type] -> Type-tApp t [] = t-tApp t ts = TApp t ts---fromTFun :: Type -> [Type]-fromTFun (TFun x) = x-fromTFun x = [x]---isTLit, isTVar :: Type -> Bool-isTLit TLit{} = True; isTLit _ = False-isTVar TVar{} = True; isTVar _ = False---fromTApp :: Type -> (Type, [Type])-fromTApp (TApp x y) = (x,y)-fromTApp x = (x,[])---isTLitTuple :: String -> Bool-isTLitTuple x = ',' `elem` x---insertTApp, removeTApp :: Type -> Type-insertTApp = transform f-    where-        f (TApp (TApp x []) y) = TApp x y-        f (TApp x y) = TApp x y-        f (TFun x) = TFun x-        f x = TApp x []--removeTApp = transform f-    where-        f (TApp x []) = x-        f x = x--------------------------------------------------------------------------- UNIPLATE INSTANCES--instance Uniplate Type where-    uniplate (TApp x xs) = (x:xs, \(x:xs) -> TApp x xs)-    uniplate (TFun xs) = (xs, \xs -> TFun xs)-    uniplate x = ([], \[] -> x)--onTypeSig :: BiplateType TypeSig Type-onTypeSig (TypeSig xs x) = (x:xs, \(x:xs) -> TypeSig xs x)--transformSig = transformOn onTypeSig-universeSig = universeOn onTypeSig---variables :: Type -> [String]-variables x = [v | TVar v <- universe x]--variablesSig :: TypeSig -> [String]-variablesSig x = [v | TVar v <- universeSig x]--------------------------------------------------------------------------- BINARYDEFER INSTANCES--instance BinaryDefer TypeSig where-    put (TypeSig a b) = put2 a b-    get = get2 TypeSig--instance BinaryDefer 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-    put (TFun a)   = putByte 3 >> put1 a--    get = do-        i <- getByte-        case i of-            0 -> get2 TApp-            1 -> get1 TLit-            2 -> get1 TVar-            3 -> get1 TFun--------------------------------------------------------------------------- SHOW INSTANCES--showConstraint :: Constraint -> String-showConstraint [] = ""-showConstraint [x] = show x ++ " => "-showConstraint xs = "(" ++ concat (intersperse ", " $ map show xs) ++ ") => "----- TODO: show (TLit ":+:") should be "(:+:)"-instance Show Type where-    showsPrec i x = showString $ f i x-        where-            -- Show lists and tuples specially-            f i (TApp (TLit "[]") [x]) = "[" ++ show x ++ "]"-            f i (TApp (TLit ('(':tup)) xs)-                | not (null tup) && last tup == ')' && all (== ',') (init tup) && length tup == length xs-                = b True $ concat $ intersperse ", " $ map show xs--            -- Should parallel lists and unboxed tuples specially-            f i (TApp (TLit "[::]") [x]) = "[:" ++ show x ++ ":]"-            f i (TApp (TLit ('(':'#':tup)) xs)-                | "#)" `isSuffixOf` tup && all (== ',') (drop 2 $ reverse tup) && length tup - 1 == length xs-                = "(# " ++ (concat $ intersperse ", " $ map show xs) ++ " #)"--            -            f i (TLit x) = x-            f i (TVar x) = x-            -            f i (TApp x xs) = b (i > 1) $ unwords $ map (f 2) (x:xs)-            f i (TFun xs)   = b (i > 0) $ concat (intersperse " -> " $ map (f 1) xs)-            -            b True x = "(" ++ x ++ ")"-            b False x = x---instance Show TypeSig where-    show (TypeSig x xs) = showConstraint x ++ show xs----- shows an element within a function--- to get brackets right after splitFun-showFun :: Type -> String-showFun x = showsPrec 1 x ""--------------------------------------------------------------------------- OPERATIONS--normaliseTypeSig :: TypeSig -> TypeSig-normaliseTypeSig = transformOn onTypeSig normaliseType---normaliseType :: Type -> Type-normaliseType = transform f-    where-        f (TApp x []) = x-        f (TApp (TLit "->") xs) = f $ TFun xs-        f (TFun [x]) = x-        f (TFun xs) = TFun $ g xs-        f x = x--        g [] = []-        g [TFun xs] = g xs-        g (x:xs) = x : g xs---splitFun :: Type -> [Type]-splitFun (TFun xs) = xs-splitFun x = [x]---renameVars :: (String -> String) -> TypeSig -> TypeSig-renameVars f = transformOn onTypeSig g-    where-        g (TVar x) = TVar $ f x-        g x = x
src/Main.hs view
@@ -2,12 +2,11 @@ module Main where  import CmdLine.All-import Web.All+import Console.All as Console+import Web.All as Web   main :: IO () main = do-    q <- cmdQuery-    if queryWeb q-        then actionWeb q-        else actionCmdLine q+    q <- cmdLine+    if isWebCmdLine q then Web.action q else Console.action q
+ src/Recipe/All.hs view
@@ -0,0 +1,85 @@+-- Recipe actions:+-- Download to foo.src in most cases, then extract to foo.txt, which can later be compiled to foo.hoo+module Recipe.All(recipes) where++import General.Base+import General.System+import Control.Concurrent+import qualified Data.Map as Map++import Recipe.Type+import Recipe.Download+import Recipe.Keyword+import Recipe.General+import Recipe.Hackage+++-- CmdLine is guaranteed to be a constructor of type Data+recipes :: CmdLine -> IO ()+recipes opt = do+    hSetBuffering stdout NoBuffering+    createDirectoryIfMissing True $ datadir opt+    withDirectory (datadir opt) $ do+        resetErrors+        download opt+        let ys = parseRules $ actions opt+        make opt (filter (not . null . snd) ys) (map fst ys)+        recapErrors+        putStrLn "Data generation complete"+++-- If I switch to the parallel-io library then it segfaults, due to GHC bug:+-- http://hackage.haskell.org/trac/ghc/ticket/4850+-- import "parallel-io" Control.Concurrent.ParallelIO.Local+withPool i f = f ()+extraWorkerWhileBlocked _ = id+parallel_ _ = sequence_+++data Status = Built | Building (MVar ())++make :: CmdLine -> [(Name,[Name])] -> [Name] -> IO ()+make opt rules xs = withPool (threads opt) $ \pool -> do+    ref <- newMVar Map.empty+    fs ref pool [] xs+    where+        fs ref pool rec xs = parallel_ pool $ map (f ref pool rec) xs++        f ref pool rec x+            | x `elem` rec = outStrLn $ "Warning: Package database appears to be recursive, " ++ x+            | otherwise = join $ modifyMVar ref $ \mp -> case Map.lookup x mp of+                Just Built -> return (mp, return ())+                Just (Building v) -> return $ (,) mp $+                    extraWorkerWhileBlocked pool $ readMVar v+                Nothing -> do+                    v <- newEmptyMVar+                    return $ (,) (Map.insert x (Building v) mp) $ do+                        build (fs ref pool $ x:rec) opt rules x+                        modifyMVar_ ref $ \mp -> return $ Map.insert x Built mp+                        putMVar v ()+++build :: ([Name] -> IO ()) -> CmdLine -> [(Name,[Name])] -> Name -> IO ()+build makeRec opt rules x = do+    outStrLn $ "Starting " ++ x+    case lookup x rules of+        Just ys -> combine makeRec x ys True+        _ -> case x of+            "keyword" -> makeKeyword+            "default" -> combine makeRec x ["keyword","package","platform"] False+            "platform" -> makePlatform makeRec+            "package" -> makePackage+            "all" -> makeAll makeRec+            _ -> makeDefault makeRec (local opt) x+    outStrLn $ "Finished " ++ x+++parseRules :: [String] -> [(Name,[Name])]+parseRules [] = [("default",[])]+parseRules xs = map parseRule xs+++parseRule :: String -> (Name,[Name])+parseRule x = (a, uncommas $ drop 1 b)+    where (a,b) = break (== '=') x+          uncommas = words . map (\x -> if x == ',' then ' ' else x)
+ src/Recipe/Download.hs view
@@ -0,0 +1,60 @@++module Recipe.Download(download) where++import General.Base+import General.System+import Recipe.Type+++-- download everything required for the recipes+download :: CmdLine -> IO ()+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"+    downloadTarball opt cabals "http://hackage.haskell.org/packages/archive/00-index.tar.gz"+    if haddock opt then downloadHaddocks opt+                   else downloadTarball opt haddocks "http://haskell.org/hoogle/hackage-haddock.tar.gz"+++wgetMay :: CmdLine -> FilePath -> URL -> IO Bool+wgetMay opt fil url = do+    b <- doesFileExist fil+    when (not b || redownload opt) $ do+        res <- system $ "wget " ++ url ++ " -O " ++ fil+        let b = res == ExitSuccess+        unless b $ removeFile fil+    doesFileExist fil+++wget :: CmdLine -> FilePath -> URL -> IO ()+wget opt fil url = do+    b <- wgetMay opt fil url+    unless b $ error $ "Failed to download " ++ url+++downloadTarball :: CmdLine -> FilePath -> URL -> IO ()+downloadTarball opt out url = do+    b <- doesFileExist $ out <.> "txt"+    unless b $ do+        wget opt (out <.> "tar.gz") url+        createDirectoryIfMissing True out+        withDirectory out $+            system_ $ "tar -xf .." </> takeFileName out <.> "tar.gz"+        writeFile (out <.> "txt") ""+++downloadHaddocks :: CmdLine -> IO ()+downloadHaddocks opt = do+    b <- doesFileExist $ haddocks <.> "txt"+    unless b $ do+        xs <- listing cabals+        forM_ xs $ \name -> do+            ver <- version cabals name+            let out = haddocks </> name </> ver </> name <.> "txt"+                url = "http://hackage.haskell.org/packages/archive/" ++ name ++ "/" ++ ver ++ "/doc/html/" ++ name ++ ".txt"+            createDirectoryIfMissing True $ takeDirectory out+            b <- wgetMay opt out url+            unless b $ writeFile out ""+        withDirectory haddocks $ system_ "tar -czf../hackage-haddock.tar.gz *"+        writeFile (haddocks <.> "txt") ""
+ src/Recipe/General.hs view
@@ -0,0 +1,49 @@++module Recipe.General(convert, combine) where++import Recipe.Type+import Hoogle+import General.Base+import General.System+import System.Console.CmdArgs.Verbosity+++-- convert a single database+convert :: ([Name] -> IO ()) -> Name -> IO ()+convert make x = do+    b <- doesFileExist $ x <.> "txt"+    if not b then+        putError $ "Error: " ++ x ++ " couldn't be converted, no input file found"+     else do+        (deps,src) <- readInput x+        make deps+        let deps2 = map hoo deps+        deps3 <- filterM doesFileExist deps2+        when (deps2 /= deps3) $ putError $ "Error: " ++ x ++ " doesn't know about dependencies on " ++ unwords (deps2 \\ deps3)+        dbs <- mapM loadDatabase deps3+        let (err,db) = createDatabase Haskell dbs src+        unless (null err) $ outStrLn $ "Skipped " ++ show (length err) ++ " errors in " ++ x+        whenLoud $ outStr $ unlines $ map show err+        outStr $ "Converting " ++ x ++ "... "+        performGC+        saveDatabase (hoo x) db+        outStrLn "done"+++readInput :: Name -> IO ([Name], String)+readInput x = do+    src <- readFile $ x <.> "txt"+    let (a,b) = span ("@depends " `isPrefixOf`) $ lines src+    return (map (drop 9) a, unlines b)++++-- combine multiple databases+combine :: ([Name] -> IO ()) -> Name -> [Name] -> Bool -> IO ()+combine make x deps force = do+    make deps+    dbs <- mapM (loadDatabase . hoo) deps+    outStr $ "Creating " ++ x ++ " from " ++ show (length deps) ++ " databases... "+    performGC+    saveDatabase (hoo x) $ mconcat dbs+    outStrLn "done"
+ src/Recipe/Hackage.hs view
@@ -0,0 +1,121 @@++module Recipe.Hackage(makePlatform, makeDefault, makePackage, makeAll) where++import Recipe.Type+import Recipe.General+import General.Base+import General.System+import General.Util+import General.Web+++avoid = words "ghc-prim integer integer-simple integer-gmp rts ghc Win32"+++makePlatform :: ([Name] -> IO ()) -> IO ()+makePlatform make = do+    xs <- listPlatform+    forM_ xs $ \(name,ver) -> do+        v2 <- version cabals name+        when (ver /= v2) $ putStrLn $ "Warning: Version mismatch for " ++ name ++ " (platform=" ++ ver ++ ", cabal=" ++ v2 ++ ")"+    combine make "platform" (map fst xs) False+++makeAll :: ([Name] -> IO ()) -> IO ()+makeAll make = do+    xs <- listing haddocks+    make xs+++-- create a database containing an entry for each package in hackage+makePackage :: IO ()+makePackage = do+    xs <- listing cabals+    xs <- forM xs $ \name -> do+        ver <- version cabals name+        let file = cabals </> name </> ver </> name <.> "cabal"+        src <- readCabal file+        return $ [""] ++ zipWith (++) ("-- | " : repeat "--   ") (cabalDescription src) +++                 ["--","-- Version " ++ ver, "@package " ++ name]+    writeFile "package.txt" $ unlines $ concat xs+    convert noDeps "package"+++makeDefault :: ([Name] -> IO ()) -> [FilePath] -> Name -> IO ()+makeDefault make local name = do+    b1 <- doesDirectoryExist $ cabals </> name+    b2 <- doesDirectoryExist $ haddocks </> name+    if not b1 || not b2 then+        putError $ "Error: " ++ name ++ " couldn't find both Cabal and Haddock inputs"+     else do+        vc <- version cabals name+        vh <- version haddocks name+        when (vc /= vh) $ putStrLn $ "Warning: Version mismatch for " ++ name ++ " (cabal=" ++ vc ++ ", haddock=" ++ vh ++ ")"+        let had = haddocks </> name </> vh </> name <.> "txt"+            cab = cabals </> name </> vc </> name <.> "cabal"+        h <- openFile had ReadMode+        sz <- hFileSize h+        hClose h+        if sz == 0 then+            putError $ "Error: " ++ name ++ " has no haddock output"+         else do+            had <- readFile' had+            cab <- readCabal cab+            loc <- findLocal local name+            writeFile (name <.> "txt") $ unlines $+                ["@depends " ++ a | a <- cabalDepends cab, a `notElem` avoid] +++                (maybe id haddockPackageUrl loc) (haddockHacks $ lines had)+            convert make name+++-- try and find a local filepath+findLocal :: [FilePath] -> Name -> IO (Maybe URL)+findLocal paths name = fmap (listToMaybe . concat . concat) $ forM paths $ \p -> do+    xs <- getDirectoryContents p+    xs <- return [p </> x | x <- reverse $ sort xs, name == fst (rbreak (== '-') x)] -- make sure highest version comes first+    forM xs $ \x -> do+        b <- doesDirectoryExist $ x </> "html"+        x <- return $ if b then x </> "html" else x+        b <- doesFileExist $ x </> "doc-index.html"+        return [filePathToURL $ x </> "index.html" | b]+++---------------------------------------------------------------------+-- READ PLATFORM++listPlatform :: IO [(Name,String)]+listPlatform = do+    src <- readFile platform+    let xs = takeWhile (not . isPrefixOf "build-tools:" . ltrim) $+             dropWhile (not . isPrefixOf "build-depends:" . ltrim) $+             lines src+    return [(name, takeWhile (\x -> x == '.' || isDigit x) $ drop 1 b)+           | x <- xs, (a,_:b) <- [break (== '=') x], let name = trim $ dropWhile (== '-') $ trim a+           , name `notElem` words "Cabal hpc Win32"]+++---------------------------------------------------------------------+-- HADDOCK HACKS++-- Eliminate @version+-- Change :*: to (:*:), Haddock bug+-- Change !!Int to !Int, Haddock bug+-- Change instance [overlap ok] to instance, Haddock bug+-- Change instance [incoherent] to instance, Haddock bug+-- Change !Int to Int, HSE bug++haddockHacks :: [String] -> [String]+haddockHacks = map (unwords . map f . words) . filter (not . isPrefixOf "@version ")+    where+        f "::" = "::"+        f (':':xs) = "(:" ++ xs ++ ")"+        f ('!':'!':x:xs) | isAlpha x = xs+        f ('!':x:xs) | isAlpha x || x `elem` "[(" = x:xs+        f x | x `elem` ["[overlap","ok]","[incoherent]"] = ""+        f x = x+++haddockPackageUrl :: URL -> [String] -> [String]+haddockPackageUrl x = concatMap f+    where f y | "@package " `isPrefixOf` y = ["@url " ++ x, y]+              | otherwise = [y]
+ src/Recipe/Keyword.hs view
@@ -0,0 +1,77 @@++module Recipe.Keyword(makeKeyword) where++import General.Base+import Text.HTML.TagSoup+import Recipe.Type+import Recipe.General+++makeKeyword :: IO ()+makeKeyword = do+    writeFile "keyword.txt" . translate =<< readFile' keywords+    convert noDeps "keyword"+++translate :: String -> String+translate src = unlines $ keywordPrefix ++ items+    where items = concatMap keywordFormat $ partitions (~== "<a name>") $+                  takeWhile (~/= "<div class=printfooter>") $ parseTags src+++keywordPrefix =+    ["-- Hoogle documentation, generated by Hoogle"+    ,"-- From http://www.haskell.org/haskellwiki/Keywords"+    ,"-- See Hoogle, http://www.haskell.org/hoogle/"+    ,""+    ,"-- | Haskell keywords, always available"+    ,"@url http://haskell.org/haskellwiki/Keywords"+    ,"@package keyword"+    ]+++keywordFormat x = concat ["" : docs ++ ["@url #" ++ concatMap g n, "@keyword " ++ noUnderscore n] | n <- name]+    where+        noUnderscore "_" = "_"+        noUnderscore xs = map (\x -> if x == '_' then ' ' else x) xs++        name = words $ f $ fromAttrib "name" (head x)+        docs = zipWith (++) ("-- | " : repeat "--   ") $+               intercalate [""] $+               map (docFormat . takeWhile (~/= "<div class=editsection>")) $+               partitions isBlock x++        g x | isAlpha x || x `elem` "_-:" = [x]+            | otherwise = '.' : map toUpper (showHex (ord x) "")+++        isBlock (TagOpen x _) = x `elem` ["p","pre"]+        isBlock _ = False++        f ('.':'2':'C':'_':xs) = ' ' : f xs+        f ('.':a:b:xs) = chr res : f xs+            where [(res,"")] = readHex [a,b]+        f (x:xs) = x : f xs+        f [] = []+++docFormat :: [Tag String] -> [String]+docFormat (TagOpen "pre" _:xs) = ["<pre>"] ++ map (drop n) ys ++ ["</pre>"]+    where+        ys = lines $ innerText xs+        n = minimum $ map (length . takeWhile isSpace) ys++docFormat (TagOpen "p" _:xs) = g 0 [] $ words $ f xs+    where+        g n acc [] = [unwords $ reverse acc | acc /= []]+        g n acc (x:xs) | nx+1+n > 70 = g n acc [] ++ g nx [x] xs+                       | otherwise = g (n+nx+1) (x:acc) xs+            where nx = length x++        f (TagOpen "code" _:xs) = "<tt>" ++ innerText a ++ "</tt>" ++ f (drop 1 b)+            where (a,b) = break (~== "</code>") xs+        f (x:xs) = h x ++ f xs+        f [] = []++        h (TagText x) = unwords (lines x)+        h _ = ""
+ src/Recipe/Type.hs view
@@ -0,0 +1,107 @@++module Recipe.Type(+    CmdLine(..), Name, hoo, noDeps,+    keywords, platform, cabals, haddocks, listing, version,+    resetErrors, putError, recapErrors,+    outStr, outStrLn,+    Cabal(..), readCabal, readCabalDepends, readCabalField+    ) where++import CmdLine.All+import Control.Concurrent+import System.IO.Unsafe+import General.Base+import General.Util+import General.System+++type Name = String++hoo :: Name -> FilePath+hoo x = x <.> "hoo"+++noDeps :: [Name] -> IO ()+noDeps [] = return ()+noDeps xs = error "Internal error: package with no dependencies had dependencies"+++---------------------------------------------------------------------+-- DOWNLOADED INFORMATION++keywords = "download/keyword.txt"+platform = "download/haskell-platform.cabal"+cabals = "download/hackage-cabal"+haddocks = "download/hackage-haddock"++listing :: FilePath -> IO [Name]+listing dir = do+    xs <- getDirectoryContents dir+    return $ sortBy (comparing $ map toLower) $ filter (`notElem` [".","..","preferred-versions"]) xs++version :: FilePath -> Name -> IO String+version dir x = do+    ys <- getDirectoryContents $ dir </> x+    when (null ys) $ error $ "Couldn't find version for " ++ x ++ " in " ++ dir+    let f = map (read :: String -> Int) . words . map (\x -> if x == '.' then ' ' else x)+    return $ maximumBy (comparing f) $ filter (all (not . isAlpha)) ys+++---------------------------------------------------------------------+-- ERROR MESSAGES++{-# NOINLINE errors #-}+errors :: MVar [String]+errors = unsafePerformIO $ newMVar []++putError :: String -> IO ()+putError x = do+    outStrLn x+    modifyMVar_ errors $ return . (x:)++recapErrors :: IO ()+recapErrors = do+    xs <- readMVar errors+    mapM_ outStrLn $ reverse xs++resetErrors :: IO ()+resetErrors = modifyMVar_ errors $ const $ return []+++outputLock :: MVar ()+outputLock = unsafePerformIO $ newMVar ()++outStr, outStrLn :: String -> IO ()+outStr x = withMVar outputLock $ \_ -> do putStr x; hFlush stdout+outStrLn x = outStr $ x ++ "\n"+++---------------------------------------------------------------------+-- CABAL++data Cabal = Cabal {cabalDepends :: [String], cabalDescription :: [String]}++readCabal :: FilePath -> IO Cabal+readCabal file = do+    src <- fmap lines $ readFile' file+    return $ Cabal (readCabalDepends src) (readCabalField src True "description")+++readCabalDepends :: [String] -> [String]+readCabalDepends xs = nub $ map (takeWhile g) $ filter f $ words $ map (rep ',' ' ') $ unwords $ readCabalField xs False "build-depends"+    where f x = x /= "" && isAlpha (head x)+          g x = isAlphaNum x || x `elem` "-_"+++readCabalField :: [String] -> Bool -> String -> [String]+readCabalField xs root name = f xs+    where+        f (x:xs) | (name ++ ":") `isPrefixOf` map toLower x2 && (null spc || not root) =+                [x4 | x4 /= []] ++ map (rep "." "" . trim) ys ++ f zs+            where+                x4 = trim x3+                x3 = drop (length name + 1) x2+                (spc,x2) = span isSpace x+                (ys,zs) = span ((> length spc) . length . takeWhile isSpace) xs+        f (x:xs) = f xs+        f [] = []
src/Test/All.hs view
@@ -3,11 +3,9 @@  import Test.Parse_TypeSig import Test.Parse_Query-import Test.Parse_TextBase   test :: IO () test = print $ do     parse_TypeSig     parse_Query-    parse_TextBase
src/Test/General.hs view
@@ -26,6 +26,14 @@     where         err pre post = error $ pre ++ ":\n  " ++ input ++ "\n  " ++ show output ++ "\n  " ++ post +parseTest2 f input output =+    case f input of+        (x:xs,_) -> err "Parse failed" (show x)+        ([],  x) -> if x == output then pass else+                    err "Parse not equal" (show x)+    where+        err pre post = error $ pre ++ ":\n  " ++ input ++ "\n  " ++ show output ++ "\n  " ++ post+  --------------------------------------------------------------------- -- The List Monad
src/Test/Parse_Query.hs view
@@ -3,16 +3,12 @@  import Test.General import Hoogle.Query.All-import Hoogle.TypeSig.All+import Hoogle.Type.All  parse_Query = do     let (===) = parseTest parseQuery         q = blankQuery -    "/info" === q{flags = [Flag "info" ""]}-    "--info" === q{flags = [Flag "info" ""]}-    "/?" === q{flags = [Flag "?" ""]}-    "/count=10" === q{flags = [Flag "count" "10"]}     "map" === q{names = ["map"]}     "#" === q{names = ["#"]}     "c#" === q{names = ["c#"]}@@ -29,10 +25,10 @@     "+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"]))}-    "a -> b /foo" === q{flags = [Flag "foo" ""], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))}-    "a -> b --foo" === q{flags = [Flag "foo" ""], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))}     "Data.Map.map" === q{scope = [PlusModule ["Data","Map"]], names = ["map"]}     "[a]" === q{typeSig = Just (TypeSig [] (TApp (TLit "[]") [TVar "a"]))}     "++" === q{names = ["++"]}     "(++)" === q{names = ["++"]}     ":+:" === q{names = [":+:"]}+    "bytestring-cvs +hackage" === q{scope=[PlusPackage "hackage"], names=["bytestring-cvs"]}+
− src/Test/Parse_TextBase.hs 
@@ -1,50 +0,0 @@--module Test.Parse_TextBase(parse_TextBase) where--import Test.General-import Hoogle.TextBase.All-import Hoogle.TypeSig.All---typ x = case parseTypeSig x of-            Left err -> error $ "parse_TextBase, failed to parse type signature: " ++ show x-            Right y -> y--parse_TextBase = do-    let (===) a b = parseTest parseTextBaseString a (map (flip (,) "") b)--    "" === []-    "-- foo" === []--    "module Foo.Bar.String" === [ItemModule ["Foo","Bar","String"]]-    "module Test" === [ItemModule ["Test"]]--    "class Foo a" === [ItemClass $ typ "Foo a"]-    "class Foo a b" === [ItemClass $ typ "Foo a b"]--    "foo :: Bool" === [ItemFunc "foo" $ typ "Bool"]-    "(++) :: Int" === [ItemFunc "++" $ typ "Int"]-    "++ :: Int" === [ItemFunc "++" $ typ "Int"]-    "@@ :: Int" === [ItemFunc "@@" $ typ "Int"]--    "type Bar a = Foo [a]" === [ItemAlias (typ "Bar a") (typ "Foo [a]")]--    "data [] a" === [ItemData DataKeyword $ typ "[a]"]-    "[] :: [] a" === [ItemFunc "[]" $ typ "[a]"]-    ": :: a -> [a] -> [] a" === [ItemFunc ":" $ typ "a -> [a] -> [a]"]-    "(:) :: a -> [a] -> [] a" === [ItemFunc ":" $ typ "a -> [a] -> [a]"]-    "() :: ()" === [ItemFunc "()" $ typ "()"]-    "data (:+:) a b" === [ItemData DataKeyword $ typ "(:+:) a b"]--    "data Foo a" === [ItemData DataKeyword $ typ "Foo a"]-    "newtype Foo a" === [ItemData NewTypeKeyword $ typ "Foo a"]--    "instance Eq a => Eq [a]" === [ItemInstance $ typ "Eq a => Eq [a]"]--    "@keyword ~" === [ItemAttribute "keyword" "~"]-    "@keyword ->" === [ItemAttribute "keyword" "->"]-    "@keyword module" === [ItemAttribute "keyword" "module"]--    "@package neil" === [ItemAttribute "package" "neil"]-    "@foo bar" === [ItemAttribute "foo" "bar"]-    "@debug" === [ItemAttribute "debug" ""]
src/Test/Parse_TypeSig.hs view
@@ -2,9 +2,12 @@ module Test.Parse_TypeSig(parse_TypeSig) where  import Test.General-import Hoogle.TypeSig.All+import Data.Maybe+import Hoogle.Type.All+import Hoogle.Query.All  parse_TypeSig = do+    let parseTypeSig x = either Left (Right . fromMaybe (error $ "Couldn't find type in: " ++ x) . typeSig) $ parseQuery (":: " ++ x)     let (===) = parseTest parseTypeSig      -- really basic stuff@@ -33,14 +36,13 @@     "a -> (b -> c)" === TypeSig [] (TFun [TVar "a",TVar "b",TVar "c"])     "(a -> b) -> c" === TypeSig [] (TFun [TFun [TVar "a",TVar "b"],TVar "c"])     "M (a b) c" === TypeSig [] (TApp (TLit "M") [TApp (TVar "a") [TVar "b"],TVar "c"])-    "(-#)" === TypeSig [] (TLit "->")-    "a -# b" === TypeSig [] (TFun [TVar "a",TVar "b"])+    "(-#)" === TypeSig [] (TLit "-#")+    "a -# b" === TypeSig [] (TApp (TLit "-#") [TVar "a",TVar "b"])      -- classes     "Eq a => a" === TypeSig [TApp (TLit "Eq") [TVar "a"]] (TVar "a")     "Class a b => a b" === TypeSig [TApp (TLit "Class") [TVar "a",TVar "b"]] (TApp (TVar "a") [TVar "b"])     "(Ord a, Eq b) => a -> b" === TypeSig [TApp (TLit "Ord") [TVar "a"],TApp (TLit "Eq") [TVar "b"]] (TFun [TVar "a",TVar "b"])-    "Eq a =# a" === TypeSig [TApp (TLit "Eq") [TVar "a"]] (TVar "a")      -- forall     "forall a . a -> a" === TypeSig [] (TFun [TVar "a", TVar "a"])
− src/Web/Action.hs 
@@ -1,174 +0,0 @@--module Web.Action(actionWeb) where--import CmdLine.All-import Hoogle.All-import Hoogle.Query.All-import Hoogle.Item.All-import Hoogle.Search.All-import Numeric-import General.Code-import System.IO.Unsafe(unsafeInterleaveIO)-import Web.Page-import Web.Text-import Text.ParserCombinators.Parsec-import Data.TagStr-import Data.Range-import Data.Binary.Defer.Index-import Data.Generics.Uniplate--import Data.Time.Clock-import Data.Time.Calendar-import General.CGI(cgiArgs)-import Paths_hoogle---logFile = "log.txt"---actionWeb :: CmdQuery -> IO ()-actionWeb q = do-    logMessage q-    res <--        if Mode "suggest" `elem` queryFlags q then do-            putStr "Content-type: application/json\n\n"-            runSuggest q-        else do-            putStr "Content-type: text/html\n\n"-            (skipped,dbs) <- loadDataBases q-            return $ unlines $ header (escapeHTML $ queryText q) ++ runQuery dbs q ++ footer-    putStrLn res-    when (Debug `elem` queryFlags q) $-        writeFile "temp.htm" res-    sequence_ [writeFile x res | Output x <- queryFlags q]---logMessage :: CmdQuery -> IO ()-logMessage q = do-    time <- getCurrentTime-    cgi <- liftM (fromMaybe []) cgiArgs-    appendFile logFile $ (++ "\n") $ unwords $-        [showGregorian (utctDay time)-        ,show (queryText q)] ++-        ["?" ++ a ++ "=" ++ c ++ b ++ c | (a,b) <- cgi, let c = ['\"' | any isSpace b]]---runSuggest :: CmdQuery -> IO String-runSuggest CmdQuery{query=Right Query{scope=[], names=[x], typeSig=Nothing}} = do-    root <- getDataDir-    db <- loadDataBase $ root </> "default.hoo"-    let res = take 8 $ completions db x-    return $ "[" ++ show x ++ "," ++ show res ++ "]"-runSuggest _ = return ""----- is the package not something that might go wrong-safePackage :: String -> Bool-safePackage = all $ \x -> isAlphaNum x || x `elem` "-_"----- return the databases you loaded, and those you can't--- guarantees not to actually load the databases unless necessary--- TODO: Should say which databases are ignored-loadDataBases :: CmdQuery -> IO ([String], [DataBase])-loadDataBases CmdQuery{query=Right q} = do-    let pkgs = nub [x | PlusPackage x <- scope q, safePackage x]-        files = if null pkgs then ["default"] else pkgs-    root <- getDataDir-    files <- filterM doesFileExist $ map (\x -> root </> x <.> "hoo") files-    dbs <- unsafeInterleaveIO $ mapM loadDataBase files-    return ([], dbs)-loadDataBases _ = return ([], [])----- TODO: Should escape the query text-runQuery :: [DataBase] -> CmdQuery -> [String]-runQuery dbs CmdQuery{queryText = text, query = Left err} =-    ["<h1><b>Parse error in user query</b></h1>"-    ,"<p>"-    ,"  Query: <tt>" +& pre ++ "<span id='error'>" +& post2 ++ "</span></tt><br/>"-    ,"</p><p>"-    ,"  Error: " +& drop 1 (dropWhile (/= ':') $ show err) ++ "<br/>"-    ,"</p><p>"-    ,"  For information on what queries should look like, see the"-    ,"  <a href='http://www.haskell.org/haskellwiki/Hoogle'>user manual</a>."-    ,"</p>"-    ]-    where-        (pre,post) = splitAt (sourceColumn (errorPos err) - 1) text-        post2 = if null post then concat (replicate 3 "&nbsp;") else post---runQuery dbs q | not $ usefulQuery $ fromRight $ query q = welcome---runQuery dbs cq@CmdQuery{query = Right q, queryFlags = flags} =-    ["<h1>Searching for " ++ qstr ++ "</h1>"] ++-    ["<p>" ++ showTagHTML (transform qurl sug) ++ "</p>" | Just sug <- [suggestQuery dbs q]] ++-    if null res then-        ["<p>No results found</p>"]-    else-        ["<table>"] ++-        concatMap (uncurry renderRes) pre ++-        insertMore (concatMap (uncurry renderRes) now) ++-        [moreResults | not $ null post] ++-        ["</table>"]-    where-        start = headDef 0 [i-1 | Start i <- flags]-        count = headDef 20 [n | Count n <- flags]-        res = zip [0..] $ searchRange (rangeStartCount 0 (start+count+1)) dbs q-        (pre,res2) = splitAt start res-        (now,post) = splitAt count res2--        moreResults = "<tr><td></td><td><a href=\"" +& urlMore ++ "\" class='more'>Show more results</a></td></tr>"-        urlMore = "?hoogle=" +% queryText cq ++ "&start=" ++ show (start+count+1) ++ "#more"--        qstr = unwords $ ["<b>" +& n ++ "</b>" | n <- names q] ++-               ["::" | names q /= [] && isJust (typeSig q)] ++-               [showTagHTML (renderEntryText view $ renderTypeSig t) | Just t <- [typeSig q]]-        view = [ArgPosNum i i | i <- [0..10]]--        qurl (TagHyperlink url x) | "query:" `isPrefixOf` url = TagHyperlink ("?hoogle=" +% drop 6 url) x-        qurl x = x------ insert <a name=more> where you can-insertMore :: [String] -> [String]-insertMore [] = []-insertMore (x:xs) = f x : xs-    where-        f ('>':xs) | not $ "<td" `isPrefixOf` xs = "><a name='more'></a>" ++ xs-        f (x:xs) = x : f xs-        f [] = []---renderRes :: Int -> Result -> [String]-renderRes i r =-        [tr $ modname ++ td "ans" (href urlEnt $ showTagHTMLWith url text)-        ,tr $ pkgname ++ td "doc" docs]-    where-        ent = fromLink $ resultEntry r-    -        (modu,text,_) = renderResult r-        modname = td "mod" $ maybe "" (href urlMod . showModule) modu-        pkgname = td "pkg" $ href urlPkg $ packageName $ fromLink $ entryPackage ent--        docs = ("<div id='d" ++ show i ++ "' class='shut'>" ++-                   "<a class='docs' onclick='return docs(" ++ show i ++ ")' href='" +& urlEnt ++ "'></a>") +?-                   (showTagHTML $ renderHaddock $ entryDocs ent) +?-               "</div>"--        urlPkg = entryPackageURL ent-        urlMod = entryModuleURL ent-        urlEnt = entryURL ent--        url (TagHyperlink _ x)-            | null urlEnt = Just $ "<span class='a'>" ++ showTagHTML x ++ "</span>"-            | otherwise = Just $ "</a><a href='" +& urlEnt ++ "'>" ++ showTagHTML x ++-                                 "</a><a class='dull' href='" +& urlEnt ++ "'>"-        url _ = Nothing--tr x = "<tr>" ++ x ++ "</tr>"-td c x = "<td" ++ (if null c then "" else " class='" ++ c ++ "'") ++ ">" ++ x ++ "</td>"-href url x = if null url then x else "<a class='dull' href='" +& url ++ "'>" ++ x ++ "</a>"
src/Web/All.hs view
@@ -1,6 +1,16 @@ -module Web.All(-    module Web.Action-    ) where+module Web.All(action) where -import Web.Action+import CmdLine.All+import Web.Server+import Web.Response+import Data.List+import Network.HTTP++action :: CmdLine -> IO ()+action q@Server{} = server q++-- would like to use datadir, but not sure how+action q = do+    res <- response "datadir/resources" q+    putStrLn $ intercalate "\n" $ map show (rspHeaders res) ++ ["",rspBody res]
src/Web/Page.hs view
@@ -1,40 +1,42 @@  module Web.Page(header, footer, welcome) where -import Web.Text+import General.Web+import General.Util -resourcePath = "res/" -header query =+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='" ++ resourcePath ++ "hoogle.css' />"-    ,"     <link type='image/png' rel='icon' href='" ++ resourcePath ++ "favicon.png' />"-    ,"     <link type='application/opensearchdescription+xml' rel='search' href='" ++ resourcePath ++ "search.xml' title='Hoogle' />"-    ,"     <script type='text/javascript' src='" ++ resourcePath ++ "hoogle.js'> </script>"+    ,"     <title>" ++ (query ++? " - ") ++ "Hoogle</title>"+    ,"     <link type='text/css' rel='stylesheet' href='" ++ resources ++ "/hoogle.css' />"+    ,"     <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 ++ "/hoogle.js'> </script>"     ,"  </head>"-    ,"  <body onload='on_load()'>"-    ] ++ links ++ search query+    ,"  <body>"+    ] ++ links ++ search resources query +++    ["<div id='body'>"]   links =     ["<div id='links'>"-    ,"  <span id='plugin' style='display:none;'><a href='javascript:add_search()'>Search plugin</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>"     ] -search query =+search resources query =     ["<form action='.' method='get'>"     ,"  <div id='search'>"     ,"    <a id='logo' href='http://haskell.org/hoogle/'>" ++-           "<img src='" ++ resourcePath ++ "hoogle.png' alt='Hoogle' />" +++           "<img src='" ++ resources ++ "/hoogle.png' width='160' height='58' alt='Hoogle' />" ++          "</a>"-    ,"    <input name='hoogle' id='hoogle' type='text' value=\"" ++ query ++ "\" />"+    ,"    <input name='hoogle' id='hoogle' type='text' autocomplete='off' value=\"" ++ query ++ "\" />"     ,"    <input id='submit' type='submit' value='Search' />"     ,"  </div>"     ,"</form>"@@ -42,7 +44,8 @@   footer =-    ["    <p id='footer'>&copy; <a href='http://community.haskell.org/~ndm/'>Neil Mitchell</a> 2004-2009</p>"+    ["</div>"+    ,"    <p id='footer'>&copy; <a href='http://community.haskell.org/~ndm/'>Neil Mitchell</a> 2004-2010</p>"     ,"  </body>"     ,"</html>"     ]@@ -74,4 +77,4 @@     ,"</p>"     ]     where-        search x = "<a href='?hoogle=" +% x ++ "'>" +& x ++ "</a><br/>"+        search x = "<a href='?hoogle=" ++% x ++ "'>" ++& x ++ "</a><br/>"
+ src/Web/Response.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE RecordWildCards #-}++module Web.Response(response) where++import CmdLine.All+import Hoogle+import General.Base+import General.Util+import General.Web+import Web.Page+import Data.Generics.Uniplate++import Data.Time.Clock+import Data.Time.Calendar+import Network.HTTP+import Paths_hoogle+++logFile = "log.txt"+++response :: FilePath -> CmdLine -> IO (Response String)+response resources q = do+    logMessage q+    let r200 x = Response (2,0,0) "OK" [Header HdrContentType x]+    case webmode q of+        Just "suggest" -> fmap (r200 "application/json") $ runSuggest q+        Just "ajax" -> do+            dbs <- if isRight $ queryParsed q+                   then fmap snd $ loadQueryDatabases (databases q) (fromRight $ queryParsed q)+                   else return mempty+            return $ r200 "text/html" $ unlines $ runQuery dbs q+        Nothing -> do+            dbs <- if isRight $ queryParsed q+                   then fmap snd $ loadQueryDatabases (databases q) (fromRight $ queryParsed q)+                   else return mempty+            return $ r200 "text/html" $ unlines $ header resources (escapeHTML $ queryText q) ++ runQuery dbs q ++ footer+        Just e -> return $ r200 "text/html" $ "Unknown webmode: " ++ show e+++logMessage :: CmdLine -> IO ()+logMessage q = do+    time <- getCurrentTime+    cgi <- fmap (fromMaybe []) cgiArgs+    appendFile logFile $ (++ "\n") $ unwords $+        [showGregorian (utctDay time)+        ,show (queryText q)] +++        ["?" ++ a ++ "=" ++ c ++ b ++ c | (a,b) <- cgi, let c = ['\"' | any isSpace b]]+++runSuggest :: CmdLine -> IO String+runSuggest Search{queryText=q} = do+    root <- getDataDir+    db <- loadDatabase $ root </> "default.hoo"+    let res = queryCompletions db q+    return $ "[" ++ show q ++ "," ++ show res ++ "]"+runSuggest _ = return ""++++runQuery :: Database -> CmdLine -> [String]+runQuery dbs Search{queryParsed = Left err} =+    ["<h1><b>Parse error in user query</b></h1>"+    ,"<p>"+    ,"  Query: <span id='error'>" ++ showTagHTMLWith f (parseInput err) ++ "</span><br/>"+    ,"</p><p>"+    ,"  Error: " ++& errorMessage err ++ "<br/>"+    ,"</p><p>"+    ,"  For information on what queries should look like, see the"+    ,"  <a href='http://www.haskell.org/haskellwiki/Hoogle'>user manual</a>."+    ,"</p>"+    ]+    where+        f (TagEmph x) = Just $ "<u>" ++ showTagHTMLWith f x ++ "</u>"+        f _ = Nothing+++runQuery dbs q | isBlankQuery $ fromRight $ queryParsed q = welcome+++runQuery dbs cq@Search{queryParsed = Right q} =+    ["<h1>Searching for " ++ qstr ++ "</h1>"] +++    ["<p>" ++ showTagHTML (transform qurl sug) ++ "</p>" | Just sug <- [querySuggestions dbs q]] +++    if null res then+        ["<p>No results found</p>"]+    else+        ["<table>"] +++        concatMap (uncurry renderRes) pre +++        insertMore (concatMap (uncurry renderRes) now) +++        [moreResults | not $ null post] +++        ["</table>"]+    where+        start2 = maybe 0 (subtract 1 . max 0) $ start cq+        count2 = maybe 20 (max 1) $ count cq+        res = zip [0..] $ map snd $ searchRange (start2,start2+count2) dbs q+        (pre,res2) = splitAt start2 res+        (now,post) = splitAt count2 res2++        moreResults = "<tr><td></td><td><a href=\"" ++& urlMore ++ "\" class='more'>Show more results</a></td></tr>"+        urlMore = "?hoogle=" ++% queryText cq ++ "&start=" ++ show (start2+count2+1) ++ "#more"++        qstr = showTagHTML (renderQuery q)+        qurl (TagLink url x) | "query:" `isPrefixOf` url = TagLink ("?hoogle=" ++% drop 6 url) x+        qurl x = x++++-- insert <a name=more> where you can+insertMore :: [String] -> [String]+insertMore [] = []+insertMore (x:xs) = f x : xs+    where+        f ('>':xs) | not $ "<td" `isPrefixOf` xs = "><a name='more'></a>" ++ xs+        f (x:xs) = x : f xs+        f [] = []+++renderRes :: Int -> Result -> [String]+renderRes i Result{..} =+        [tr $ td "mod" (f modul) ++ td "ans" (href selfUrl $ showTagHTMLWith url selfText)+        ,tr $ td "pkg" (f package) ++ td "doc" docs2]+    where+        (selfUrl,selfText) = self+        f = maybe "" (uncurry href)++        docs2 = ("<div id='d" ++ show i ++ "' class='shut'>" +++                   "<a class='docs' onclick='return docs(" ++ show i ++ ")' href='" ++& selfUrl ++ "'></a>") ++?+                   showTagHTML 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) +++                                 "</a><a class='dull' href='" ++& selfUrl ++ "'>"+        url _ = Nothing++        g (TagEmph x) = TagBold x+        g x = x+++tr x = "<tr>" ++ x ++ "</tr>"+td c x = "<td" ++ (if null c then "" else " class='" ++ c ++ "'") ++ ">" ++ x ++ "</td>"+href url x = if null url then x else "<a class='dull' href='" ++& url ++ "'>" ++ x ++ "</a>"
+ src/Web/Server.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE RecordWildCards #-}++module Web.Server(server) where++import General.Base+import General.Web+import CmdLine.All+import Web.Response+import Control.Concurrent+import Control.Exception+import Network+import Network.HTTP+import Network.URI+import Network.Socket+import Data.Time+import General.System+++server :: CmdLine -> IO ()+server q@Server{..} = withSocketsDo $ do+    stop <- httpServer port (talk q)+    putStrLn $ "Started Hoogle Server on port " ++ show port+    b <- hIsClosed stdin+    (if b then forever $ threadDelay maxBound else getChar >> return ()) `finally` stop+++-- | Given a port and a handler, return an action to shutdown the server+httpServer :: Int -> (Request String -> IO (Response String)) -> IO (IO ())+httpServer port handler = do+    s <- listenOn $ PortNumber $ fromIntegral port+    forkIO $ forever $ do+        (sock,host) <- Network.Socket.accept s+        bracket+            (socketConnection "" sock)+            close+            (\strm -> do+                start <- getCurrentTime+                res <- receiveHTTP strm+                case res of+                    Left x -> do+                        putStrLn $ "Bad request: " ++ show x+                        respondHTTP strm $ Response (4,0,0) "Bad Request" [] ("400 Bad Request: " ++ show x)+                    Right x -> do+                        respondHTTP strm =<< handler x+                        end <- getCurrentTime+                        let t = floor $ diffUTCTime end start * 1000+                        putStrLn $ "Served in " ++ show t ++ "ms: " ++ unescapeURL (show $ rqURI x)+            )+    return $ sClose s+++-- FIXME: This should be in terms of Lazy ByteString's, for higher performance+--        serving of local files+talk :: CmdLine -> Request String -> IO (Response String)+talk Server{..} Request{rqURI=URI{uriPath=path,uriQuery=query}}+    | path `elem` ["/","/hoogle"] = do+        args <- cmdLineWeb $ parseHttpQueryArgs $ drop 1 query+        r <- response "/res" args{databases=databases}+        return $ if local_ then fmap rewriteFileLinks r else r+    | takeDirectory path == "/res" = do+        h <- openBinaryFile (resources </> takeFileName path) ReadMode+        src <- hGetContents h+        return $ Response (2,0,0) "OK"+            [Header HdrContentType $ contentExt $ takeExtension path+            ,Header HdrCacheControl "max-age=604800" {- 1 week -}] src+    | local_ && "/file/" `isPrefixOf` path = do+        src <- readFile $ drop 6 path+        return $ Response (2,0,0) "OK" [] src+    | otherwise+        = return $ Response (4,0,4) "Not Found" [] $ "404 Not Found: " ++ show path+++rewriteFileLinks :: String -> String+rewriteFileLinks x+    | "href='file://" `isPrefixOf` x = "href='/file/" ++ rewriteFileLinks (drop (13+1) x)+    | null x = x+    | otherwise = head x : rewriteFileLinks (tail x)+++contentExt ".png" = "image/png"+contentExt ".css" = "text/css"+contentExt ".js" = "text/javascript"+contentExt _ = "text/plain"
− src/Web/Text.hs 
@@ -1,74 +0,0 @@--module Web.Text where--import General.Code-import Data.TagStr-import Numeric----- | Only append strings if neither one is empty-(+?) :: String -> String -> String-a +? b = if null a || null b then [] else a ++ b---- | Escape the second argument as HTML before appending-(+&) :: String -> String -> String-a +& b = a ++ escapeHTML b---- | Escape the second argument as a CGI query string before appending-(+%) :: String -> String -> String-a +% b = a ++ escapeCGI b----- TODO: Should be somewhere else-escapeHTML = concatMap f-    where-        f '\"' = "&quot;"-        f '<' = "&lt;"-        f '>' = "&gt;"-        f '&' = "&amp;"-        f '\n' = "<br/>"-        f x = [x]--escapeCGI = concatMap f-    where-        f x | isAlphaNum x || x `elem` "-" = [x]-            | x == ' ' = "+"-            | otherwise = '%' : ['0'|length s == 1] ++ s-            where s = showHex (ord x) ""---showTagHTML = showTagHTMLWith (const Nothing)---showTagHTMLWith :: (TagStr -> Maybe String) -> TagStr -> String-showTagHTMLWith f x = g x-    where-        g x | isJust (f x) = fromJust $ f x-        g (Str x) = escapeHTML x-        g (Tags xs) = concatMap g xs-        g (TagBold x) = "<b>" ++ showTagHTML x ++ "</b>"-        g (TagUnderline x) = "<i>" ++ showTagHTML x ++ "</i>"-        g (TagHyperlink "" x) = g (TagHyperlink url x)-            where str = showTagText x-                  url = if "http:" `isPrefixOf` str then str else "?hoogle=" +% str-        g (TagHyperlink url x) = "<a href=\"" +& url ++ "\">" ++ showTagHTML x ++ "</a>"-        g (TagColor i x) = "<span class='c" ++ show i ++ "'>" ++ showTagHTML x ++ "</span>"----- TODO: Should be in Data.TagStr?---- TODO: Should only break on spaces-trimTags :: Int -> TagStr -> TagStr-trimTags n (Tags xs) = Tags $ f n xs-    where-        f n [] = []-        f n (x:xs) | m <  n = x : f (n-m) xs-                   | otherwise = [trimTags n x, Str "..."]-            where m = length (showTagText x)-trimTags n x | length (showTagText x) > n = Tags []-             | otherwise = x---onStr :: (String -> String) -> TagStr -> TagStr-onStr f (Str x) = Str $ f x-onStr f x = x