diff --git a/README.txt b/README.txt --- a/README.txt +++ b/README.txt @@ -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 ------- diff --git a/database/array.hoo b/database/array.hoo deleted file mode 100644 Binary files a/database/array.hoo and /dev/null differ diff --git a/database/base.hoo b/database/base.hoo deleted file mode 100644 Binary files a/database/base.hoo and /dev/null differ diff --git a/database/bytestring.hoo b/database/bytestring.hoo deleted file mode 100644 Binary files a/database/bytestring.hoo and /dev/null differ diff --git a/database/cabal.hoo b/database/cabal.hoo deleted file mode 100644 Binary files a/database/cabal.hoo and /dev/null differ diff --git a/database/containers.hoo b/database/containers.hoo deleted file mode 100644 Binary files a/database/containers.hoo and /dev/null differ diff --git a/database/default.hoo b/database/default.hoo deleted file mode 100644 # file too large to diff: database/default.hoo diff --git a/database/directory.hoo b/database/directory.hoo deleted file mode 100644 Binary files a/database/directory.hoo and /dev/null differ diff --git a/database/filepath.hoo b/database/filepath.hoo deleted file mode 100644 Binary files a/database/filepath.hoo and /dev/null differ diff --git a/database/ghc.hoo b/database/ghc.hoo deleted file mode 100644 Binary files a/database/ghc.hoo and /dev/null differ diff --git a/database/hackage.hoo b/database/hackage.hoo deleted file mode 100644 Binary files a/database/hackage.hoo and /dev/null differ diff --git a/database/haskell-src.hoo b/database/haskell-src.hoo deleted file mode 100644 Binary files a/database/haskell-src.hoo and /dev/null differ diff --git a/database/hunit.hoo b/database/hunit.hoo deleted file mode 100644 Binary files a/database/hunit.hoo and /dev/null differ diff --git a/database/keyword.hoo b/database/keyword.hoo deleted file mode 100644 Binary files a/database/keyword.hoo and /dev/null differ diff --git a/database/mtl.hoo b/database/mtl.hoo deleted file mode 100644 Binary files a/database/mtl.hoo and /dev/null differ diff --git a/database/parallel.hoo b/database/parallel.hoo deleted file mode 100644 Binary files a/database/parallel.hoo and /dev/null differ diff --git a/database/parsec.hoo b/database/parsec.hoo deleted file mode 100644 Binary files a/database/parsec.hoo and /dev/null differ diff --git a/database/pretty.hoo b/database/pretty.hoo deleted file mode 100644 Binary files a/database/pretty.hoo and /dev/null differ diff --git a/database/process.hoo b/database/process.hoo deleted file mode 100644 Binary files a/database/process.hoo and /dev/null differ diff --git a/database/quickcheck.hoo b/database/quickcheck.hoo deleted file mode 100644 Binary files a/database/quickcheck.hoo and /dev/null differ diff --git a/database/random.hoo b/database/random.hoo deleted file mode 100644 Binary files a/database/random.hoo and /dev/null differ diff --git a/database/stm.hoo b/database/stm.hoo deleted file mode 100644 Binary files a/database/stm.hoo and /dev/null differ diff --git a/database/syb.hoo b/database/syb.hoo deleted file mode 100644 Binary files a/database/syb.hoo and /dev/null differ diff --git a/database/template-haskell.hoo b/database/template-haskell.hoo deleted file mode 100644 Binary files a/database/template-haskell.hoo and /dev/null differ diff --git a/database/time.hoo b/database/time.hoo deleted file mode 100644 Binary files a/database/time.hoo and /dev/null differ diff --git a/database/xhtml.hoo b/database/xhtml.hoo deleted file mode 100644 Binary files a/database/xhtml.hoo and /dev/null differ diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -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 maintainer: Neil Mitchell -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 diff --git a/src/CmdLine/Action.hs b/src/CmdLine/Action.hs deleted file mode 100644 --- a/src/CmdLine/Action.hs +++ /dev/null @@ -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 diff --git a/src/CmdLine/All.hs b/src/CmdLine/All.hs --- a/src/CmdLine/All.hs +++ b/src/CmdLine/All.hs @@ -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 diff --git a/src/CmdLine/Files.hs b/src/CmdLine/Files.hs deleted file mode 100644 --- a/src/CmdLine/Files.hs +++ /dev/null @@ -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 diff --git a/src/CmdLine/Flag.hs b/src/CmdLine/Flag.hs deleted file mode 100644 --- a/src/CmdLine/Flag.hs +++ /dev/null @@ -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 diff --git a/src/CmdLine/Load.hs b/src/CmdLine/Load.hs new file mode 100644 --- /dev/null +++ b/src/CmdLine/Load.hs @@ -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"] diff --git a/src/CmdLine/Query.hs b/src/CmdLine/Query.hs deleted file mode 100644 --- a/src/CmdLine/Query.hs +++ /dev/null @@ -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] diff --git a/src/CmdLine/Search.hs b/src/CmdLine/Search.hs deleted file mode 100644 --- a/src/CmdLine/Search.hs +++ /dev/null @@ -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' diff --git a/src/CmdLine/Test.hs b/src/CmdLine/Test.hs deleted file mode 100644 --- a/src/CmdLine/Test.hs +++ /dev/null @@ -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 - diff --git a/src/CmdLine/Type.hs b/src/CmdLine/Type.hs new file mode 100644 --- /dev/null +++ b/src/CmdLine/Type.hs @@ -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" + ] diff --git a/src/Console/All.hs b/src/Console/All.hs new file mode 100644 --- /dev/null +++ b/src/Console/All.hs @@ -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) + diff --git a/src/Console/Rank.hs b/src/Console/Rank.hs new file mode 100644 --- /dev/null +++ b/src/Console/Rank.hs @@ -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 diff --git a/src/Console/Search.hs b/src/Console/Search.hs new file mode 100644 --- /dev/null +++ b/src/Console/Search.hs @@ -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' diff --git a/src/Console/Test.hs b/src/Console/Test.hs new file mode 100644 --- /dev/null +++ b/src/Console/Test.hs @@ -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 diff --git a/src/Data/Binary/Defer.hs b/src/Data/Binary/Defer.hs --- a/src/Data/Binary/Defer.hs +++ b/src/Data/Binary/Defer.hs @@ -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 diff --git a/src/Data/Binary/Defer/Array.hs b/src/Data/Binary/Defer/Array.hs --- a/src/Data/Binary/Defer/Array.hs +++ b/src/Data/Binary/Defer/Array.hs @@ -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 diff --git a/src/Data/Binary/Defer/Class.hs b/src/Data/Binary/Defer/Class.hs --- a/src/Data/Binary/Defer/Class.hs +++ b/src/Data/Binary/Defer/Class.hs @@ -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 diff --git a/src/Data/Binary/Defer/Index.hs b/src/Data/Binary/Defer/Index.hs --- a/src/Data/Binary/Defer/Index.hs +++ b/src/Data/Binary/Defer/Index.hs @@ -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 diff --git a/src/Data/Binary/Defer/Map.hs b/src/Data/Binary/Defer/Map.hs deleted file mode 100644 --- a/src/Data/Binary/Defer/Map.hs +++ /dev/null @@ -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 diff --git a/src/Data/Binary/Defer/Monad.hs b/src/Data/Binary/Defer/Monad.hs --- a/src/Data/Binary/Defer/Monad.hs +++ b/src/Data/Binary/Defer/Monad.hs @@ -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 diff --git a/src/Data/Binary/Defer/Trie.hs b/src/Data/Binary/Defer/Trie.hs deleted file mode 100644 --- a/src/Data/Binary/Defer/Trie.hs +++ /dev/null @@ -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] diff --git a/src/Data/Binary/Defer/Vector.hs b/src/Data/Binary/Defer/Vector.hs deleted file mode 100644 --- a/src/Data/Binary/Defer/Vector.hs +++ /dev/null @@ -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 diff --git a/src/Data/Binary/Raw.hs b/src/Data/Binary/Raw.hs --- a/src/Data/Binary/Raw.hs +++ b/src/Data/Binary/Raw.hs @@ -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 diff --git a/src/Data/Heap.hs b/src/Data/Heap.hs --- a/src/Data/Heap.hs +++ b/src/Data/Heap.hs @@ -9,7 +9,6 @@ import Prelude import qualified Data.Map as Map -import Data.Maybe -- (k,v) pairs are stored in reverse order diff --git a/src/Data/Key.hs b/src/Data/Key.hs deleted file mode 100644 --- a/src/Data/Key.hs +++ /dev/null @@ -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) diff --git a/src/Data/Range.hs b/src/Data/Range.hs deleted file mode 100644 --- a/src/Data/Range.hs +++ /dev/null @@ -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 diff --git a/src/Data/TagStr.hs b/src/Data/TagStr.hs deleted file mode 100644 --- a/src/Data/TagStr.hs +++ /dev/null @@ -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" - diff --git a/src/Data/TypeMap.hs b/src/Data/TypeMap.hs --- a/src/Data/TypeMap.hs +++ b/src/Data/TypeMap.hs @@ -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 diff --git a/src/General/Base.hs b/src/General/Base.hs new file mode 100644 --- /dev/null +++ b/src/General/Base.hs @@ -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 diff --git a/src/General/CGI.hs b/src/General/CGI.hs deleted file mode 100644 --- a/src/General/CGI.hs +++ /dev/null @@ -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 '<' = "<" - f '>' = ">" - f '&' = "&" - f x = [x] - - -escapeAttrib :: String -> String -escapeAttrib = concatMap f . escapeHTML - where - f '\"' = """ - f x = [x] diff --git a/src/General/Code.hs b/src/General/Code.hs deleted file mode 100644 --- a/src/General/Code.hs +++ /dev/null @@ -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 diff --git a/src/General/Glob.hs b/src/General/Glob.hs deleted file mode 100644 --- a/src/General/Glob.hs +++ /dev/null @@ -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] diff --git a/src/General/System.hs b/src/General/System.hs new file mode 100644 --- /dev/null +++ b/src/General/System.hs @@ -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 diff --git a/src/General/TextUtil.hs b/src/General/TextUtil.hs deleted file mode 100644 --- a/src/General/TextUtil.hs +++ /dev/null @@ -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 diff --git a/src/General/Util.hs b/src/General/Util.hs --- a/src/General/Util.hs +++ b/src/General/Util.hs @@ -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 diff --git a/src/General/Web.hs b/src/General/Web.hs new file mode 100644 --- /dev/null +++ b/src/General/Web.hs @@ -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 '<' = "<" + f '>' = ">" + f '&' = "&" + 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 ++ "" + + +--------------------------------------------------------------------- +-- 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 diff --git a/src/Hoogle.hs b/src/Hoogle.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle.hs @@ -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 diff --git a/src/Hoogle/All.hs b/src/Hoogle/All.hs deleted file mode 100644 --- a/src/Hoogle/All.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/DataBase/Aliases.hs b/src/Hoogle/DataBase/Aliases.hs --- a/src/Hoogle/DataBase/Aliases.hs +++ b/src/Hoogle/DataBase/Aliases.hs @@ -1,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 diff --git a/src/Hoogle/DataBase/All.hs b/src/Hoogle/DataBase/All.hs --- a/src/Hoogle/DataBase/All.hs +++ b/src/Hoogle/DataBase/All.hs @@ -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) diff --git a/src/Hoogle/DataBase/Instances.hs b/src/Hoogle/DataBase/Instances.hs --- a/src/Hoogle/DataBase/Instances.hs +++ b/src/Hoogle/DataBase/Instances.hs @@ -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 diff --git a/src/Hoogle/DataBase/Items.hs b/src/Hoogle/DataBase/Items.hs --- a/src/Hoogle/DataBase/Items.hs +++ b/src/Hoogle/DataBase/Items.hs @@ -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) diff --git a/src/Hoogle/DataBase/NameSearch.hs b/src/Hoogle/DataBase/NameSearch.hs deleted file mode 100644 --- a/src/Hoogle/DataBase/NameSearch.hs +++ /dev/null @@ -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]) - - diff --git a/src/Hoogle/DataBase/Serialise.hs b/src/Hoogle/DataBase/Serialise.hs --- a/src/Hoogle/DataBase/Serialise.hs +++ b/src/Hoogle/DataBase/Serialise.hs @@ -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 diff --git a/src/Hoogle/DataBase/SubstrSearch.hs b/src/Hoogle/DataBase/SubstrSearch.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/DataBase/SubstrSearch.hs @@ -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 diff --git a/src/Hoogle/DataBase/Suggest.hs b/src/Hoogle/DataBase/Suggest.hs --- a/src/Hoogle/DataBase/Suggest.hs +++ b/src/Hoogle/DataBase/Suggest.hs @@ -1,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 diff --git a/src/Hoogle/DataBase/Type.hs b/src/Hoogle/DataBase/Type.hs --- a/src/Hoogle/DataBase/Type.hs +++ b/src/Hoogle/DataBase/Type.hs @@ -1,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 diff --git a/src/Hoogle/DataBase/TypeSearch/All.hs b/src/Hoogle/DataBase/TypeSearch/All.hs --- a/src/Hoogle/DataBase/TypeSearch/All.hs +++ b/src/Hoogle/DataBase/TypeSearch/All.hs @@ -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] diff --git a/src/Hoogle/DataBase/TypeSearch/Binding.hs b/src/Hoogle/DataBase/TypeSearch/Binding.hs --- a/src/Hoogle/DataBase/TypeSearch/Binding.hs +++ b/src/Hoogle/DataBase/TypeSearch/Binding.hs @@ -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 diff --git a/src/Hoogle/DataBase/TypeSearch/Cost.hs b/src/Hoogle/DataBase/TypeSearch/Cost.hs deleted file mode 100644 --- a/src/Hoogle/DataBase/TypeSearch/Cost.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/DataBase/TypeSearch/EntryInfo.hs b/src/Hoogle/DataBase/TypeSearch/EntryInfo.hs --- a/src/Hoogle/DataBase/TypeSearch/EntryInfo.hs +++ b/src/Hoogle/DataBase/TypeSearch/EntryInfo.hs @@ -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 diff --git a/src/Hoogle/DataBase/TypeSearch/Graph.hs b/src/Hoogle/DataBase/TypeSearch/Graph.hs --- a/src/Hoogle/DataBase/TypeSearch/Graph.hs +++ b/src/Hoogle/DataBase/TypeSearch/Graph.hs @@ -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 diff --git a/src/Hoogle/DataBase/TypeSearch/Graphs.hs b/src/Hoogle/DataBase/TypeSearch/Graphs.hs --- a/src/Hoogle/DataBase/TypeSearch/Graphs.hs +++ b/src/Hoogle/DataBase/TypeSearch/Graphs.hs @@ -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 diff --git a/src/Hoogle/DataBase/TypeSearch/Result.hs b/src/Hoogle/DataBase/TypeSearch/Result.hs --- a/src/Hoogle/DataBase/TypeSearch/Result.hs +++ b/src/Hoogle/DataBase/TypeSearch/Result.hs @@ -8,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 diff --git a/src/Hoogle/DataBase/TypeSearch/TypeScore.hs b/src/Hoogle/DataBase/TypeSearch/TypeScore.hs --- a/src/Hoogle/DataBase/TypeSearch/TypeScore.hs +++ b/src/Hoogle/DataBase/TypeSearch/TypeScore.hs @@ -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 diff --git a/src/Hoogle/Item/All.hs b/src/Hoogle/Item/All.hs deleted file mode 100644 --- a/src/Hoogle/Item/All.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/Item/Haddock.hs b/src/Hoogle/Item/Haddock.hs deleted file mode 100644 --- a/src/Hoogle/Item/Haddock.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/Item/Item.hs b/src/Hoogle/Item/Item.hs deleted file mode 100644 --- a/src/Hoogle/Item/Item.hs +++ /dev/null @@ -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 - diff --git a/src/Hoogle/Item/URL.hs b/src/Hoogle/Item/URL.hs deleted file mode 100644 --- a/src/Hoogle/Item/URL.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/Language/Haskell.hs b/src/Hoogle/Language/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Language/Haskell.hs @@ -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] diff --git a/src/Hoogle/Operations/All.hs b/src/Hoogle/Operations/All.hs deleted file mode 100644 --- a/src/Hoogle/Operations/All.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/Operations/Combine.hs b/src/Hoogle/Operations/Combine.hs deleted file mode 100644 --- a/src/Hoogle/Operations/Combine.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/Operations/Convert.hs b/src/Hoogle/Operations/Convert.hs deleted file mode 100644 --- a/src/Hoogle/Operations/Convert.hs +++ /dev/null @@ -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"] - diff --git a/src/Hoogle/Operations/Rank.hs b/src/Hoogle/Operations/Rank.hs deleted file mode 100644 --- a/src/Hoogle/Operations/Rank.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/Operations/RankSolve.hs b/src/Hoogle/Operations/RankSolve.hs deleted file mode 100644 --- a/src/Hoogle/Operations/RankSolve.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/Query/All.hs b/src/Hoogle/Query/All.hs --- a/src/Hoogle/Query/All.hs +++ b/src/Hoogle/Query/All.hs @@ -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 diff --git a/src/Hoogle/Query/Parser.hs b/src/Hoogle/Query/Parser.hs --- a/src/Hoogle/Query/Parser.hs +++ b/src/Hoogle/Query/Parser.hs @@ -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) diff --git a/src/Hoogle/Query/Render.hs b/src/Hoogle/Query/Render.hs --- a/src/Hoogle/Query/Render.hs +++ b/src/Hoogle/Query/Render.hs @@ -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 diff --git a/src/Hoogle/Query/Suggest.hs b/src/Hoogle/Query/Suggest.hs --- a/src/Hoogle/Query/Suggest.hs +++ b/src/Hoogle/Query/Suggest.hs @@ -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 diff --git a/src/Hoogle/Query/Type.hs b/src/Hoogle/Query/Type.hs --- a/src/Hoogle/Query/Type.hs +++ b/src/Hoogle/Query/Type.hs @@ -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 diff --git a/src/Hoogle/Score/All.hs b/src/Hoogle/Score/All.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Score/All.hs @@ -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 diff --git a/src/Hoogle/Score/Scoring.hs b/src/Hoogle/Score/Scoring.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Score/Scoring.hs @@ -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) diff --git a/src/Hoogle/Score/Type.hs b/src/Hoogle/Score/Type.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Score/Type.hs @@ -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) diff --git a/src/Hoogle/Search/All.hs b/src/Hoogle/Search/All.hs --- a/src/Hoogle/Search/All.hs +++ b/src/Hoogle/Search/All.hs @@ -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] diff --git a/src/Hoogle/Search/Result.hs b/src/Hoogle/Search/Result.hs deleted file mode 100644 --- a/src/Hoogle/Search/Result.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/Search/Results.hs b/src/Hoogle/Search/Results.hs --- a/src/Hoogle/Search/Results.hs +++ b/src/Hoogle/Search/Results.hs @@ -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 diff --git a/src/Hoogle/TextBase/All.hs b/src/Hoogle/TextBase/All.hs deleted file mode 100644 --- a/src/Hoogle/TextBase/All.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/TextBase/Parser.hs b/src/Hoogle/TextBase/Parser.hs deleted file mode 100644 --- a/src/Hoogle/TextBase/Parser.hs +++ /dev/null @@ -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) diff --git a/src/Hoogle/TextBase/Type.hs b/src/Hoogle/TextBase/Type.hs deleted file mode 100644 --- a/src/Hoogle/TextBase/Type.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/Type/All.hs b/src/Hoogle/Type/All.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Type/All.hs @@ -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 diff --git a/src/Hoogle/Type/Documentation.hs b/src/Hoogle/Type/Documentation.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Type/Documentation.hs @@ -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 diff --git a/src/Hoogle/Type/Item.hs b/src/Hoogle/Type/Item.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Type/Item.hs @@ -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 diff --git a/src/Hoogle/Type/ParseError.hs b/src/Hoogle/Type/ParseError.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Type/ParseError.hs @@ -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 "" diff --git a/src/Hoogle/Type/Result.hs b/src/Hoogle/Type/Result.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Type/Result.hs @@ -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 diff --git a/src/Hoogle/Type/TagStr.hs b/src/Hoogle/Type/TagStr.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Type/TagStr.hs @@ -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) = "" ++ showTagHTML x ++ "" + g (TagColor i x) = "" ++ showTagHTML x ++ "" + + nbsp (' ':' ':xs) = "  " ++ 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 /= ""] diff --git a/src/Hoogle/Type/TypeSig.hs b/src/Hoogle/Type/TypeSig.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Type/TypeSig.hs @@ -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 diff --git a/src/Hoogle/TypeSig/All.hs b/src/Hoogle/TypeSig/All.hs deleted file mode 100644 --- a/src/Hoogle/TypeSig/All.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/TypeSig/Parser.hs b/src/Hoogle/TypeSig/Parser.hs deleted file mode 100644 --- a/src/Hoogle/TypeSig/Parser.hs +++ /dev/null @@ -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 diff --git a/src/Hoogle/TypeSig/Type.hs b/src/Hoogle/TypeSig/Type.hs deleted file mode 100644 --- a/src/Hoogle/TypeSig/Type.hs +++ /dev/null @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Recipe/All.hs b/src/Recipe/All.hs new file mode 100644 --- /dev/null +++ b/src/Recipe/All.hs @@ -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) diff --git a/src/Recipe/Download.hs b/src/Recipe/Download.hs new file mode 100644 --- /dev/null +++ b/src/Recipe/Download.hs @@ -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") "" diff --git a/src/Recipe/General.hs b/src/Recipe/General.hs new file mode 100644 --- /dev/null +++ b/src/Recipe/General.hs @@ -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" diff --git a/src/Recipe/Hackage.hs b/src/Recipe/Hackage.hs new file mode 100644 --- /dev/null +++ b/src/Recipe/Hackage.hs @@ -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] diff --git a/src/Recipe/Keyword.hs b/src/Recipe/Keyword.hs new file mode 100644 --- /dev/null +++ b/src/Recipe/Keyword.hs @@ -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 (~== "") $ + takeWhile (~/= "
") $ 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 (~/= "
")) $ + 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) = ["
"] ++ map (drop n) ys ++ ["
"] + 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) = "" ++ innerText a ++ "" ++ f (drop 1 b) + where (a,b) = break (~== "") xs + f (x:xs) = h x ++ f xs + f [] = [] + + h (TagText x) = unwords (lines x) + h _ = "" diff --git a/src/Recipe/Type.hs b/src/Recipe/Type.hs new file mode 100644 --- /dev/null +++ b/src/Recipe/Type.hs @@ -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 [] = [] diff --git a/src/Test/All.hs b/src/Test/All.hs --- a/src/Test/All.hs +++ b/src/Test/All.hs @@ -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 diff --git a/src/Test/General.hs b/src/Test/General.hs --- a/src/Test/General.hs +++ b/src/Test/General.hs @@ -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 diff --git a/src/Test/Parse_Query.hs b/src/Test/Parse_Query.hs --- a/src/Test/Parse_Query.hs +++ b/src/Test/Parse_Query.hs @@ -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"]} + diff --git a/src/Test/Parse_TextBase.hs b/src/Test/Parse_TextBase.hs deleted file mode 100644 --- a/src/Test/Parse_TextBase.hs +++ /dev/null @@ -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" ""] diff --git a/src/Test/Parse_TypeSig.hs b/src/Test/Parse_TypeSig.hs --- a/src/Test/Parse_TypeSig.hs +++ b/src/Test/Parse_TypeSig.hs @@ -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"]) diff --git a/src/Web/Action.hs b/src/Web/Action.hs deleted file mode 100644 --- a/src/Web/Action.hs +++ /dev/null @@ -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} = - ["

Parse error in user query

" - ,"

" - ," Query: " +& pre ++ "" +& post2 ++ "
" - ,"

" - ," Error: " +& drop 1 (dropWhile (/= ':') $ show err) ++ "
" - ,"

" - ," For information on what queries should look like, see the" - ," user manual." - ,"

" - ] - where - (pre,post) = splitAt (sourceColumn (errorPos err) - 1) text - post2 = if null post then concat (replicate 3 " ") else post - - -runQuery dbs q | not $ usefulQuery $ fromRight $ query q = welcome - - -runQuery dbs cq@CmdQuery{query = Right q, queryFlags = flags} = - ["

Searching for " ++ qstr ++ "

"] ++ - ["

" ++ showTagHTML (transform qurl sug) ++ "

" | Just sug <- [suggestQuery dbs q]] ++ - if null res then - ["

No results found

"] - else - [""] ++ - concatMap (uncurry renderRes) pre ++ - insertMore (concatMap (uncurry renderRes) now) ++ - [moreResults | not $ null post] ++ - ["
"] - 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 = "Show more results" - urlMore = "?hoogle=" +% queryText cq ++ "&start=" ++ show (start+count+1) ++ "#more" - - qstr = unwords $ ["" +& n ++ "" | 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 where you can -insertMore :: [String] -> [String] -insertMore [] = [] -insertMore (x:xs) = f x : xs - where - f ('>':xs) | not $ " 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 = ("
" ++ - "") +? - (showTagHTML $ renderHaddock $ entryDocs ent) +? - "
" - - urlPkg = entryPackageURL ent - urlMod = entryModuleURL ent - urlEnt = entryURL ent - - url (TagHyperlink _ x) - | null urlEnt = Just $ "" ++ showTagHTML x ++ "" - | otherwise = Just $ "" ++ showTagHTML x ++ - "" - url _ = Nothing - -tr x = "" ++ x ++ "" -td c x = "" ++ x ++ "" -href url x = if null url then x else "" ++ x ++ "" diff --git a/src/Web/All.hs b/src/Web/All.hs --- a/src/Web/All.hs +++ b/src/Web/All.hs @@ -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] diff --git a/src/Web/Page.hs b/src/Web/Page.hs --- a/src/Web/Page.hs +++ b/src/Web/Page.hs @@ -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 = ["" ,"" ," " ," " - ," " ++ (query +? " - ") ++ "Hoogle" - ," " - ," " - ," " - ," " + ," " ++ (query ++? " - ") ++ "Hoogle" + ," " + ," " + ," " + ," " + ," " ," " - ," " - ] ++ links ++ search query + ," " + ] ++ links ++ search resources query ++ + ["
"] links = ["" ] -search query = +search resources query = ["
" ," " ,"
" @@ -42,7 +44,8 @@ footer = - [" " + ["
" + ," " ," " ,"" ] @@ -74,4 +77,4 @@ ,"

" ] where - search x = "" +& x ++ "
" + search x = "" ++& x ++ "
" diff --git a/src/Web/Response.hs b/src/Web/Response.hs new file mode 100644 --- /dev/null +++ b/src/Web/Response.hs @@ -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} = + ["

Parse error in user query

" + ,"

" + ," Query: " ++ showTagHTMLWith f (parseInput err) ++ "
" + ,"

" + ," Error: " ++& errorMessage err ++ "
" + ,"

" + ," For information on what queries should look like, see the" + ," user manual." + ,"

" + ] + where + f (TagEmph x) = Just $ "" ++ showTagHTMLWith f x ++ "" + f _ = Nothing + + +runQuery dbs q | isBlankQuery $ fromRight $ queryParsed q = welcome + + +runQuery dbs cq@Search{queryParsed = Right q} = + ["

Searching for " ++ qstr ++ "

"] ++ + ["

" ++ showTagHTML (transform qurl sug) ++ "

" | Just sug <- [querySuggestions dbs q]] ++ + if null res then + ["

No results found

"] + else + [""] ++ + concatMap (uncurry renderRes) pre ++ + insertMore (concatMap (uncurry renderRes) now) ++ + [moreResults | not $ null post] ++ + ["
"] + 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 = "Show more results" + 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 where you can +insertMore :: [String] -> [String] +insertMore [] = [] +insertMore (x:xs) = f x : xs + where + f ('>':xs) | not $ " 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 = ("
" ++ + "") ++? + showTagHTML docs ++? + "
" + + url (TagBold x) + | null selfUrl = Just $ "" ++ showTagHTML (transform g x) ++ "" + | otherwise = Just $ "" ++ showTagHTML (transform g x) ++ + "" + url _ = Nothing + + g (TagEmph x) = TagBold x + g x = x + + +tr x = "" ++ x ++ "" +td c x = "" ++ x ++ "" +href url x = if null url then x else "" ++ x ++ "" diff --git a/src/Web/Server.hs b/src/Web/Server.hs new file mode 100644 --- /dev/null +++ b/src/Web/Server.hs @@ -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" diff --git a/src/Web/Text.hs b/src/Web/Text.hs deleted file mode 100644 --- a/src/Web/Text.hs +++ /dev/null @@ -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 '\"' = """ - f '<' = "<" - f '>' = ">" - f '&' = "&" - f '\n' = "
" - 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) = "" ++ showTagHTML x ++ "" - g (TagUnderline x) = "" ++ showTagHTML x ++ "" - 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) = "" ++ showTagHTML x ++ "" - g (TagColor i x) = "" ++ showTagHTML x ++ "" - - --- 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