hoogle 5.0.17.3 → 5.0.17.4
raw patch · 29 files changed
+953/−343 lines, 29 filesdep +foundationdep +hashabledep −networkdep ~haskell-src-extsdep ~network-uriPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: foundation, hashable
Dependencies removed: network
Dependency ranges changed: haskell-src-exts, network-uri
API changes (from Hackage documentation)
- Hoogle: Target :: URL -> Maybe (String, URL) -> Maybe (String, URL) -> String -> String -> String -> Target
+ Hoogle: Target :: URL -> Maybe (PkgName, URL) -> Maybe (ModName, URL) -> String -> String -> String -> Target
- Hoogle: [targetModule] :: Target -> Maybe (String, URL)
+ Hoogle: [targetModule] :: Target -> Maybe (ModName, URL)
- Hoogle: [targetPackage] :: Target -> Maybe (String, URL)
+ Hoogle: [targetPackage] :: Target -> Maybe (PkgName, URL)
Files
- CHANGES.txt +7/−0
- README.md +12/−3
- hoogle.cabal +6/−13
- html/hoogle.css +13/−10
- html/index.html +0/−1
- src/Action/CmdLine.hs +2/−0
- src/Action/Generate.hs +49/−43
- src/Action/Search.hs +220/−14
- src/Action/Server.hs +38/−25
- src/Action/Test.hs +1/−0
- src/General/Conduit.hs +3/−3
- src/General/IString.hs +10/−11
- src/General/Log.hs +13/−10
- src/General/Store.hs +21/−20
- src/General/Str.hs +62/−32
- src/General/Template.hs +12/−12
- src/General/Timing.hs +1/−1
- src/General/Util.hs +12/−7
- src/General/Web.hs +2/−2
- src/Input/Cabal.hs +23/−23
- src/Input/Download.hs +1/−2
- src/Input/Haddock.hs +20/−20
- src/Input/Item.hs +53/−18
- src/Input/Reorder.hs +5/−3
- src/Output/Items.hs +5/−4
- src/Output/Names.hs +4/−4
- src/Output/Tags.hs +16/−16
- src/Output/Types.hs +341/−46
- src/Query.hs +1/−0
CHANGES.txt view
@@ -1,5 +1,12 @@ Changelog for Hoogle +5.0.17.4, released 2018-12-10+ Require haskell-src-exts-1.21+ #271, added FromJSON instance for Target+ #253, adds JSON pagination from query parameters+ Make sure <h1> works well in doc snippets+ #251, make sure transformers is more popular than mtl+ Require network-uri >= 2.6, don't require network 5.0.17.3, released 2018-04-17 Require extra-1.6.6 Fix the reported memory sizes
README.md view
@@ -1,10 +1,19 @@-# Hoogle [](https://hackage.haskell.org/package/hoogle) [](https://www.stackage.org/package/hoogle) [](https://travis-ci.org/ndmitchell/hoogle) [](https://ci.appveyor.com/project/ndmitchell/hoogle)+# Hoogle [](https://hackage.haskell.org/package/hoogle) [](https://www.stackage.org/package/hoogle) [](https://travis-ci.org/ndmitchell/hoogle) [](https://ci.appveyor.com/project/ndmitchell/hoogle) -The development branch for Hoogle version 5. The current released version lives on the `hoogle4` branch. For details of the current state and future direction see [this blog post](http://neilmitchell.blogspot.co.uk/2015/01/hoogle-5-is-coming.html).+## Hoogle 4 vs Hoogle 5 +Hoogle is in the middle of a transition from version 4 to version 5.++Hoogle 4 is at https://www.haskell.org/hoogle/. It searches the [Haskell platform](https://www.haskell.org/platform/contents.html) as-of 2013. It has good type search.++Hoogle 5 is at https://hoogle.haskell.org/ and on Hackage, so will be obtained by `cabal install hoogle`. It searches [Stackage](https://www.stackage.org/) and is updated daily. It has weaker type search, with various tickets to improve that.++## Other stuff (somewhat outdated)++ ---------- -**This page describes how Hoogle 5 might work, and has not yet been fully implemented.** +**This page describes how Hoogle 5 might work, and has not yet been fully implemented.** ----------
hoogle.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hoogle-version: 5.0.17.3+version: 5.0.17.4 license: BSD3 license-file: LICENSE category: Development@@ -15,7 +15,7 @@ or by approximate type signature. homepage: http://hoogle.haskell.org/ bug-reports: https://github.com/ndmitchell/hoogle/issues-tested-with: GHC==8.4.1, GHC==8.2.2, GHC==8.0.2+tested-with: GHC==8.6.1, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2 extra-doc-files: README.md CHANGES.txt@@ -37,20 +37,10 @@ type: git location: https://github.com/ndmitchell/hoogle.git -flag network-uri- default: True- manual: False- description: Get Network.URI from the network-uri package- library hs-source-dirs: src default-language: Haskell2010 - if flag(network-uri)- build-depends: network-uri >= 2.6, network >= 2.6- else- build-depends: network-uri < 2.6, network < 2.6- build-depends: QuickCheck, aeson,@@ -66,13 +56,16 @@ directory, extra >= 1.6.6, filepath,+ foundation >= 0.0.13, old-locale,- haskell-src-exts >= 1.18 && < 1.21,+ hashable,+ haskell-src-exts >= 1.21 && < 1.22, http-conduit >= 2.3, http-types, js-flot, js-jquery, mmap,+ network-uri >= 2.6, process-extras, resourcet, storable-tuple,
html/hoogle.css view
@@ -11,10 +11,15 @@ padding: 0px; font-family: sans-serif; font-size: 13px;- position: relative;- min-height: 100%;+ min-height: 100vh;+ display: flex;+ flex-direction: column; } +#body {+ flex-grow: 1;+}+ a img { padding: 0px; margin: 0px;@@ -30,16 +35,11 @@ text-decoration: none; } -.push {- height: 4em;-}- /******************************************************************** * TOP - LINKS AND SEARCH */ #links {- position: relative; background: none repeat scroll 0 0 #293845; border-top: 5px solid #4E6272; color: #DDDDDD;@@ -62,7 +62,7 @@ } #top-menu li a,-#top-menu li a:link, +#top-menu li a:link, #top-menu li a:visited { font-size: 85%; color: white;@@ -166,8 +166,6 @@ color: #666666; width: 100%; padding: 1.3em 0;- position: absolute;- bottom: 0; text-align: center; } @@ -303,6 +301,11 @@ } .doc, .doc a { color: #888;+}+.doc h1, .doc h2, .doc h3, .doc h4, .doc h5, .doc h6 {+ font-size: 11px;+ display: inline;+ padding: 0px; } .open, .shut {padding-left: 13px;}
html/index.html view
@@ -32,7 +32,6 @@ </form> <div id="body"> #{body}- <div class="push"></div> </div> <div id="footer">© <a href="http://ndmitchell.com">Neil Mitchell</a> 2004-2018, version #{version}</div> </body>
src/Action/CmdLine.hs view
@@ -37,6 +37,7 @@ ,database :: FilePath ,insecure :: Bool ,include :: [String]+ ,count :: Int ,local_ :: [FilePath] ,haddock :: Maybe FilePath ,debug :: Bool@@ -121,6 +122,7 @@ ,insecure = def &= help "Allow insecure HTTPS connections" ,include = def &= args &= typ "PACKAGE" ,local_ = def &= opt "" &= help "Index local packages and link to local haddock docs"+ ,count = 0 &= name "n" &= help "Maximum number of packages to index (defaults to all)" ,haddock = def &= help "Use local haddocks" ,debug = def &= help "Generate debug information" } &= help "Generate Hoogle databases"
src/Action/Generate.hs view
@@ -11,8 +11,7 @@ import Data.IORef import Data.Maybe import qualified Data.Set as Set-import qualified Data.Map as Map-import qualified Data.Text as T+import qualified Data.Map.Strict as Map import Control.Monad.Extra import Data.Monoid import Data.Ord@@ -36,6 +35,7 @@ import General.Str import Action.CmdLine import General.Conduit+import Control.DeepSeq {- @@ -92,7 +92,7 @@ type Download = String -> URL -> IO FilePath -readHaskellOnline :: Timing -> Settings -> Download -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ())+readHaskellOnline :: Timing -> Settings -> Download -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) readHaskellOnline timing settings download = do stackage <- download "haskell-stackage.txt" "https://www.stackage.org/lts/cabal.config" platform <- download "haskell-platform.txt" "https://raw.githubusercontent.com/haskell/haskell-platform/master/hptool/src/Releases2015.hs"@@ -100,27 +100,27 @@ hoogles <- download "haskell-hoogle.tar.gz" "https://hackage.haskell.org/packages/hoogle.tar.gz" -- peakMegabytesAllocated = 2- setStackage <- setStackage stackage- setPlatform <- setPlatform platform- setGHC <- setGHC platform+ setStackage <- Set.map strPack <$> setStackage stackage+ setPlatform <- Set.map strPack <$> setPlatform platform+ setGHC <- Set.map strPack <$> setGHC platform cbl <- timed timing "Reading Cabal" $ parseCabalTarball settings cabals- let want = Set.insert "ghc" $ Set.unions [setStackage, setPlatform, setGHC]+ let want = Set.insert (strPack "ghc") $ Set.unions [setStackage, setPlatform, setGHC] cbl <- return $ flip Map.mapWithKey cbl $ \name p -> p{packageTags =- [(T.pack "set",T.pack "included-with-ghc") | name `Set.member` setGHC] ++- [(T.pack "set",T.pack "haskell-platform") | name `Set.member` setPlatform] ++- [(T.pack "set",T.pack "stackage") | name `Set.member` setStackage] +++ [(strPack "set",strPack "included-with-ghc") | name `Set.member` setGHC] +++ [(strPack "set",strPack "haskell-platform") | name `Set.member` setPlatform] +++ [(strPack "set",strPack "stackage") | name `Set.member` setStackage] ++ packageTags p} let source = do tar <- liftIO $ tarballReadFiles hoogles- forM_ tar $ \(takeBaseName -> name, src) ->+ forM_ tar $ \(strPack . takeBaseName -> name, src) -> yield (name, hackagePackageURL name, src) return (cbl, want, source) -readHaskellDirs :: Timing -> Settings -> [FilePath] -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ())+readHaskellDirs :: Timing -> Settings -> [FilePath] -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) readHaskellDirs timing settings dirs = do files <- concatMapM listFilesRecursive dirs -- We reverse/sort the list because of #206@@ -128,70 +128,71 @@ -- We never distinguish on versions, so they are considered equal when reordering -- So put 2.0 first in the list and rely on stable sorting. A bit of a hack. let order a = second Down $ parseTrailingVersion a- let packages = map (takeBaseName &&& id) $ sortOn (map order . splitDirectories) $ filter ((==) ".txt" . takeExtension) files+ let packages = map (strPack . takeBaseName &&& id) $ sortOn (map order . splitDirectories) $ filter ((==) ".txt" . takeExtension) files cabals <- mapM parseCabal $ filter ((==) ".cabal" . takeExtension) files let source = forM_ packages $ \(name, file) -> do- src <- liftIO $ strReadFile file+ src <- liftIO $ bstrReadFile file dir <- liftIO $ canonicalizePath $ takeDirectory file let url = "file://" ++ ['/' | not $ "/" `isPrefixOf` dir] ++ replace "\\" "/" dir ++ "/"- yield (name, url, lstrFromChunks [src])+ yield (name, url, lbstrFromChunks [src]) return (Map.union (Map.fromList cabals)- (Map.fromList $ map ((,mempty{packageTags=[(T.pack "set",T.pack "all")]}) . fst) packages)+ (Map.fromList $ map ((,mempty{packageTags=[(strPack "set",strPack "all")]}) . fst) packages) ,Set.fromList $ map fst packages, source) where parseCabal fp = do src <- readFileUTF8' fp let pkg = readCabal settings src- return (takeBaseName fp, pkg)+ return (strPack $ takeBaseName fp, pkg) -readFregeOnline :: Timing -> Download -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ())+readFregeOnline :: Timing -> Download -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) readFregeOnline timing download = do frege <- download "frege-frege.txt" "http://try.frege-lang.org/hoogle-frege.txt" let source = do- src <- liftIO $ strReadFile frege- yield ("frege", "http://google.com/", lstrFromChunks [src])- return (Map.empty, Set.singleton "frege", source)+ src <- liftIO $ bstrReadFile frege+ yield (strPack "frege", "http://google.com/", lbstrFromChunks [src])+ return (Map.empty, Set.singleton $ strPack "frege", source) -readHaskellGhcpkg :: Timing -> Settings -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ())+readHaskellGhcpkg :: Timing -> Settings -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) readHaskellGhcpkg timing settings = do cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings let source = forM_ (Map.toList cbl) $ \(name,Package{..}) -> whenJust packageDocs $ \docs -> do- let file = docs </> name <.> "txt"+ let file = docs </> strUnpack name <.> "txt" whenM (liftIO $ doesFileExist file) $ do- src <- liftIO $ strReadFile file+ src <- liftIO $ bstrReadFile file docs <- liftIO $ canonicalizePath docs let url = "file://" ++ ['/' | not $ all isPathSeparator $ take 1 docs] ++ replace "\\" "/" (addTrailingPathSeparator docs)- yield (name, url, lstrFromChunks [src])- cbl <- return $ let ts = map (both T.pack) [("set","stackage"),("set","installed")]+ yield (name, url, lbstrFromChunks [src])+ cbl <- return $ let ts = map (both strPack) [("set","stackage"),("set","installed")] in Map.map (\p -> p{packageTags = ts ++ packageTags p}) cbl return (cbl, Map.keysSet cbl, source) -readHaskellHaddock :: Timing -> Settings -> FilePath -> IO (Map.Map String Package, Set.Set String, ConduitT () (String, URL, LStr) IO ())+readHaskellHaddock :: Timing -> Settings -> FilePath -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) readHaskellHaddock timing settings docBaseDir = do cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings let source = forM_ (Map.toList cbl) $ \(name, p@Package{..}) -> do- let docs = docDir name p- file = docBaseDir </> docs </> name <.> "txt"+ let docs = docDir (strUnpack name) p+ file = docBaseDir </> docs </> (strUnpack name) <.> "txt" whenM (liftIO $ doesFileExist file) $ do- src <- liftIO $ strReadFile file+ src <- liftIO $ bstrReadFile file let url = ['/' | not $ all isPathSeparator $ take 1 docs] ++ replace "\\" "/" (addTrailingPathSeparator docs)- yield (name, url, lstrFromChunks [src])- cbl <- return $ let ts = map (both T.pack) [("set","stackage"),("set","installed")]+ yield (name, url, lbstrFromChunks [src])+ cbl <- return $ let ts = map (both strPack) [("set","stackage"),("set","installed")] in Map.map (\p -> p{packageTags = ts ++ packageTags p}) cbl return (cbl, Map.keysSet cbl, source) - where docDir name Package{..} = name ++ "-" ++ T.unpack packageVersion+ where docDir name Package{..} = name ++ "-" ++ strUnpack packageVersion actionGenerate :: CmdLine -> IO () actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtension database "timing" else Nothing) $ \timing -> do putStrLn "Starting generate" createDirectoryIfMissing True $ takeDirectory database+ whenLoud $ putStrLn $ "Generating files to " ++ takeDirectory database download <- return $ downloadInput timing insecure download (takeDirectory database) settings <- loadSettings@@ -202,9 +203,16 @@ | otherwise -> readHaskellDirs timing settings local_ Frege | [] <- local_ -> readFregeOnline timing download | otherwise -> errorIO "No support for local Frege databases"- let (cblErrs, popularity) = packagePopularity cbl- want <- return $ if include /= [] then Set.fromList include else want+ (cblErrs, popularity) <- evaluate $ packagePopularity cbl+ cbl <- evaluate $ Map.map (\p -> p{packageDepends=[]}) cbl -- clear the memory, since the information is no longer used+ evaluate popularity + -- mtl is more popular than transformers, despite having dodgy docs, which is a shame, so we hack it+ popularity <- evaluate $ Map.adjust (max $ 1 + Map.findWithDefault 0 (strPack "mtl") popularity) (strPack "transformers") popularity++ want <- return $ if include /= [] then Set.fromList $ map strPack include else want+ want <- return $ if count == 0 then want else Set.fromList $ take count $ Set.toList want+ (stats, _) <- storeWriteFile database $ \store -> do xs <- withBinaryFile (database `replaceExtension` "warn") WriteMode $ \warnings -> do hSetEncoding warnings utf8@@ -214,8 +222,8 @@ itemWarn <- newIORef 0 let warning msg = do modifyIORef itemWarn succ; hPutStrLn warnings msg - let consume :: ConduitM (Int, (String, URL, LStr)) (Maybe Target, [Item]) IO ()- consume = awaitForever $ \(i, (pkg, url, body)) -> do+ let consume :: ConduitM (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()+ consume = awaitForever $ \(i, (strUnpack -> pkg, url, body)) -> do timedOverwrite timing ("[" ++ show i ++ "/" ++ show (Set.size want) ++ "] " ++ pkg) $ parseHoogle (\msg -> warning $ pkg ++ ":" ++ msg) url body @@ -225,19 +233,17 @@ filterC (flip Set.member want . fst3) .| void ((|$|) (zipFromC 1 .| consume)- (do seen <- fmap Set.fromList $ mapC fst3 .| sinkList-+ (do seen <- fmap Set.fromList $ mapMC (evaluate . force . strCopy . fst3) .| sinkList let missing = [x | x <- Set.toList $ want `Set.difference` seen , fmap packageLibrary (Map.lookup x cbl) /= Just False] liftIO $ putStrLn "" liftIO $ whenNormal $ when (missing /= []) $ do- putStrLn $ "Packages missing documentation: " ++ unwords (sortOn lower missing)+ putStrLn $ "Packages missing documentation: " ++ unwords (sortOn lower $ map strUnpack missing) liftIO $ when (Set.null seen) $ exitFail "No packages were found, aborting (use no arguments to index all of Stackage)"- -- synthesise things for Cabal packages that are not documented forM_ (Map.toList cbl) $ \(name, Package{..}) -> when (name `Set.notMember` seen) $ do- let ret prefix = yield $ fakePackage name $ prefix ++ trim (T.unpack packageSynopsis)+ let ret prefix = yield $ fakePackage name $ prefix ++ trim (strUnpack packageSynopsis) if name `Set.member` want then (if packageLibrary then ret "Documentation not found, so not searched.\n"@@ -256,7 +262,7 @@ itemsMemory <- getStatsCurrentLiveBytes xs <- timed timing "Reordering items" $ return $! reorderItems settings (\s -> maybe 1 negate $ Map.lookup s popularity) xs- timed timing "Writing tags" $ writeTags store (`Set.member` want) (\x -> maybe [] (map (both T.unpack) . packageTags) $ Map.lookup x cbl) xs+ timed timing "Writing tags" $ writeTags store (`Set.member` want) (\x -> maybe [] (map (both strUnpack) . packageTags) $ Map.lookup x cbl) xs timed timing "Writing names" $ writeNames store xs timed timing "Writing types" $ writeTypes store (if debug then Just $ dropExtension database else Nothing) xs
src/Action/Search.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE TupleSections, RecordWildCards, ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase, RecordWildCards, ScopedTypeVariables, TupleSections #-} module Action.Search (actionSearch, withSearch, search@@ -7,23 +7,25 @@ ,action_search_test ) where -import Control.Monad.Extra import Control.DeepSeq+import Control.Monad.Extra+import Data.Functor.Identity+import Data.List.Extra+import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set-import Data.List.Extra-import Data.Functor.Identity import System.Directory +import Action.CmdLine+import General.Store+import General.Str+import General.Util+import Input.Item import Output.Items-import Output.Tags import Output.Names+import Output.Tags import Output.Types-import General.Store import Query-import Input.Item-import Action.CmdLine-import General.Util -- -- generate all -- @tagsoup -- generate tagsoup@@ -50,7 +52,7 @@ let parseType x = case parseQuery x of [QueryType t] -> (pretty t, hseToSig t) _ -> error $ "Expected a type signature, got: " ++ x- putStr $ unlines $ searchTypesDebug store (parseType $ unwords query) (map parseType compare_)+ putStr $ unlines $ searchFingerprintsDebug store (parseType $ unwords query) (map parseType compare_) -- | Returns the details printed out when hoogle --info is called targetInfo :: Target -> String@@ -58,13 +60,13 @@ unlines $ [ unHTML targetItem ] ++ [ unwords packageModule | not $ null packageModule] ++ [ unHTML targetDocs ]- where packageModule = map fst $ catMaybes [targetPackage, targetModule]+ where packageModule = map (strUnpack . fst) $ catMaybes [targetPackage, targetModule] -- | Returns the Target formatted as an item to display in the results -- | Bool argument decides whether links are shown targetResultDisplay :: Bool -> Target -> String targetResultDisplay link Target{..} = unHTML $ unwords $- fmap fst (maybeToList targetModule) +++ fmap (strUnpack . fst) (maybeToList targetModule) ++ [targetItem] ++ ["-- " ++ targetURL | link] @@ -92,7 +94,6 @@ let look = lookupItem store return (qs, map look $ filter filt is) - action_search_test :: Bool -> FilePath -> IO () action_search_test sample database = testing "Action.Search.search" $ withSearch database $ \store -> do let noResults a = do@@ -106,6 +107,16 @@ Target{..}:_ | f targetURL -> putChar '.' _ -> error $ "Searching for: " ++ show a ++ "\nGot: " ++ show (take 1 res) let a === b = a ==$ (== b)++ let query :: String -> [ExpectedQueryResult] -> IO ()+ query a qrs = let results = deDup $ snd (search store (parseQuery a))+ in forM_ qrs $ \qr -> case matchQR qr results of+ Success -> putChar '.'+ ExpectedFailure -> putChar 'o'+ _ -> error $ "Searching for: " ++ show a+ ++ "\nGot: " ++ show (take 5 results)+ ++ "\n expected " ++ expected qr+ let hackage x = "https://hackage.haskell.org/package/" ++ x if sample then do "__prefix__" === "http://henry.com?too_long"@@ -145,7 +156,7 @@ -- FIXME: "author:Neil-M" === hackage "filepath" -- FIXME: "Data.Se.insert" === hackage "containers/docs/Data-Set.html#v:insert" "set:-haskell-platform author:Neil-Mitchell" === hackage "safe"- "author:Neil-Mitchell category:Development" === hackage "hlint"+ "author:Neil-Mitchell category:Javascript" === hackage "js-jquery" "( )" ==$ flip seq True -- used to segfault "( -is:exact) package:base=" ==$ flip seq True "(a -> b) -> [a] -> [b]" === hackage "base/docs/Prelude.html#v:map"@@ -157,9 +168,204 @@ "weeder" === hackage "weeder" -- executable in Stackage "supero" === hackage "supero" + query "(a -> [a]) -> [a] -> [a]"+ [ TopHit ("concatMap" `inPackage` "base")+ , InTop 10 ("(=<<)" `inPackage` "base")+ , InTop 50 ("(>>=)" `inPackage` "base")+ ]+ query "[a] -> Maybe a"+ [ TopHit ("listToMaybe" `inModule` "Data.Maybe")+ , InTop 5 ("headMay" `inModule` "Safe")+ ]+ query "a -> [a]"+ [ InTop 10 ("repeat" `inPackage` "base")+ , InTop 50 ("singleton" `inModule` "Util")+ , DoesNotFind ("head" `inPackage` "base")+ , DoesNotFind ("last" `inPackage` "base")+ , InTop 50 ("pure" `inPackage` "base")+ , InTop 100 ("return" `inPackage` "base")+ , KnownFailure "GitHub issue #267" $+ ("pure" `inPackage` "base") `AppearsBefore` ("shrinkNothing" `inModule` "Test.QuickCheck")+ , KnownFailure "GitHub issue #267" $+ InTop 10 ("pure" `inPackage` "base")+ , KnownFailure "GitHub issue #267" $+ InTop 10 ("return" `inPackage` "base")+ ]+ query "[a] -> a"+ [ InTop 10 ("head" `inPackage` "base")+ , InTop 10 ("last" `inPackage` "base")+ , DoesNotFind ("repeat" `inPackage` "base")+ ]+ query "[Char] -> Char"+ [ InTop 10 ("head" `inPackage` "base")+ , RanksBelow 10 ("mconcat" `inPackage` "base")+ ]+ query "a -> b"+ [ TopHit ("unsafeCoerce" `inModule` "Unsafe.Coerce")+ , DoesNotFind ("id" `inPackage` "base") -- see GitHub issue #180+ , KnownFailure "GitHub issue #268" $+ InTop 20 ("coerce" `inModule` "Data.Coerce")+ , KnownFailure "GitHub issue #268" $+ InTop 5 ("coerce" `inModule` "Data.Coerce")+ ]+ query "String -> (Char -> Maybe Char) -> Maybe String" -- c/o @ndrssmn+ [ KnownFailure "GitHub issue #266" $+ InTop 10 ("traverse" `inPackage` "base")+ , KnownFailure "GitHub issue #266" $+ InTop 10 ("mapM" `inPackage` "base")+ , KnownFailure "GitHub issue #266" $+ InTop 10 ("forM" `inPackage` "base")+ ]+ query "a -> [(a,b)] -> b"+ [ TopHit ("lookup" `inPackage` "base")+ , DoesNotFind ("zip" `inPackage` "base")+ ]+ query "[(a,b)] -> a -> b"+ [ TopHit ("lookup" `inPackage` "base")+ , DoesNotFind ("zip" `inPackage` "base")+ ]+ query "(a -> m b) -> t a -> m (t b)" -- see GitHub issue #218+ [ InTop 10 ("traverse" `inPackage` "base")+ , InTop 10 ("mapConcurrently" `inModule` "Control.Concurrent.Async.Lifted")+ , InTop 10 ("mapM" `inPackage` "base")+ , InTop 50 ("forM" `inPackage` "base")+ ]+ query "m (m a) -> m a" -- see GitHub issue #252+ [ TopHit ("join" `inPackage` "base")+ ]+ query "(a -> b -> c) -> (a -> b) -> a -> c"+ [ KnownFailure "GitHub issue #269" $+ InTop 5 ("ap" `inPackage` "base")+ , KnownFailure "GitHub issue #269" $+ InTop 5 ("(<*>)" `inPackage` "base")+ ]+ query "String -> Int"+ [ DoesNotFind ("cursorUpCode" `inPackage` "ansi-terminal")+ , KnownFailure "GitHub issue #266" $ InTop 20 ("length" `inPackage` "base")+ ]+ query "(a -> b) -> f a -> f b"+ [ TopHit ("fmap" `inPackage` "base")+ ]+ query "(a -> b) -> Maybe a -> Maybe b"+ [ InTop 3 ("fmap" `inPackage` "base")+ ]+ query "IO a -> m a" -- see GitHub issue #180+ [ InTop 50 ("liftIO" `inPackage` "base")+ , KnownFailure "GitHub issue #180" $+ InTop 3 ("liftIO" `inPackage` "base")+ ]+ query "a -> m a" -- see GitHub issue #180+ [ InTop 20 ("pure" `inPackage` "base")+ , InTop 50 ("return" `inPackage` "base")+ , KnownFailure "GitHub issue #267" $+ InTop 3 ("pure" `inPackage` "base")+ , KnownFailure "GitHub issue #267" $+ InTop 3 ("return" `inPackage` "base")+ ]+ query "(a -> a) -> k -> Map k a -> Map k a" -- see GitHub issue #180+ [ TopHit ("adjust" `inPackage` "containers")+ ]+ query "Int -> Integer" -- see GitHub issue #127+ [ InTop 40 ("toInteger" `inPackage` "base")+ , KnownFailure "GitHub issue #127" $+ TopHit ("toInteger" `inPackage` "base")+ ]+ query "Integer -> Int" -- see GitHub issue #127+ [ InTop 40 ("fromInteger" `inPackage` "base")+ , KnownFailure "GitHub issue #127" $+ TopHit ("fromInteger" `inPackage` "base")+ ]+ query "[Parser a] -> Parser a" -- see GitHub issue #90+ [ InTop 10 ("choice" `inPackage` "attoparsec")+ ]+ let tags = completionTags store let asserts b x = if b then putChar '.' else error $ "Assertion failed, got False for " ++ x asserts ("set:haskell-platform" `elem` tags) "set:haskell-platform `elem` tags" asserts ("author:Neil-Mitchell" `elem` tags) "author:Neil-Mitchell `elem` tags" asserts ("package:uniplate" `elem` tags) "package:uniplate `elem` tags" asserts ("package:supero" `notElem` tags) "package:supero `notElem` tags"+++--------------------------------------------------------------------------------------------------+-- Test helpers++data ExpectedQueryResult+ = TopHit TargetMatcher+ | InTop Int TargetMatcher+ | RanksBelow Int TargetMatcher+ | DoesNotFind TargetMatcher+ | AppearsBefore TargetMatcher TargetMatcher+ | NoHits+ | KnownFailure String ExpectedQueryResult++expected :: ExpectedQueryResult -> String+expected = \case+ TopHit tm -> showTM tm ++ " as first hit."+ InTop n tm -> showTM tm ++ " in top " ++ show n ++ " hits."+ RanksBelow n tm -> showTM tm ++ " not in top " ++ show n ++ " hits."+ DoesNotFind tm -> "to not match " ++ showTM tm ++ "."+ AppearsBefore tm tm' -> showTM tm ++ " to appear before " ++ showTM tm' ++ "."+ NoHits -> "no results."+ KnownFailure why qr -> "to see a failure (" ++ why ++ "): \"" ++ expected qr ++ "\" But it succeeded!"++data TestResult+ = Success+ | Failure+ | ExpectedFailure+ | UnexpectedSuccess++matchQR :: ExpectedQueryResult -> [[Target]] -> TestResult+matchQR qr res = case qr of+ TopHit tm -> success $ any (runTargetMatcher tm) (concat $ take 1 res)+ InTop n tm -> success $ any (runTargetMatcher tm) (concat $ take n res)+ RanksBelow n tm -> success $ any (runTargetMatcher tm) (concat $ drop n res)+ DoesNotFind tm -> success $ not $ any (runTargetMatcher tm) (concat res)+ AppearsBefore tm tm' -> success $ ( (<) <$> matchIdx tm <*> matchIdx tm' ) == Just True+ NoHits -> success $ null res+ KnownFailure _ qr' -> case matchQR qr' res of+ Success -> UnexpectedSuccess+ Failure -> ExpectedFailure+ ExpectedFailure -> Failure+ UnexpectedSuccess -> Failure+ where+ success p = if p then Success else Failure+ matchIdx tm = fmap fst $ find (runTargetMatcher tm . snd) (zip [0..] $ concat res)++data TargetMatcher+ = MatchFunctionInModule String String+ | MatchFunctionInPackage String String++showTM :: TargetMatcher -> String+showTM = \case+ MatchFunctionInModule f m -> m ++ "'s " ++ f+ MatchFunctionInPackage f p -> f ++ " from package " ++ p++runTargetMatcher :: TargetMatcher -> Target -> Bool+runTargetMatcher matcher Target{..} = case matcher of+ MatchFunctionInModule f m ->+ Just m == fmap (strUnpack . fst) targetModule+ && f `isPrefixOf` unHTML targetItem+ MatchFunctionInPackage f m ->+ Just m == fmap (strUnpack . fst) targetPackage+ && f `isPrefixOf` unHTML targetItem++inModule :: String -> String -> TargetMatcher+inModule = MatchFunctionInModule++inPackage :: String -> String -> TargetMatcher+inPackage = MatchFunctionInPackage++-- Group duplicated targets (e.g. re-exports) together.+deDup :: [Target] -> [[Target]]+deDup tgts = Map.elems (Map.fromList $ Map.elems tgtMap)+ where+ tgtMap :: Map.Map Target (Int, [Target])+ tgtMap = Map.fromListWith (\(n, ts) (n', ts') -> (min n n', ts ++ ts'))+ $ map (\(n,t) -> (simple t, (n, [t]))) (zip [0..] tgts)++ simple :: Target -> Target+ simple t = t { targetURL = "", targetPackage = Nothing, targetModule = Nothing }+++
src/Action/Server.hs view
@@ -96,27 +96,40 @@ ,("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"+ Just "body" -> OutputHTML <$> if null qSource then templateRender templateEmpty [] else return $ lbstrPack body+ Just "json" ->+ let argRead :: Read a => String -> a -> a+ argRead key def = fromMaybe def $+ readMaybe =<< lookup key inputArgs+ -- 1 means don't drop anything, if it's less than 1 ignore it+ start :: Int+ start = max 0 $ (argRead "start" 1) - 1+ -- by default it returns 100 entries+ count :: Int+ count = min 500 $ argRead "count" 100+ in pure $ OutputJSON $ JSON.encode $ take count $ drop start results+ Just m -> return $ OutputFail $ lbstrPack $ "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+ return $ (if errs == 0 && alive < 1.5 then OutputText else OutputFail) $ lbstrPack $+ "Errors " ++ (if errs == 0 then "good" else "bad") ++ ": " ++ show errs ++ " in the last 24 hours.\n" +++ "Updates " ++ (if alive < 1.5 then "good" else "bad") ++ ": Last updated " ++ showDP 2 alive ++ " days ago.\n"+ ["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+ Nothing -> OutputFail $ lbstrPack "GHC Statistics is not enabled, restart with +RTS -T"+ Just x -> OutputText $ lbstrPack $ 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 "")@@ -129,12 +142,12 @@ 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+ return $ OutputHTML $ lbstrPack $ 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+ str = templateStr . lbstrPack tagOptions sel = concat [tag "option" ["selected=selected" | x `elem` sel] x | x <- completionTags store] params = map (second str) [("cdn",cdn)@@ -187,12 +200,12 @@ [("is","exact")] ++ [("is","package") | any ((==) "package" . targetType) xs] ++ [("is","module") | any ((==) "module" . targetType) xs] ++- nubOrd [("package",p) | Just (p,_) <- map targetPackage xs]+ nubOrd [("package",strUnpack p) | Just (p,_) <- map targetPackage xs] showFroms :: Bool -> Maybe FilePath -> [Target] -> String-showFroms local haddock xs = intercalate ", " $ for pkgs $ \p ->+showFroms local haddock xs = intercalate ", " $ flip map pkgs $ \p -> let ms = filter ((==) p . targetPackage) xs- in unwords ["<a href=\"" ++ showURL local haddock b ++ "\">" ++ a ++ "</a>" | (a,b) <- catMaybes $ p : map remod ms]+ in unwords ["<a href=\"" ++ showURL local haddock b ++ "\">" ++ strUnpack a ++ "</a>" | (a,b) <- catMaybes $ p : map remod ms] where remod Target{..} = do (a,_) <- targetModule; return (a,targetURL) pkgs = nubOrd $ map targetPackage xs@@ -208,7 +221,7 @@ highlightItem :: [Query] -> String -> String highlightItem qs x- | Just (pre,x) <- stripInfix "<0>" x, Just (name,post) <- stripInfix "</0>" x = pre ++ highlight (unescapeHTML name) ++ post+ | Just (pre,x) <- stripInfix "<s0>" x, Just (name,post) <- stripInfix "</s0>" x = pre ++ highlight (unescapeHTML name) ++ post | otherwise = x where highlight = concatMap (\xs@((b,_):_) -> let s = escapeHTML $ map snd xs in if b then "<b>" ++ s ++ "</b>" else s) .@@ -226,19 +239,19 @@ action_server_test_ :: IO () action_server_test_ = do testing "Action.Server.displayItem" $ do- let expand = replace "{" "<b>" . replace "}" "</b>" . replace "<0>" "" . replace "</0>" ""+ let expand = replace "{" "<b>" . replace "}" "</b>" . replace "<s0>" "" . replace "</s0>" "" 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}</0> :: Int -> test"- "new west" === "<0>{newest}_{new}</0> :: Int"- "+*" === "(<0>{+*}&</0>) :: Int"- "+<" === "(<0>>{+<}</0>) :: Int"- "foo" === "<i>data</i> <0>{Foo}d</0>"- "foo" === "<i>type</i> <0>{Foo}d</0>"- "foo" === "<i>type family</i> <0>{Foo}d</0>"- "foo" === "<i>module</i> Foo.Bar.<0>F{Foo}</0>"- "foo" === "<i>module</i> <0>{Foo}o</0>"+ "test" === "<s0>my{Test}</s0> :: Int -> test"+ "new west" === "<s0>{newest}_{new}</s0> :: Int"+ "+*" === "(<s0>{+*}&</s0>) :: Int"+ "+<" === "(<s0>>{+<}</s0>) :: Int"+ "foo" === "<i>data</i> <s0>{Foo}d</s0>"+ "foo" === "<i>type</i> <s0>{Foo}d</s0>"+ "foo" === "<i>type family</i> <s0>{Foo}d</s0>"+ "foo" === "<i>module</i> Foo.Bar.<s0>F{Foo}</s0>"+ "foo" === "<i>module</i> <s0>{Foo}o</s0>" action_server_test :: Bool -> FilePath -> IO () action_server_test sample database = do@@ -246,7 +259,7 @@ log <- logNone dataDir <- getDataDir let q === want = do- OutputHTML (lstrUnpack -> res) <- replyServer log False Nothing store "" "" (dataDir </> "html") "" (Input [] [("hoogle",q)])+ OutputHTML (lbstrUnpack -> 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" === "<b>type family</b>"@@ -265,5 +278,5 @@ where f Summary{..} = "{date:" ++ show (showGregorian summaryDate) ++ ",users:" ++ show summaryUsers ++ ",uses:" ++ show summaryUses ++- ",slowest:" ++ show summarySlowest ++ ",average:" ++ show summaryAverage +++ ",slowest:" ++ show summarySlowest ++ ",average:" ++ show (fromAverage summaryAverage) ++ ",errors:" ++ show summaryErrors ++ "}"
src/Action/Test.hs view
@@ -25,6 +25,7 @@ input_haddock_test query_test action_server_test_+ item_test putStrLn "" putStrLn "Sample database tests"
src/General/Conduit.hs view
@@ -53,13 +53,13 @@ f k2 v2 -linesCR :: Monad m => ConduitM Str Str m ()+linesCR :: Monad m => ConduitM BStr BStr 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+sourceLStr :: Monad m => LBStr -> ConduitM i BStr m ()+sourceLStr = sourceList . lbstrToChunks pipelineC :: Int -> ConduitM o Void IO r -> ConduitM o Void IO r
src/General/IString.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, DeriveDataTypeable #-}+{-# LANGUAGE PatternGuards, DeriveDataTypeable, ViewPatterns, BangPatterns #-} -- | Interned strings module General.IString(@@ -8,12 +8,12 @@ import Data.Data import Data.IORef import Control.DeepSeq-import Data.String+import General.Str import qualified Data.Map as Map import System.IO.Unsafe -data IString = IString {-# UNPACK #-} !Int !String+data IString = IString {-# UNPACK #-} !Int !Str deriving (Data,Typeable) instance Eq IString where@@ -24,19 +24,18 @@ | 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+instance Show IString where show = strUnpack . fromIString+instance NFData IString where rnf IString{} = () -- we force the string at construction time + {-# NOINLINE istrings #-}-istrings :: IORef (Map.Map String IString)+istrings :: IORef (Map.Map Str IString) istrings = unsafePerformIO $ newIORef Map.empty -fromIString :: IString -> String+fromIString :: IString -> Str fromIString (IString _ x) = x -toIString :: String -> IString-toIString x | () <- rnf x = unsafePerformIO $ atomicModifyIORef istrings $ \mp -> case Map.lookup x mp of+toIString :: Str -> IString+toIString 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)
src/General/Log.hs view
@@ -9,11 +9,12 @@ import Control.Applicative import System.Directory import System.IO+import Data.Hashable import Data.Time.Calendar import Data.Time.Clock import Numeric.Extra import Control.Monad.Extra-import qualified Data.Set as Set+import qualified Data.IntSet as Set import qualified Data.Map.Strict as Map import qualified Data.ByteString.Lazy.Char8 as LBS import Data.Semigroup@@ -63,7 +64,7 @@ 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)+ add $ SummaryI (Set.singleton $ hash $ LBS.pack user) 1 taken (toAverage taken) (if isJust err then 1 else 0) else if isJust err then add mempty{iErrors=1} else@@ -75,16 +76,16 @@ -- Summary collapsed data Summary = Summary {summaryDate :: Day- ,summaryUsers :: Int- ,summaryUses :: Int- ,summarySlowest :: Double- ,summaryAverage :: Double- ,summaryErrors :: Int+ ,summaryUsers :: {-# UNPACK #-} !Int+ ,summaryUses :: {-# UNPACK #-} !Int+ ,summarySlowest :: {-# UNPACK #-} !Double+ ,summaryAverage :: {-# UNPACK #-} !(Average Double)+ ,summaryErrors :: {-# UNPACK #-} !Int } -- Summary accumulating data SummaryI = SummaryI- {iUsers :: !(Set.Set String) -- number of distinct users+ {iUsers :: !Set.IntSet -- number of distinct users ,iUses :: !Int -- number of uses ,iSlowest :: !Double -- slowest result ,iAverage :: !(Average Double) -- average result@@ -104,14 +105,16 @@ mappend = (<>) summarize :: Day -> SummaryI -> Summary-summarize date SummaryI{..} = Summary date (Set.size iUsers) iUses iSlowest (fromAverage iAverage) iErrors+summarize date SummaryI{..} = Summary date (Set.size iUsers) iUses iSlowest iAverage iErrors +-- This noinline solves a massive memory leak at -O2, and I have no idea why+{-# NOINLINE parseLogLine #-} 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 Set.singleton $ hash user else Set.empty) (if use then 1 else 0) (if use then dur2 else 0) (toAverage $ if use then dur2 else 0)
src/General/Store.hs view
@@ -1,39 +1,40 @@-{-# LANGUAGE ScopedTypeVariables, RecordWildCards, PatternGuards, ViewPatterns, DeriveDataTypeable, GADTs #-}+{-# LANGUAGE DeriveDataTypeable, GADTs, PatternGuards, RecordWildCards,+ ScopedTypeVariables, ViewPatterns #-} module General.Store( Typeable, Stored,- intSize, intFromBS, intToBS, encodeBS,+ intSize, intFromBS, intToBS, encodeBS, decodeBS, StoreWrite, storeWriteFile, storeWrite, storeWritePart, StoreRead, storeReadFile, storeRead, Jagged, jaggedFromList, jaggedAsk, ) where +import Control.Applicative+import Control.DeepSeq+import Control.Exception+import Control.Monad.Extra+import Data.Binary+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Unsafe as BS+import Data.Char import Data.IORef.Extra-import System.IO.Extra-import Data.Typeable+import Data.List.Extra import qualified Data.Map as Map+import Data.Typeable 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 Data.Version 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 Foreign.Ptr+import Foreign.Storable import General.Util-import Control.DeepSeq-import Data.Version-import Data.Char+import Numeric.Extra import Paths_hoogle import Prelude+import System.IO.Extra+import System.IO.MMap+import System.IO.Unsafe -- 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
src/General/Str.hs view
@@ -1,69 +1,99 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} -- | 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+ Str, strPack, strUnpack, strNull, strCopy, strCons,+ BStr, bstrPack, bstrUnpack, bstrReadFile, bstrSplitInfix, bstrNull, bstrStripPrefix, bstrTrimStart,+ LBStr, lbstrPack, lbstrUnpack, lbstrToChunks, lbstrFromChunks,+ BStr0, bstr0Join, bstr0Split ) where +import qualified Foundation as Fdn+import qualified Foundation.Collection as Fdn 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 Control.DeepSeq import Data.Char+import Data.Data import Data.List+import Data.Semigroup+import Data.String+import Prelude -type Str = BS.ByteString+newtype Str = Str {fromStr :: Fdn.String}+ deriving (Data,Typeable,Eq,Ord,Semigroup,Monoid) -type LStr = LBS.ByteString+instance Show Str where show = strUnpack+instance NFData Str where rnf x = x `seq` () +type BStr = BS.ByteString++type LBStr = LBS.ByteString++ strPack :: String -> Str-strPack = US.fromString+strPack = Str . fromString strUnpack :: Str -> String-strUnpack = US.toString+strUnpack = Fdn.toList . fromStr -strReadFile :: FilePath -> IO Str-strReadFile = BS.readFile+strCons :: Char -> Str -> Str+strCons c = Str . Fdn.cons c . fromStr -strSplitInfix :: Str -> Str -> Maybe (Str, Str)-strSplitInfix needle haystack+strCopy :: Str -> Str+strCopy = Str . Fdn.copy . fromStr++strNull :: Str -> Bool+strNull = Fdn.null . fromStr++bstrPack :: String -> BStr+bstrPack = US.fromString++bstrUnpack :: BStr -> String+bstrUnpack = US.toString++bstrReadFile :: FilePath -> IO BStr+bstrReadFile = BS.readFile++bstrSplitInfix :: BStr -> BStr -> Maybe (BStr, BStr)+bstrSplitInfix needle haystack | (a,b) <- BS.breakSubstring needle haystack , not $ BS.null b = Just (a, BS.drop (BS.length needle) b)-strSplitInfix _ _ = Nothing+bstrSplitInfix _ _ = Nothing -strNull :: Str -> Bool-strNull = BS.null+bstrNull :: BStr -> Bool+bstrNull = BS.null -strStripPrefix :: Str -> Str -> Maybe Str-strStripPrefix needle x+bstrStripPrefix :: BStr -> BStr -> Maybe BStr+bstrStripPrefix needle x | BS.isPrefixOf needle x = Just $ BS.drop (BS.length needle) x | otherwise = Nothing -strTrimStart :: Str -> Str-strTrimStart = BS.dropWhile isSpace+bstrTrimStart :: BStr -> BStr+bstrTrimStart = BS.dropWhile isSpace -lstrToChunks :: LStr -> [Str]-lstrToChunks = LBS.toChunks+lbstrToChunks :: LBStr -> [BStr]+lbstrToChunks = LBS.toChunks -lstrFromChunks :: [Str] -> LStr-lstrFromChunks = LBS.fromChunks+lbstrFromChunks :: [BStr] -> LBStr+lbstrFromChunks = LBS.fromChunks -lstrUnpack :: LStr -> String-lstrUnpack = LUS.toString+lbstrUnpack :: LBStr -> String+lbstrUnpack = LUS.toString -lstrPack :: String -> LStr-lstrPack = LUS.fromString+lbstrPack :: String -> LBStr+lbstrPack = LUS.fromString -type Str0 = Str+type BStr0 = BStr -join0 :: [String] -> Str0-join0 = BS.pack . intercalate "\0"+bstr0Join :: [String] -> BStr0+bstr0Join = LBS.toStrict . LUS.fromString . intercalate "\0" -split0 :: Str0 -> [Str]-split0 = BS.split '\0'+bstr0Split :: BStr0 -> [BStr]+bstr0Split = BS.split '\0'
src/General/Template.hs view
@@ -20,9 +20,9 @@ -- 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+ | Var BStr -- a real variable+ | App Tree [(BStr, Tree)] -- applies a foo string to the lambda+ | Lit BStr | List [Tree] deriving (Typeable,Data,Show) @@ -31,11 +31,11 @@ treeRemoveLam :: Tree -> IO Tree treeRemoveLam = transformM f where- f (Lam file) = List . parse <$> strReadFile file+ f (Lam file) = List . parse <$> bstrReadFile file f x = return x - parse x | Just (a,b) <- strSplitInfix (strPack "#{") x- , Just (b,c) <- strSplitInfix (strPack "}") b+ parse x | Just (a,b) <- bstrSplitInfix (bstrPack "#{") x+ , Just (b,c) <- bstrSplitInfix (bstrPack "}") b = Lit a : Var b : parse c parse x = [Lit x] @@ -61,7 +61,7 @@ g xs = [Lit x | let x = mconcat $ map fromLit a, x /= mempty] ++ g b where (a,b) = span isLit xs -treeEval :: Tree -> [Str]+treeEval :: Tree -> [BStr] treeEval = f . treeRemoveApp where f (Lit x) = [x] f (List xs) = concatMap f xs@@ -96,14 +96,14 @@ templateFile :: FilePath -> Template templateFile = templateTree . Lam -templateStr :: LStr -> Template-templateStr = templateTree . List . map Lit . lstrToChunks+templateStr :: LBStr -> Template+templateStr = templateTree . List . map Lit . lbstrToChunks templateApply :: Template -> [(String, Template)] -> Template-templateApply (Template t _) args = templateTree $ App t [(strPack a, b) | (a,Template b _) <- args]+templateApply (Template t _) args = templateTree $ App t [(bstrPack a, b) | (a,Template b _) <- args] -templateRender :: Template -> [(String, Template)] -> IO LStr+templateRender :: Template -> [(String, Template)] -> IO LBStr templateRender (Template _ t) args = do t <- t let Template t2 _ = templateApply (Template t $ return t) args- lstrFromChunks . treeEval <$> treeRemoveLam t2+ lbstrFromChunks . treeEval <$> treeRemoveLam t2
src/General/Timing.hs view
@@ -33,7 +33,7 @@ -- 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+ xs <- return $ sortOn (negate . snd) $ ("Unrecorded", total - sum (map snd xs)) : xs writeFile file $ unlines $ prettyTable 2 "Secs" xs putStrLn $ "Took " ++ showDuration total return res
src/General/Util.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE PatternGuards, ViewPatterns, CPP, ScopedTypeVariables #-} module General.Util(+ PkgName, ModName, URL, pretty, parseMode, applyType, applyFun1, unapplyFun, fromName, fromQName, fromTyVarBind, declNames, isTypeSig, fromDeclHead, fromContext, fromIParen, fromInstHead,@@ -51,9 +52,13 @@ import System.Exit import System.Mem import GHC.Stats+import General.Str import Prelude +type PkgName = Str+type ModName = Str+ -- | A URL, complete with a @https:@ prefix. type URL = String @@ -266,9 +271,9 @@ 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+ Right v -> evaluate $ force v -data Average a = Average !a !Int deriving Show -- a / b+data Average a = Average !a {-# UNPACK #-} !Int deriving Show -- a / b toAverage :: a -> Average a toAverage x = Average x 1@@ -322,14 +327,14 @@ minimum' = minimumBy' compare -hackagePackageURL :: String -> URL-hackagePackageURL x = "https://hackage.haskell.org/package/" ++ x+hackagePackageURL :: PkgName -> URL+hackagePackageURL x = "https://hackage.haskell.org/package/" ++ strUnpack x -hackageModuleURL :: String -> URL+hackageModuleURL :: ModName -> URL hackageModuleURL x = "/docs/" ++ ghcModuleURL x -ghcModuleURL :: String -> URL-ghcModuleURL x = replace "." "-" x ++ ".html"+ghcModuleURL :: ModName -> URL+ghcModuleURL x = replace "." "-" (strUnpack x) ++ ".html" hackageDeclURL :: Bool -> String -> URL hackageDeclURL typesig x = "#" ++ (if typesig then "v" else "t") ++ ":" ++ concatMap f x
src/General/Web.hs view
@@ -77,8 +77,8 @@ 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+ [(bstrUnpack a, maybe "" bstrUnpack b) | (a,b) <- queryString req]+ (time,res) <- duration $ try_ $ do s <- act pay; evaluate $ force 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)
src/Input/Cabal.hs view
@@ -2,7 +2,7 @@ -- | Module for reading Cabal files. module Input.Cabal(- Package(..),+ PkgName, Package(..), parseCabalTarball, readGhcPkg, packagePopularity, readCabal ) where@@ -23,7 +23,6 @@ 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@@ -36,21 +35,21 @@ -- | 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+ {packageTags :: ![(Str, Str)] -- ^ 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 :: !Str -- ^ The synposis, grabbed from the top section.+ ,packageVersion :: !Str -- ^ The version, grabbed from the top section.+ ,packageDepends :: ![PkgName] -- ^ 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+ where one a b = if strNull a then b else a instance Monoid Package where- mempty = Package [] True T.empty T.empty [] Nothing+ mempty = Package [] True mempty mempty [] Nothing mappend = (<>) instance NFData Package where@@ -62,21 +61,22 @@ -- | 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)+packagePopularity :: Map.Map PkgName Package -> ([String], Map.Map PkgName Int)+packagePopularity cbl = mp `seq` (errs, mp) where- errs = [ user ++ ".cabal: Import of non-existant package " ++ name +++ mp = Map.map length good+ errs = [ strUnpack user ++ ".cabal: Import of non-existant package " ++ strUnpack 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]+ Map.fromListWith (++) [(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 -> IO (Map.Map PkgName Package) readGhcPkg settings = do topdir <- findExecutable "ghc-pkg" -- important to use BS process reading so it's in Binary format, see #194@@ -86,13 +86,13 @@ 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)+ let f ((stripPrefix "name: " -> Just x):xs) = Just (strPack 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)+parseCabalTarball :: Settings -> FilePath -> IO (Map.Map PkgName Package) -- items are stored as: -- QuickCheck/2.7.5/QuickCheck.cabal -- QuickCheck/2.7.6/QuickCheck.cabal@@ -100,8 +100,8 @@ 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)+ mapC (first takeBaseName) .| groupOnLastC fst .| mapMC (evaluate . force) .|+ pipelineC 10 (mapC (strPack *** readCabal settings . lbstrUnpack) .| mapMC (evaluate . force) .| sinkList) return $ Map.fromList res @@ -116,15 +116,15 @@ ask x = Map.findWithDefault [] x mp packageDepends =- map T.pack $ nubOrd $ filter (/= "") $+ map strPack $ 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"+ packageVersion = strPack $ head $ dropWhile null (ask "version") ++ ["0.0"]+ packageSynopsis = strPack $ 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+ packageTags = map (both strPack) $ nubOrd $ concat [ map (head xs,) $ concatMap cleanup $ concatMap ask xs | xs <- [["license"],["category"],["author","maintainer"]]]
src/Input/Download.hs view
@@ -11,7 +11,6 @@ import qualified Data.Conduit as C import General.Util import General.Timing-import Network import Control.Monad.Trans.Resource @@ -29,7 +28,7 @@ return file downloadFile :: Bool -> FilePath -> String -> IO ()-downloadFile insecure file url = withSocketsDo $ do+downloadFile insecure file url = do let request = C.parseRequest_ url manager <- C.newManager $ C.mkManagerSettings (TLSSettingsSimple insecure False False) Nothing runResourceT $ do
src/Input/Haddock.hs view
@@ -17,31 +17,31 @@ -- | An entry in the Hoogle DB-data Entry = EPackage String- | EModule String+data Entry = EPackage PkgName+ | EModule ModName | EDecl (Decl ()) deriving (Data,Typeable,Show) -fakePackage :: String -> String -> (Maybe Target, [Item])+fakePackage :: PkgName -> 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 :: Monad m => (String -> m ()) -> URL -> LBStr -> 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 :: Monad m => (String -> m ()) -> ConduitM (Int, BStr) (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 [] ""+ _ | Just s <- bstrStripPrefix "-- | " s -> f [s] url+ | Just s <- bstrStripPrefix "--" s -> f (if null com then [] else bstrTrimStart s : com) url+ | Just s <- bstrStripPrefix "@url " s -> f com (bstrUnpack s)+ | bstrNull $ bstrTrimStart s -> f [] "" | otherwise -> do- case parseLine $ fixLine $ strUnpack s of+ case parseLine $ fixLine $ bstrUnpack 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@@ -56,8 +56,8 @@ -- FIXME: used to be in two different modules, now does and then undoes lots of stuff-reformat :: [Str] -> String-reformat = unlines . map strUnpack+reformat :: [BStr] -> String+reformat = unlines . map bstrUnpack hierarchyC :: Monad m => URL -> ConduitM (Target, Entry) (Maybe Target, [Item]) m ()@@ -80,8 +80,8 @@ orIfNull x y = if null x then y else x -renderPackage x = "<b>package</b> <span class=name><0>" ++ escapeHTML x ++ "</0></span>"-renderModule (breakEnd (== '.') -> (pre,post)) = "<b>module</b> " ++ escapeHTML pre ++ "<span class=name><0>" ++ escapeHTML post ++ "</0></span>"+renderPackage x = "<b>package</b> <span class=name><s0>" ++ escapeHTML (strUnpack x) ++ "</s0></span>"+renderModule (breakEnd (== '.') . strUnpack -> (pre,post)) = "<b>module</b> " ++ escapeHTML pre ++ "<span class=name><s0>" ++ escapeHTML post ++ "</s0></span>" renderItem :: Entry -> String@@ -104,16 +104,16 @@ focus (EDecl x) = pretty x highlight :: String -> String- highlight x = "<0>" ++ escapeHTML x ++ "</0>"+ highlight x = "<s0>" ++ escapeHTML x ++ "</s0>" parseLine :: String -> Either String [Entry] parseLine x@('@':str) = case a of- "package" | [b] <- words b, b /= "" -> Right [EPackage b]+ "package" | [b] <- words b, b /= "" -> Right [EPackage $ strPack b] "version" -> Right [] _ -> Left $ "unknown attribute: " ++ x where (a,b) = word1 str-parseLine (stripPrefix "module " -> Just x) = Right [EModule x]+parseLine (stripPrefix "module " -> Just x) = Right [EModule $ strPack 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]@@ -139,7 +139,7 @@ , 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+ | 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@@ -163,8 +163,8 @@ unGADT x = x prettyItem :: Entry -> String-prettyItem (EPackage x) = "package " ++ x-prettyItem (EModule x) = "module " ++ x+prettyItem (EPackage x) = "package " ++ strUnpack x+prettyItem (EModule x) = "module " ++ strUnpack x prettyItem (EDecl x) = pretty x
src/Input/Item.hs view
@@ -7,7 +7,7 @@ Item(..), itemName, Target(..), targetExpandURL, TargetId(..), splitIPackage, splitIModule,- hseToSig, hseToItem+ hseToSig, hseToItem, item_test ) where import Numeric@@ -23,10 +23,13 @@ import Control.DeepSeq import Data.Data import General.Util+import General.Str import General.IString import Prelude+import qualified Data.Aeson as J import Data.Aeson.Types import qualified Data.Text as T+import Test.QuickCheck --------------------------------------------------------------------- -- TYPES @@ -70,23 +73,23 @@ -- ITEMS data Item- = IPackage String- | IModule String- | IName String+ = IPackage PkgName+ | IModule ModName+ | IName Str | ISignature (Sig IString)- | IAlias String [IString] (Sig IString)+ | IAlias Str [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 (IName x) = x `seq` () rnf (ISignature x) = rnf x rnf (IAlias a b c) = rnf (a,b,c) rnf (IInstance a) = rnf a -itemName :: Item -> Maybe String+itemName :: Item -> Maybe Str itemName (IPackage x) = Just x itemName (IModule x) = Just x itemName (IName x) = Just x@@ -106,10 +109,10 @@ -- | 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)+ ,targetPackage :: Maybe (PkgName, URL) -- ^ Name and URL of the package it is in (Nothing if it is a package)+ ,targetModule :: Maybe (ModName, 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+ ,targetItem :: String -- ^ HTML span of the item, using @\<s0\>@ for the name and @\<s1\>@ onwards for arguments ,targetDocs :: String -- ^ HTML documentation to show, a sequence of block level elements } deriving (Show,Eq,Ord) @@ -127,9 +130,36 @@ ] where maybeNamedURL m = maybe emptyObject namedURL m- namedURL (name, url) = object [("name" :: T.Text, toJSON name), ("url" :: T.Text, toJSON url)]+ namedURL (name, url) = object [("name" :: T.Text, toJSON $ strUnpack name), ("url" :: T.Text, toJSON url)] +instance FromJSON Target where+ parseJSON = withObject "Target" $ \o ->+ Target <$> o .: ("url" :: T.Text)+ <*> o `namedUrl` ("package" :: T.Text)+ <*> o `namedUrl` ("module" :: T.Text)+ <*> o .: ("type" :: T.Text)+ <*> o .: ("item" :: T.Text)+ <*> o .: ("docs" :: T.Text)+ where namedUrl o' n = do+ mObj <- o' .: n+ if null mObj then return Nothing+ else do+ pkName <- mObj .: ("name" :: T.Text)+ pkUrl <- mObj .: ("url" :: T.Text)+ return $ Just (strPack pkName ,pkUrl) +instance Arbitrary Target where+ arbitrary = Target <$> a+ <*> mNurl+ <*> mNurl+ <*> a+ <*> a+ <*> a+ where a = arbitrary+ mNurl = do+ oneof [return Nothing+ , Just <$> liftA2 (,) (strPack <$> a) a]+ targetExpandURL :: Target -> Target targetExpandURL t@Target{..} = t{targetURL = url, targetModule = second (const mod) <$> targetModule} where@@ -142,15 +172,20 @@ | otherwise = a ++ b -splitIPackage, splitIModule :: [(a, Item)] -> [(String, [(a, Item)])]+splitIPackage, splitIModule :: [(a, Item)] -> [(Str, [(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 :: (a -> Maybe Str) -> [a] -> [(Str, [a])] splitUsing f = repeatedly $ \(x:xs) -> let (a,b) = break (isJust . f) xs- in ((fromMaybe "" $ f x, x:a), b)+ in ((fromMaybe mempty $ f x, x:a), b) +item_test :: IO ()+item_test = testing "Input.Item.Target JSON (encode . decode = id) " $ do+ quickCheck $ \(t :: Target) -> case J.eitherDecode $ J.encode t of+ (Left e ) -> False+ (Right t') -> t == t' --------------------------------------------------------------------- -- HSE CONVERSION@@ -195,7 +230,7 @@ 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+hseToItem (TypeSig _ names ty) = ISignature (toIString . strPack <$> hseToSig ty) : map (IName . strPack . fromName) names+hseToItem (TypeDecl _ (fromDeclHead -> (name, bind)) rhs) = [IAlias (strPack $ fromName name) (map (toIString . strPack . fromName . fromTyVarBind) bind) (toIString . strPack <$> hseToSig rhs)]+hseToItem (InstDecl an _ (fromIParen -> IRule _ _ ctx (fromInstHead -> (name, args))) _) = [IInstance $ fmap (toIString . strPack) $ hseToSig $ TyForall an Nothing ctx $ applyType (TyCon an name) args]+hseToItem x = map (IName . strPack) $ declNames x
src/Input/Reorder.hs view
@@ -6,13 +6,15 @@ import Input.Settings import Data.List.Extra import Data.Tuple.Extra+import General.Util+import General.Str -- | Reorder items so the most popular ones are first, using reverse dependencies-reorderItems :: Settings -> (String -> Int) -> [(a, Item)] -> [(a, Item)]+reorderItems :: Settings -> (PkgName -> 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+ rebase (x, xs) = (x, concatMap snd $ sortOn (((negate . f . strUnpack) &&& id) . fst) $ refunc $ splitIModule xs)+ where f = reorderModule (strUnpack x)
src/Output/Items.hs view
@@ -4,6 +4,7 @@ import Control.Monad import Data.List.Extra+import Data.Tuple.Extra import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.ByteString.Lazy.UTF8 as UTF8@@ -22,8 +23,8 @@ outputItem :: Target -> [String] outputItem Target{..} = [if null targetURL then "." else targetURL- ,maybe "." (joinPair " ") targetPackage- ,maybe "." (joinPair " ") targetModule+ ,maybe "." (joinPair " " . first strUnpack) targetPackage+ ,maybe "." (joinPair " " . first strUnpack) targetModule ,if null targetType then "." else targetType ,targetItem] ++ replace [""] ["."] (lines targetDocs)@@ -33,7 +34,7 @@ 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)+ f x = Just (first strPack $ 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@@ -42,7 +43,7 @@ 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+ let bs = LBS.toStrict $ GZip.compress $ lbstrPack $ unlines $ outputItem target liftIO $ do storeWritePart store Items $ intToBS $ BS.length bs storeWritePart store Items bs
src/Output/Names.hs view
@@ -31,15 +31,15 @@ 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"+ let b = bstr0Join $ strs ++ ["",""] 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+itemNamePart (IModule x) = [last $ splitOn "." $ strUnpack x]+itemNamePart x = maybeToList $ strUnpack <$> itemName x searchNames :: StoreRead -> Bool -> [String] -> [TargetId] -- very important to not search for [" "] or [] since the output buffer is too small@@ -47,7 +47,7 @@ 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"+ let tweak x = bstrPack $ [' ' | 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 ->
src/Output/Tags.hs view
@@ -23,42 +23,42 @@ -- matches (a,b) if i >= a && i <= b -data Packages a where Packages :: Packages (Str0, V.Vector (TargetId, TargetId)) deriving Typeable+data Packages a where Packages :: Packages (BStr0, 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+data Modules a where Modules :: Modules (BStr0, 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+data Categories a where Categories :: Categories (BStr0, 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+data Completions a where Completions :: Completions BStr0 deriving Typeable -- a list of things to complete to, interspersed with \0 -writeTags :: StoreWrite -> (String -> Bool) -> (String -> [(String,String)]) -> [(Maybe TargetId, Item)] -> IO ()+writeTags :: StoreWrite -> (PkgName -> Bool) -> (PkgName -> [(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)+ storeWrite store Packages (bstr0Join $ map (strUnpack . 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)+ storeWrite store Categories (bstr0Join $ 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 Modules (bstr0Join $ map (lower . strUnpack . fst) modules, V.fromList $ map snd modules) - storeWrite store Completions $ join0 $+ storeWrite store Completions $ bstr0Join $ takeWhile ("set:" `isPrefixOf`) (map fst categories) ++- map ("package:"++) (sortOn lower $ nubOrd $ filter keep $ map fst packages) +++ map ("package:"++) (sortOn lower $ map strUnpack $ 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 /= []]+ addRange :: [(Str, [(Maybe TargetId,a)])] -> [(Str, (TargetId, TargetId))]+ addRange xs = [(a, (minimum' is, maximum' is)) | (a,b) <- xs, let is = mapMaybe fst b, not $ strNull a, is /= []] weightTag ("set",x) = fromMaybe 0.9 $ lookup x [("stackage",0.0),("haskell-platform",0.1)] weightTag ("package",x) = 1@@ -71,7 +71,7 @@ -- SIMPLE SELECTORS completionTags :: StoreRead -> [String]-completionTags store = map BS.unpack $ split0 $ storeRead store Completions+completionTags store = map BS.unpack $ bstr0Split $ storeRead store Completions ---------------------------------------------------------------------@@ -115,13 +115,13 @@ 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]+ | res@(_:_) <- [(BS.length x, (i,x)) | (i,x) <- zip [0..] $ bstr0Split 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)+ EqModule x -> (EqModule x, Just $ map (moduleIds V.!) $ findIndices (eqModule $ lower x) $ bstr0Split moduleNames) EqCategory cat val -> (EqCategory cat val, Just $ concat [ V.toList $ jaggedAsk categoryIds i- | i <- elemIndices (BS.pack (cat ++ ":" ++ val)) $ split0 categoryNames])+ | i <- elemIndices (BS.pack (cat ++ ":" ++ val)) $ bstr0Split categoryNames]) where eqModule x | Just x <- stripPrefix "." x, Just x <- stripSuffix "." x = (==) (BS.pack x) | Just x <- stripPrefix "." x = BS.isPrefixOf $ BS.pack x
src/Output/Types.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, BangPatterns, GADTs #-}+{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveFunctor, GADTs,+ GeneralizedNewtypeDeriving, LambdaCase, RecordWildCards,+ ScopedTypeVariables, TupleSections, ViewPatterns #-} -module Output.Types(writeTypes, searchTypes, searchTypesDebug) where+module Output.Types(writeTypes, searchTypes, searchFingerprintsDebug) where {- Approach:@@ -10,28 +11,34 @@ A slow search ranks the 100 items, excluding some -} -import qualified Data.Map.Strict as Map+import Control.Applicative+import Control.Monad.Extra+import Control.Monad.ST+import Control.Monad.Trans.Class+import Control.Monad.Trans.State.Strict+import Data.Binary hiding (get, put) 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.Data+import Data.Generics.Uniplate.Data import Data.List.Extra+import qualified Data.Map.Strict as Map+import Data.Maybe+import qualified Data.Set as Set+import Data.STRef import Data.Tuple.Extra-import Data.Generics.Uniplate.Data-import Data.Data-import System.FilePath-import System.IO.Extra-import Control.Monad.Extra+import qualified Data.Vector.Storable as V+import qualified Data.Vector.Storable.Mutable as VM import Foreign.Storable-import Control.Applicative import Numeric.Extra import Prelude+import System.FilePath+import System.IO.Extra -import Input.Item-import General.Store import General.IString+import General.Store+import General.Str import General.Util+import Input.Item writeTypes :: StoreWrite -> Maybe FilePath -> [(Maybe TargetId, Item)] -> IO ()@@ -44,22 +51,59 @@ 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. _+ take nMatches (concat [ search fps qry' | variantClass <- variants+ , fpSig <- case head variantClass qry of+ (f:_) -> [f]+ [] -> []+ , let fps = bestByFingerprint db nMatches fpSig+ , variant <- variantClass+ , qry' <- variant qry+ ]) where+ nMatches = 100+ qry = lookupNames names name0 (strPack <$> q) -- map unknown fields to name0, i.e. _ names = readNames store+ search fps sig = concatMap (expandDuplicates $ readDuplicates store)+ $ searchTypeMatch fps getSig arrow nMatches sig+ db = zip (readSignatureIndex store)+ (V.toList $ storeRead store TypesFingerprints :: [Fingerprint])+ getSig = readSignatureAt store+ arrow = lookupCtor store names "->" + -- Different variations on the search query. Each variation is run in turn until we've gathered+ -- 100 hits or run out of variations to try.+ -- As an optimization, these are grouped by variants that have the same fingerprint, saving+ -- redundant scans through the fingerprint data.+ variants = [ [ pure, permuted ],+ [ partial, partial >=> permuted ] ] -searchTypesDebug :: StoreRead -> (String, Sig String) -> [(String, Sig String)] -> [String]-searchTypesDebug store query answers = intercalate [""] $+ -- Permute the arguments of a two-argument query.+ permuted qq = case sigTy qq of+ [a1, a2, r] -> [ qq { sigTy = [a2, a1, r] } ]+ _ -> []++ -- Add a `Maybe` to the query's result type.+ partial qq = case sigTy qq of+ [] -> []+ tys -> [ qq { sigTy = init tys ++ [TCon maybeCtor [last tys]] } ]++ maybeCtor = lookupCtor store names "Maybe"++lookupCtor :: StoreRead -> Names -> String -> Name+lookupCtor store names c =+ case sigTy (lookupNames names name0 s) of+ [TCon n _] -> n+ _ -> name0+ where+ s = strPack <$> Sig { sigCtx = [], sigTy = [TCon c []] }++searchFingerprintsDebug :: StoreRead -> (String, Sig String) -> [(String, Sig String)] -> [String]+searchFingerprintsDebug store query answers = intercalate [""] $ f False "Query" query : zipWith (\i -> f True ("Answer " ++ show i)) [1..] answers where- qsig = lookupNames names name0 $ snd query+ qsig = lookupNames names name0 $ strPack <$> snd query names = readNames store f match name (raw, sig) =@@ -71,7 +115,7 @@ ["Cost: " ++ maybe "X, no match" show (matchFingerprint qsig fp) ,"Explain: " ++ showExplain (matchFingerprintDebug qsig fp)] where- sn = lookupNames names name0 sig+ sn = lookupNames names name0 $ strPack <$> sig fp = toFingerprint sn showExplain = intercalate ", " . map g . sortOn (either (const minBound) (negate . snd))@@ -82,7 +126,7 @@ --------------------------------------------------------------------- -- NAME/CTOR INFORMATION -data TypesNames a where TypesNames :: TypesNames (BS.ByteString, V.Vector Name) deriving Typeable+data TypesNames a where TypesNames :: TypesNames (BStr0, V.Vector Name) deriving Typeable -- Must be a unique Name per String. -- First 0-99 are variables, rest are constructors.@@ -108,33 +152,33 @@ 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}+newtype Names = Names {lookupName :: Str -> Maybe Name} -lookupNames :: Names -> Name -> Sig String -> Sig Name+lookupNames :: Names -> Name -> Sig Str -> 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]+ vars = nubOrd $ strPack "_" : [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)+ f (Ctx a b) = Ctx (con $ strCons '~' 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 :: StoreWrite -> (String -> String -> IO ()) -> Map.Map Str Int -> [Sig Str] -> IO Names writeNames store debug inst xs = do- let sigNames (Sig ctx typ) = nubOrd ['~':x | Ctx x _ <- ctx] ++ nubOrd [x | TCon x _ <- universeBi typ]+ let sigNames (Sig ctx typ) = nubOrd [strCons '~' 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) $+ let freq :: Map.Map Str Int = -- how many times each identifier occurs+ Map.unionWith (\typ sig -> sig + min sig typ) (Map.mapKeysMonotonic (strCons '~') 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]+ debug "names" $ unlines [strUnpack 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)+ storeWrite store TypesNames (bstr0Join $ map (strUnpack . fst) names, V.fromList $ map snd names) let mp2 = Map.fromAscList names return $ Names $ \x -> Map.lookup x mp2 @@ -143,7 +187,7 @@ -- 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+spreadNames (sortOn (negate . 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"@@ -162,8 +206,8 @@ 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+readNames store = Names $ \x -> Map.lookup (bstrPack $ strUnpack x) mp+ where mp = Map.fromAscList $ zip (bstr0Split s) $ V.toList n (s, n) = storeRead store TypesNames @@ -244,7 +288,6 @@ ,mfpMiss :: String -> ma } - matchFingerprint :: Sig Name -> Fingerprint -> Maybe Int matchFingerprint = matchFingerprintEx MatchFingerprint{..} where@@ -310,12 +353,6 @@ 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 @@ -331,3 +368,261 @@ VM.write v i $ fromIntegral $ BS.length b v <- V.freeze v storeWrite store TypesSigPositions v++type SigLoc = (Word32, Word32)++readSignatureIndex :: StoreRead -> [SigLoc] -- (offset,size) pairs for each field+readSignatureIndex store = zip offsets (V.toList sizes)+ where sizes = storeRead store TypesSigPositions+ offsets = V.toList $ V.prescanl' (+) 0 sizes++readSignatureAt :: StoreRead -> SigLoc -> Sig Name+readSignatureAt store (offset, size) = decodeBS (BS.take (fromIntegral size)+ $ snd+ $ BS.splitAt (fromIntegral offset) bs)+ where+ bs = storeRead store TypesSigData++---------------------------------------------------------------------+-- TYPE SEARCH++searchTypeMatch :: [ (Int, (Int, SigLoc, Fingerprint)) ]+ -> (SigLoc -> Sig Name)+ -> Name+ -> Int+ -> Sig Name+ -> [Int]+searchTypeMatch possibilities getSig arrow n sig =+ map snd $ takeSortOn fst n+ [ (500 * v + fv, i) | (fv, (i, sigIdx, f)) <- possibilities+ , v <- maybeToList (matchType arrow sig $ getSig sigIdx)]++bestByFingerprint :: [(SigLoc, Fingerprint)] -> Int -> Sig Name -> [ (Int, (Int, SigLoc, Fingerprint)) ]+bestByFingerprint db n sig =+ takeSortOn fst (max 5000 n)+ [ (fv, (i, sigIdx, f)) | (i, (sigIdx, f)) <- zip [0..] db+ , fv <- maybeToList (matchFp f) ]+ where+ matchFp = matchFingerprint sig++matchType :: Name -> Sig Name -> Sig Name -> Maybe Int+matchType arr qry ans = unWork <$> lhs `matches` rhs+ where+ lhs = (toTyp arr qry, sigCtx qry)+ rhs = (toTyp arr ans, sigCtx ans)++-- Check if two types-with-context match, returning the amount of work+-- needed to create the match.+matches :: (Typ Name, [Ctx Name]) -> (Typ Name, [Ctx Name]) -> Maybe Work+matches (lhs, lctx) (rhs, rctx) = runST $ evalStateT (getWork go) (Work 0)+ where+ go :: forall s. StateT Work (ST s) Bool+ go = do+ -- Try to unify the answer type with the query type.+ (qry, qryC) <- lift (refTyp True lhs lctx)+ (ans, ansC) <- lift (refTyp False rhs rctx)+ unifyTyp qry ans >>= \case+ False -> return False+ True -> do+ -- Normalize constraints+ let normalize (Ctx c a) = lift (Ctx <$> getName c <*> getName a)+ qryNCs <- Set.fromList <$> (mapM normalize qryC)+ ansNCs <- Set.fromList <$> (mapM normalize ansC)++ nqry <- lift $ normalizeTy qry+ nans <- lift $ normalizeTy ans++ -- Discharge constraints; remove any answer-constraint that is also a query-constraint,+ -- and then remove any remaining answer-constraint that is constraining a concrete type.+ -- TODO: keep constrained concrete types but weight them differently if they correspond+ -- to a known instance (e.g. free if we know the instance, rather expensive otherwise).+ let addl = filter isAbstract (Set.toList $ ansNCs `Set.difference` qryNCs)+ isAbstract (Ctx c a) = isVar a++ workDelta (Work (3 * length addl))++ return True++ getWork action = action >>= \case+ True -> Just <$> get+ False -> return Nothing++ normalizeTy = \case+ TyVar n tys -> TyVar <$> getName n <*> mapM normalizeTy tys+ TyCon n tys -> TyCon <$> getName n <*> mapM normalizeTy tys+ TyFun args retn -> TyFun <$> mapM normalizeTy args <*> normalizeTy retn+++-- A slight variation on 'Ty', with a special term for functions.+data Typ n+ = TyFun [Typ n] (Typ n)+ | TyCon n [Typ n]+ | TyVar n [Typ n]+ deriving (Eq, Ord, Functor)++-- Rebuild a little bit of recursion-schemes machinery for Typ.+data TypF n t+ = TyFunF [t] t+ | TyConF n [t]+ | TyVarF n [t]+ deriving (Eq, Ord, Functor)++unroll :: Typ n -> TypF n (Typ n)+unroll = \case+ TyFun args retn -> TyFunF args retn+ TyCon n tys -> TyConF n tys+ TyVar n tys -> TyVarF n tys++foldTy :: (TypF n a -> a) -> Typ n -> a+foldTy phi = phi . fmap (foldTy phi) . unroll++instance Show n => Show (Typ n) where+ show = foldTy $ \case+ TyFunF typs res -> "<" ++ intercalate ", " typs ++ "; " ++ res ++ ">"+ TyConF n args -> unwords (show n : args)+ TyVarF n args -> unwords (show n : args)++-- Convert a Sig to a Typ.+toTyp :: Name -> Sig Name -> Typ Name+toTyp arrow Sig{..} = case sigTy of+ [] -> error "no types?"+ tys -> let args = init tys+ retn = last tys+ in TyFun (map toTy args) (toTy retn)+ where+ toTy = \case+ TCon n [] | n == arrow -> TyCon n [] -- empty function type?!+ TCon n tys | n == arrow -> TyFun (map toTy (init tys)) (toTy $ last tys)+ TCon n tys -> TyCon n (map toTy tys)+ TVar n tys -> TyVar n (map toTy tys)+++---------------------------------------------------------------------+-- UNIFICATION++-- A union-find data structure for names++type NameRef s = STRef s (NameInfo s)++data NameInfo s =+ NameInfo { niParent :: !(Maybe (NameRef s))+ , niRank :: !Int+ , niName :: !Name+ , niFree :: !Bool+ }+ deriving Eq++-- Find the name of the equivalence class's (current) representative.+getName :: NameRef s -> ST s Name+getName ref = do+ rep <- findRep ref+ niName <$> readSTRef rep++-- Create a new name reference from a name. @fixed == True@ means+-- that the reference cannot be unified with any other fixed refs.+newNameInfo :: Bool -> Name -> ST s (STRef s (NameInfo s))+newNameInfo fixed n = newSTRef $+ NameInfo { niParent = Nothing+ , niRank = 0+ , niName = n+ , niFree = not fixed && isVar n+ }++-- The "find" part of union-find, with path compression.+findRep :: NameRef s -> ST s (NameRef s)+findRep ref = do+ ni <- readSTRef ref+ case niParent ni of+ Nothing -> return ref+ Just p -> do+ root <- findRep p+ writeSTRef ref (ni { niParent = Just root })+ return root++-- The "union" part of union-find, with union-by-rank.+-- Each unification is given a cost of 1 work unit.+unifyName :: NameRef s -> NameRef s -> StateT Work (ST s) Bool+unifyName lhs rhs = do+ lhs' <- lift $ findRep lhs+ rhs' <- lift $ findRep rhs+ lInfo <- lift $ readSTRef lhs'+ rInfo <- lift $ readSTRef rhs'+ let lFree = niFree lInfo+ rFree = niFree rInfo+ lName = niName lInfo+ rName = niName rInfo+ let ok = lFree || rFree || lName == rName+ when (ok && lInfo /= rInfo) $ do+ -- Union by rank, except prefer concrete names over type variables.+ workDelta (Work 1)+ let lRank = niRank lInfo+ rRank = niRank rInfo+ let (root, child) = if not lFree || lRank <= rRank+ then (lhs', rhs')+ else (rhs', lhs')+ lift $ modifySTRef' child (\n -> n { niParent = Just root })+ when (lRank == rRank) $ lift $ modifySTRef' root (\n -> n { niRank = lRank + 1 })++ return ok++-- Allocate new references for each name that appears in the type and context.+refTyp :: Bool -> Typ Name -> [Ctx Name] -> ST s (Typ (NameRef s), [Ctx (NameRef s)])+refTyp fixed t cs =+ evalStateT go (Map.fromList [])+ where+ go = do+ ty <- mkRefs t+ ctx <- forM cs $ \(Ctx c a) -> Ctx <$> getRef c <*> getRef a+ return (ty, ctx)++ mkRefs = foldTy $ \case+ TyVarF n args -> TyVar <$> getRef n <*> sequence args+ TyConF n args -> TyCon <$> getRef n <*> sequence args+ TyFunF args retn -> TyFun <$> sequence args <*> retn++ getRef n = do+ known <- get+ case Map.lookup n known of+ Just ref -> return ref+ Nothing -> do+ ref <- lift (newNameInfo fixed n)+ put (Map.insert n ref known)+ return ref++-- Unify two types.+unifyTyp :: Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool+unifyTyp lhs rhs = case (lhs, rhs) of+ (TyCon n tys, TyVar n' tys') | length tys == length tys' -> do+ ok <- unifyName n n'+ if not ok+ then return False+ else and <$> zipWithM unifyTyp tys tys'++ (TyCon n tys, TyCon n' tys') | length tys == length tys' -> do+ ok <- unifyName n n'+ if not ok+ then return False+ else and <$> zipWithM unifyTyp tys tys'++ (TyVar n tys, TyVar n' tys') | length tys == length tys' -> do+ ok <- unifyName n n'+ if not ok+ then return False+ else and <$> zipWithM unifyTyp tys tys'++ (TyFun args ret, TyFun args' ret') | length args == length args' -> do+ ok <- unifyTyp ret ret'+ if not ok+ then return False+ else and <$> zipWithM unifyTyp args args'++ _ -> return False++-- The total cost of a unification operation.+newtype Work = Work Int++unWork :: Work -> Int+unWork (Work w) = w++workDelta :: Monad m => Work -> StateT Work m ()+workDelta (Work dw) = modify' (\(Work w) -> Work (w + dw))
src/Query.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards, ViewPatterns, RecordWildCards #-}+{-# OPTIONS_GHC -O0 #-} -- otherwise it takes a lot of memory to compile on the haskell.org server module Query( Query(..), isQueryName, isQueryType, isQueryScope,