tags in Haddock output (as well as )
Make package matching case insensitive
#372, add features to improve module name search
Make module name searching case insensitive
4.2.1, released 2011-01-26
Fix for pattern match failure when searching for "to"
Fix for not sending text/html when serving local files
Eliminate the --nostdin flag, now unnecessary
Change to use WAI/Warp instead of HTTP and custom server
Fix a bug, didn't ever show Waiting... on the real website
Make embed work in IE8
4.2, released 2011-01-23
Make the CGI interface send the right number of newlines
Accept prefix and suffix web parameters
Eliminate isBlankQuery, make Query a Monoid
Make Query abstract, add queryPackages/querySetPackage
Rename querySuggestions/queryCompletions by dropping the query
Add mode=embed support
Add some log analysis features
Ignore some whitespace in the input file
Work around a cabal bug, include jquery.cookie.js
Add ?version=xxx to .css and .js, to make it auto refresh
4.1.5, released 2011-01-16
#399, rehabilitate mode=suggest
Stop mode=suggest failing entirely, now cleanly gives no answers
Combine --web and --webmode
Complete the command line flag help
#327, ensure utf8 is found
#187, ensure LT is found
Use the Hoogle tarball direct from Hackage
#54, rework packages, entries and keywords
#87, make all database files lowercase
Various javascript/ajax enhancements
4.1.4, released 2011-01-15
Running data on Posix sets all files to global read/execute
Relax haskell-src-exts to allow 1.10.1
Rework the web page display further
4.1.3, released 2011-01-09
Read and write all database files in UTF8
#391, add tar -xzf when extracting from the tarball
Change search results display, packages/modules on separate line
Exclude haskellN* from the platform, they are in base
Add --nostdin to server mode, to support running with nohup
Loosen dependencies for tagsoup (typo'd it before)
4.1.2, released 2010-12-19
Loosen dependencies for tagsoup and HTTP (but not parsec)
Avoid self circular dependencies
4.1.1, released 2010-12-18
#195, include all the necessary resources to run as a server
When in server mode, be more robust to errors
4.1, released 2010-12-18
#320, make sure system is found
#146, preserve forall's in everywhere
#186, switch to using haskell-src-exts to parse input files
#249, make sure you find MonadWriter
#235, make sure you find forall
#309, make sure there are links for keywords
#78, add --link flag
#59, operators look nicer, and have blue brackets round them
#352, can now parse ( # ) as a function name in the input
#280, searching for "~ +keyword" should find keyword
#116, fix links for types/classes
#83, all searching for package-name
#94, allow textbases to be used automatically
#92, short flags are now handled by cmdargs, so work
#51, test mode now does what test and testfile did
#66, turn Hoogle into a library
Add --server flag, to run as a server
4.0.7, released 2009-07-19
Start of changelog
hoogle-5.0.17.3/src/ 0000755 0000000 0000000 00000000000 13265310054 012176 5 ustar 00 0000000 0000000 hoogle-5.0.17.3/src/Query.hs 0000644 0000000 0000000 00000023477 13265310054 013654 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards #-}
module Query(
Query(..), isQueryName, isQueryType, isQueryScope,
parseQuery, renderQuery,
query_test
) where
import Data.List
import Language.Haskell.Exts
import Data.Char
import Data.List.Extra
import Data.Generics.Uniplate.Data
import General.Util
import Data.Maybe
import Control.Applicative
import Prelude
---------------------------------------------------------------------
-- DATA TYPE
data Query
= QueryName {fromQueryName :: String}
| QueryType {fromQueryType :: Type ()}
| QueryScope {scopeInclude :: Bool, scopeCategory :: String, scopeValue :: String}
| QueryNone String -- part of the query that is ignored
deriving (Show,Eq)
isQueryName, isQueryType, isQueryScope :: Query -> Bool
isQueryName QueryName{} = True; isQueryName _ = False
isQueryType QueryType{} = True; isQueryType _ = False
isQueryScope QueryScope{} = True; isQueryScope _ = False
renderQuery :: [Query] -> String
renderQuery [] = "No query "
renderQuery xs = unwords $
[escapeHTML x | QueryName x <- xs] ++
[":: " ++ escapeHTML (pretty x) | QueryType x <- xs] ++
[['-' | not scopeInclude] ++ escapeHTML scopeCategory ++ ":" ++ escapeHTML scopeValue | QueryScope{..} <- xs] ++
["" ++ escapeHTML x ++ " " | QueryNone x <- xs]
---------------------------------------------------------------------
-- PARSER
parseQuery :: String -> [Query]
parseQuery x = map QueryName nam ++ map QueryType (maybeToList typ) ++ scp
where
(scp,rest) = scope_ $ lexer x
(nam,typ) = divide rest
openBrackets = ["(#","[:","(","["]
shutBrackets = ["#)",":]",")","]"]
isBracket x = x `elem` (openBrackets ++ shutBrackets)
isBracketPair x = x `elem` zipWith (++) openBrackets shutBrackets
isSym x = ((isSymbol x || isPunctuation x) && x `notElem` special) || x `elem` ascSymbol
where special = "(),;[]`{}\"'"
ascSymbol = "!#$%&*+./<=>?@\\^|-~"
isSyms xs | isBracket xs || isBracketPair xs = False
isSyms (x:xs) = isSym x
isSyms [] = False
-- | Split into small lexical chunks.
--
-- > "Data.Map.(!)" ==> ["Data",".","Map",".","(","!",")"]
lexer :: String -> [String]
lexer ('(':',':xs) | (a,')':b) <- span (== ',') xs = ("(," ++ a ++ ")") : lexer b
lexer x | Just s <- (bs !!) <$> findIndex (`isPrefixOf` x) bs = s : lexer (drop (length s) x)
where bs = zipWith (++) openBrackets shutBrackets ++ openBrackets ++ shutBrackets
lexer (x:xs)
| isSpace x = " " : lexer (dropWhile isSpace xs)
| isAlpha x || x == '_' =
let (a,b) = span (\x -> isAlphaNum x || x `elem` "_'#-") xs
(a1,a2) = spanEnd (== '-') a
in (x:a1) : lexer (a2 ++ b)
| isSym x = let (a,b) = span isSym xs in (x:a) : lexer b
| x == ',' = "," : lexer xs
| otherwise = lexer xs -- drop invalid bits
lexer [] = []
-- | Find and extract the scope annotations.
--
-- > +package
-- > +module
-- > name.bar
-- > name.++ name.(++) (name.++)
-- > +foo -foo
-- > +scope:foo -scope:foo scope:foo
scope_ :: [String] -> ([Query], [String])
scope_ xs = case xs of
(readPM -> Just pm):(readCat -> Just cat):":":(readMod -> Just (mod,rest)) -> add pm cat mod rest
(readPM -> Just pm):(readCat -> Just cat):":-":(readMod -> Just (mod,rest)) -> add False cat mod rest
(readPM -> Just pm):(readMod -> Just (mod,rest)) -> add_ pm mod rest
(readCat -> Just cat):":":(readMod -> Just (mod,rest)) -> add True cat mod rest
(readCat -> Just cat):":.":(readMod -> Just (mod,rest)) -> add True cat ('.':mod) rest
(readCat -> Just cat):":-":(readMod -> Just (mod,rest)) -> add False cat mod rest
(readCat -> Just cat):":-.":(readMod -> Just (mod,rest)) -> add False cat ('.':mod) rest
"(":(readDots -> Just (scp,x:")":rest)) -> out ["(",x,")"] $ add_ True scp rest
(readDots -> Just (scp,rest)) -> add_ True scp rest
"(":".":(readDots -> Just (scp,x:")":rest)) -> out ["(",x,")"] $ add_ True ('.':scp) rest
".":(readDots -> Just (scp,rest)) -> add_ True ('.':scp) rest
x:xs -> out [x] $ scope_ xs
[] -> ([], [])
where
out xs (a,b) = (a,xs++b)
add a b c rest = let (x,y) = scope_ rest in (QueryScope a b c : x, y)
add_ a c rest = add a b c rest
where b = if '.' `elem` c || any isUpper (take 1 c) then "module" else "package"
readPM x = case x of "+" -> Just True; "-" -> Just False; _ -> Nothing
readCat x | isAlpha1 x = Just x
| otherwise = Nothing
readMod (x:xs) | isAlpha1 x = Just $ case xs of
".":ys | Just (a,b) <- readMod ys -> (x ++ "." ++ a, b)
".":[] -> (x ++ ".",[])
".":" ":ys -> (x ++ "."," ":ys)
_ -> (x,xs)
readMod _ = Nothing
readDots (x:xs) | isAlpha1 x = case xs of
".":ys | Just (a,b) <- readDots ys -> Just (x ++ "." ++ a, b)
('.':y):ys -> Just (x, [y | y /= ""] ++ ys)
_ -> Nothing
readDots _ = Nothing
-- | If everything is a name, or everything is a symbol, then you only have names.
divide :: [String] -> ([String], Maybe (Type ()))
divide xs | all isAlpha1 ns = (ns, Nothing)
| all isSyms ns = (ns, Nothing)
| length ns == 1 = (ns, Nothing)
| otherwise = case break (== "::") xs of
(nam, _:rest) -> (names_ nam, typeSig_ rest)
_ -> ([], typeSig_ xs)
where ns = names_ xs
-- | Ignore brackets around symbols, and try to deal with tuple names.
names_ :: [String] -> [String]
names_ ("(":x:")":xs) = [x | x /= " "] ++ names_ xs
names_ ["(",x] = [x]
names_ (x:xs) = [x | x /= " "] ++ names_ xs
names_ [] = []
typeSig_ :: [String] -> Maybe (Type ())
typeSig_ xs = case parseTypeWithMode parseMode $ unwords $ fixup $ filter (not . all isSpace) xs of
ParseOk x -> Just $ transformBi (\v -> if v == Ident () "__" then Ident () "_" else v) $ fmap (const ()) x
_ -> Nothing
where
fixup = underscore . closeBracket . completeFunc . completeArrow
completeArrow (unsnoc -> Just (a,b)) | b `elem` ["-","="] = snoc a (b ++ ">")
completeArrow x = x
completeFunc (unsnoc -> Just (a,b)) | b `elem` ["->","=>"] = a ++ [b,"_"]
completeFunc x = x
closeBracket xs = xs ++ foldl f [] xs
where f stack x | Just c <- lookup x (zip openBrackets shutBrackets) = c:stack
f (s:tack) x | x == s = tack
f stack x = stack
underscore = replace ["_"] ["__"]
query_test :: IO ()
query_test = testing "Query.parseQuery" $ do
let want s p (bad,q) = (["missing " ++ s | not $ any p q], filter (not . p) q)
wantEq v = want (show v) (== v)
name = wantEq . QueryName
scope b c v = wantEq $ QueryScope b c v
typ = wantEq . QueryType . fmap (const ()) . fromParseResult . parseTypeWithMode parseMode
typpp x = want ("type " ++ x) (\v -> case v of QueryType s -> pretty s == x; _ -> False)
let infixl 0 ===
a === f | bad@(_:_) <- fst $ f ([], q) = error $ show (a,q,bad :: [String])
| otherwise = putChar '.'
where q = parseQuery a
"" === id
"map" === name "map"
"#" === name "#"
"c#" === name "c#"
"-" === name "-"
"/" === name "/"
"->" === name "->"
"foldl'" === name "foldl'"
"fold'l" === name "fold'l"
"Int#" === name "Int#"
"concat map" === name "concat" . name "map"
"a -> b" === typ "a -> b"
"a->b" === typ "a -> b"
"(a b)" === typ "(a b)"
"map :: a -> b" === typ "a -> b"
"+Data.Map map" === scope True "module" "Data.Map" . name "map"
"a -> b package:foo" === scope True "package" "foo" . typ "a -> b"
"a -> b package:foo-bar" === scope True "package" "foo-bar" . typ "a -> b"
"Data.Map.map" === scope True "module" "Data.Map" . name "map"
"[a]" === typ "[a]"
"++" === name "++"
"(++)" === name "++"
":+:" === name ":+:"
"bytestring-cvs +hackage" === scope True "package" "hackage" . name "bytestring-cvs"
"m => c" === typ "m => c"
"[b ()" === typ "[b ()]"
"[b (" === typ "[b ()]"
"_ -> a" === typpp "_ -> a"
"(a -> b) ->" === typpp "(a -> b) -> _"
"(a -> b) -" === typpp "(a -> b) -> _"
"Monad m => " === typpp "Monad m => _"
"map is:exact" === name "map" . scope True "is" "exact"
"sort set:hackage" === name "sort" . scope True "set" "hackage"
"sort -set:hackage" === name "sort" . scope False "set" "hackage"
"sort set:-hackage" === name "sort" . scope False "set" "hackage"
"sort -set:-hackage" === name "sort" . scope False "set" "hackage"
"package:bytestring-csv" === scope True "package" "bytestring-csv"
"(>>=)" === name ">>="
"(>>=" === name ">>="
">>=" === name ">>="
"Control.Monad.mplus" === name "mplus" . scope True "module" "Control.Monad"
"Control.Monad.>>=" === name ">>=" . scope True "module" "Control.Monad"
"Control.Monad.(>>=)" === name ">>=" . scope True "module" "Control.Monad"
"(Control.Monad.>>=)" === name ">>=" . scope True "module" "Control.Monad"
"Control.Monad.(>>=" === name ">>=" . scope True "module" "Control.Monad"
"(Control.Monad.>>=" === name ">>=" . scope True "module" "Control.Monad"
"foo.bar" === name "bar" . scope True "package" "foo"
"insert module:.Map" === name "insert" . scope True "module" ".Map"
"insert module:Map." === name "insert" . scope True "module" "Map."
"insert module:.Map." === name "insert" . scope True "module" ".Map."
".Map.insert" === name "insert" . scope True "module" ".Map"
".Map." === scope True "module" ".Map"
-- FIXME: ".Map" === scope True "module" ".Map" -- probably should work, but really needs to rewrite a fair bit
"(.Monad.>>=" === name ">>=" . scope True "module" ".Monad"
-- FIXME: "author:Taylor-M.-Hedberg" === scope True "author" "Taylor-M.-Hedberg"
"author:Bryan-O'Sullivan" === scope True "author" "Bryan-O'Sullivan"
"\8801" === name "\8801"
"( )" === id -- FIXME: Should probably be ()
hoogle-5.0.17.3/src/Main.hs 0000644 0000000 0000000 00000000241 13265310054 013413 0 ustar 00 0000000 0000000
module Main(main) where
import System.Environment
import System.IO
import Hoogle
main :: IO ()
main = do
hSetEncoding stdout utf8
hoogle =<< getArgs
hoogle-5.0.17.3/src/Hoogle.hs 0000644 0000000 0000000 00000002437 13265310054 013755 0 ustar 00 0000000 0000000
-- | High level Hoogle API
module Hoogle(
Database, withDatabase, searchDatabase, defaultDatabaseLocation,
Target(..), URL,
hoogle,
targetInfo,
targetResultDisplay
) where
import Control.DeepSeq (NFData)
import Query
import Input.Item
import General.Util
import General.Store
import Action.CmdLine
import Action.Generate
import Action.Search
import Action.Server
import Action.Test
-- | Database containing Hoogle search data.
newtype Database = Database StoreRead
-- | Load a database from a file.
withDatabase :: NFData a => FilePath -> (Database -> IO a) -> IO a
withDatabase file act = storeReadFile file $ act . Database
-- | The default location of a database
defaultDatabaseLocation :: IO FilePath
defaultDatabaseLocation = defaultDatabaseLang Haskell
-- | Search a database, given a query string, produces a list of results.
searchDatabase :: Database -> String -> [Target]
searchDatabase (Database db) query = snd $ search db $ parseQuery query
-- | Run a command line Hoogle operation.
hoogle :: [String] -> IO ()
hoogle args = do
args <- getCmdLine args
case args of
Search{} -> actionSearch args
Generate{} -> actionGenerate args
Server{} -> actionServer args
Test{} -> actionTest args
Replay{} -> actionReplay args
hoogle-5.0.17.3/src/Output/ 0000755 0000000 0000000 00000000000 13265310054 013476 5 ustar 00 0000000 0000000 hoogle-5.0.17.3/src/Output/Types.hs 0000644 0000000 0000000 00000035761 13265310054 015152 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, BangPatterns, GADTs #-}
module Output.Types(writeTypes, searchTypes, searchTypesDebug) where
{-
Approach:
Each signature is stored, along with a fingerprint
A quick search finds the most promising 100 fingerprints
A slow search ranks the 100 items, excluding some
-}
import qualified Data.Map.Strict as Map
import qualified Data.ByteString.Char8 as BS
import qualified Data.Vector.Storable as V
import qualified Data.Vector.Storable.Mutable as VM
import Data.Binary
import Data.Maybe
import Data.List.Extra
import Data.Tuple.Extra
import Data.Generics.Uniplate.Data
import Data.Data
import System.FilePath
import System.IO.Extra
import Control.Monad.Extra
import Foreign.Storable
import Control.Applicative
import Numeric.Extra
import Prelude
import Input.Item
import General.Store
import General.IString
import General.Util
writeTypes :: StoreWrite -> Maybe FilePath -> [(Maybe TargetId, Item)] -> IO ()
writeTypes store debug xs = do
let debugger ext body = whenJust debug $ \file -> writeFileUTF8 (file <.> ext) body
inst <- return $ Map.fromListWith (+) [(fromIString x,1) | (_, IInstance (Sig _ [TCon x _])) <- xs]
xs <- writeDuplicates store [(i, fromIString <$> t) | (Just i, ISignature t) <- xs]
names <- writeNames store debugger inst xs
xs <- return $ map (lookupNames names (error "Unknown name in writeTypes")) xs
writeFingerprints store xs
writeSignatures store xs
searchTypes :: StoreRead -> Sig String -> [TargetId]
searchTypes store q =
concatMap (expandDuplicates $ readDuplicates store) $
searchFingerprints store names 100 $
lookupNames names name0 q
-- map unknown fields to name0, i.e. _
where
names = readNames store
searchTypesDebug :: StoreRead -> (String, Sig String) -> [(String, Sig String)] -> [String]
searchTypesDebug store query answers = intercalate [""] $
f False "Query" query : zipWith (\i -> f True ("Answer " ++ show i)) [1..] answers
where
qsig = lookupNames names name0 $ snd query
names = readNames store
f match name (raw, sig) =
[name ++ ": " ++ raw
,"Sig String: " ++ prettySig sig
,"Sig Name: " ++ prettySig (fmap prettyName sn)
,"Fingerprint: " ++ prettyFingerprint fp] ++
if not match then [] else
["Cost: " ++ maybe "X, no match" show (matchFingerprint qsig fp)
,"Explain: " ++ showExplain (matchFingerprintDebug qsig fp)]
where
sn = lookupNames names name0 sig
fp = toFingerprint sn
showExplain = intercalate ", " . map g . sortOn (either (const minBound) (negate . snd))
g (Left s) = "X " ++ s
g (Right (s, x)) = show x ++ " " ++ s
---------------------------------------------------------------------
-- NAME/CTOR INFORMATION
data TypesNames a where TypesNames :: TypesNames (BS.ByteString, V.Vector Name) deriving Typeable
-- Must be a unique Name per String.
-- First 0-99 are variables, rest are constructors.
-- More popular type constructors have higher numbers.
-- There are currently about 14K names, so about 25% of the bit patterns are taken
newtype Name = Name Word16 deriving (Eq,Ord,Show,Data,Typeable,Storable,Binary)
name0 = Name 0 -- use to represent _
isCon, isVar :: Name -> Bool
isVar (Name x) = x < 100
isCon = not . isVar
prettyName :: Name -> String
prettyName x@(Name i)
| x == name0 = "_"
| isVar x = "v" ++ show i
| otherwise = "C" ++ show i
-- | Give a name a popularity, where 0 is least popular, 1 is most popular
popularityName :: Name -> Double
popularityName (Name n) | isVar $ Name n = error "Can't call popularityName on a Var"
| otherwise = fromIntegral (n - 100) / fromIntegral (maxBound - 100 :: Word16)
newtype Names = Names {lookupName :: String -> Maybe Name}
lookupNames :: Names -> Name -> Sig String -> Sig Name
lookupNames Names{..} def (Sig ctx typ) = Sig (map f ctx) (map g typ)
where
vars = nubOrd $ "_" : [x | Ctx _ x <- ctx] ++ [x | TVar x _ <- universeBi typ]
var x = Name $ min 99 $ fromIntegral $ fromMaybe (error "lookupNames") $ elemIndex x vars
con = fromMaybe def . lookupName
f (Ctx a b) = Ctx (con $ '~':a) (var b)
g (TCon x xs) = TCon (con x) $ map g xs
g (TVar x xs) = TVar (var x) $ map g xs
writeNames :: StoreWrite -> (String -> String -> IO ()) -> Map.Map String Int -> [Sig String] -> IO Names
writeNames store debug inst xs = do
let sigNames (Sig ctx typ) = nubOrd ['~':x | Ctx x _ <- ctx] ++ nubOrd [x | TCon x _ <- universeBi typ]
-- want to rank highly instances that have a lot of types, and a lot of definitions
-- eg Eq is used and defined a lot. Constructor is used in 3 places but defined a lot.
let freq :: Map.Map String Int = -- how many times each identifier occurs
Map.unionWith (\typ sig -> sig + min sig typ) (Map.mapKeysMonotonic ('~':) inst) $
Map.fromListWith (+) $ map (,1::Int) $ concatMap sigNames xs
let names = spreadNames $ Map.toList freq
debug "names" $ unlines [s ++ " = " ++ show n ++ " (" ++ show (freq Map.! s) ++ " uses)" | (s,n) <- names]
names <- return $ sortOn fst names
storeWrite store TypesNames (BS.pack $ intercalate "\0" $ map fst names, V.fromList $ map snd names)
let mp2 = Map.fromAscList names
return $ Names $ \x -> Map.lookup x mp2
-- | Given a list of names, spread them out uniquely over the range [Name 100 .. Name maxBound]
-- Aim for something with a count of p to be at position (p / pmax) linear interp over the range
spreadNames :: [(a, Int)] -> [(a, Name)]
spreadNames [] = []
spreadNames (reverse . sortOn snd -> xs@((_,limit):_)) = check $ f (99 + fromIntegral (length xs)) maxBound xs
where
check xs | all (isCon . snd) xs && length (nubOrd $ map snd xs) == length xs = xs
| otherwise = error "Invalid spreadNames"
-- I can only assign values between mn and mx inclusive
f :: Word16 -> Word16 -> [(a, Int)] -> [(a, Name)]
f !mn !mx [] = []
f mn mx ((a,i):xs) = (a, Name real) : f (mn-1) (real-1) xs
where real = fromIntegral $ max mn $ min mx ideal
ideal = mn + floor (fromIntegral (min commonNameThreshold i) * fromIntegral (mx - mn) / fromIntegral (min commonNameThreshold limit))
-- WARNING: Magic constant.
-- Beyond this count names don't accumulate extra points for being common.
-- Ensures that things like Bool (4523 uses) ranks much higher than ShakeOptions (24 uses) by not having
-- [] (10237 uses) skew the curve too much and use up all the available bits of discrimination.
commonNameThreshold = 1024
readNames :: StoreRead -> Names
readNames store = Names $ \x -> Map.lookup (BS.pack x) mp
where mp = Map.fromAscList $ zip (BS.split '\0' s) $ V.toList n
(s, n) = storeRead store TypesNames
---------------------------------------------------------------------
-- DUPLICATION INFORMATION
data TypesDuplicates a where TypesDuplicates :: TypesDuplicates (Jagged TargetId) deriving Typeable
newtype Duplicates = Duplicates {expandDuplicates :: Int -> [TargetId]}
-- writeDuplicates xs == nub (map snd xs)
-- all duplicates are removed, order of first element is preserved
-- (i,x) <- zip [0..] (writeDuplicates xs); expandDuplicates i == map fst (filter ((==) x . snd) xs)
-- given the result at position i, expandDuplicates gives the TargetId's related to it
writeDuplicates :: Ord a => StoreWrite -> [(TargetId, Sig a)] -> IO [Sig a]
writeDuplicates store xs = do
-- s=signature, t=targetid, p=popularity (incoing index), i=index (outgoing index)
xs <- return $ map (second snd) $ sortOn (fst . snd) $ Map.toList $
Map.fromListWith (\(x1,x2) (y1,y2) -> (, x2 ++ y2) $! min x1 y1)
[(s,(p,[t])) | (p,(t,s)) <- zip [0::Int ..] xs]
-- give a list of TargetId's at each index
storeWrite store TypesDuplicates $ jaggedFromList $ map (reverse . snd) xs
return $ map fst xs
readDuplicates :: StoreRead -> Duplicates
readDuplicates store = Duplicates $ V.toList . ask
where ask = jaggedAsk $ storeRead store TypesDuplicates
---------------------------------------------------------------------
-- FINGERPRINT INFORMATION
data TypesFingerprints a where TypesFingerprints :: TypesFingerprints (V.Vector Fingerprint) deriving Typeable
data Fingerprint = Fingerprint
{fpRare1 :: {-# UNPACK #-} !Name -- Most rare ctor, or 0 if no rare stuff
,fpRare2 :: {-# UNPACK #-} !Name -- 2nd rare ctor
,fpRare3 :: {-# UNPACK #-} !Name -- 3rd rare ctor
,fpArity :: {-# UNPACK #-} !Word8 -- Artiy, where 0 = CAF
,fpTerms :: {-# UNPACK #-} !Word8 -- Number of terms (where 255 = 255 and above)
} deriving (Eq,Show,Typeable)
prettyFingerprint :: Fingerprint -> String
prettyFingerprint Fingerprint{..} =
"arity=" ++ show fpArity ++ ", terms=" ++ show fpTerms ++
", rarity=" ++ unwords (map prettyName [fpRare1, fpRare2, fpRare3])
{-# INLINE fpRaresFold #-}
fpRaresFold :: (b -> b -> b) -> (Name -> b) -> Fingerprint -> b
fpRaresFold g f Fingerprint{..} = f fpRare1 `g` f fpRare2 `g` f fpRare3
instance Storable Fingerprint where
sizeOf _ = 64
alignment _ = 4
peekByteOff ptr i = Fingerprint
<$> peekByteOff ptr (i+0) <*> peekByteOff ptr (i+2) <*> peekByteOff ptr (i+4)
<*> peekByteOff ptr (i+6) <*> peekByteOff ptr (i+7)
pokeByteOff ptr i Fingerprint{..} = do
pokeByteOff ptr (i+0) fpRare1 >> pokeByteOff ptr (i+2) fpRare2 >> pokeByteOff ptr (i+4) fpRare3
pokeByteOff ptr (i+6) fpArity >> pokeByteOff ptr (i+7) fpTerms
toFingerprint :: Sig Name -> Fingerprint
toFingerprint sig = Fingerprint{..}
where fpRare1:fpRare2:fpRare3:_ = sort (nubOrd $ filter isCon $ universeBi sig) ++ [name0,name0,name0]
fpArity = fromIntegral $ min 255 $ max 0 $ pred $ length $ sigTy sig
fpTerms = fromIntegral $ min 255 $ length (universeBi sig :: [Name])
writeFingerprints :: StoreWrite -> [Sig Name] -> IO ()
writeFingerprints store xs = storeWrite store TypesFingerprints $ V.fromList $ map toFingerprint xs
data MatchFingerprint a ma = MatchFingerprint
{mfpAdd :: a -> a -> a
,mfpAddM :: ma -> ma -> ma
,mfpJust :: a -> ma
,mfpCost :: String -> Int -> a
,mfpMiss :: String -> ma
}
matchFingerprint :: Sig Name -> Fingerprint -> Maybe Int
matchFingerprint = matchFingerprintEx MatchFingerprint{..}
where
mfpAdd = (+)
mfpAddM = liftM2 (+)
mfpJust = Just
mfpCost _ x = x
mfpMiss _ = Nothing
matchFingerprintDebug :: Sig Name -> Fingerprint -> [Either String (String, Int)]
matchFingerprintDebug = matchFingerprintEx MatchFingerprint{..}
where
mfpAdd = (++)
mfpAddM = (++)
mfpJust = id
mfpCost s x = [Right (s,x)]
mfpMiss s = [Left s]
{-# INLINE matchFingerprintEx #-}
matchFingerprintEx :: forall a ma . MatchFingerprint a ma -> Sig Name -> Fingerprint -> ma -- lower is better
matchFingerprintEx MatchFingerprint{..} sig@(toFingerprint -> target) =
\candidate -> arity (fpArity candidate) `mfpAddM` terms (fpTerms candidate) `mfpAddM` rarity candidate
where
-- CAFs must match perfectly, otherwise too many is better than too few
arity | ta == 0 = \ca -> if ca == 0 then mfpJust $ mfpCost "arity equal" 0 else mfpMiss "arity different and query a CAF" -- searching for a CAF
| otherwise = \ca -> case fromIntegral $ ca - ta of
_ | ca == 0 -> mfpMiss "arity different and answer a CAF" -- searching for a CAF
0 -> mfpJust $ mfpCost "arity equal" 0 -- perfect match
-1 -> mfpJust $ mfpCost "arity 1 to remove" 1000 -- not using something the user carefully wrote
n | n > 0 && allowMore -> mfpJust $ mfpCost ("arity " ++ show n ++ " to add with wildcard") $ 300 * n -- user will have to make up a lot, but they said _ in their search
1 -> mfpJust $ mfpCost "arity 1 to add" 300 -- user will have to make up an extra param
2 -> mfpJust $ mfpCost "arity 2 to add" 900 -- user will have to make up two params
_ -> mfpMiss ""
where
ta = fpArity target
allowMore = TVar name0 [] `elem` sigTy sig
-- missing terms are a bit worse than invented terms, but it's fairly balanced, clip at large numbers
terms = \ct -> case fromIntegral $ ct - tt of
n | abs n > 20 -> mfpMiss $ "terms " ++ show n ++ " different" -- too different
| n == 0 -> mfpJust $ mfpCost "terms equal" 0
| n > 0 -> mfpJust $ mfpCost ("terms " ++ show n ++ " to add") $ n * 10 -- candidate has more terms
| otherwise -> mfpJust $ mfpCost ("terms " ++ show (-n) ++ " to remove") $ abs n * 12 -- candidate has less terms
where
tt = fpTerms target
-- given two fingerprints, you have three sets:
-- Those in common; those in one but not two; those in two but not one
-- those that are different
rarity = \cr -> let tr = target in mfpJust $
differences 5000 400 tr cr `mfpAdd` -- searched for T but its not in the candidate, bad if rare, not great if common
differences 1000 50 cr tr -- T is in the candidate but I didn't search for it, bad if rare, OK if common
where
fpRaresElem :: Name -> Fingerprint -> Bool
fpRaresElem !x = fpRaresFold (||) (== x)
differences :: Double -> Double -> Fingerprint -> Fingerprint -> a
differences !rare !common !want !have = fpRaresFold mfpAdd f want
where f n | fpRaresElem n have = mfpCost ("term in common " ++ prettyName n) 0
| n == name0 = mfpCost ("term _ missing") $ floor rare -- should this be common?
| otherwise = let p = popularityName n in mfpCost ("term " ++ prettyName n ++ " (" ++ showDP 2 p ++ ") missing") $
floor $ (p*common) + ((1-p)*rare)
searchFingerprints :: StoreRead -> Names -> Int -> Sig Name -> [Int]
searchFingerprints store names n sig = map snd $ takeSortOn fst n [(v, i) | (i,f) <- zip [0..] fs, Just v <- [test f]]
where fs = V.toList $ storeRead store TypesFingerprints :: [Fingerprint]
test = matchFingerprint sig
---------------------------------------------------------------------
-- SIGNATURES
data TypesSigPositions a where TypesSigPositions :: TypesSigPositions (V.Vector Word32) deriving Typeable
data TypesSigData a where TypesSigData :: TypesSigData BS.ByteString deriving Typeable
writeSignatures :: StoreWrite -> [Sig Name] -> IO ()
writeSignatures store xs = do
v <- VM.new $ length xs
forM_ (zip [0..] xs) $ \(i,x) -> do
let b = encodeBS x
storeWritePart store TypesSigData b
VM.write v i $ fromIntegral $ BS.length b
v <- V.freeze v
storeWrite store TypesSigPositions v
hoogle-5.0.17.3/src/Output/Tags.hs 0000644 0000000 0000000 00000020412 13265310054 014727 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, TupleSections, ScopedTypeVariables, DeriveDataTypeable, PatternGuards, GADTs #-}
module Output.Tags(writeTags, completionTags, applyTags) where
import Data.Function
import Data.List.Extra
import Data.Tuple.Extra
import Data.Maybe
import Foreign.Storable.Tuple()
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Vector.Storable as V
import qualified Data.ByteString.Char8 as BS
import Input.Item
import Query
import General.Util
import General.Store
import General.Str
---------------------------------------------------------------------
-- DATA TYPE
-- matches (a,b) if i >= a && i <= b
data Packages a where Packages :: Packages (Str0, V.Vector (TargetId, TargetId)) deriving Typeable
-- list of packages, sorted by popularity, lowercase, interspersed with \0
-- for each index in PackageNames, the first is the module item, any in the bounds are in that package
data Modules a where Modules :: Modules (Str0, V.Vector (TargetId, TargetId)) deriving Typeable
-- list of modules, sorted by popularity, not unique, lowercase, interspersed with \0
-- for each index in ModuleNames, the first is the module item, any in the bounds are in that module
data Categories a where Categories :: Categories (Str0, Jagged (TargetId, TargetId)) deriving Typeable
-- list of categories, sorted by name, interspersed with \0
-- for each index in CategoryNames, a range of items containing a category, first item is a package
data Completions a where Completions :: Completions Str0 deriving Typeable
-- a list of things to complete to, interspersed with \0
writeTags :: StoreWrite -> (String -> Bool) -> (String -> [(String,String)]) -> [(Maybe TargetId, Item)] -> IO ()
writeTags store keep extra xs = do
let splitPkg = splitIPackage xs
let packages = addRange splitPkg
storeWrite store Packages (join0 $ map fst packages, V.fromList $ map snd packages)
let categories = map (first snd . second reverse) $ Map.toList $ Map.fromListWith (++)
[(((weightTag ex, both lower ex), joinPair ":" ex),[rng]) | (p,rng) <- packages, ex <- extra p]
storeWrite store Categories (join0 $ map fst categories, jaggedFromList $ map snd categories)
let modules = addRange $ concatMap (splitIModule . snd) splitPkg
storeWrite store Modules (join0 $ map (lower . fst) modules, V.fromList $ map snd modules)
storeWrite store Completions $ join0 $
takeWhile ("set:" `isPrefixOf`) (map fst categories) ++
map ("package:"++) (sortOn lower $ nubOrd $ filter keep $ map fst packages) ++
map (joinPair ":") (sortOn (weightTag &&& both lower) $ nubOrd [ex | (p,_) <- packages, keep p, ex <- extra p, fst ex /= "set"])
where
addRange :: [(String, [(Maybe TargetId,a)])] -> [(String, (TargetId, TargetId))]
addRange xs = [(a, (minimum' is, maximum' is)) | (a,b) <- xs, let is = mapMaybe fst b, a /= "", is /= []]
weightTag ("set",x) = fromMaybe 0.9 $ lookup x [("stackage",0.0),("haskell-platform",0.1)]
weightTag ("package",x) = 1
weightTag ("category",x) = 2
weightTag ("license",x) = 3
weightTag _ = 4
---------------------------------------------------------------------
-- SIMPLE SELECTORS
completionTags :: StoreRead -> [String]
completionTags store = map BS.unpack $ split0 $ storeRead store Completions
---------------------------------------------------------------------
-- DATA TYPE, PARSE, PRINT
data Tag = IsExact | IsPackage | IsModule | EqPackage String | EqModule String | EqCategory String String deriving Eq
parseTag :: String -> String -> Maybe Tag
parseTag k v
| k ~~ "is" = case () of
_ | v ~~ "exact" -> Just IsExact
| v ~~ "package" -> Just IsPackage
| v ~~ "module" -> Just IsModule
| otherwise -> Nothing
| k ~~ "package" = if v == "" then Nothing else Just $ EqPackage v
| k ~~ "module" = if v == "" then Nothing else Just $ EqModule v
| v /= "" = Just $ EqCategory k v
| otherwise = Nothing
where
-- make the assumption the first letter always disambiguates
x ~~ lit = x /= "" && lower x `isPrefixOf` lit
showTag :: Tag -> (String, String)
showTag IsExact = ("is","exact")
showTag IsPackage = ("is","package")
showTag IsModule = ("is","module")
showTag (EqPackage x) = ("package",x)
showTag (EqModule x) = ("module",x)
showTag (EqCategory k v) = (k,v)
---------------------------------------------------------------------
-- TAG SEMANTICS
-- | Given a tag, find the ranges of identifiers it covers (if it restricts the range)
-- An empty range means an empty result, while a Nothing means a search on the entire range
resolveTag :: StoreRead -> Tag -> (Tag, Maybe [(TargetId,TargetId)])
resolveTag store x = case x of
IsExact -> (IsExact, Nothing)
IsPackage -> (IsPackage, Just $ map (dupe . fst) $ V.toList packageIds)
IsModule -> (IsModule, Just $ map (dupe . fst) $ V.toList moduleIds)
EqPackage orig@(BS.pack -> val)
-- look for people who are an exact prefix, sort by remaining length, if there are ties, pick the first one
| res@(_:_) <- [(BS.length x, (i,x)) | (i,x) <- zip [0..] $ split0 packageNames, val `BS.isPrefixOf` x]
-> let (i,x) = snd $ minimumBy (compare `on` fst) res in (EqPackage $ BS.unpack x, Just [packageIds V.! i])
| otherwise -> (EqPackage orig , Just [])
EqModule x -> (EqModule x, Just $ map (moduleIds V.!) $ findIndices (eqModule $ lower x) $ split0 moduleNames)
EqCategory cat val -> (EqCategory cat val, Just $ concat
[ V.toList $ jaggedAsk categoryIds i
| i <- elemIndices (BS.pack (cat ++ ":" ++ val)) $ split0 categoryNames])
where
eqModule x | Just x <- stripPrefix "." x, Just x <- stripSuffix "." x = (==) (BS.pack x)
| Just x <- stripPrefix "." x = BS.isPrefixOf $ BS.pack x
| otherwise = let y = BS.pack x; y2 = BS.pack ('.':x)
in \v -> y `BS.isPrefixOf` v || y2 `BS.isInfixOf` v
(packageNames, packageIds) = storeRead store Packages
(categoryNames, categoryIds) = storeRead store Categories
(moduleNames, moduleIds) = storeRead store Modules
---------------------------------------------------------------------
-- TAG QUERIES
-- | Given a query produce: (refined query, is:exact, filter, enumeration)
-- You should apply the filter to other peoples results, or if you have nothing else, use the enumeration.
applyTags :: StoreRead -> [Query] -> ([Query], Bool, TargetId -> Bool, [TargetId])
applyTags store qs = (qs2, exact, filt, searchTags store qs)
where (qs2, exact, filt) = filterTags store qs
filterTags :: StoreRead -> [Query] -> ([Query], Bool, TargetId -> Bool)
filterTags ts qs = (map redo qs, exact, \i -> all ($ i) fs)
where fs = map (filterTags2 ts . snd) $ groupSort $ map (scopeCategory &&& id) $ filter isQueryScope qs
exact = Just IsExact `elem` [parseTag a b | QueryScope True a b <- qs]
redo (QueryScope sense cat val)
| Just (k,v) <- fmap (showTag . fst . resolveTag ts) $ parseTag cat val = QueryScope sense k v
| otherwise = QueryNone $ ['-' | not sense] ++ cat ++ ":" ++ val
redo q = q
filterTags2 ts qs = \i -> not (negq i) && (noPosRestrict || posq i)
where (posq,negq) = both inRanges (pos,neg)
(pos, neg) = both (concatMap snd) $ partition fst xs
xs = catMaybes restrictions
noPosRestrict = all pred restrictions
restrictions = map getRestriction qs
pred Nothing = True
pred (Just (sense, _)) = not sense
getRestriction :: Query -> Maybe (Bool,[(TargetId, TargetId)])
getRestriction (QueryScope sense cat val) = do
tag <- parseTag cat val
ranges <- snd $ resolveTag ts tag
return (sense, ranges)
-- | Given a search which has no type or string in it, run the query on the tag bits.
-- Using for things like IsModule, EqCategory etc.
searchTags :: StoreRead -> [Query] -> [TargetId]
searchTags ts qs
| x:xs <- [map fst $ maybe [] (fromMaybe [] . snd . resolveTag ts) $ parseTag cat val | QueryScope True cat val <- qs]
= if null xs then x else filter (`Set.member` foldl1' Set.intersection (map Set.fromList xs)) x
searchTags ts _ = map fst $ fromMaybe [] $ snd $ resolveTag ts IsPackage
hoogle-5.0.17.3/src/Output/Names.hs 0000644 0000000 0000000 00000005152 13265310054 015100 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, TupleSections, ScopedTypeVariables, DeriveDataTypeable, ForeignFunctionInterface, GADTs #-}
module Output.Names(writeNames, searchNames) where
import Data.List.Extra
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.Vector.Storable as V
import General.Str
import Foreign.Ptr
import Foreign.Marshal
import Foreign.C.String
import Foreign.C.Types
import Control.Exception
import System.IO.Unsafe
import Data.Maybe
import Input.Item
import General.Util
import General.Store
foreign import ccall text_search_bound :: CString -> IO CInt
foreign import ccall text_search :: CString -> Ptr CString -> CInt -> Ptr CInt -> IO CInt
data NamesSize a where NamesSize :: NamesSize Int deriving Typeable
data NamesItems a where NamesItems :: NamesItems (V.Vector TargetId) deriving Typeable
data NamesText a where NamesText :: NamesText BS.ByteString deriving Typeable
writeNames :: StoreWrite -> [(Maybe TargetId, Item)] -> IO ()
writeNames store xs = do
let (ids, strs) = unzip [(i, [' ' | isUpper1 name] ++ lower name) | (Just i, x) <- xs, name <- itemNamePart x]
let b = BS.intercalate (BS.pack "\0") (map strPack strs) `BS.append` BS.pack "\0\0"
bound <- BS.unsafeUseAsCString b $ \ptr -> text_search_bound ptr
storeWrite store NamesSize $ fromIntegral bound
storeWrite store NamesItems $ V.fromList ids
storeWrite store NamesText b
itemNamePart :: Item -> [String]
itemNamePart (IModule x) = [last $ splitOn "." x]
itemNamePart x = maybeToList $ itemName x
searchNames :: StoreRead -> Bool -> [String] -> [TargetId]
-- very important to not search for [" "] or [] since the output buffer is too small
searchNames store exact (filter (/= "") . map trim -> xs) = unsafePerformIO $ do
let vs = storeRead store NamesItems
-- if there are no questions, we will match everything, which exceeds the result buffer
if null xs then return $ V.toList vs else do
let tweak x = strPack $ [' ' | isUpper1 x] ++ lower x ++ "\0"
bracket (mallocArray $ storeRead store NamesSize) free $ \result ->
BS.unsafeUseAsCString (storeRead store NamesText) $ \haystack ->
withs (map (BS.unsafeUseAsCString . tweak) xs) $ \needles ->
withArray0 nullPtr needles $ \needles -> do
found <- c_text_search haystack needles (if exact then 1 else 0) result
xs <- peekArray (fromIntegral found) result
return $ map ((vs V.!) . fromIntegral) xs
{-# NOINLINE c_text_search #-} -- for profiling
c_text_search a b c d = text_search a b c d
hoogle-5.0.17.3/src/Output/Items.hs 0000644 0000000 0000000 00000005151 13265310054 015115 0 ustar 00 0000000 0000000 {-# LANGUAGE TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards, DeriveDataTypeable, GADTs #-}
module Output.Items(writeItems, lookupItem, listItems) where
import Control.Monad
import Data.List.Extra
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import qualified Codec.Compression.GZip as GZip
import General.Str
import Input.Item
import General.Util
import General.Store
import General.Conduit
data Items a where Items :: Items BS.ByteString deriving Typeable
outputItem :: Target -> [String]
outputItem Target{..} =
[if null targetURL then "." else targetURL
,maybe "." (joinPair " ") targetPackage
,maybe "." (joinPair " ") targetModule
,if null targetType then "." else targetType
,targetItem] ++
replace [""] ["."] (lines targetDocs)
inputItem :: [String] -> Target
inputItem (url:pkg:modu:typ:self:docs) = targetExpandURL $
Target (if url == "." then "" else url) (f pkg) (f modu) (if typ == "." then "" else typ) self (unlines $ replace ["."] [""] docs)
where
f "." = Nothing
f x = Just (word1 x)
-- write all the URLs, docs and enough info to pretty print it to a result
-- and replace each with an identifier (index in the space) - big reduction in memory
writeItems :: StoreWrite -> (ConduitM (Maybe Target, item) (Maybe TargetId, item) IO () -> IO a) -> IO a
writeItems store act = act $ do
void $ (\f -> mapAccumMC f 0) $ \pos (target, item) -> case target of
Nothing -> return (pos, (Nothing, item))
Just target -> do
let bs = LBS.toStrict $ GZip.compress $ lstrPack $ unlines $ outputItem target
liftIO $ do
storeWritePart store Items $ intToBS $ BS.length bs
storeWritePart store Items bs
let pos2 = pos + fromIntegral (intSize + BS.length bs)
return (pos2, (Just $ TargetId pos, item))
listItems :: StoreRead -> [Target]
listItems store = unfoldr f $ storeRead store Items
where
f x | BS.null x = Nothing
| (n,x) <- BS.splitAt intSize x
, n <- intFromBS n
, (this,x) <- BS.splitAt n x
= Just (inputItem $ lines $ UTF8.toString $ GZip.decompress $ LBS.fromChunks [this], x)
lookupItem :: StoreRead -> (TargetId -> Target)
lookupItem store =
let x = storeRead store Items
in \(TargetId i) ->
let i2 = fromIntegral i
n = intFromBS $ BS.take intSize $ BS.drop i2 x
in inputItem $ lines $ UTF8.toString $ GZip.decompress $ LBS.fromChunks $ return $ BS.take n $ BS.drop (i2 + intSize) x
hoogle-5.0.17.3/src/Input/ 0000755 0000000 0000000 00000000000 13265310054 013275 5 ustar 00 0000000 0000000 hoogle-5.0.17.3/src/Input/Settings.hs 0000644 0000000 0000000 00000005674 13265310054 015445 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards, PatternGuards, TemplateHaskell, CPP #-}
-- | Module for reading settings files.
module Input.Settings(
Settings(..), loadSettings
) where
import Control.Exception (catch, throwIO)
import Data.List.Extra
import Data.Maybe
import Language.Haskell.TH.Syntax (lift, runIO)
import System.FilePath
import System.IO.Error (isDoesNotExistError)
import System.IO.Extra
import qualified Data.Map.Strict as Map
import Paths_hoogle
-- | Settings values. Later settings always override earlier settings.
data Setting
= -- | Given a Cabal tag/author rename it from the LHS to the RHS.
-- If the RHS is blank, delete the tag.
RenameTag String String
| -- | Change the priority of a module. Given package name, module name, new priority.
-- Use * for wildcard matches. All un-reordered modules are 0
ReorderModule String String Int
deriving Read
data Settings = Settings
{renameTag :: String -> String -- ^ Rename a cabal tag
,reorderModule :: String -> String -> Int
}
readFileSettings :: FilePath -> String -> IO [Setting]
readFileSettings file backup = do
src <- readFileUTF8 file `catch` \e ->
if isDoesNotExistError e
then return backup
else throwIO e
return $ concat $ zipWith f [1..] $ map trim $ lines src
where
f i s | null s = []
| "--" `isPrefixOf` s = []
| [(x,"")] <- reads s = [x]
| otherwise = error $ file ++ ":" ++ show i ++ ": Failure to parse, got: " ++ s
-- | Fix bad names in the Cabal file.
loadSettings :: IO Settings
loadSettings = do
dataDir <- getDataDir
#ifdef PROFILE
-- profiling and TemplateHaskell don't play well
let backup = ""
#else
let backup = $(runIO (readFileUTF8 "misc/settings.txt") >>= lift)
#endif
src <- readFileSettings (dataDir "misc/settings.txt") backup
return $ createSettings src
createSettings :: [Setting] -> Settings
createSettings xs = Settings{..}
where
renameTag = \x -> fromMaybe x $ f x
where f = literals [(a,b) | RenameTag a b <- xs]
reorderModule = \pkg -> case f pkg of
[] -> const 0
xs -> let f = wildcards xs
in \mod -> last $ 0 : f mod
where f = wildcards [(a,(b,c)) | ReorderModule a b c <- xs]
---------------------------------------------------------------------
-- SPECIAL LOOKUPS
literals :: [(String, a)] -> String -> Maybe a
literals xs = \x -> Map.lookup x mp
where mp = Map.fromList xs
wildcards :: [(String, a)] -> String -> [a]
wildcards xs x = [b | (a,b) <- xs, matchWildcard a x]
matchWildcard :: String -> String -> Bool
matchWildcard ['*'] ys = True -- special common case
matchWildcard ('*':xs) ys = any (matchWildcard xs) $ tails ys
matchWildcard (x:xs) (y:ys) = x == y && matchWildcard xs ys
matchWildcard [] [] = True
matchWildcard _ _ = False
hoogle-5.0.17.3/src/Input/Set.hs 0000644 0000000 0000000 00000002270 13265310054 014365 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, TupleSections #-}
module Input.Set(setStackage, setPlatform, setGHC) where
import Control.Applicative
import Data.List.Extra
import System.IO.Extra
import qualified Data.Set as Set
import Prelude
-- | Return information about which items are in a particular set.
setStackage :: FilePath -> IO (Set.Set String)
setStackage file = Set.fromList . filter (`notElem` stackOverflow) . f . lines <$> readFile' file
where
stackOverflow = [] -- ["telegram-api","pinchot","gogol-dfareporting"] -- see https://github.com/ndmitchell/hoogle/issues/167
f (x:xs) | Just x <- stripPrefix "constraints:" x =
map (fst . word1) $ takeWhile (" " `isPrefixOf`) $ (' ':x) : xs
| otherwise = f xs
f [] = []
setPlatform :: FilePath -> IO (Set.Set String)
setPlatform file = setPlatformWith file ["incGHCLib","incLib"]
setPlatformWith :: FilePath -> [String] -> IO (Set.Set String)
setPlatformWith file names = do
src <- lines <$> readFile' file
return $ Set.fromList [read lib | ",":name:lib:_ <- map words src, name `elem` names]
setGHC :: FilePath -> IO (Set.Set String)
setGHC file = setPlatformWith file ["incGHCLib"]
hoogle-5.0.17.3/src/Input/Reorder.hs 0000644 0000000 0000000 00000001256 13265310054 015237 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
module Input.Reorder(reorderItems) where
import Input.Item
import Input.Settings
import Data.List.Extra
import Data.Tuple.Extra
-- | Reorder items so the most popular ones are first, using reverse dependencies
reorderItems :: Settings -> (String -> Int) -> [(a, Item)] -> [(a, Item)]
reorderItems Settings{..} packageOrder xs =
concatMap snd $ sortOn ((packageOrder &&& id) . fst) $ map rebase $ splitIPackage xs
where
refunc = map $ second $ \(x:xs) -> x : sortOn (itemName . snd) xs
rebase (x, xs) = (x, concatMap snd $ sortOn (((negate . f) &&& id) . fst) $ refunc $ splitIModule xs)
where f = reorderModule x
hoogle-5.0.17.3/src/Input/Item.hs 0000644 0000000 0000000 00000016720 13265310054 014535 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveDataTypeable, DeriveFunctor, ViewPatterns #-}
{-# LANGUAGE RecordWildCards, OverloadedStrings, PatternGuards, ScopedTypeVariables #-}
-- | Types used to generate the input.
module Input.Item(
Sig(..), Ctx(..), Ty(..), prettySig,
Item(..), itemName,
Target(..), targetExpandURL, TargetId(..),
splitIPackage, splitIModule,
hseToSig, hseToItem
) where
import Numeric
import Control.Applicative
import Data.Tuple.Extra
import Language.Haskell.Exts
import Data.Char
import Data.List.Extra
import Data.Maybe
import Data.Ix
import Data.Binary
import Foreign.Storable
import Control.DeepSeq
import Data.Data
import General.Util
import General.IString
import Prelude
import Data.Aeson.Types
import qualified Data.Text as T
---------------------------------------------------------------------
-- TYPES
data Sig n = Sig {sigCtx :: [Ctx n], sigTy :: [Ty n]} deriving (Show,Eq,Ord,Typeable,Data,Functor) -- list of -> types
data Ctx n = Ctx n n deriving (Show,Eq,Ord,Typeable,Data,Functor) -- context, second will usually be a free variable
data Ty n = TCon n [Ty n] | TVar n [Ty n] deriving (Show,Eq,Ord,Typeable,Data,Functor) -- type application, vectorised, all symbols may occur at multiple kinds
instance NFData n => NFData (Sig n) where rnf (Sig x y) = rnf x `seq` rnf y
instance NFData n => NFData (Ctx n) where rnf (Ctx x y) = rnf x `seq` rnf y
instance NFData n => NFData (Ty n) where
rnf (TCon x y) = rnf x `seq` rnf y
rnf (TVar x y) = rnf x `seq` rnf y
instance Binary n => Binary (Sig n) where
put (Sig a b) = put a >> put b
get = liftA2 Sig get get
instance Binary n => Binary (Ctx n) where
put (Ctx a b) = put a >> put b
get = liftA2 Ctx get get
instance Binary n => Binary (Ty n) where
put (TCon x y) = put (0 :: Word8) >> put x >> put y
put (TVar x y) = put (1 :: Word8) >> put x >> put y
get = do i :: Word8 <- get; liftA2 (case i of 0 -> TCon; 1 -> TVar) get get
prettySig :: Sig String -> String
prettySig Sig{..} =
(if length ctx > 1 then "(" ++ ctx ++ ") => "
else if null ctx then "" else ctx ++ " => ") ++
intercalate " -> " (map f sigTy)
where
ctx = intercalate ", " [a ++ " " ++ b | Ctx a b <- sigCtx]
f (TVar x xs) = f $ TCon x xs
f (TCon x []) = x
f (TCon x xs) = "(" ++ unwords (x : map f xs) ++ ")"
---------------------------------------------------------------------
-- ITEMS
data Item
= IPackage String
| IModule String
| IName String
| ISignature (Sig IString)
| IAlias String [IString] (Sig IString)
| IInstance (Sig IString)
deriving (Show,Eq,Ord,Typeable,Data)
instance NFData Item where
rnf (IPackage x) = rnf x
rnf (IModule x) = rnf x
rnf (IName x) = rnf x
rnf (ISignature x) = rnf x
rnf (IAlias a b c) = rnf (a,b,c)
rnf (IInstance a) = rnf a
itemName :: Item -> Maybe String
itemName (IPackage x) = Just x
itemName (IModule x) = Just x
itemName (IName x) = Just x
itemName (ISignature _) = Nothing
itemName (IAlias x _ _) = Just x
itemName (IInstance _) = Nothing
---------------------------------------------------------------------
-- DATABASE
newtype TargetId = TargetId Word32 deriving (Eq,Ord,Storable,NFData,Ix,Typeable)
instance Show TargetId where
show (TargetId x) = showHex x ""
-- | A location of documentation.
data Target = Target
{targetURL :: URL -- ^ URL where this thing is located
,targetPackage :: Maybe (String, URL) -- ^ Name and URL of the package it is in (Nothing if it is a package)
,targetModule :: Maybe (String, URL) -- ^ Name and URL of the module it is in (Nothing if it is a package or module)
,targetType :: String -- ^ One of package, module or empty string
,targetItem :: String -- ^ HTML span of the item, using <0> for the name and <1> onwards for arguments
,targetDocs :: String -- ^ HTML documentation to show, a sequence of block level elements
} deriving (Show,Eq,Ord)
instance NFData Target where
rnf (Target a b c d e f) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` rnf f
instance ToJSON Target where
toJSON (Target a b c d e f) = object [
("url" :: T.Text, toJSON a),
("package" :: T.Text, maybeNamedURL b),
("module" :: T.Text, maybeNamedURL c),
("type" :: T.Text, toJSON d),
("item" :: T.Text, toJSON e),
("docs" :: T.Text, toJSON f)
]
where
maybeNamedURL m = maybe emptyObject namedURL m
namedURL (name, url) = object [("name" :: T.Text, toJSON name), ("url" :: T.Text, toJSON url)]
targetExpandURL :: Target -> Target
targetExpandURL t@Target{..} = t{targetURL = url, targetModule = second (const mod) <$> targetModule}
where
pkg = maybe "" snd targetPackage
mod = maybe pkg (plus pkg . snd) targetModule
url = plus mod targetURL
plus a b | b == "" = ""
| ':':_ <- dropWhile isAsciiLower b = b -- match http: etc
| otherwise = a ++ b
splitIPackage, splitIModule :: [(a, Item)] -> [(String, [(a, Item)])]
splitIPackage = splitUsing $ \x -> case snd x of IPackage x -> Just x; _ -> Nothing
splitIModule = splitUsing $ \x -> case snd x of IModule x -> Just x; _ -> Nothing
splitUsing :: (a -> Maybe String) -> [a] -> [(String, [a])]
splitUsing f = repeatedly $ \(x:xs) ->
let (a,b) = break (isJust . f) xs
in ((fromMaybe "" $ f x, x:a), b)
---------------------------------------------------------------------
-- HSE CONVERSION
hseToSig :: Type a -> Sig String
hseToSig = tyForall
where
-- forall at the top is different
tyForall (TyParen _ x) = tyForall x
tyForall (TyForall _ _ c t) | Sig cs ts <- tyForall t =
Sig (maybe [] (concatMap ctx . fromContext) c ++ cs) ts
tyForall x = Sig [] $ tyFun x
tyFun (TyParen _ x) = tyFun x
tyFun (TyFun _ a b) = ty a : tyFun b
tyFun x = [ty x]
ty (TyForall _ _ _ x) = TCon "\\/" [ty x]
ty x@TyFun{} = TCon "->" $ tyFun x
ty (TyTuple an box ts) = TCon (fromQName $ Special an $ TupleCon an box $ length ts - 1) (map ty ts)
ty (TyList _ x) = TCon "[]" [ty x]
ty (TyParArray _ x) = TCon "[::]" [ty x]
ty (TyApp _ x y) = case ty x of
TCon a b -> TCon a (b ++ [ty y])
TVar a b -> TVar a (b ++ [ty y])
ty (TyVar _ x) = TVar (fromName x) []
ty (TyCon _ x) = TCon (fromQName x) []
#if !defined(MIN_VERSION_haskell_src_exts) || MIN_VERSION_haskell_src_exts(1,20,0)
ty (TyInfix an a (UnpromotedName _ b) c) = ty $ let ap = TyApp an in TyCon an b `ap` a `ap` c
#else
ty (TyInfix an a b c) = ty $ let ap = TyApp an in TyCon an b `ap` a `ap` c
#endif
ty (TyKind _ x _) = ty x
ty (TyBang _ _ _ x) = ty x
ty (TyParen _ x) = ty x
ty _ = TVar "_" []
ctx (ParenA _ x) = ctx x
ctx (InfixA an a con b) = ctx $ ClassA an con [a,b]
ctx (ClassA _ con (TyVar _ var:_)) = [Ctx (fromQName con) (fromName var)]
ctx _ = []
hseToItem :: Decl a -> [Item]
hseToItem (TypeSig _ names ty) = ISignature (toIString <$> hseToSig ty) : map (IName . fromName) names
hseToItem (TypeDecl _ (fromDeclHead -> (name, bind)) rhs) = [IAlias (fromName name) (map (toIString . fromName . fromTyVarBind) bind) (toIString <$> hseToSig rhs)]
hseToItem (InstDecl an _ (fromIParen -> IRule _ _ ctx (fromInstHead -> (name, args))) _) = [IInstance $ fmap toIString $ hseToSig $ TyForall an Nothing ctx $ applyType (TyCon an name) args]
hseToItem x = map IName $ declNames x
hoogle-5.0.17.3/src/Input/Haddock.hs 0000644 0000000 0000000 00000021132 13265310054 015165 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, OverloadedStrings, Rank2Types, DeriveDataTypeable #-}
module Input.Haddock(parseHoogle, fakePackage, input_haddock_test) where
import Language.Haskell.Exts as HSE
import Data.Char
import Data.List.Extra
import Data.Data
import Input.Item
import General.Util
import Control.DeepSeq
import Control.Monad.Trans.Class
import General.Conduit
import Control.Monad.Extra
import Data.Generics.Uniplate.Data
import General.Str
-- | An entry in the Hoogle DB
data Entry = EPackage String
| EModule String
| EDecl (Decl ())
deriving (Data,Typeable,Show)
fakePackage :: String -> String -> (Maybe Target, [Item])
fakePackage name desc = (Just $ Target (hackagePackageURL name) Nothing Nothing "package" (renderPackage name) desc, [IPackage name])
-- | Given a file name (for errors), feed in lines to the conduit and emit either errors or items
parseHoogle :: Monad m => (String -> m ()) -> URL -> LStr -> ConduitM i (Maybe Target, [Item]) m ()
parseHoogle warning url body = sourceLStr body .| linesCR .| zipFromC 1 .| parserC warning .| hierarchyC url .| mapC (\x -> rnf x `seq` x)
parserC :: Monad m => (String -> m ()) -> ConduitM (Int, Str) (Target, Entry) m ()
parserC warning = f [] ""
where
f com url = do
x <- await
whenJust x $ \(i,s) -> case () of
_ | Just s <- strStripPrefix "-- | " s -> f [s] url
| Just s <- strStripPrefix "--" s -> f (if null com then [] else strTrimStart s : com) url
| Just s <- strStripPrefix "@url " s -> f com (strUnpack s)
| strNull $ strTrimStart s -> f [] ""
| otherwise -> do
case parseLine $ fixLine $ strUnpack s of
Left y -> lift $ warning $ show i ++ ":" ++ y
-- only check Nothing as some items (e.g. "instance () :> Foo a")
-- don't roundtrip but do come out equivalent
Right [EDecl InfixDecl{}] -> return () -- can ignore infix constructors
Right xs -> forM_ xs $ \x ->
yield (Target url Nothing Nothing (typeItem x) (renderItem x) $ reformat $ reverse com, x) -- descendBi stringShare x)
f [] ""
typeItem (EPackage x) = "package"
typeItem (EModule x) = "module"
typeItem _ = ""
-- FIXME: used to be in two different modules, now does and then undoes lots of stuff
reformat :: [Str] -> String
reformat = unlines . map strUnpack
hierarchyC :: Monad m => URL -> ConduitM (Target, Entry) (Maybe Target, [Item]) m ()
hierarchyC packageUrl = void $ mapAccumC f (Nothing, Nothing)
where
f (pkg, mod) (t, EPackage x) = ((Just (x, url), Nothing), (Just t{targetURL=url}, [IPackage x]))
where url = targetURL t `orIfNull` packageUrl
f (pkg, mod) (t, EModule x) = ((pkg, Just (x, url)), (Just t{targetPackage=pkg, targetURL=url}, [IModule x]))
where url = targetURL t `orIfNull` (if isGhc then ghcModuleURL x else hackageModuleURL x)
f (pkg, mod) (t, EDecl i@InstDecl{}) = ((pkg, mod), (Nothing, hseToItem_ i))
f (pkg, mod) (t, EDecl x) = ((pkg, mod), (Just t{targetPackage=pkg, targetModule=mod, targetURL=url}, hseToItem_ x))
where url = targetURL t `orIfNull` case x of
_ | [n] <- declNames x -> hackageDeclURL (isTypeSig x) n
| otherwise -> ""
isGhc = "~ghc" `isInfixOf` packageUrl || "/" `isSuffixOf` packageUrl
hseToItem_ x = hseToItem x `orIfNull` error ("hseToItem failed, " ++ pretty x)
infix 1 `orIfNull`
orIfNull x y = if null x then y else x
renderPackage x = "package <0>" ++ escapeHTML x ++ " "
renderModule (breakEnd (== '.') -> (pre,post)) = "module " ++ escapeHTML pre ++ "<0>" ++ escapeHTML post ++ " "
renderItem :: Entry -> String
renderItem = keyword . focus
where
keyword x | Just b <- stripPrefix "type family " x = "type family " ++ b
| (a,b) <- word1 x, a `elem` kws = "" ++ a ++ " " ++ b
| otherwise = x
where kws = words "class data type newtype"
name x = "" ++ x ++ " " :: String
focus (EModule x) = renderModule x
focus (EPackage x) = renderPackage x
focus (EDecl x) | [now] <- declNames x, (pre,stripPrefix now -> Just post) <- breakOn now $ pretty x =
if "(" `isSuffixOf` pre && ")" `isPrefixOf` post then
init (escapeHTML pre) ++ name ("(" ++ highlight now ++ ")") ++ escapeHTML (tail post)
else
escapeHTML pre ++ name (highlight now) ++ escapeHTML post
focus (EDecl x) = pretty x
highlight :: String -> String
highlight x = "<0>" ++ escapeHTML x ++ ""
parseLine :: String -> Either String [Entry]
parseLine x@('@':str) = case a of
"package" | [b] <- words b, b /= "" -> Right [EPackage b]
"version" -> Right []
_ -> Left $ "unknown attribute: " ++ x
where (a,b) = word1 str
parseLine (stripPrefix "module " -> Just x) = Right [EModule x]
parseLine x | Just x <- readItem x = case x of
TypeSig a bs c -> Right [EDecl (TypeSig a [b] c) | b <- bs]
x -> Right [EDecl x]
parseLine x = Left $ "failed to parse: " ++ x
fixLine :: String -> String
fixLine (stripPrefix "instance [incoherent] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "instance [overlap ok] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "instance [overlapping] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "instance [safe] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "(#) " -> Just x) = "( # ) " ++ x
fixLine ('[':x:xs) | isAlpha x || x `elem` ("_(" :: String), (a,']':b) <- break (== ']') xs = x : a ++ b
fixLine ('[':':':xs) | (a,']':b) <- break (== ']') xs = "(:" ++ a ++ ")" ++ b
fixLine x | "class " `isPrefixOf` x = fst $ breakOn " where " x
fixLine x = x
readItem :: String -> Maybe (Decl ())
readItem x | ParseOk y <- myParseDecl x = Just $ unGADT y
readItem x -- newtype
| Just x <- stripPrefix "newtype " x
, ParseOk (DataDecl an _ b c d e) <- fmap unGADT $ myParseDecl $ "data " ++ x
= Just $ DataDecl an (NewType ()) b c d e
readItem x -- constructors
| ParseOk (GDataDecl _ _ _ _ _ [GadtDecl s name _ ty] _) <- myParseDecl $ "data Data where " ++ x
, let f (TyBang _ _ _ (TyParen _ x@TyApp{})) = x
f (TyBang _ _ _ x) = x
f x = x
= Just $ TypeSig s [name] $ applyFun1 $ map f $ unapplyFun ty
readItem ('(':xs) -- tuple constructors
| (com,')':rest) <- span (== ',') xs
, ParseOk (TypeSig s [Ident{}] ty) <- myParseDecl $ replicate (length com + 2) 'a' ++ rest
= Just $ TypeSig s [Ident s $ '(':com++")"] ty
readItem (stripPrefix "data (" -> Just xs) -- tuple data type
| (com,')':rest) <- span (== ',') xs
, ParseOk (DataDecl a b c d e f) <- fmap unGADT $ myParseDecl $
"data " ++ replicate (length com + 2) 'A' ++ rest
= Just $ DataDecl a b c (transform (op $ '(':com++")") d) e f
where op s DHead{} = DHead () $ Ident () s
op s x = x
readItem _ = Nothing
myParseDecl = fmap (fmap $ const ()) . parseDeclWithMode parseMode -- partial application, to share the initialisation cost
unGADT (GDataDecl a b c d _ [] e) = DataDecl a b c d [] e
unGADT x = x
prettyItem :: Entry -> String
prettyItem (EPackage x) = "package " ++ x
prettyItem (EModule x) = "module " ++ x
prettyItem (EDecl x) = pretty x
input_haddock_test :: IO ()
input_haddock_test = testing "Input.Haddock.parseLine" $ do
let a === b | fmap (map prettyItem) (parseLine a) == Right [b] = putChar '.'
| otherwise = error $ show (a,b,parseLine a, fmap (map prettyItem) $ parseLine a)
let test a = a === a
test "type FilePath = [Char]"
test "data Maybe a"
test "Nothing :: Maybe a"
test "Just :: a -> Maybe a"
test "newtype Identity a"
test "foo :: Int# -> b"
test "(,,) :: a -> b -> c -> (a, b, c)"
test "data (,,) a b"
test "reverse :: [a] -> [a]"
test "reverse :: [:a:] -> [:a:]"
test "module Foo.Bar"
test "data Char"
"data Char :: *" === "data Char"
"newtype ModuleName :: *" === "newtype ModuleName"
"Progress :: !(Maybe String) -> {-# UNPACK #-} !Int -> !(Int -> Bool) -> Progress" ===
"Progress :: Maybe String -> Int -> (Int -> Bool) -> Progress"
-- Broken in the last HSE release, fixed in HSE HEAD
-- test "quotRemInt# :: Int# -> Int# -> (# Int#, Int# #)"
test "( # ) :: Int"
hoogle-5.0.17.3/src/Input/Download.hs 0000644 0000000 0000000 00000002573 13265310054 015407 0 ustar 00 0000000 0000000 {-# LANGUAGE TupleSections #-}
module Input.Download(downloadInput) where
import System.FilePath
import Control.Monad.Extra
import System.Directory
import Data.Conduit.Binary (sinkFile)
import qualified Network.HTTP.Conduit as C
import Network.Connection
import qualified Data.Conduit as C
import General.Util
import General.Timing
import Network
import Control.Monad.Trans.Resource
-- | Download all the input files to input/
downloadInput :: Timing -> Bool -> Maybe Bool -> FilePath -> String -> URL -> IO FilePath
downloadInput timing insecure download dir name url = do
let file = dir "input-" ++ name
exists <- doesFileExist file
when (not exists && download == Just False) $
error $ "File is not already downloaded and --download=no given, downloading " ++ url ++ " to " ++ file
when (not exists || download == Just True) $
timed timing ("Downloading " ++ url) $ do
downloadFile insecure (file <.> "part") url
renameFile (file <.> "part") file
return file
downloadFile :: Bool -> FilePath -> String -> IO ()
downloadFile insecure file url = withSocketsDo $ do
let request = C.parseRequest_ url
manager <- C.newManager $ C.mkManagerSettings (TLSSettingsSimple insecure False False) Nothing
runResourceT $ do
response <- C.http request manager
C.runConduit $ C.responseBody response C..| sinkFile file
hoogle-5.0.17.3/src/Input/Cabal.hs 0000644 0000000 0000000 00000014450 13265310054 014637 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, RecordWildCards, ScopedTypeVariables #-}
-- | Module for reading Cabal files.
module Input.Cabal(
Package(..),
parseCabalTarball, readGhcPkg,
packagePopularity, readCabal
) where
import Input.Settings
import Data.List.Extra
import System.FilePath
import Control.DeepSeq
import Control.Exception
import Control.Monad
import System.IO.Extra
import General.Str
import System.Exit
import qualified System.Process.ByteString as BS
import qualified Data.ByteString.UTF8 as UTF8
import System.Directory
import Data.Char
import Data.Maybe
import Data.Tuple.Extra
import qualified Data.Text as T
import qualified Data.Map.Strict as Map
import General.Util
import General.Conduit
import Data.Semigroup
import Control.Applicative
import Prelude
---------------------------------------------------------------------
-- DATA TYPE
-- | A representation of a Cabal package.
data Package = Package
{packageTags :: [(T.Text, T.Text)] -- ^ The Tag information, e.g. (category,Development) (author,Neil Mitchell).
,packageLibrary :: Bool -- ^ True if the package provides a library (False if it is only an executable with no API)
,packageSynopsis :: T.Text -- ^ The synposis, grabbed from the top section.
,packageVersion :: T.Text -- ^ The version, grabbed from the top section.
,packageDepends :: [T.Text] -- ^ The list of packages that this package directly depends on.
,packageDocs :: Maybe FilePath -- ^ Directory where the documentation is located
} deriving Show
instance Semigroup Package where
Package x1 x2 x3 x4 x5 x6 <> Package y1 y2 y3 y4 y5 y6 =
Package (x1++y1) (x2||y2) (one x3 y3) (one x4 y4) (nubOrd $ x5 ++ y5) (x6 `mplus` y6)
where one a b = if T.null a then b else a
instance Monoid Package where
mempty = Package [] True T.empty T.empty [] Nothing
mappend = (<>)
instance NFData Package where
rnf (Package a b c d e f) = rnf (a,b,c,d,e,f)
---------------------------------------------------------------------
-- POPULARITY
-- | Given a set of packages, return the popularity of each package, along with any warnings
-- about packages imported but not found.
packagePopularity :: Map.Map String Package -> ([String], Map.Map String Int)
packagePopularity cbl = (errs, Map.map length good)
where
errs = [ user ++ ".cabal: Import of non-existant package " ++ name ++
(if null rest then "" else ", also imported by " ++ show (length rest) ++ " others")
| (name, user:rest) <- Map.toList bad]
(good, bad) = Map.partitionWithKey (\k _ -> k `Map.member` cbl) $
Map.fromListWith (++) [(T.unpack b,[a]) | (a,bs) <- Map.toList cbl, b <- packageDepends bs]
---------------------------------------------------------------------
-- READERS
-- | Run 'ghc-pkg' and get a list of packages which are installed.
readGhcPkg :: Settings -> IO (Map.Map String Package)
readGhcPkg settings = do
topdir <- findExecutable "ghc-pkg"
-- important to use BS process reading so it's in Binary format, see #194
(exit, stdout, stderr) <- BS.readProcessWithExitCode "ghc-pkg" ["dump"] mempty
when (exit /= ExitSuccess) $
fail $ "Error when reading from ghc-pkg, " ++ show exit ++ "\n" ++ UTF8.toString stderr
let g (stripPrefix "$topdir" -> Just x) | Just t <- topdir = takeDirectory t ++ x
g x = x
let fixer p = p{packageLibrary = True, packageDocs = g <$> packageDocs p}
let f ((stripPrefix "name: " -> Just x):xs) = Just (x, fixer $ readCabal settings $ unlines xs)
f xs = Nothing
return $ Map.fromList $ mapMaybe f $ splitOn ["---"] $ lines $ filter (/= '\r') $ UTF8.toString stdout
-- | Given a tarball of Cabal files, parse the latest version of each package.
parseCabalTarball :: Settings -> FilePath -> IO (Map.Map String Package)
-- items are stored as:
-- QuickCheck/2.7.5/QuickCheck.cabal
-- QuickCheck/2.7.6/QuickCheck.cabal
-- rely on the fact the highest version is last (using lastValues)
parseCabalTarball settings tarfile = do
res <- runConduit $
(sourceList =<< liftIO (tarballReadFiles tarfile)) .|
mapC (first takeBaseName) .| groupOnLastC fst .| mapMC (\x -> do evaluate $ rnf x; return x) .|
pipelineC 10 (mapC (second $ readCabal settings . lstrUnpack) .| mapMC (\x -> do evaluate $ rnf x; return x) .| sinkList)
return $ Map.fromList res
---------------------------------------------------------------------
-- PARSERS
-- | Cabal information, plus who I depend on
readCabal :: Settings -> String -> Package
readCabal Settings{..} src = Package{..}
where
mp = Map.fromListWith (++) $ lexCabal src
ask x = Map.findWithDefault [] x mp
packageDepends =
map T.pack $ nubOrd $ filter (/= "") $
map (intercalate "-" . takeWhile (all isAlpha . take 1) . splitOn "-" . fst . word1) $
concatMap (split (== ',')) (ask "build-depends") ++ concatMap words (ask "depends")
packageVersion = T.pack $ head $ dropWhile null (ask "version") ++ ["0.0"]
packageSynopsis = T.pack $ unwords $ words $ unwords $ ask "synopsis"
packageLibrary = "library" `elem` map (lower . trim) (lines src)
packageDocs = listToMaybe $ ask "haddock-html"
packageTags = map (both T.pack) $ nubOrd $ concat
[ map (head xs,) $ concatMap cleanup $ concatMap ask xs
| xs <- [["license"],["category"],["author","maintainer"]]]
-- split on things like "," "&" "and", then throw away email addresses, replace spaces with "-" and rename
cleanup =
filter (/= "") .
map (renameTag . intercalate "-" . filter ('@' `notElem`) . words . takeWhile (`notElem` "<(")) .
concatMap (map unwords . split (== "and") . words) . split (`elem` ",&")
-- Ignores nesting beacuse it's not interesting for any of the fields I care about
lexCabal :: String -> [(String, [String])]
lexCabal = f . lines
where
f (x:xs) | (white,x) <- span isSpace x
, (name@(_:_),x) <- span (\c -> isAlpha c || c == '-') x
, ':':x <- trim x
, (xs1,xs2) <- span (\s -> length (takeWhile isSpace s) > length white) xs
= (lower name, trim x : replace ["."] [""] (map (trim . fst . breakOn "--") xs1)) : f xs2
f (x:xs) = f xs
f [] = []
hoogle-5.0.17.3/src/General/ 0000755 0000000 0000000 00000000000 13265310054 013553 5 ustar 00 0000000 0000000 hoogle-5.0.17.3/src/General/Web.hs 0000644 0000000 0000000 00000006616 13265310054 014635 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, RecordWildCards #-}
module General.Web(
Input(..), Output(..), readInput, server
) where
import Network.Wai.Handler.Warp hiding (Port, Handle)
import Network.Wai.Handler.WarpTLS
import Action.CmdLine
import Network.Wai.Logger
import Network.Wai
import Control.DeepSeq
import Network.HTTP.Types.Status
import qualified Data.Text as Text
import General.Str
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.List.Extra
import Data.String
import Data.Tuple.Extra
import Data.Monoid
import System.FilePath
import Control.Exception.Extra
import System.Time.Extra
import General.Log
import Network.URI
import Prelude
data Input = Input
{inputURL :: [String]
,inputArgs :: [(String, String)]
} deriving Show
readInput :: String -> Input
readInput (breakOn "?" -> (a,b)) = Input (dropWhile null $ splitOn "/" a) $
map (second (unEscapeString . drop1) . breakOn "=") $ splitOn "&" $ drop1 b
data Output
= OutputText LBS.ByteString
| OutputHTML LBS.ByteString
| OutputJSON LBS.ByteString
| OutputFail LBS.ByteString
| OutputFile FilePath
deriving Show
instance NFData Output where
rnf (OutputText x) = rnf x
rnf (OutputJSON x) = rnf x
rnf (OutputHTML x) = rnf x
rnf (OutputFail x) = rnf x
rnf (OutputFile x) = rnf x
server :: Log -> CmdLine -> (Input -> IO Output) -> IO ()
server log Server{..} act = do
let
host' = fromString $
if host == "" then
if local then
"127.0.0.1"
else
"*"
else
host
set = setOnExceptionResponse exceptionResponseForDebug
. setHost host'
. setPort port $
defaultSettings
runServer :: Application -> IO ()
runServer = if https then runTLS (tlsSettings cert key) set
else runSettings set
logAddMessage log $ "Server starting on port " ++ show port ++ " and host/IP " ++ show host'
runServer $ \req reply -> do
putStrLn $ BS.unpack $ rawPathInfo req <> rawQueryString req
let pay = Input (map Text.unpack $ pathInfo req)
[(strUnpack a, maybe "" strUnpack b) | (a,b) <- queryString req]
(time,res) <- duration $ try_ $ do s <- act pay; evaluate $ rnf s; return s
res <- either (fmap Left . showException) (return . Right) res
logAddEntry log (showSockAddr $ remoteHost req)
(BS.unpack $ rawPathInfo req <> rawQueryString req) time (either Just (const Nothing) res)
case res of
Left s -> reply $ responseLBS status500 [] $ LBS.pack s
Right v -> reply $ case v of
OutputFile file -> responseFile status200
[("content-type",c) | Just c <- [lookup (takeExtension file) contentType]] file Nothing
OutputText msg -> responseLBS status200 [("content-type","text/plain")] msg
OutputJSON msg -> responseLBS status200 [("content-type","application/json"), ("access-control-allow-origin","*")] msg
OutputFail msg -> responseLBS status500 [] msg
OutputHTML msg -> responseLBS status200 [("content-type","text/html")] msg
contentType = [(".html","text/html"),(".css","text/css"),(".js","text/javascript")]
hoogle-5.0.17.3/src/General/Util.hs 0000644 0000000 0000000 00000027611 13265310054 015033 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ViewPatterns, CPP, ScopedTypeVariables #-}
module General.Util(
URL,
pretty, parseMode, applyType, applyFun1, unapplyFun, fromName, fromQName, fromTyVarBind, declNames, isTypeSig,
fromDeclHead, fromContext, fromIParen, fromInstHead,
tarballReadFiles,
isUpper1, isAlpha1,
joinPair,
testing, testEq,
showUTCTime,
strict,
withs,
escapeHTML, unescapeHTML, unHTML, tag, tag_,
takeSortOn,
Average, toAverage, fromAverage,
inRanges,
readMaybe,
parseTrailingVersion,
trimVersion,
exitFail,
prettyTable,
getStatsPeakAllocBytes, getStatsCurrentLiveBytes, getStatsDebug,
hackagePackageURL, hackageModuleURL, hackageDeclURL, ghcModuleURL,
minimum', maximum',
general_util_test
) where
import Language.Haskell.Exts
import Control.Applicative
import Data.List.Extra
import Data.Char
import Data.Either.Extra
import Data.Semigroup
import Data.Tuple.Extra
import Control.Monad.Extra
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Map as Map
import Data.Ix
import Numeric.Extra
import Codec.Compression.GZip as GZip
import Codec.Archive.Tar as Tar
import Data.Time.Clock
import Data.Time.Format
import Control.DeepSeq
import Control.Exception.Extra
import Test.QuickCheck
import Data.Version
import Data.Int
import System.IO
import System.Exit
import System.Mem
import GHC.Stats
import Prelude
-- | A URL, complete with a @https:@ prefix.
type URL = String
#if __GLASGOW_HASKELL__ >= 802
#define RTS_STATS 1
#endif
showMb :: (Show a, Integral a) => a -> String
#if RTS_STATS
showMb x = show (x `div` (1024*1024)) ++ "Mb"
#else
showMb x = show x ++ "Mb"
#endif
#if RTS_STATS
withRTSStats :: (RTSStats -> a) -> IO (Maybe a)
withRTSStats f = ifM getRTSStatsEnabled (Just . f <$> getRTSStats) (return Nothing)
#else
withGCStats :: (GCStats -> a) -> IO (Maybe a)
withGCStats f = ifM getGCStatsEnabled (Just . f <$> getGCStats) (return Nothing)
#endif
getStatsCurrentLiveBytes :: IO (Maybe String)
getStatsCurrentLiveBytes = do
performGC
#if RTS_STATS
withRTSStats $ showMb . gcdetails_live_bytes . gc
#else
withGCStats $ showMb . currentBytesUsed
#endif
getStatsPeakAllocBytes :: IO (Maybe String)
getStatsPeakAllocBytes = do
#if RTS_STATS
withRTSStats $ showMb . max_mem_in_use_bytes
#else
withGCStats $ showMb . peakMegabytesAllocated
#endif
getStatsDebug :: IO (Maybe String)
getStatsDebug = do
let dump = replace ", " "\n" . takeWhile (/= '}') . drop 1 . dropWhile (/= '{') . show
#if RTS_STATS
withRTSStats dump
#else
withGCStats dump
#endif
exitFail :: String -> IO ()
exitFail msg = do
hPutStrLn stderr msg
exitFailure
pretty :: Pretty a => a -> String
pretty = prettyPrintWithMode defaultMode{layout=PPNoLayout}
parseMode :: ParseMode
parseMode = defaultParseMode{extensions=map EnableExtension es}
where es = [ConstraintKinds,EmptyDataDecls,TypeOperators,ExplicitForAll,GADTs,KindSignatures,MultiParamTypeClasses
,TypeFamilies,FlexibleContexts,FunctionalDependencies,ImplicitParams,MagicHash,UnboxedTuples
,ParallelArrays,UnicodeSyntax,DataKinds,PolyKinds]
applyType :: Type a -> [Type a] -> Type a
applyType x (t:ts) = applyType (TyApp (ann t) x t) ts
applyType x [] = x
applyFun1 :: [Type a] -> Type a
applyFun1 [x] = x
applyFun1 (x:xs) = TyFun (ann x) x $ applyFun1 xs
unapplyFun :: Type a -> [Type a]
unapplyFun (TyFun _ x y) = x : unapplyFun y
unapplyFun x = [x]
fromName :: Name a -> String
fromName (Ident _ x) = x
fromName (Symbol _ x) = x
fromQName :: QName a -> String
fromQName (Qual _ _ x) = fromName x
fromQName (UnQual _ x) = fromName x
fromQName (Special _ UnitCon{}) = "()"
fromQName (Special _ ListCon{}) = "[]"
fromQName (Special _ FunCon{}) = "->"
fromQName (Special _ (TupleCon _ box n)) = "(" ++ h ++ replicate n ',' ++ h ++ ")"
where h = ['#' | box == Unboxed]
fromQName (Special _ UnboxedSingleCon{}) = "(##)"
fromQName (Special _ Cons{}) = ":"
fromContext :: Context a -> [Asst a]
fromContext (CxSingle _ x) = [x]
fromContext (CxTuple _ xs) = xs
fromContext _ = []
fromIParen :: InstRule a -> InstRule a
fromIParen (IParen _ x) = fromIParen x
fromIParen x = x
fromTyVarBind :: TyVarBind a -> Name a
fromTyVarBind (KindedVar _ x _) = x
fromTyVarBind (UnkindedVar _ x) = x
fromDeclHead :: DeclHead a -> (Name a, [TyVarBind a])
fromDeclHead (DHead _ n) = (n, [])
fromDeclHead (DHInfix _ x n) = (n, [x])
fromDeclHead (DHParen _ x) = fromDeclHead x
fromDeclHead (DHApp _ dh x) = second (++[x]) $ fromDeclHead dh
fromInstHead :: InstHead a -> (QName a, [Type a])
fromInstHead (IHCon _ n) = (n, [])
fromInstHead (IHInfix _ x n) = (n, [x])
fromInstHead (IHParen _ x) = fromInstHead x
fromInstHead (IHApp _ ih x) = second (++[x]) $ fromInstHead ih
declNames :: Decl a -> [String]
declNames x = map fromName $ case x of
TypeDecl _ hd _ -> f hd
DataDecl _ _ _ hd _ _ -> f hd
GDataDecl _ _ _ hd _ _ _ -> f hd
TypeFamDecl _ hd _ _ -> f hd
DataFamDecl _ _ hd _ -> f hd
ClassDecl _ _ hd _ _ -> f hd
TypeSig _ names _ -> names
_ -> []
where f x = [fst $ fromDeclHead x]
isTypeSig :: Decl a -> Bool
isTypeSig TypeSig{} = True
isTypeSig _ = False
tarballReadFiles :: FilePath -> IO [(FilePath, LBS.ByteString)]
tarballReadFiles file = f . Tar.read . GZip.decompress <$> LBS.readFile file
where
f (Next e rest) | NormalFile body _ <- entryContent e = (entryPath e, body) : f rest
f (Next _ rest) = f rest
f Done = []
f (Fail e) = error $ "tarballReadFiles on " ++ file ++ ", " ++ show e
innerTextHTML :: String -> String
innerTextHTML ('<':xs) = innerTextHTML $ drop 1 $ dropWhile (/= '>') xs
innerTextHTML (x:xs) = x : innerTextHTML xs
innerTextHTML [] = []
unHTML :: String -> String
unHTML = unescapeHTML . innerTextHTML
isUpper1 (x:xs) = isUpper x
isUpper1 _ = False
isAlpha1 (x:xs) = isAlpha x
isAlpha1 [] = False
splitPair :: String -> String -> (String, String)
splitPair x y | (a,stripPrefix x -> Just b) <- breakOn x y = (a,b)
| otherwise = error $ "splitPair does not contain separator " ++ show x ++ " in " ++ show y
joinPair :: [a] -> ([a], [a]) -> [a]
joinPair sep (a,b) = a ++ sep ++ b
testing_, testing :: String -> IO () -> IO ()
testing_ name act = do putStr $ "Test " ++ name ++ " "; act
testing name act = do testing_ name act; putStrLn ""
testEq :: (Show a, Eq a) => a -> a -> IO ()
testEq a b | a == b = putStr "."
| otherwise = errorIO $ "Expected equal, but " ++ show a ++ " /= " ++ show b
showUTCTime :: String -> UTCTime -> String
showUTCTime = formatTime defaultTimeLocale
withs :: [(a -> r) -> r] -> ([a] -> r) -> r
withs [] act = act []
withs (f:fs) act = f $ \a -> withs fs $ \as -> act $ a:as
prettyTable :: Int -> String -> [(String, Double)] -> [String]
prettyTable dp units xs =
( padR len units ++ "\tPercent\tName") :
[ padL len (showDP dp b) ++ "\t" ++ padL 7 (showDP 1 (100 * b / tot) ++ "%") ++ "\t" ++ a
| (a,b) <- ("Total", tot) : sortOn (negate . snd) xs]
where
tot = sum $ map snd xs
len = length units `max` length (showDP dp tot)
padL n s = replicate (n - length s) ' ' ++ s
padR n s = s ++ replicate (n - length s) ' '
tag :: String -> [String] -> String -> String
tag name attr inner = "<" ++ unwords (name : map f attr) ++ ">" ++ inner ++ ""
where f (break (== '=') -> (a,'=':b)) = a ++ "=\"" ++ escapeHTML b ++ "\""
f x = x
tag_ :: String -> String -> String
tag_ name = tag name []
-- ensure that no value escapes in a thunk from the value
strict :: NFData a => IO a -> IO a
strict act = do
res <- try_ act
case res of
Left e -> do msg <- showException e; evaluate $ rnf msg; error msg
Right v -> do evaluate $ rnf v; return v
data Average a = Average !a !Int deriving Show -- a / b
toAverage :: a -> Average a
toAverage x = Average x 1
fromAverage :: Fractional a => Average a -> a
fromAverage (Average a b) = a / fromIntegral b
instance Num a => Semigroup (Average a) where
Average x1 x2 <> Average y1 y2 = Average (x1+y1) (x2+y2)
instance Num a => Monoid (Average a) where
mempty = Average 0 0
mappend = (<>)
readMaybe :: Read a => String -> Maybe a
readMaybe s | [x] <- [x | (x,t) <- reads s, ("","") <- lex t] = Just x
| otherwise = Nothing
data TakeSort k v = More !Int !(Map.Map k [v])
| Full !k !(Map.Map k [v])
-- | @takeSortOn n op == take n . sortOn op@
takeSortOn :: Ord k => (a -> k) -> Int -> [a] -> [a]
takeSortOn op n xs
| n <= 0 = []
| otherwise = concatMap reverse $ Map.elems $ getMap $ foldl' add (More n Map.empty) xs
where
getMap (More _ mp) = mp
getMap (Full _ mp) = mp
add (More n mp) x = (if n <= 1 then full else More (n-1)) $ Map.insertWith (++) (op x) [x] mp
add o@(Full mx mp) x = let k = op x in if k >= mx then o else full $ Map.insertWith (++) k [x] $ delMax mp
full mp = Full (fst $ Map.findMax mp) mp
delMax mp | Just ((k,_:vs), mp) <- Map.maxViewWithKey mp = if null vs then mp else Map.insert k vs mp
-- See https://ghc.haskell.org/trac/ghc/ticket/10830 - they broke maximumBy
maximumBy' :: (a -> a -> Ordering) -> [a] -> a
maximumBy' cmp = foldl1' $ \x y -> if cmp x y == GT then x else y
maximum' :: Ord a => [a] -> a
maximum' = maximumBy' compare
minimumBy' :: (a -> a -> Ordering) -> [a] -> a
minimumBy' cmp = foldl1' $ \x y -> if cmp x y == LT then x else y
minimum' :: Ord a => [a] -> a
minimum' = minimumBy' compare
hackagePackageURL :: String -> URL
hackagePackageURL x = "https://hackage.haskell.org/package/" ++ x
hackageModuleURL :: String -> URL
hackageModuleURL x = "/docs/" ++ ghcModuleURL x
ghcModuleURL :: String -> URL
ghcModuleURL x = replace "." "-" x ++ ".html"
hackageDeclURL :: Bool -> String -> URL
hackageDeclURL typesig x = "#" ++ (if typesig then "v" else "t") ++ ":" ++ concatMap f x
where
f x | isLegal x = [x]
| otherwise = "-" ++ show (ord x) ++ "-"
-- isLegal is from haddock-api:Haddock.Utils; we need to use
-- the same escaping strategy here in order for fragment links
-- to work
isLegal ':' = True
isLegal '_' = True
isLegal '.' = True
isLegal c = isAscii c && isAlphaNum c
trimVersion :: Int -> Version -> Version
trimVersion i v = v{versionBranch = take 3 $ versionBranch v}
parseTrailingVersion :: String -> (String, [Int])
parseTrailingVersion = (reverse *** reverse) . f . reverse
where
f xs | (ver@(_:_),sep:xs) <- span isDigit xs
, sep == '-' || sep == '.'
, (a, b) <- f xs
= (a, Prelude.read (reverse ver) : b)
f xs = (xs, [])
-- | Equivalent to any (`inRange` x) xs, but more efficient
inRanges :: Ix a => [(a,a)] -> (a -> Bool)
inRanges xs = \x -> maybe False (`inRange` x) $ Map.lookupLE x mp
where
mp = foldl' add Map.empty xs
merge (l1,u1) (l2,u2) = (min l1 l2, max u1 u2)
overlap x1 x2 = x1 `inRange` fst x2 || x2 `inRange` fst x1
add mp x
| Just x2 <- Map.lookupLE (fst x) mp, overlap x x2 = add (Map.delete (fst x2) mp) (merge x x2)
| Just x2 <- Map.lookupGE (fst x) mp, overlap x x2 = add (Map.delete (fst x2) mp) (merge x x2)
| otherwise = Map.insert (fst x) (snd x) mp
general_util_test :: IO ()
general_util_test = do
testing "General.Util.splitPair" $ do
let a === b = if a == b then putChar '.' else error $ show (a,b)
splitPair ":" "module:foo:bar" === ("module","foo:bar")
do x <- try_ $ evaluate $ rnf $ splitPair "-" "module:foo"; isLeft x === True
splitPair "-" "module-" === ("module","")
testing_ "General.Util.inRanges" $ do
quickCheck $ \(x :: Int8) xs -> inRanges xs x == any (`inRange` x) xs
testing "General.Util.parseTrailingVersion" $ do
let a === b = if a == b then putChar '.' else error $ show (a,b)
parseTrailingVersion "shake-0.15.2" === ("shake",[0,15,2])
parseTrailingVersion "test-of-stuff1" === ("test-of-stuff1",[])
hoogle-5.0.17.3/src/General/Timing.hs 0000644 0000000 0000000 00000005046 13265310054 015343 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards #-}
module General.Timing(Timing, withTiming, timed, timedOverwrite) where
import Data.List.Extra
import System.Time.Extra
import Data.IORef
import Control.Monad.Extra
import System.IO
import General.Util
import Control.Monad.IO.Class
data Timing = Timing
{timingOffset :: IO Seconds
,timingStore :: IORef [(String, Seconds)] -- records for writing to a file
,timingOverwrite :: IORef (Maybe (Seconds, Int)) -- if you are below T you may overwrite N characters
,timingTerminal :: Bool -- is this a terminal
}
withTiming :: Maybe FilePath -> (Timing -> IO a) -> IO a
withTiming file f = do
timingOffset <- offsetTime
timingStore <- newIORef []
timingOverwrite <- newIORef Nothing
timingTerminal <- hIsTerminalDevice stdout
res <- f Timing{..}
total <- timingOffset
whenJust file $ \file -> do
xs <- readIORef timingStore
-- Expecting unrecorded of ~2s
-- Most of that comes from the pipeline - we get occasional 0.01 between items as one flushes
-- Then at the end there is ~0.5 while the final item flushes
xs <- return $ reverse $ sortOn snd $ ("Unrecorded", total - sum (map snd xs)) : xs
writeFile file $ unlines $ prettyTable 2 "Secs" xs
putStrLn $ "Took " ++ showDuration total
return res
-- skip it if have written out in the last 1s and takes < 0.1
timed :: MonadIO m => Timing -> String -> m a -> m a
timed = timedEx False
timedOverwrite :: MonadIO m => Timing -> String -> m a -> m a
timedOverwrite = timedEx True
timedEx :: MonadIO m => Bool -> Timing -> String -> m a -> m a
timedEx overwrite Timing{..} msg act = do
start <- liftIO timingOffset
liftIO $ whenJustM (readIORef timingOverwrite) $ \(t,n) ->
if overwrite && start < t then
putStr $ replicate n '\b' ++ replicate n ' ' ++ replicate n '\b'
else
putStrLn ""
let out msg = liftIO $ putStr msg >> return (length msg)
undo1 <- out $ msg ++ "... "
liftIO $ hFlush stdout
res <- act
end <- liftIO timingOffset
let time = end - start
liftIO $ modifyIORef timingStore ((msg,time):)
s <- maybe "" (\x -> " (" ++ x ++ ")") <$> liftIO getStatsPeakAllocBytes
undo2 <- out $ showDuration time ++ s
old <- liftIO $ readIORef timingOverwrite
let next = maybe (start + 1.0) fst old
liftIO $ if timingTerminal && overwrite && end < next then
writeIORef timingOverwrite $ Just (next, undo1 + undo2)
else do
writeIORef timingOverwrite Nothing
putStrLn ""
return res
hoogle-5.0.17.3/src/General/Template.hs 0000644 0000000 0000000 00000006575 13265310054 015677 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, DeriveDataTypeable, ScopedTypeVariables #-}
module General.Template(
Template, templateFile, templateStr, templateApply, templateRender
) where
import Data.Data
import Data.Monoid
import General.Str
import Control.Exception
import Data.Generics.Uniplate.Data
import Control.Applicative
import System.IO.Unsafe
import System.Directory
import Control.Monad
import Data.IORef
import Prelude
---------------------------------------------------------------------
-- TREE DATA TYPE
data Tree = Lam FilePath -- #{foo} defines a lambda
| Var Str -- a real variable
| App Tree [(Str, Tree)] -- applies a foo string to the lambda
| Lit Str
| List [Tree]
deriving (Typeable,Data,Show)
-- | Turn all Lam into Var/Lit
treeRemoveLam :: Tree -> IO Tree
treeRemoveLam = transformM f
where
f (Lam file) = List . parse <$> strReadFile file
f x = return x
parse x | Just (a,b) <- strSplitInfix (strPack "#{") x
, Just (b,c) <- strSplitInfix (strPack "}") b
= Lit a : Var b : parse c
parse x = [Lit x]
treeRemoveApp :: Tree -> Tree
treeRemoveApp = f []
where
f seen (App t xs) = f (xs ++ seen) t
f seen (Var x) | Just t <- lookup x seen = f seen t
f seen x = descend (f seen) x
treeOptimise :: Tree -> Tree
treeOptimise = transform f . treeRemoveApp
where
fromList (List xs) = xs; fromList x = [x]
toList [x] = x; toList xs = List xs
isLit (Lit x) = True; isLit _ = False
fromLit (Lit x) = x
f = toList . g . concatMap fromList . fromList
g [] = []
g (x:xs) | not $ isLit x = x : g xs
g xs = [Lit x | let x = mconcat $ map fromLit a, x /= mempty] ++ g b
where (a,b) = span isLit xs
treeEval :: Tree -> [Str]
treeEval = f . treeRemoveApp
where f (Lit x) = [x]
f (List xs) = concatMap f xs
f _ = []
---------------------------------------------------------------------
-- TEMPLATE DATA TYPE
-- a tree, and a pre-optimised tree you can create
data Template = Template Tree (IO Tree)
{-# NOINLINE treeCache #-}
treeCache :: Tree -> IO Tree
treeCache t0 = unsafePerformIO $ do
let files = [x | Lam x <- universe t0]
ref <- newIORef ([], treeOptimise t0)
return $ do
(old,t) <- readIORef ref
new <- forM files $ \file ->
-- the standard getModificationTime message on Windows doesn't say the file
getModificationTime file `catch` \(e :: IOException) ->
fail $ "Failed: getModificationTime on " ++ file ++ ", " ++ show e
if old == new then return t else do
t <- treeOptimise <$> treeRemoveLam t0
writeIORef ref (new,t)
return t
templateTree :: Tree -> Template
templateTree t = Template t $ treeCache t
templateFile :: FilePath -> Template
templateFile = templateTree . Lam
templateStr :: LStr -> Template
templateStr = templateTree . List . map Lit . lstrToChunks
templateApply :: Template -> [(String, Template)] -> Template
templateApply (Template t _) args = templateTree $ App t [(strPack a, b) | (a,Template b _) <- args]
templateRender :: Template -> [(String, Template)] -> IO LStr
templateRender (Template _ t) args = do
t <- t
let Template t2 _ = templateApply (Template t $ return t) args
lstrFromChunks . treeEval <$> treeRemoveLam t2
hoogle-5.0.17.3/src/General/Str.hs 0000644 0000000 0000000 00000003130 13265310054 014654 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
-- | ByteString wrappers which don't require special imports and are all UTF8 safe
module General.Str(
Str, strPack, strUnpack, strReadFile, strSplitInfix, strNull, strStripPrefix, strTrimStart,
LStr, lstrPack, lstrUnpack, lstrToChunks, lstrFromChunks,
Str0, join0, split0
) where
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.UTF8 as US
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.ByteString.Lazy.UTF8 as LUS
import Data.Char
import Data.List
type Str = BS.ByteString
type LStr = LBS.ByteString
strPack :: String -> Str
strPack = US.fromString
strUnpack :: Str -> String
strUnpack = US.toString
strReadFile :: FilePath -> IO Str
strReadFile = BS.readFile
strSplitInfix :: Str -> Str -> Maybe (Str, Str)
strSplitInfix needle haystack
| (a,b) <- BS.breakSubstring needle haystack
, not $ BS.null b
= Just (a, BS.drop (BS.length needle) b)
strSplitInfix _ _ = Nothing
strNull :: Str -> Bool
strNull = BS.null
strStripPrefix :: Str -> Str -> Maybe Str
strStripPrefix needle x
| BS.isPrefixOf needle x = Just $ BS.drop (BS.length needle) x
| otherwise = Nothing
strTrimStart :: Str -> Str
strTrimStart = BS.dropWhile isSpace
lstrToChunks :: LStr -> [Str]
lstrToChunks = LBS.toChunks
lstrFromChunks :: [Str] -> LStr
lstrFromChunks = LBS.fromChunks
lstrUnpack :: LStr -> String
lstrUnpack = LUS.toString
lstrPack :: String -> LStr
lstrPack = LUS.fromString
type Str0 = Str
join0 :: [String] -> Str0
join0 = BS.pack . intercalate "\0"
split0 :: Str0 -> [Str]
split0 = BS.split '\0'
hoogle-5.0.17.3/src/General/Store.hs 0000644 0000000 0000000 00000023057 13265310054 015212 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables, RecordWildCards, PatternGuards, ViewPatterns, DeriveDataTypeable, GADTs #-}
module General.Store(
Typeable, Stored,
intSize, intFromBS, intToBS, encodeBS,
StoreWrite, storeWriteFile, storeWrite, storeWritePart,
StoreRead, storeReadFile, storeRead,
Jagged, jaggedFromList, jaggedAsk,
) where
import Data.IORef.Extra
import System.IO.Extra
import Data.Typeable
import qualified Data.Map as Map
import qualified Data.Vector.Storable as V
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Lazy as LBS
import Foreign.C.String
import Foreign.Storable
import Foreign.Ptr
import Foreign.ForeignPtr
import Control.Monad.Extra
import Control.Exception
import Numeric.Extra
import Data.Binary
import Data.List.Extra
import System.IO.MMap
import Control.Applicative
import System.IO.Unsafe
import General.Util
import Control.DeepSeq
import Data.Version
import Data.Char
import Paths_hoogle
import Prelude
-- Ensure the string is always 25 chars long, so version numbers don't change its size
-- Only use the first two components of the version number to identify the database
verString = BS.pack $ take 25 $ "HOOGLE-" ++ showVersion (trimVersion 3 version) ++ repeat ' '
---------------------------------------------------------------------
-- SERIALISATION HELPERS
intSize :: Int
intSize = 4
intToBS :: Int -> BS.ByteString
intToBS i = encodeBS (fromIntegral i :: Word32)
intFromBS :: BS.ByteString -> Int
intFromBS bs = fromIntegral (decodeBS bs :: Word32)
encodeBS :: Binary a => a -> BS.ByteString
encodeBS = LBS.toStrict . encode
decodeBS :: Binary a => BS.ByteString -> a
decodeBS = decode . LBS.fromStrict
---------------------------------------------------------------------
-- TREE INDEX STRUCTURE
-- each atom name is either unique (a scope) or "" (a list entry)
data Atom = Atom
{atomType :: String -- Type that the atom contains (for sanity checking)
,atomPosition :: {-# UNPACK #-} !Int -- Position at which the atom starts in the file
,atomSize :: {-# UNPACK #-} !Int -- Number of bytes the value takes up
} deriving Show
instance Binary Atom where
put (Atom a b c) = put a >> put b >> put c
get = liftA3 Atom get get get
---------------------------------------------------------------------
-- TYPE CLASS
class Typeable a => Stored a where
storedWrite :: Typeable (t a) => StoreWrite -> t a -> Bool -> a -> IO ()
storedRead :: Typeable (t a) => StoreRead -> t a -> a
instance Stored BS.ByteString where
storedWrite store k part v = BS.unsafeUseAsCStringLen v $ \x -> storeWriteAtom store k part x
storedRead store k = storeReadAtom store k BS.unsafePackCStringLen
instance forall a . (Typeable a, Storable a) => Stored (V.Vector a) where
storedWrite store k part v = V.unsafeWith v $ \ptr ->
storeWriteAtom store k part (castPtr ptr, V.length v * sizeOf (undefined :: a))
storedRead store k = storeReadAtom store k $ \(ptr, len) -> do
ptr <- newForeignPtr_ $ castPtr ptr
return $ V.unsafeFromForeignPtr0 ptr (len `div` sizeOf (undefined :: a))
---------------------------------------------------------------------
-- WRITE OUT
data SW = SW
{swHandle :: Handle -- Immutable handle I write to
,swPosition :: !Int -- Position within swHandle
,swAtoms :: [(String, Atom)] -- List of pieces, in reverse
}
newtype StoreWrite = StoreWrite (IORef SW)
storeWriteFile :: FilePath -> (StoreWrite -> IO a) -> IO ([String], a)
storeWriteFile file act = do
atoms <- newIORef Map.empty
parts <- newIORef Nothing
withBinaryFile file WriteMode $ \h -> do
-- put the version string at the start and end, so we can tell truncation vs wrong version
BS.hPut h verString
ref <- newIORef $ SW h (BS.length verString) []
res <- act $ StoreWrite ref
SW{..} <- readIORef ref
-- sort the atoms and validate there are no duplicates
let atoms = Map.fromList swAtoms
when (Map.size atoms /= length swAtoms) $
error "Some duplicate names have been written out"
-- write the atoms out, then put the size at the end
let bs = encodeBS atoms
BS.hPut h bs
BS.hPut h $ intToBS $ BS.length bs
BS.hPut h verString
final <- hTell h
let stats = prettyTable 0 "Bytes" $
("Overheads", intToDouble $ fromIntegral final - sum (map atomSize $ Map.elems atoms)) :
[(name ++ " :: " ++ atomType, intToDouble atomSize) | (name, Atom{..}) <- Map.toList atoms]
return (stats, res)
storeWrite :: (Typeable (t a), Typeable a, Stored a) => StoreWrite -> t a -> a -> IO ()
storeWrite store k = storedWrite store k False
storeWritePart :: forall t a . (Typeable (t a), Typeable a, Stored a) => StoreWrite -> t a -> a -> IO ()
storeWritePart store k = storedWrite store k True
{-# NOINLINE putBuffer #-}
putBuffer a b c = hPutBuf a b c
storeWriteAtom :: forall t a . (Typeable (t a), Typeable a) => StoreWrite -> t a -> Bool -> CStringLen -> IO ()
storeWriteAtom (StoreWrite ref) (show . typeOf -> key) part (ptr, len) = do
sw@SW{..} <- readIORef ref
putBuffer swHandle ptr len
let val = show $ typeOf (undefined :: a)
atoms <- case swAtoms of
(keyOld,a):xs | part, key == keyOld -> do
let size = atomSize a + len
evaluate size
return $ (key,a{atomSize=size}) : xs
_ -> return $ (key, Atom val swPosition len) : swAtoms
writeIORef' ref sw{swPosition = swPosition + len, swAtoms = atoms}
---------------------------------------------------------------------
-- READ OUT
data StoreRead = StoreRead
{srFile :: FilePath
,srLen :: Int
,srPtr :: Ptr ()
,srAtoms :: Map.Map String Atom
}
storeReadFile :: NFData a => FilePath -> (StoreRead -> IO a) -> IO a
storeReadFile file act = mmapWithFilePtr file ReadOnly Nothing $ \(ptr, len) -> strict $ do
-- check is longer than my version string
when (len < (BS.length verString * 2) + intSize) $
error $ "The Hoogle file " ++ file ++ " is corrupt, only " ++ show len ++ " bytes."
let verN = BS.length verString
verEnd <- BS.unsafePackCStringLen (plusPtr ptr $ len - verN, verN)
when (verString /= verEnd) $ do
verStart <- BS.unsafePackCStringLen (plusPtr ptr 0, verN)
if verString /= verStart then
error $ "The Hoogle file " ++ file ++ " is the wrong version or format.\n" ++
"Expected: " ++ trim (BS.unpack verString) ++ "\n" ++
"Got : " ++ map (\x -> if isAlphaNum x || x `elem` "_-. " then x else '?') (trim $ BS.unpack verStart)
else
error $ "The Hoogle file " ++ file ++ " is truncated, probably due to an error during creation."
atomSize <- intFromBS <$> BS.unsafePackCStringLen (plusPtr ptr $ len - verN - intSize, intSize)
when (len < verN + intSize + atomSize) $
error $ "The Hoogle file " ++ file ++ " is corrupt, couldn't read atom table."
atoms <- decodeBS <$> BS.unsafePackCStringLen (plusPtr ptr $ len - verN - intSize - atomSize, atomSize)
act $ StoreRead file len ptr atoms
storeRead :: (Typeable (t a), Typeable a, Stored a) => StoreRead -> t a -> a
storeRead = storedRead
storeReadAtom :: forall a t . (Typeable (t a), Typeable a) => StoreRead -> t a -> (CStringLen -> IO a) -> a
storeReadAtom StoreRead{..} (typeOf -> k) unpack = unsafePerformIO $ do
let key = show k
let val = show $ typeOf (undefined :: a)
let corrupt msg = error $ "The Hoogle file " ++ srFile ++ " is corrupt, " ++ key ++ " " ++ msg ++ "."
case Map.lookup key srAtoms of
Nothing -> corrupt "is missing"
Just Atom{..}
| atomType /= val -> corrupt $ "has type " ++ atomType ++ ", expected " ++ val
| atomPosition < 0 || atomPosition + atomSize > srLen -> corrupt "has incorrect bounds"
| otherwise -> unpack (plusPtr srPtr atomPosition, atomSize)
---------------------------------------------------------------------
-- PAIRS
newtype Fst k v where Fst :: k -> Fst k a deriving Typeable
newtype Snd k v where Snd :: k -> Snd k b deriving Typeable
instance (Typeable a, Typeable b, Stored a, Stored b) => Stored (a,b) where
storedWrite store k False (a,b) = storeWrite store (Fst k) a >> storeWrite store (Snd k) b
storedRead store k = (storeRead store $ Fst k, storeRead store $ Snd k)
---------------------------------------------------------------------
-- LITERALS
data StoredInt k v where StoredInt :: k -> StoredInt k BS.ByteString deriving Typeable
instance Stored Int where
storedWrite store k False v = storeWrite store (StoredInt k) $ intToBS v
storedRead store k = intFromBS $ storeRead store (StoredInt k)
---------------------------------------------------------------------
-- JAGGED ARRAYS
data Jagged a = Jagged (V.Vector Word32) (V.Vector a) deriving Typeable
data JaggedStore k v where JaggedStore :: k -> JaggedStore k (V.Vector Word32, V.Vector a) deriving Typeable
jaggedFromList :: Storable a => [[a]] -> Jagged a
jaggedFromList xs = Jagged is vs
where is = V.fromList $ scanl (+) 0 $ map (\x -> fromIntegral $ length x :: Word32) xs
vs = V.fromList $ concat xs
jaggedAsk :: Storable a => Jagged a -> Int -> V.Vector a
jaggedAsk (Jagged is vs) i = V.slice start (end - start) vs
where start = fromIntegral $ is V.! i
end = fromIntegral $ is V.! succ i
instance (Typeable a, Storable a) => Stored (Jagged a) where
storedWrite store k False (Jagged is vs) = storeWrite store (JaggedStore k) (is, vs)
storedRead store k = uncurry Jagged $ storeRead store $ JaggedStore k
hoogle-5.0.17.3/src/General/Log.hs 0000644 0000000 0000000 00000011111 13265310054 014623 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards, ViewPatterns, TupleSections, PatternGuards #-}
module General.Log(
Log, logCreate, logNone, logAddMessage, logAddEntry,
Summary(..), logSummary,
) where
import Control.Concurrent.Extra
import Control.Applicative
import System.Directory
import System.IO
import Data.Time.Calendar
import Data.Time.Clock
import Numeric.Extra
import Control.Monad.Extra
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.Semigroup
import General.Util
import Data.Maybe
import Data.List
import Data.IORef
import Prelude
data Log = Log
{logOutput :: Maybe (Var Handle)
,logCurrent :: IORef (Map.Map Day SummaryI)
,logInteresting :: String -> Bool
}
showTime :: UTCTime -> String
showTime = showUTCTime "%Y-%m-%dT%H:%M:%S%Q"
logNone :: IO Log
logNone = do ref <- newIORef Map.empty; return $ Log Nothing ref (const False)
logCreate :: Either Handle FilePath -> (String -> Bool) -> IO Log
logCreate store interesting = do
(h, old) <- case store of
Left h -> return (h, Map.empty)
Right file -> do
b <- doesFileExist file
mp <- if not b then return Map.empty else withFile file ReadMode $ \h -> do
src <- LBS.hGetContents h
let xs = mapMaybe (parseLogLine interesting) $ LBS.lines src
return $! foldl' (\mp (k,v) -> Map.alter (Just . maybe v (<> v)) k mp) Map.empty xs
(,mp) <$> openFile file AppendMode
hSetBuffering h LineBuffering
var <- newVar h
ref <- newIORef old
return $ Log (Just var) ref interesting
logAddMessage :: Log -> String -> IO ()
logAddMessage Log{..} msg = do
time <- showTime <$> getCurrentTime
whenJust logOutput $ \var -> withVar var $ \h ->
hPutStrLn h $ time ++ " - " ++ msg
logAddEntry :: Log -> String -> String -> Double -> Maybe String -> IO ()
logAddEntry Log{..} user question taken err = do
time <- getCurrentTime
let add v = atomicModifyIORef logCurrent $ \mp -> (Map.alter (Just . maybe v (<> v)) (utctDay time) mp, ())
if logInteresting question then
add $ SummaryI (Set.singleton user) 1 taken (toAverage taken) (if isJust err then 1 else 0)
else if isJust err then
add mempty{iErrors=1}
else
return ()
whenJust logOutput $ \var -> withVar var $ \h ->
hPutStrLn h $ unwords $ [showTime time, user, showDP 3 taken, question] ++
maybeToList (fmap ((++) "ERROR: " . unwords . words) err)
-- Summary collapsed
data Summary = Summary
{summaryDate :: Day
,summaryUsers :: Int
,summaryUses :: Int
,summarySlowest :: Double
,summaryAverage :: Double
,summaryErrors :: Int
}
-- Summary accumulating
data SummaryI = SummaryI
{iUsers :: !(Set.Set String) -- number of distinct users
,iUses :: !Int -- number of uses
,iSlowest :: !Double -- slowest result
,iAverage :: !(Average Double) -- average result
,iErrors :: !Int -- number of errors
}
instance Semigroup SummaryI where
SummaryI x1 x2 x3 x4 x5 <> SummaryI y1 y2 y3 y4 y5 =
SummaryI (f x1 y1) (x2+y2) (max x3 y3) (x4 <> y4) (x5+y5)
-- more efficient union for the very common case of a single element
where f x y | Set.size x == 1 = Set.insert (head $ Set.toList x) y
| Set.size y == 1 = Set.insert (head $ Set.toList y) x
| otherwise = Set.union x y
instance Monoid SummaryI where
mempty = SummaryI Set.empty 0 0 (toAverage 0) 0
mappend = (<>)
summarize :: Day -> SummaryI -> Summary
summarize date SummaryI{..} = Summary date (Set.size iUsers) iUses iSlowest (fromAverage iAverage) iErrors
parseLogLine :: (String -> Bool) -> LBS.ByteString -> Maybe (Day, SummaryI)
parseLogLine interesting (LBS.words -> time:user:dur:query:err)
| user /= LBS.pack "-"
, Just [a, b, c] <- fmap (map fst) $ mapM LBS.readInt $ LBS.split '-' $ LBS.takeWhile (/= 'T') time
= Just (fromGregorian (fromIntegral a) b c, SummaryI
(if use then Set.singleton $ LBS.unpack user else Set.empty)
(if use then 1 else 0)
(if use then dur2 else 0)
(toAverage $ if use then dur2 else 0)
(if [LBS.pack "ERROR:"] `isPrefixOf` err then 1 else 0))
where use = interesting $ LBS.unpack query
dur2 = let s = LBS.unpack dur in fromMaybe 0 $
if '.' `elem` s then readMaybe s else (/ 1000) . intToDouble <$> readMaybe s
parseLogLine _ _ = Nothing
logSummary :: Log -> IO [Summary]
logSummary Log{..} = map (uncurry summarize) . Map.toAscList <$> readIORef logCurrent
hoogle-5.0.17.3/src/General/IString.hs 0000644 0000000 0000000 00000002336 13265310054 015472 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, DeriveDataTypeable #-}
-- | Interned strings
module General.IString(
IString, fromIString, toIString
) where
import Data.Data
import Data.IORef
import Control.DeepSeq
import Data.String
import qualified Data.Map as Map
import System.IO.Unsafe
data IString = IString {-# UNPACK #-} !Int !String
deriving (Data,Typeable)
instance Eq IString where
IString x _ == IString y _ = x == y
instance Ord IString where
compare (IString x1 x2) (IString y1 y2)
| x1 == y1 = EQ
| otherwise = compare x2 y2
instance Show IString where show = fromIString
instance Read IString where readsPrec _ x = [(toIString x,"")]
instance IsString IString where fromString = toIString
instance NFData IString where rnf (IString _ _) = () -- we force the string at construction time
{-# NOINLINE istrings #-}
istrings :: IORef (Map.Map String IString)
istrings = unsafePerformIO $ newIORef Map.empty
fromIString :: IString -> String
fromIString (IString _ x) = x
toIString :: String -> IString
toIString x | () <- rnf x = unsafePerformIO $ atomicModifyIORef istrings $ \mp -> case Map.lookup x mp of
Just v -> (mp, v)
Nothing -> let res = IString (Map.size mp) x in (Map.insert x res mp, res)
hoogle-5.0.17.3/src/General/Conduit.hs 0000644 0000000 0000000 00000005112 13265310054 015513 0 ustar 00 0000000 0000000 {-# LANGUAGE NoMonomorphismRestriction, PatternGuards, CPP #-}
module General.Conduit(
module Data.Conduit, MonadIO, liftIO,
sourceList, sinkList, sourceLStr,
mapC, mapAccumC, filterC,
mapMC, mapAccumMC,
(|$|), pipelineC, groupOnLastC,
zipFromC, linesCR
) where
import Data.Void
import Data.Conduit
import Data.Conduit.List as C
import Data.Conduit.Binary as C
import Data.Maybe
import Control.Applicative
import Control.Monad.Extra
import Control.Exception
import qualified Data.ByteString.Char8 as BS
import Control.Concurrent.Extra hiding (yield)
import Control.Monad.IO.Class
import General.Str
import Prelude
mapC = C.map
mapMC = C.mapM
mapAccumC f = C.mapAccum (\x a -> a `seq` f a x)
mapAccumMC f = C.mapAccumM (\x a -> a `seq` f a x)
filterC = C.filter
zipFromC :: (Monad m, Enum i) => i -> ConduitM a (i, a) m ()
zipFromC = void . mapAccumC (\i x -> (succ i, (i,x)))
(|$|) :: Monad m => ConduitM i o m r1 -> ConduitM i o m r2 -> ConduitM i o m (r1,r2)
(|$|) a b = getZipConduit $ (,) <$> ZipConduit a <*> ZipConduit b
sinkList :: Monad m => ConduitM a o m [a]
sinkList = consume
-- | Group things while they have the same function result, only return the last value.
-- Conduit version of @groupOnLast f = map last . groupOn f@.
groupOnLastC :: (Monad m, Eq b) => (a -> b) -> ConduitM a a m ()
groupOnLastC op = do
x <- await
whenJust x $ \x -> f (op x) x
where
f k v = await >>= \x -> case x of
Nothing -> yield v
Just v2 | let k2 = op v2 -> do
when (k /= k2) $ yield v
f k2 v2
linesCR :: Monad m => ConduitM Str Str m ()
linesCR = C.lines .| mapC f
where f x | Just (x, '\r') <- BS.unsnoc x = x
| otherwise = x
sourceLStr :: Monad m => LStr -> ConduitM i Str m ()
sourceLStr = sourceList . lstrToChunks
pipelineC :: Int -> ConduitM o Void IO r -> ConduitM o Void IO r
pipelineC buffer sink = do
sem <- liftIO $ newQSem buffer -- how many are in flow, to avoid memory leaks
chan <- liftIO newChan -- the items in flow (type o)
bar <- liftIO newBarrier -- the result type (type r)
me <- liftIO myThreadId
liftIO $ flip forkFinally (either (throwTo me) (signalBarrier bar)) $ do
runConduit $
(whileM $ do
x <- liftIO $ readChan chan
liftIO $ signalQSem sem
whenJust x yield
return $ isJust x) .|
sink
awaitForever $ \x -> liftIO $ do
waitQSem sem
writeChan chan $ Just x
liftIO $ writeChan chan Nothing
liftIO $ waitBarrier bar
hoogle-5.0.17.3/src/Action/ 0000755 0000000 0000000 00000000000 13265310054 013413 5 ustar 00 0000000 0000000 hoogle-5.0.17.3/src/Action/Test.hs 0000644 0000000 0000000 00000002220 13265310054 014662 0 ustar 00 0000000 0000000 {-# LANGUAGE TupleSections, RecordWildCards, ScopedTypeVariables #-}
module Action.Test(actionTest) where
import Query
import Action.CmdLine
import Action.Search
import Action.Server
import Action.Generate
import General.Util
import Input.Item
import Input.Haddock
import System.IO.Extra
import Control.Monad
import Output.Items
import Control.DeepSeq
import Control.Exception
actionTest :: CmdLine -> IO ()
actionTest Test{..} = withBuffering stdout NoBuffering $ withTempFile $ \sample -> do
putStrLn "Code tests"
general_util_test
input_haddock_test
query_test
action_server_test_
putStrLn ""
putStrLn "Sample database tests"
actionGenerate defaultGenerate{database=sample, local_=["misc/sample-data"]}
action_search_test True sample
action_server_test True sample
putStrLn ""
putStrLn "Haskell.org database tests"
action_search_test False database
action_server_test False database
when deep $ withSearch database $ \store -> do
putStrLn "Deep tests"
let xs = map targetItem $ listItems store
evaluate $ rnf xs
putStrLn $ "Loaded " ++ show (length xs) ++ " items"
hoogle-5.0.17.3/src/Action/Server.hs 0000644 0000000 0000000 00000030725 13265310054 015224 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-}
module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where
import Data.List.Extra
import System.FilePath
import Control.Exception
import Control.DeepSeq
import System.Directory
import Data.Tuple.Extra
import qualified Language.Javascript.JQuery as JQuery
import qualified Language.Javascript.Flot as Flot
import Data.Version
import Paths_hoogle
import Data.Maybe
import Control.Monad
import System.IO.Extra
import General.Str
import qualified Data.Map as Map
import System.Time.Extra
import Data.Time.Clock
import Data.Time.Calendar
import System.IO.Unsafe
import Numeric.Extra
import System.Info.Extra
import Output.Tags
import Query
import Input.Item
import General.Util
import General.Web
import General.Store
import General.Template
import General.Log
import Action.Search
import Action.CmdLine
import Control.Applicative
import Prelude
import qualified Data.Aeson as JSON
actionServer :: CmdLine -> IO ()
actionServer cmd@Server{..} = do
-- so I can get good error messages
hSetBuffering stdout LineBuffering
hSetBuffering stderr LineBuffering
putStrLn $ "Server started on port " ++ show port
putStr "Reading log..." >> hFlush stdout
time <- offsetTime
log <- logCreate (if logs == "" then Left stdout else Right logs) $
\x -> "hoogle=" `isInfixOf` x && not ("is:ping" `isInfixOf` x)
putStrLn . showDuration =<< time
evaluate spawned
dataDir <- case datadir of
Just d -> return d
Nothing -> getDataDir
haddock <- maybe (return Nothing) (fmap Just . canonicalizePath) haddock
withSearch database $ \store ->
server log cmd $ replyServer log local haddock store cdn home (dataDir "html") scope
actionReplay :: CmdLine -> IO ()
actionReplay Replay{..} = withBuffering stdout NoBuffering $ do
src <- readFile logs
let qs = [readInput url | _:ip:_:url:_ <- map words $ lines src, ip /= "-"]
(t,_) <- duration $ withSearch database $ \store -> do
log <- logNone
dataDir <- getDataDir
let op = replyServer log False Nothing store "" "" (dataDir "html") scope
replicateM_ repeat_ $ forM_ qs $ \x -> do
res <- op x
evaluate $ rnf res
putChar '.'
putStrLn $ "\nTook " ++ showDuration t ++ " (" ++ showDuration (t / intToDouble (repeat_ * length qs)) ++ ")"
{-# NOINLINE spawned #-}
spawned :: UTCTime
spawned = unsafePerformIO getCurrentTime
replyServer :: Log -> Bool -> Maybe FilePath -> StoreRead -> String -> String -> FilePath -> String -> Input -> IO Output
replyServer log local haddock store cdn home htmlDir scope Input{..} = case inputURL of
-- without -fno-state-hack things can get folded under this lambda
[] -> do
let grab name = [x | (a,x) <- inputArgs, a == name, x /= ""]
let qScope = let xs = grab "scope" in [scope | null xs && scope /= ""] ++ xs
let qSource = grab "hoogle" ++ filter (/= "set:stackage") qScope
let q = concatMap parseQuery qSource
let (q2, results) = search store q
let body = showResults local haddock (filter ((/= "mode") . fst) inputArgs) q2 $
dedupeTake 25 (\t -> t{targetURL="",targetPackage=Nothing, targetModule=Nothing}) results
case lookup "mode" $ reverse inputArgs of
Nothing | qSource /= [] -> fmap OutputHTML $ templateRender templateIndex $ map (second str)
[("tags",tagOptions qScope)
,("body",body)
,("title",unwords qSource ++ " - Hoogle")
,("search",unwords $ grab "hoogle")
,("robots",if any isQueryScope q then "none" else "index")]
| otherwise -> OutputHTML <$> templateRender templateHome []
Just "body" -> OutputHTML <$> if null qSource then templateRender templateEmpty [] else return $ lstrPack body
Just "json" -> return $ OutputJSON $ JSON.encode $ take 100 results
Just m -> return $ OutputFail $ lstrPack $ "Mode " ++ m ++ " not (currently) supported"
["plugin","jquery.js"] -> OutputFile <$> JQuery.file
["plugin","jquery.flot.js"] -> OutputFile <$> Flot.file Flot.Flot
["plugin","jquery.flot.time.js"] -> OutputFile <$> Flot.file Flot.FlotTime
["canary"] -> do
now <- getCurrentTime
summ <- logSummary log
let errs = sum [summaryErrors | Summary{..} <- summ, summaryDate >= pred (utctDay now)]
let alive = fromRational $ toRational $ (now `diffUTCTime` spawned) / (24 * 60 * 60)
let s = show errs ++ " errors since yesterday, running for " ++ showDP 2 alive ++ " days."
return $ if errs == 0 && alive < 1.5 then OutputText $ lstrPack $ "Happy. " ++ s else OutputFail $ lstrPack $ "Sad. " ++ s
["log"] -> do
log <- displayLog <$> logSummary log
OutputHTML <$> templateRender templateLog [("data",str log)]
["stats"] -> do
stats <- getStatsDebug
return $ case stats of
Nothing -> OutputFail $ lstrPack "GHC Statistics is not enabled, restart with +RTS -T"
Just x -> OutputText $ lstrPack $ replace ", " "\n" $ takeWhile (/= '}') $ drop 1 $ dropWhile (/= '{') $ show x
"haddock":xs | Just x <- haddock -> do
let file = intercalate "/" $ filter (not . (== "..")) (x:xs)
return $ OutputFile $ file ++ (if hasTrailingPathSeparator file then "index.html" else "")
"file":xs | local -> do
let x = ['/' | not isWindows] ++ intercalate "/" (dropWhile null xs)
let file = x ++ (if hasTrailingPathSeparator x then "index.html" else "")
if takeExtension file /= ".html" then
return $ OutputFile file
else do
src <- readFile file
-- Haddock incorrectly generates file:// on Windows, when it should be file:///
-- so replace on file:// and drop all leading empty paths above
return $ OutputHTML $ lstrPack $ replace "file://" "/file/" src
xs ->
-- avoid "" and ".." in the URLs, since they could be trying to browse on the server
return $ OutputFile $ joinPath $ htmlDir : filter (not . all (== '.')) xs
where
str = templateStr . lstrPack
tagOptions sel = concat [tag "option" ["selected=selected" | x `elem` sel] x | x <- completionTags store]
params = map (second str)
[("cdn",cdn)
,("home",home)
,("jquery",if null cdn then "plugin/jquery.js" else JQuery.url)
,("version",showVersion version ++ " " ++ showUTCTime "%Y-%m-%d %H:%M" spawned)]
templateIndex = templateFile (htmlDir "index.html") `templateApply` params
templateEmpty = templateFile (htmlDir "welcome.html")
templateHome = templateIndex `templateApply` [("tags",str $ tagOptions []),("body",templateEmpty),("title",str "Hoogle"),("search",str ""),("robots",str "index")]
templateLog = templateFile (htmlDir "log.html") `templateApply` params
dedupeTake :: Ord k => Int -> (v -> k) -> [v] -> [[v]]
dedupeTake n key = f [] Map.empty
where
-- map is Map k [v]
f res mp xs | Map.size mp >= n || null xs = map (reverse . (Map.!) mp) $ reverse res
f res mp (x:xs) | Just vs <- Map.lookup k mp = f res (Map.insert k (x:vs) mp) xs
| otherwise = f (k:res) (Map.insert k [x] mp) xs
where k = key x
showResults :: Bool -> Maybe FilePath -> [(String, String)] -> [Query] -> [[Target]] -> String
showResults local haddock args query results = unlines $
["" ++ renderQuery query ++ " "
,""
,"Packages "] ++
[" No results found
" | null results] ++
["" ++
"
" ++
"
" ++ showFroms local haddock is ++ "
" ++
"
" ++ targetDocs ++ "
" ++
"
" ++
(if cat == "package" then "" else cat ++ ":") ++ val ++ " "
itemCategories :: [Target] -> [(String,String)]
itemCategories xs =
[("is","exact")] ++
[("is","package") | any ((==) "package" . targetType) xs] ++
[("is","module") | any ((==) "module" . targetType) xs] ++
nubOrd [("package",p) | Just (p,_) <- map targetPackage xs]
showFroms :: Bool -> Maybe FilePath -> [Target] -> String
showFroms local haddock xs = intercalate ", " $ for pkgs $ \p ->
let ms = filter ((==) p . targetPackage) xs
in unwords ["" ++ a ++ " " | (a,b) <- catMaybes $ p : map remod ms]
where
remod Target{..} = do (a,_) <- targetModule; return (a,targetURL)
pkgs = nubOrd $ map targetPackage xs
showURL :: Bool -> Maybe FilePath -> URL -> String
showURL _ (Just _) x = "haddock" ++ x
showURL True _ (stripPrefix "file:///" -> Just x) = "file/" ++ x
showURL _ _ x = x
-------------------------------------------------------------
-- DISPLAY AN ITEM (bold keywords etc)
highlightItem :: [Query] -> String -> String
highlightItem qs x
| Just (pre,x) <- stripInfix "<0>" x, Just (name,post) <- stripInfix "" x = pre ++ highlight (unescapeHTML name) ++ post
| otherwise = x
where
highlight = concatMap (\xs@((b,_):_) -> let s = escapeHTML $ map snd xs in if b then "" ++ s ++ " " else s) .
groupOn fst . (\x -> zip (f x) x)
where
f (x:xs) | m > 0 = replicate m True ++ drop (m - 1) (f xs)
where m = maximum $ 0 : [length y | QueryName y <- qs, lower y `isPrefixOf` lower (x:xs)]
f (x:xs) = False : f xs
f [] = []
displayItem :: [Query] -> String -> String
displayItem = highlightItem
action_server_test_ :: IO ()
action_server_test_ = do
testing "Action.Server.displayItem" $ do
let expand = replace "{" "" . replace "}" " " . replace "<0>" "" . replace "" ""
contract = replace "{" "" . replace "}" ""
let q === s | displayItem (parseQuery q) (contract s) == expand s = putChar '.'
| otherwise = error $ show (q,s,displayItem (parseQuery q) (contract s))
"test" === "<0>my{Test} :: Int -> test"
"new west" === "<0>{newest}_{new} :: Int"
"+*" === "(<0>{+*}&) :: Int"
"+<" === "(<0>>{+<}) :: Int"
"foo" === "data <0>{Foo}d"
"foo" === "type <0>{Foo}d"
"foo" === "type family <0>{Foo}d"
"foo" === "module Foo.Bar.<0>F{Foo}"
"foo" === "module <0>{Foo}o"
action_server_test :: Bool -> FilePath -> IO ()
action_server_test sample database = do
testing "Action.Server.replyServer" $ withSearch database $ \store -> do
log <- logNone
dataDir <- getDataDir
let q === want = do
OutputHTML (lstrUnpack -> res) <- replyServer log False Nothing store "" "" (dataDir "html") "" (Input [] [("hoogle",q)])
if want `isInfixOf` res then putChar '.' else fail $ "Bad substring: " ++ res
if sample then
"Wife" === "type family "
else do
"<>" === "(<> ) "
"filt" === "filt erWelcome to Hoogle
Warning: Alpha version, type search doesn't work !
Hoogle is a Haskell API search engine, which allows you to search the Haskell libraries
on Stackage by either function name, or by approximate type signature.
Example searches:map (a -> b) -> [a] -> [b] Ord a => [a] -> [a] Data.Set.insert +bytestring concat
The Hoogle manual contains more details,
including further details on search queries, how to install Hoogle as a command line application
and how to integrate Hoogle with Firefox/Emacs/Vim etc.
I am very interested in any feedback you may have. Please
email me , or add an entry to my
bug tracker .
hoogle-5.0.17.3/html/search.xml 0000644 0000000 0000000 00000002053 13265310054 014342 0 ustar 00 0000000 0000000
Hoogle
Hoogle - Haskell API Search
Hoogle is a Haskell API search engine, which allows you to
search many standard Haskell libraries by either function name,
or by approximate type signature.
haskell
http://hoogle.haskell.org/favicon.png
http://hoogle.haskell.org/favicon64.png
Neil Mitchell
false
en-us
UTF-8
UTF-8
hoogle-5.0.17.3/html/more_small.png 0000644 0000000 0000000 00000000225 13265310054 015212 0 ustar 00 0000000 0000000 PNG
IHDR [A PLTENN~׃ 8IDATxc(/VR2/g()/w g(L/`/g0)/`/wfPQE @ P%P
PP [u.h IENDB` hoogle-5.0.17.3/html/more_gray.png 0000644 0000000 0000000 00000000200 13265310054 015035 0 ustar 00 0000000 0000000 PNG
IHDR
PX GIDATxcL]bw$ Zˀ,D*H!)?< , J xi=\ IENDB` hoogle-5.0.17.3/html/more_blue.png 0000644 0000000 0000000 00000000314 13265310054 015030 0 ustar 00 0000000 0000000 PNG
IHDR ˰ IDATxAFz z!&2pwwww9;`|z| - /HC%!:Nt: =v2t2V+B$ _ VH ģU7P*FPl֚Ha5$$+*-
#4 IENDB` hoogle-5.0.17.3/html/log.html 0000644 0000000 0000000 00000004512 13265310054 014024 0 ustar 00 0000000 0000000
Log view
Hoogle Log
Users
Timings
Errors
hoogle-5.0.17.3/html/less_small.png 0000644 0000000 0000000 00000000224 13265310054 015215 0 ustar 00 0000000 0000000 PNG
IHDR [A PLTENN/3 7IDATxc(/VR2/g()/w g(L///g0)guUĠ 0
*U 5 ?$ IENDB` hoogle-5.0.17.3/html/less_gray.png 0000644 0000000 0000000 00000000173 13265310054 015052 0 ustar 00 0000000 0000000 PNG
IHDR
PX BIDATxcLΝ?bv$ rXU'Ճnx g ( ~E % IENDB` hoogle-5.0.17.3/html/less_blue.png 0000644 0000000 0000000 00000000324 13265310054 015035 0 ustar 00 0000000 0000000 PNG
IHDR ˰ IDATx@᭑ g: q9.n{Bb>
dx*NʥV5 Ky6M^q jXy`1E5fxD1">M))㹒(=H[x } y"6u7k IENDB` hoogle-5.0.17.3/html/index.html 0000644 0000000 0000000 00000003704 13265310054 014354 0 ustar 00 0000000 0000000
#{title}
hoogle-5.0.17.3/html/hoogle.png 0000644 0000000 0000000 00000003652 13265310054 014344 0 ustar 00 0000000 0000000 PNG
IHDR : : PLTEٳ >'t)Ҥҙ2۶ۃ
V*ĉjرإK
D,=lҥҬY8"P̘ĈĬXCO!Ncݻݮ] EΜ\7Ϟφ
Æn{ + ժզLAk۷۷oJ^~.H (˗֤֭I׃Çܹܽz pɒRhٲʔʊ&ΝΏ ŋӦӋ3q ݺƌmFѣڵի߾ߞ<̙̦MʕС?͚͉ׯז-r;_ivڴ֬ذػw:ƍy@WZ4ǎǼx5eɓɩS}1dР#%GgȑȘ0f[ ȐǏ˖ܸѢa/߿ߒ$6NZ IDATxփ [xqqv2o۶m۶ly콧{lf-[7V"hU8+ jbRuM X
|
C6qP
lڬ9Vн1C6P)nb<b {a -Q}-[զmŵбS]"[ ={:ۯ\1HEvNnrug2Taq 0
8RU^VefʨђUߘ o,qg0EFM$ɲhjiX O&rM#όI=g( .0
Ɯ2/XHb%m^61rI+0Vi>X>9bVH[#Z[TZccp09 h+4ض^j]֢ XJaRU,)W~{0سJ5/G:̒c>>99TV0L8q4Qu08B GC@
t!0[< ň)92&S ds覱yN :qN@d]bc@KN-O syF`W uTe-pEdyҁSQr- IUIT=Mn875%x`Im re⮻"VG &qW O+ Nyn%z2pԔ E[?L^G/
Q*'W%' ,y BItuれ~6X}P xKE6j%Eaz1^JŸ^FM^^|e IxƯ>Q d4Vz듀 oHV̛ه [7D i=0Je|g}CI cL,s v{,!O`ɚJ}Meu#P*˽?sgs9^H@ob*K|VYTTr㕃^>-wXJgW 7}8:w:8>IeBP_ iɕ..#^6?K8j&yN叽
n!S?"O,㒚})U:W\{ǯ M=M xLt[}ГFXޚДr??/(ߟr[ IENDB` hoogle-5.0.17.3/html/hoogle.js 0000644 0000000 0000000 00000031411 13265310054 014166 0 ustar 00 0000000 0000000
// PERHAPS I SHOULD BE USING Bootstrap with:
// http://silviomoreto.github.io/bootstrap-select/
var embed = false; // are we running as an embedded search box
var instant = true; // should we search on key presses
var query = parseQuery(); // what is the current query string
var $hoogle; // $("#hoogle") after load
/////////////////////////////////////////////////////////////////////
// SEARCHING
function on_arrow_press(ev) {
var offset = 0;
if (ev.keyCode == Key.Up) {
offset = -1;
} else if (ev.keyCode == Key.Down) {
offset = +1;
} else if (ev.keyCode != Key.Return) {
return;
}
// Figure out where we are
var results = $("div#body .result");
var activeResults = $("div#body .result.active");
var activeRow = -1;
if (activeResults.length == 1) {
activeRow = results.index(activeResults[0]);
}
if (ev.keyCode == Key.Return) {
if (activeRow >= 0)
document.location.href = $("a", activeResults).attr("href");
} else {
var newRow = activeRow + offset;
var $activeRow = $(results[activeRow]);
if (newRow < 0) {
$activeRow.removeClass("active");
$hoogle.focus();
} else if (newRow < results.length) {
var $newRow = $(results[newRow]);
if (activeRow >= 0)
$activeRow.removeClass("active");
$newRow.addClass("active");
$hoogle.blur();
}
}
}
$(function() {
$(document).keyup(on_arrow_press);
});
$(function(){
$hoogle = $("#hoogle");
var $form = $hoogle.parents("form:first");
var $scope = $form.find("[name=scope]");
embed = !$hoogle.hasClass("HOOGLE_REAL");
if (!embed) $scope.chosen({"search_contains":true});
var self = embed ? newEmbed() : newReal();
var ajaxUrl = !embed ? "?" : $form.attr("action") + "?";
var ajaxMode = embed ? 'embed' : 'body';
var active = $hoogle.val() + " " + $scope.val(); // What is currently being searched for (may not yet be displayed)
var past = cache(100); // Cache of previous searches
var watch = watchdog(500, function(){self.showWaiting();}); // Timeout of the "Waiting..." callback
function hit(){
if (!instant) return;
function getScope(){return $scope && $scope.val() !== "set:stackage" ? $scope.val() : "";}
var nowHoogle = $hoogle.val();
var nowScope = getScope();
var now = nowHoogle + " " + nowScope;
if (now == active) return;
active = now;
var title = now + (now == " " ? "" : " - ") + "Hoogle";
query["hoogle"] = nowHoogle;
query["scope"] = nowScope;
if (!embed){
if (window.history)
window.history.replaceState(null, title, renderQuery(query));
$("title").text(title);
}
var old = past.ask(now);
if (old != undefined){self.showResult(old); return;}
watch.stop();
if (embed && now == ""){self.hide(); return;}
watch.start();
var data = {hoogle:nowHoogle, scope:nowScope, mode:ajaxMode};
function complete(e)
{
watch.stop();
var current = $hoogle.val() + " " + getScope() == now;
if (e.status == 200)
{
past.add(now,e.responseText);
if (current)
self.showResult(e.responseText);
}
else if (current)
self.showError(e.status, e.responseText);
}
var args = {url:ajaxUrl, data:data, complete:complete, dataType:"html"}
try {
$.ajax(args);
} catch (err) {
try {
if (!embed) throw err;
$.ajaxCrossDomain(args);
} catch (err) {
// Probably a permissions error from cross domain scripting...
watch.stop();
}
}
};
$hoogle.keyup(hit);
$scope.change(hit);
})
function newReal()
{
$hoogle.focus();
$hoogle.select();
var $body = $("#body");
return {
showWaiting: function(){$("h1").text("Still working...");},
showError: function(status,text){$body.html("Error: status " + status + "" + text + "
")},
showResult: function(text){$body.html(text); newDocs();}
}
}
function newEmbed()
{
$hoogle.attr("autocomplete","off");
// IE note: unless the div in the iframe contain any border it doesn't calculate the correct outerHeight()
// therefore we put 3 borders on the iframe, and leave one for the bottom div
var $iframe = $("");
var $body;
$iframe.load(function(){
var $contents = $iframe.contents();
$contents.find("head").html(
"");
$body = $("").appendTo($contents.find("body"));
});
$iframe.insertBefore($hoogle);
var finishOnBlur = true; // Should a blur hide the box
function show(x){
if (x == undefined)
$iframe.css("display","none");
else {
$body.html(x).find("a").attr("target","_parent")
.mousedown(function(){finishOnBlur = false;})
.mouseup(function(){finishOnBlur = true;})
.mouseenter(function(){
$body.find(".sel").removeClass("sel");
$(this).addClass("sel");
});
var pos = $hoogle.position();
// need to display before using $body.outerHeight() on Firefox
$iframe.css("display","").css(
{top:px(pos.top + $hoogle.outerHeight() + unpx($hoogle.css("margin-top")))
,left:px(pos.left + unpx($hoogle.css("margin-left")))
,width:px($hoogle.outerWidth() - 2 /* iframe border */)
,height:$body.outerHeight()
});
}
}
$hoogle.blur(function(){if (finishOnBlur) show();});
$hoogle.keydown(function(event){
switch(event.which)
{
case Key.Return:
var sel = $body.find(".sel:first");
if (sel.size() == 0) return;
event.preventDefault();
document.location.href = sel.attr("href");
break;
case Key.Escape:
$body.find(".sel").removeClass("sel");
show();
break;
case Key.Down: case Key.Up:
var i = event.which == Key.Down ? 1 : -1;
var all = $body.find("a");
var sel = all.filter(".sel");
var now = all.index(sel);
if (now == -1)
all.filter(i == 1 ? ":first" : ":last").addClass("sel");
else {
sel.removeClass("sel");
// IE treats :eq(-1) as :eq(0), so filter specifically
if (now+i >= 0) all.filter(":eq(" + (now+i) + ")").addClass("sel");
}
event.preventDefault();
break;
}
});
return {
showWaiting: function(){show("Still working... ");},
showError: function(status,text){show("Error: status " + status + " ");},
showResult: function(text){show(text);},
hide: function(){show();}
}
}
/////////////////////////////////////////////////////////////////////
// SEARCH PLUGIN
var prefixUrl = document.location.protocol + "//" + document.location.hostname + document.location.pathname;
$(function(){
if (embed) return;
if (prefixUrl != "http://hoogle.haskell.org/")
{
$("link[rel=search]").attr("href", function(){
return this.href + "?domain=" + escape(prefixUrl);
});
}
if (window.external && ("AddSearchProvider" in window.external))
$("#plugin").css("display","");
});
function searchPlugin()
{
var url = $("link[rel=search]").attr("href");
// If neither scheme(http(s)://) nor DSN prefix(//) is in URL then we
// should add prefix.
if (url.indexOf('://') === -1 && url.indexOf('//') !== 0)
url = prefixUrl + url;
window.external.AddSearchProvider(url);
}
/////////////////////////////////////////////////////////////////////
// DOCUMENTATION
$(function(){
if (embed) return;
$(window).resize(resizeDocs);
newDocs();
});
function resizeDocs()
{
$("#body .doc").each(function(){
// If a segment is open, it should remain open forever
var $this = $(this);
var toosmall = ($.support.preWrap && $this.hasClass("newline")) ||
($this.height() < $this.children().height());
if (toosmall && !$this.hasClass("open"))
$this.addClass("shut");
else if (!toosmall && $this.hasClass("shut"))
$this.removeClass("shut");
});
}
function newDocs()
{
resizeDocs();
$("#body .doc").click(function(){
var $this = $(this);
if ($this.hasClass("open") || $this.hasClass("shut"))
$this.toggleClass("open").toggleClass("shut");
});
}
/////////////////////////////////////////////////////////////////////
// iOS TWEAKS
$(function(){
if ($.support.inputSearch)
$("#hoogle")[0].type = "search";
var qphone = query["phone"];
phone =
qphone == "0" ? false :
qphone == "1" ? true :
$.support.phone;
if (!phone) return;
$("body").addClass("phone");
$("head").append("l gvO_ߍy}u6Zʵn?"rIrP8 Űs OIQoadEcu#?x &*I)x8Ds!%\. }(g}THR@pَ 5
咟As?h
ߏX| gq4>9
F/8g{Փ$=I|۞G^: IENDB` hoogle-5.0.17.3/html/favicon.png 0000644 0000000 0000000 00000000420 13265310054 014502 0 ustar 00 0000000 0000000 PNG
IHDR a IDATx%\A@qNAACz$
l/8 o}wzϛƇw#)S@#}'+
CtC~u'0_j 0ֽ:B fK/ij QC
Ϧ!)p˜gi>_d~TL+@=Nqv@5ްc8JE IENDB` hoogle-5.0.17.3/cbits/ 0000755 0000000 0000000 00000000000 13265310054 012513 5 ustar 00 0000000 0000000 hoogle-5.0.17.3/cbits/text_search.c 0000644 0000000 0000000 00000007146 13265310054 015200 0 ustar 00 0000000 0000000 #include
#include
int min_int(int a, int b){return a > b ? b : a;}
int max_int(int a, int b){return a < b ? b : a;}
int maximum_int(int xs[], int n)
{
int mx = 0;
for (int i = 0; i < n; i++)
mx = max_int(mx, xs[i]);
return mx;
}
// Given a list of words, separated by 0 and ending with two 0
// Find the character that occurs in most words, and return the count of it
int text_search_bound(char* xs)
{
int counts[256]; // number of words I've seen each char in
int poss[256]; // position I saw last char at
int pos = 0; // the current position I am at
for (int i = 0; i < 256; i++)
{
counts[i] = 0;
poss[i] = -1;
}
for (char* cs = xs; ; cs++)
{
unsigned char c = *cs;
if (c == 0)
{
if (cs[1] == 0) break;
pos++;
}
else if (poss[c] != pos)
{
poss[c] = pos;
counts[c]++;
}
}
return maximum_int(counts, 256);
}
int count_pointers(char** xs)
{
int i;
for (i = 0; xs[i] != NULL; i++)
;
return i;
}
int compare_int(const void *a, const void *b)
{
const int *da = (const int*) a;
const int *db = (const int*) b;
return (*da > *db) - (*da < *db);
}
// Taken from http://stackoverflow.com/questions/23999797/implementing-strnstr/24000056#24000056
char* memmem_(char* haystack, size_t hlen, char* needle, size_t nlen)
{
if (nlen == 0) return haystack; // degenerate edge case
if (hlen < nlen) return 0; // another degenerate edge case
char *hlimit = haystack + hlen - nlen + 1;
while ((haystack = memchr(haystack, needle[0], hlimit-haystack)))
{
if (!memcmp(haystack, needle, nlen)) return haystack;
haystack++;
}
return 0;
}
// haystack is \0 (space if leading upper) (lowercase string), ends with two \0
// needles are a NULL terminated list of lowercase strings, with a leading space if upper
int text_search(char* haystack, char** needles, int exact, int* results)
{
// information about the needles
int n = count_pointers(needles);
int uppers[n]; // is this needle uppercase prefix
int lengths[n]; // length of this needle
char* strings[n]; // actual text of this needle
for (int i = 0; i < n; i++)
{
uppers[i] = needles[i][0] == ' ';
strings[i] = uppers[i] ? &needles[i][1] : needles[i];
lengths[i] = strlen(strings[i]);
}
int index = 0; // Number of \n's I've already seen in haystack
int found = 0; // Number I've written to results
for (index = 0; ; index++)
{
int upper = haystack[0] == ' ';
if (upper) haystack++;
int length = strlen(haystack);
if (length == 0) break;
char* string = haystack;
haystack = &haystack[length+1];
int score = 4;
for (int i = 0; i < n; i++)
{
char* pos = strstr(string, strings[i]); // length, strings[i], lengths[i]);
if (pos == NULL)
{
score = -1;
break;
}
else if (pos == string)
{
int complete = lengths[i] == length;
int cased = uppers[i] == upper;
score = min_int(score, (!complete ? 2 : 0) + (!cased ? 1 : 0));
}
}
if (score >= 0 && (!exact || score == 0))
results[found++] = (score << 24) | index;
}
qsort(results, found, sizeof(int), compare_int);
for (int i = 0; i < found; i++)
results[i] = results[i] & 0xffffff;
return found;
}
hoogle-5.0.17.3/cbits/include.h 0000644 0000000 0000000 00000000154 13265310054 014307 0 ustar 00 0000000 0000000
int text_search(char* haystack, char** needles, int exact, int* results);
int text_search_bound(char* xs);