diff --git a/database/array.hoo b/database/array.hoo Binary files a/database/array.hoo and b/database/array.hoo differ diff --git a/database/base.hoo b/database/base.hoo Binary files a/database/base.hoo and b/database/base.hoo differ diff --git a/database/bytestring.hoo b/database/bytestring.hoo Binary files a/database/bytestring.hoo and b/database/bytestring.hoo differ diff --git a/database/cabal.hoo b/database/cabal.hoo Binary files a/database/cabal.hoo and b/database/cabal.hoo differ diff --git a/database/containers.hoo b/database/containers.hoo Binary files a/database/containers.hoo and b/database/containers.hoo differ diff --git a/database/default.hoo b/database/default.hoo # file too large to diff: database/default.hoo diff --git a/database/directory.hoo b/database/directory.hoo Binary files a/database/directory.hoo and b/database/directory.hoo differ diff --git a/database/filepath.hoo b/database/filepath.hoo Binary files a/database/filepath.hoo and b/database/filepath.hoo differ diff --git a/database/ghc.hoo b/database/ghc.hoo Binary files a/database/ghc.hoo and b/database/ghc.hoo differ diff --git a/database/hackage.hoo b/database/hackage.hoo Binary files a/database/hackage.hoo and b/database/hackage.hoo differ diff --git a/database/haskell-src.hoo b/database/haskell-src.hoo Binary files a/database/haskell-src.hoo and b/database/haskell-src.hoo differ diff --git a/database/hunit.hoo b/database/hunit.hoo Binary files a/database/hunit.hoo and b/database/hunit.hoo differ diff --git a/database/keyword.hoo b/database/keyword.hoo Binary files a/database/keyword.hoo and b/database/keyword.hoo differ diff --git a/database/mtl.hoo b/database/mtl.hoo Binary files a/database/mtl.hoo and b/database/mtl.hoo differ diff --git a/database/parallel.hoo b/database/parallel.hoo Binary files a/database/parallel.hoo and b/database/parallel.hoo differ diff --git a/database/parsec.hoo b/database/parsec.hoo Binary files a/database/parsec.hoo and b/database/parsec.hoo differ diff --git a/database/pretty.hoo b/database/pretty.hoo Binary files a/database/pretty.hoo and b/database/pretty.hoo differ diff --git a/database/process.hoo b/database/process.hoo Binary files a/database/process.hoo and b/database/process.hoo differ diff --git a/database/random.hoo b/database/random.hoo Binary files a/database/random.hoo and b/database/random.hoo differ diff --git a/database/stm.hoo b/database/stm.hoo Binary files a/database/stm.hoo and b/database/stm.hoo differ diff --git a/database/syb.hoo b/database/syb.hoo new file mode 100644 Binary files /dev/null and b/database/syb.hoo differ diff --git a/database/template-haskell.hoo b/database/template-haskell.hoo Binary files a/database/template-haskell.hoo and b/database/template-haskell.hoo differ diff --git a/database/time.hoo b/database/time.hoo Binary files a/database/time.hoo and b/database/time.hoo differ diff --git a/database/xhtml.hoo b/database/xhtml.hoo Binary files a/database/xhtml.hoo and b/database/xhtml.hoo differ diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.2 build-type: Simple name: hoogle -version: 4.0.0.5 +version: 4.0.6 license: GPL license-file: docs/LICENSE category: Development @@ -39,6 +39,7 @@ quickcheck.hoo random.hoo stm.hoo + syb.hoo template-haskell.hoo time.hoo xhtml.hoo @@ -49,9 +50,9 @@ executable hoogle build-depends: parsec, filepath, safe, uniplate, mtl, time if flag(splitBase) - build-depends: base >= 3, directory, process, containers, array, bytestring + build-depends: base >= 3 && < 4, directory, process, containers, array, bytestring else - build-depends: base < 3 + build-depends: base >= 2 && < 3 main-is: Main.hs hs-source-dirs: src diff --git a/src/CmdLine/Action.hs b/src/CmdLine/Action.hs --- a/src/CmdLine/Action.hs +++ b/src/CmdLine/Action.hs @@ -17,13 +17,13 @@ actionCmdLine :: CmdQuery -> IO () -actionCmdLine CmdQuery{queryText = text, query = Left err} = do +actionCmdLine CmdQuery{queryText = text, query = Left err} = exitMessage ["Parse error:", " " ++ text ,replicate (sourceColumn (errorPos err) + 1) ' ' ++ "^" ,show err] -actionCmdLine q | not $ null $ queryBadFlags q = do +actionCmdLine q | not $ null $ queryBadFlags q = exitMessage $ "Unrecognised or malformed flags:": map (" "++) (queryBadFlags q) ++ ["For details on correct flags pass --help"] @@ -52,7 +52,7 @@ mapM_ rank [x | Rank x <- queryFlags q] -actionCmdLine q | Convert{} `elemEnum` queryFlags q = do +actionCmdLine q | Convert{} `elemEnum` queryFlags q = mapM_ (actionConvert q) [x | Convert x <- queryFlags q] @@ -73,7 +73,7 @@ mapM_ (actionDump q) dbs -actionCmdLine q | not $ usefulQuery $ fromRight $ query q = do +actionCmdLine q | not $ usefulQuery $ fromRight $ query q = exitMessage ["No query entered" ,"Try --help for command line options"] diff --git a/src/CmdLine/Flag.hs b/src/CmdLine/Flag.hs --- a/src/CmdLine/Flag.hs +++ b/src/CmdLine/Flag.hs @@ -127,14 +127,11 @@ flagsHelp :: String -flagsHelp = unlines $ map f res +flagsHelp = unlines . map concat . tabulate $ map f res where - f (a,b,c) = " " ++ (if null a then " " else "--" ++ a ++ ",") ++ - " --" ++ b ++ replicate (maxLong - length b) ' ' ++ - " " ++ c + f (a,b,c) = [" ", "--" <+ a, " --" ++ b, " " ++ c] - maxLong = maximum $ map (length . snd3) res - res = [ (shortOpt (names i), longOpt (names i) ++ typ (argument i), description i) + res = [ (shortOpt (names i) +> typ (argument i), longOpt (names i) ++ typ (argument i), description i) | i <- flagInfo, PCmdLine `elem` permissions i] shortOpt ([x]:_) = [x] @@ -145,6 +142,16 @@ 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 ] --------------------------------------------------------------------- diff --git a/src/CmdLine/Query.hs b/src/CmdLine/Query.hs --- a/src/CmdLine/Query.hs +++ b/src/CmdLine/Query.hs @@ -55,6 +55,8 @@ 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"]] [] 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 @@ -169,7 +169,7 @@ get = do i <- getByte - if i /= maxByte then do + if i /= maxByte then replicateM (fromIntegral i) get else do xs <- replicateM 100 get diff --git a/src/Data/Binary/Defer/Map.hs b/src/Data/Binary/Defer/Map.hs --- a/src/Data/Binary/Defer/Map.hs +++ b/src/Data/Binary/Defer/Map.hs @@ -17,5 +17,5 @@ instance (Ord k, BinaryDefer k, BinaryDefer v) => BinaryDefer (Data.Map.Map k v) where - put = putDefer . put . Vector.fromList . Prelude.map (id *** Defer) . Data.Map.toAscList - get = getDefer $ liftM (Data.Map.fromAscList . Prelude.map (id *** fromDefer) . Vector.toList) get + 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 @@ -83,7 +83,7 @@ lift $ do p <- bufferPos buf b <- bufferPatch buf pos (fromIntegral p :: Int32) - when (not b) $ modifyIORef back (DeferPatchup pos p :) + unless b $ modifyIORef back (DeferPatchup pos p :) act runDeferPendings diff --git a/src/Data/TagStr.hs b/src/Data/TagStr.hs --- a/src/Data/TagStr.hs +++ b/src/Data/TagStr.hs @@ -45,5 +45,5 @@ getCode (TagColor n _) | n <= 5 && n >= 0 = Just ['3', intToDigit (n + 1)] getCode _ = Nothing - tag stack = chr 27 : '[' : (concat $ intersperse ";" $ ("0":reverse stack)) ++ "m" + tag stack = chr 27 : '[' : (concat $ intersperse ";" $ "0":reverse stack) ++ "m" diff --git a/src/General/CGI.hs b/src/General/CGI.hs --- a/src/General/CGI.hs +++ b/src/General/CGI.hs @@ -15,9 +15,18 @@ 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 = catch (liftM Just $ getEnv "QUERY_STRING") - (const $ return Nothing) +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)]) diff --git a/src/General/Util.hs b/src/General/Util.hs --- a/src/General/Util.hs +++ b/src/General/Util.hs @@ -68,7 +68,7 @@ -- | all permutations of a list permute :: [a] -> [[a]] permute [] = [[]] -permute (x:xs) = concat $ map (\a -> zipWith f (inits a) (tails a)) (permute xs) +permute (x:xs) = concatMap (\a -> zipWith f (inits a) (tails a)) (permute xs) where f a b = a ++ [x] ++ b 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 @@ -79,7 +79,7 @@ normAliases :: Aliases -> Type -> ([String], Type) -normAliases as t = (sort . nub *** id) $ f t +normAliases as t = first (sort . nub) $ f t where f t = case followAlias as t of Just (s,t) -> ([s],t) 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 @@ -88,7 +88,7 @@ (if null b1 && null b2 then a1 `mplus` a2 else Nothing) (f b1 b2) (f c1 c2) where - f x y = map (id *** maximum) $ sortGroupFsts $ x ++ y + f x y = map (second maximum) $ sortGroupFsts $ x ++ y askSuggest :: [Suggest] -> TypeSig -> Maybe (Either String TypeSig) @@ -130,8 +130,8 @@ improve :: (String -> Maybe SuggestItem) -> Bool -> Type -> Type improve get cls typ - | cls == False = f $ transform (improveName nameTyp) typ - | cls == True = improveArity arity $ + | not cls = f $ transform (improveName nameTyp) typ + | otherwise = improveArity arity $ tApp (improveName nameCls t1) (map (transform (improveName nameTyp)) ts) where (t1,ts) = fromTApp typ diff --git a/src/Hoogle/Item/URL.hs b/src/Hoogle/Item/URL.hs --- a/src/Hoogle/Item/URL.hs +++ b/src/Hoogle/Item/URL.hs @@ -3,7 +3,6 @@ import General.Code import Hoogle.Item.Item -import Web.Text(escapeHTML) -- TODO: Shouldn't be importing this! import Numeric import Data.Binary.Defer.Index @@ -12,7 +11,7 @@ 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:" ++ escapeHTML (entryName 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 diff --git a/src/Hoogle/Operations/RankSolve.hs b/src/Hoogle/Operations/RankSolve.hs --- a/src/Hoogle/Operations/RankSolve.hs +++ b/src/Hoogle/Operations/RankSolve.hs @@ -58,8 +58,8 @@ where -- all x in xs, x.max = ys.max - 1 -- all y in ys, y.min = xs.min + 1 - f mp (xs :< ys) = upd (id *** min (maxRhs - 1)) xs $ - upd (max (minLhs + 1) *** id) ys mp + 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 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 @@ -7,7 +7,7 @@ import Text.ParserCombinators.Parsec -ascSymbols = "!#$%&*+./<=>?@\\^|-~" +ascSymbols = "!#$%&*+./<=>?@\\^|-~:" parseQuery :: String -> Either ParseError Query parseQuery input = parse parsecQuery "" input @@ -43,7 +43,7 @@ name = (do x <- operator ; spaces ; return blankQuery{names=[x]}) <|> - (do xs <- keyword `sepBy1` (char '.') ; spaces + (do xs <- keyword False `sepBy1` (char '.') ; spaces return $ case xs of [x] -> blankQuery{names=[x]} xs -> blankQuery{names=[last xs],scope=[PlusModule (init xs)]} @@ -51,7 +51,9 @@ operator = between (char '(') (char ')') op <|> op - op = many1 $ satisfy (`elem` ascSymbols) + op = try $ do + res <- many1 $ satisfy (`elem` ascSymbols) + if res == "::" then fail ":: is not an operator name" else return res types = do a <- flags b <- parsecTypeSig @@ -92,11 +94,11 @@ [x] -> return $ blankQuery{scope=[if isLower (head x) then aPackage x else aModule [x]]} xs -> return $ blankQuery{scope=[aModule xs]} - modname = keyword `sepBy1` (char '.') + modname = keyword True `sepBy1` (char '.') --- TODO: Should share this definition with Hoogle.TypeSig.Parser -keyword = do x <- letter - xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#") - return (x:xs) +keyword hyphen = do + x <- letter + xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#" || (hyphen && x == '-')) + return (x:xs) 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 @@ -22,7 +22,7 @@ -- They searched for "Int to Float", they meant "Int -> Float" suggestQuery db q@Query{typeSig=Nothing, names=names} | "to" `elem` names = Just $ didYouMean q2 where q2 = fixup db $ q{names = [] ,typeSig = Just $ TypeSig [] t2} - t2 = TFun $ map (toApp . map toLitVar) $ split "to" $ names + t2 = TFun $ map (toApp . map toLitVar) $ split "to" names -- They search for "Maybe a", did they mean ":: Maybe a" suggestQuery db q@Query{typeSig=Nothing, names=names} | length names > 1 && all f names = Just $ didYouMean q2 diff --git a/src/Hoogle/TextBase/Parser.hs b/src/Hoogle/TextBase/Parser.hs --- a/src/Hoogle/TextBase/Parser.hs +++ b/src/Hoogle/TextBase/Parser.hs @@ -85,6 +85,6 @@ keysymbol = many1 $ satisfy (\x -> isSymbol x || x `elem` ascSymbol) ascSymbol = "!#$%&*+./<=>?@\\^|-~:" - keyword = do x <- letter + keyword = do x <- satisfy (\x -> isAlphaNum x || x == '_') xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#") return (x:xs) diff --git a/src/Hoogle/TypeSig/Parser.hs b/src/Hoogle/TypeSig/Parser.hs --- a/src/Hoogle/TypeSig/Parser.hs +++ b/src/Hoogle/TypeSig/Parser.hs @@ -51,7 +51,7 @@ close return $ tLit hash (length xs + 1) ) <|> - (do sym <- white $ keysymbol + (do sym <- white keysymbol close return $ TLit sym ) <|> @@ -67,10 +67,10 @@ where h = ['#'|hash] - atom = do x <- satisfy isAlpha + atom = do x <- satisfy (\x -> isAlpha x || x == '_') xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#") whites - return $ (if isLower x then TVar else TLit) (x:xs) + 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 '[' diff --git a/src/Hoogle/TypeSig/Type.hs b/src/Hoogle/TypeSig/Type.hs --- a/src/Hoogle/TypeSig/Type.hs +++ b/src/Hoogle/TypeSig/Type.hs @@ -150,7 +150,7 @@ f i (TLit x) = x f i (TVar x) = x - f i (TApp x xs) = b (i > 1) $ concat (intersperse " " $ map (f 2) (x:xs)) + 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 ++ ")" 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 @@ -28,9 +28,11 @@ "map :: a -> b" === q{names = ["map"], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} "+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 = [":+:"]} 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 @@ -9,7 +9,11 @@ -- really basic stuff "a" === TypeSig [] (TVar "a") + "a_" === TypeSig [] (TVar "a_") + "_" === TypeSig [] (TVar "_") + "_a" === TypeSig [] (TVar "_a") "A" === TypeSig [] (TLit "A") + "A_" === TypeSig [] (TLit "A_") "m a" === TypeSig [] (TApp (TVar "m") [TVar "a"]) "M a b" === TypeSig [] (TApp (TLit "M") [TVar "a",TVar "b"]) diff --git a/src/Web/Action.hs b/src/Web/Action.hs --- a/src/Web/Action.hs +++ b/src/Web/Action.hs @@ -23,6 +23,9 @@ import Paths_hoogle +logFile = "log.txt" + + actionWeb :: CmdQuery -> IO () actionWeb q = do logMessage q @@ -33,25 +36,18 @@ else do putStr "Content-type: text/html\n\n" (skipped,dbs) <- loadDataBases q - return $ unlines $ header (escapeHTML $ queryText $ queryPretty q) ++ runQuery dbs q ++ footer + 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] --- TODO: Hacky, requires a better parser --- Strip out Web, Debug and Output from queryText -queryPretty :: CmdQuery -> CmdQuery -queryPretty q = q{queryText = unwords $ filter f $ words $ queryText q} - where f x = not $ any (`isPrefixOf` x) ["/debug","/output","/web"] - - logMessage :: CmdQuery -> IO () logMessage q = do time <- getCurrentTime - cgi <- liftM (fromMaybe []) $ cgiArgs - appendFile "log.txt" $ (++ "\n") $ unwords $ + 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]] @@ -159,7 +155,7 @@ pkgname = td "pkg" $ href urlPkg $ packageName $ fromLink $ entryPackage ent docs = ("
" ++ - "") +? + "") +? (showTagHTML $ renderHaddock $ entryDocs ent) +? "
" @@ -175,4 +171,4 @@ tr x = "" ++ x ++ "" td c x = "" ++ x ++ "" -href url x = if null url then x else "" ++ x ++ "" +href url x = if null url then x else "" ++ x ++ "" diff --git a/src/Web/Page.hs b/src/Web/Page.hs --- a/src/Web/Page.hs +++ b/src/Web/Page.hs @@ -3,16 +3,18 @@ import Web.Text +resourcePath = "res/" + header query = ["" ,"" ," " ," " ," " ++ (query +? " - ") ++ "Hoogle" - ," " - ," " - ," " - ," " + ," " + ," " + ," " + ," " ," " ," " ] ++ links ++ search query @@ -30,7 +32,7 @@ ["
" ,"