diff --git a/hoogle.cabal b/hoogle.cabal
--- a/hoogle.cabal
+++ b/hoogle.cabal
@@ -1,7 +1,7 @@
cabal-version: >= 1.1.4
build-type: Simple
name: hoogle
-version: 4.0.0.1
+version: 4.0.0.2
license: GPL
license-file: LICENSE
category: Development
@@ -89,7 +89,6 @@
Hoogle.TypeSig.All
Hoogle.TypeSig.Parser
Hoogle.TypeSig.Type
- Main
Test.All
Test.General
Test.Parse_Query
@@ -97,3 +96,4 @@
Test.Parse_TypeSig
Web.Action
Web.All
+ Web.Page
diff --git a/src/CmdLine/All.hs b/src/CmdLine/All.hs
--- a/src/CmdLine/All.hs
+++ b/src/CmdLine/All.hs
@@ -1,8 +1,10 @@
module CmdLine.All(
module CmdLine.Query,
+ module CmdLine.Flag,
module CmdLine.Action
) where
import CmdLine.Query
+import CmdLine.Flag
import CmdLine.Action
diff --git a/src/CmdLine/Flag.hs b/src/CmdLine/Flag.hs
--- a/src/CmdLine/Flag.hs
+++ b/src/CmdLine/Flag.hs
@@ -34,7 +34,7 @@
| Include FilePath -- ^ Include directory
| TestFile FilePath -- ^ Run tests in a file
| Rank FilePath -- ^ Generate rankings
- deriving (Eq {-! Enum !-} )
+ deriving (Show,Eq {-! Enum !-} )
-- | In which circumstances are you allowed to pass this command
diff --git a/src/CmdLine/Query.hs b/src/CmdLine/Query.hs
--- a/src/CmdLine/Query.hs
+++ b/src/CmdLine/Query.hs
@@ -3,9 +3,9 @@
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.
@@ -24,11 +24,11 @@
data CmdQuery = CmdQuery {
queryWeb :: Bool, -- ^ Are you operating from the web (via CGI)
- queryText :: String, -- ^ The string the user entered, @""@ for no string
+ 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
@@ -57,11 +57,12 @@
cmdQueryArgs :: [String] -> IO CmdQuery
cmdQueryArgs xs = case parseCmdLineQuery xs of
- Left err -> return $ CmdQuery False orig (Left err) [] []
+ 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
diff --git a/src/CmdLine/Search.hs b/src/CmdLine/Search.hs
--- a/src/CmdLine/Search.hs
+++ b/src/CmdLine/Search.hs
@@ -48,7 +48,7 @@
verbose = Verbose `elem` flags
color = Color True `elem` flags
- showTag = if color then showTagConsole else show
+ showTag = if color then showTagConsole else showTagText
f (m,r,v) = maybe "" (\m -> showModule m ++ " ") m ++
showTag r ++ (if verbose then " -- " ++ v else "")
diff --git a/src/CmdLine/Test.hs b/src/CmdLine/Test.hs
--- a/src/CmdLine/Test.hs
+++ b/src/CmdLine/Test.hs
@@ -21,7 +21,7 @@
-- LineNo Query Results
-data Test = Test Int String Query [String]
+data Test = Test Int String Query [[String]]
deriving Show
@@ -29,7 +29,7 @@
parseTest line str | "@test " `isPrefixOf` str =
case reads $ drop 5 str of
[(x,rest)] -> case parseQuery x of
- Right q -> Just $ Test line x q (words rest)
+ Right q -> Just $ Test line x q (map (split ',') $ words rest)
_ -> err
_ -> err
where err = error $ "Couldn't parse @test on line " ++ show line
@@ -37,15 +37,16 @@
runTest :: DataBase -> Test -> Bool
-runTest db (Test _ _ q ans) = f ans $ searchAll [db] q
+runTest db (Test _ _ q 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
where
- f ["*"] _ = True
- f ("*":x:xs) (m:ms) = f (if g x m then xs else "*":x:xs) ms
- f (x:xs) (m:ms) = g x m && f xs ms
- f [] [] = True
- f _ _ = False
+ res = searchAll [db] q
+ items = map (entryName . fromLink . resultEntry &&& resultScore) res
- g name m = name == entryName (fromLink $ resultEntry m)
+ ordered ((x:xs):(y:ys):zs) = x < y && all (== x) xs && ordered ((y:ys):zs)
+ ordered [x:xs] = all (== x) xs
failedTest :: Test -> String
diff --git a/src/Data/TagStr.hs b/src/Data/TagStr.hs
--- a/src/Data/TagStr.hs
+++ b/src/Data/TagStr.hs
@@ -3,6 +3,7 @@
import Data.Char
import Data.List
+import Data.Generics.Uniplate
data TagStr = Str String
@@ -11,46 +12,38 @@
| TagUnderline TagStr
| TagHyperlink String TagStr
| TagColor Int TagStr
+ deriving Show
-tagInner (TagBold x) = x
-tagInner (TagUnderline x) = x
-tagInner (TagHyperlink _ x) = x
-tagInner (TagColor _ x) = x
+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)
-showTag :: TagStr -> String
-showTag x = f x
- where
- f (Str x) = x
- f (Tags x) = concatMap f x
- f x = f $ tagInner 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 (Tags xs) = concatMap (f a) xs
f a t =
case getCode t of
- Nothing -> f a x
- Just val -> tag (val:a) ++ f (val:a) x ++ tag a
- where x = tagInner t
+ 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 _ _) = Just "4"
+ 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"
-
-
+ tag stack = chr 27 : '[' : (concat $ intersperse ";" $ ("0":reverse stack)) ++ "m"
-instance Show TagStr where
- show (Str x) = x
- show (Tags x) = concatMap show x
- show x = show $ tagInner x
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
@@ -84,4 +84,6 @@
b <- mergeBindings $ map resultArgBind $ args ++ [res]
let s = newTypeScore is query (fromLink e) b
view = zipWith ArgPosNum [0..] $ map resultArgPos args
- return (e, view, s)
+ -- need to fake at least one ArgPosNum, so we know we have some highlight info
+ view2 = [ArgPosNum (-1) (-1) | null view] ++ view
+ return (e, view2, s)
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
@@ -52,7 +52,7 @@
(entryInfoAlias query `diff` entryInfoAlias result)
diff a b = (a \\ b, b \\ a)
- ctx = nub $ concat [f c b | (c,v) <- entryInfoContext result, (TVar a, b) <- bindings bs, a == v]
+ ctx = nub $ concat [f c b | (c,v) <- entryInfoContext result, (b, TVar a) <- bindings bs, a == v]
f c (TVar v) = [(c,v)]
f c (TLit l) = [(c,l) | not $ hasInstance is c l]
diff --git a/src/Hoogle/Item/Item.hs b/src/Hoogle/Item/Item.hs
--- a/src/Hoogle/Item/Item.hs
+++ b/src/Hoogle/Item/Item.hs
@@ -85,7 +85,7 @@
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) = renderFocus [i | FocusOn i <- view] x
+ f (Focus x) = TagHyperlink "" $ renderFocus [i | FocusOn i <- view] x
renderFocus :: [Range] -> String -> TagStr
diff --git a/src/Main.hs b/src/Main.hs
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -11,96 +11,3 @@
if queryWeb q
then actionWeb q
else actionCmdLine q
-
-
-{-
-
-
-
-exec :: Origin -> Query -> IO ()
-
-exec CmdLine q | not $ usefulQuery q = putStr $ "No query given\n" ++ helpMsg
-
-exec CmdLine q = do
- checkFlags q (fColor ++ fDatabase ++ fStart ++ fCount ++ fDocs ++ fInfo)
- databases <- collectDataBases q
- res <- searcher databases
- if null res then putStrLn "No results found" else do
-
- when showInfo $ do
- putStrLn $ showTags $ renderResult $ head res
- putStrLn ""
- docs <- loadDocs $ itemResult $ head res
- case docs of
- Nothing -> putStrLn "No info on this item"
- Just x -> putStr $ showTags $ renderDocs x
-
- when (showInfo && showDocs) $ putStrLn ""
- when showDocs $ putStrLn $ fromMaybe "No documentation" $ locateWebDocs $ itemResult $ head res
-
- when (not (showDocs || showInfo)) $
- putStr $ unlines $ map (showTags . renderResult) res
- where
- showDocs = hasFlag q fDocs
- showInfo = hasFlag q fInfo
-
- showTags = if hasFlag q fColor then showTagConsole else showTag
-
- searcher dbs | isJust start || isJust count
- = searchRange dbs q (fromMaybe 1 start - 1) (fromMaybe 25 count)
- | otherwise = searchAll dbs q
-
- start = getPosIntFlag fStart
- count = getPosIntFlag fCount
-
- getPosIntFlag flags =
- case getFlag q flags of
- Nothing -> Nothing
- Just x ->
- case (reads x :: [(Int,String)]) of
- [(n,"")] | n > 0 -> Just n
- _ -> Nothing
-- }
-
-{ - RULES
-For each /db=... flag, it must be either a file (load it) or a folder (look for +packages in it)
-If always check the current directory if all /db directives fail
-If no /db files and no +packages then default to +base
-- }
-collectDataBases :: Query -> IO [DataBase]
-collectDataBases q = do
- (files,dirs) <- f (getFlags q fDatabase)
- let packs = [x | PlusPackage x <- scope q]
- files2 <- mapM (g (dirs++[""])) (if null packs && null files then ["base"] else packs)
- res <- mapM h (files ++ catMaybes files2)
- return $ catMaybes res
- where
- f :: [FilePath] -> IO ([FilePath],[FilePath])
- f [] = return ([], [])
- f (x:xs) = do
- bfile <- doesFileExist x
- bdir <- doesDirectoryExist x
- if not (bfile || bdir)
- then do
- putStrLn $ "Warning, database not found: " ++ x
- f xs
- else do
- (a,b) <- f xs
- return ([x|bfile]++a, [x|not bfile]++b)
-
- -- maybe return an item
- g :: [FilePath] -> String -> IO (Maybe FilePath)
- g (x:xs) y = do
- let file = x y <.> "hoo"
- b <- doesFileExist file
- if b then return $ Just file
- else g xs y
- g [] y = do
- putStrLn $ "Warning, failed to find package " ++ y
- return Nothing
-
- h file = do
- db <- loadDataBase file
- when (isNothing db) $ putStrLn $ "Failed to load database, " ++ file
- return db
--}
diff --git a/src/Web/Action.hs b/src/Web/Action.hs
--- a/src/Web/Action.hs
+++ b/src/Web/Action.hs
@@ -1,5 +1,105 @@
module Web.Action(actionWeb) where
+import CmdLine.All
+import Hoogle.All
+import Hoogle.Query.All
+import Hoogle.Item.All
+import Hoogle.Search.All
+import General.Code
+import System.IO.Unsafe(unsafeInterleaveIO)
+import Web.Page
+import Text.ParserCombinators.Parsec
+import Data.TagStr
+import Data.Range
+import Data.Binary.Defer.Index
-actionWeb = undefined
+
+actionWeb :: CmdQuery -> IO ()
+actionWeb q = do
+ (skipped,dbs) <- loadDataBases q
+ let res = unlines $ header (escapeHTML $ queryText q) ++ runQuery dbs q ++ footer
+ when (Debug `elem` queryFlags q) $
+ writeFile "temp.htm" res
+ putStrLn res
+
+
+-- 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
+ files <- filterM doesFileExist $ map (\x -> "res" 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 to Hoogle
"
+ ,"
"
+ ," Hoogle is a Haskell API search engine, have fun!"
+ ,"