diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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

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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,19 @@ -# Hoogle [![Hackage version](https://img.shields.io/hackage/v/hoogle.svg?label=Hackage)](https://hackage.haskell.org/package/hoogle) [![Stackage version](https://www.stackage.org/package/hoogle/badge/lts?label=Stackage)](https://www.stackage.org/package/hoogle) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/hoogle.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/hoogle) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/hoogle.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/hoogle) +# Hoogle [![Hackage version](https://img.shields.io/hackage/v/hoogle.svg?label=Hackage)](https://hackage.haskell.org/package/hoogle) [![Stackage version](https://www.stackage.org/package/hoogle/badge/nightly?label=Stackage)](https://www.stackage.org/package/hoogle) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/hoogle/master.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/hoogle) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/hoogle/master.svg?label=Windows%20build)](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.** ---------- diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -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, diff --git a/html/hoogle.css b/html/hoogle.css --- a/html/hoogle.css +++ b/html/hoogle.css @@ -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;} diff --git a/html/index.html b/html/index.html --- a/html/index.html +++ b/html/index.html @@ -32,7 +32,6 @@
#{body} -
diff --git a/src/Action/CmdLine.hs b/src/Action/CmdLine.hs --- a/src/Action/CmdLine.hs +++ b/src/Action/CmdLine.hs @@ -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" diff --git a/src/Action/Generate.hs b/src/Action/Generate.hs --- a/src/Action/Generate.hs +++ b/src/Action/Generate.hs @@ -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 diff --git a/src/Action/Search.hs b/src/Action/Search.hs --- a/src/Action/Search.hs +++ b/src/Action/Search.hs @@ -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 } + + + diff --git a/src/Action/Server.hs b/src/Action/Server.hs --- a/src/Action/Server.hs +++ b/src/Action/Server.hs @@ -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 ++ "" | (a,b) <- catMaybes $ p : map remod ms] + in unwords ["" ++ strUnpack 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 "" x = pre ++ highlight (unescapeHTML name) ++ post + | Just (pre,x) <- stripInfix "" x, Just (name,post) <- stripInfix "" x = pre ++ highlight (unescapeHTML name) ++ post | otherwise = x where highlight = concatMap (\xs@((b,_):_) -> let s = escapeHTML $ map snd xs in if b then "" ++ s ++ "" else s) . @@ -226,19 +239,19 @@ action_server_test_ :: IO () action_server_test_ = do testing "Action.Server.displayItem" $ do - let expand = replace "{" "" . replace "}" "" . replace "<0>" "" . replace "" "" + let expand = replace "{" "" . replace "}" "" . replace "" "" . replace "" "" contract = replace "{" "" . replace "}" "" let q === s | displayItem (parseQuery q) (contract s) == expand s = putChar '.' | otherwise = error $ show (q,s,displayItem (parseQuery q) (contract s)) - "test" === "<0>my{Test} :: Int -> test" - "new west" === "<0>{newest}_{new} :: Int" - "+*" === "(<0>{+*}&) :: Int" - "+<" === "(<0>>{+<}) :: Int" - "foo" === "data <0>{Foo}d" - "foo" === "type <0>{Foo}d" - "foo" === "type family <0>{Foo}d" - "foo" === "module Foo.Bar.<0>F{Foo}" - "foo" === "module <0>{Foo}o" + "test" === "my{Test} :: Int -> test" + "new west" === "{newest}_{new} :: Int" + "+*" === "({+*}&) :: Int" + "+<" === "(>{+<}) :: Int" + "foo" === "data {Foo}d" + "foo" === "type {Foo}d" + "foo" === "type family {Foo}d" + "foo" === "module Foo.Bar.F{Foo}" + "foo" === "module {Foo}o" 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" === "type family" @@ -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 ++ "}" diff --git a/src/Action/Test.hs b/src/Action/Test.hs --- a/src/Action/Test.hs +++ b/src/Action/Test.hs @@ -25,6 +25,7 @@ input_haddock_test query_test action_server_test_ + item_test putStrLn "" putStrLn "Sample database tests" diff --git a/src/General/Conduit.hs b/src/General/Conduit.hs --- a/src/General/Conduit.hs +++ b/src/General/Conduit.hs @@ -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 diff --git a/src/General/IString.hs b/src/General/IString.hs --- a/src/General/IString.hs +++ b/src/General/IString.hs @@ -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) diff --git a/src/General/Log.hs b/src/General/Log.hs --- a/src/General/Log.hs +++ b/src/General/Log.hs @@ -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) diff --git a/src/General/Store.hs b/src/General/Store.hs --- a/src/General/Store.hs +++ b/src/General/Store.hs @@ -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 diff --git a/src/General/Str.hs b/src/General/Str.hs --- a/src/General/Str.hs +++ b/src/General/Str.hs @@ -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' diff --git a/src/General/Template.hs b/src/General/Template.hs --- a/src/General/Template.hs +++ b/src/General/Template.hs @@ -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 diff --git a/src/General/Timing.hs b/src/General/Timing.hs --- a/src/General/Timing.hs +++ b/src/General/Timing.hs @@ -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 diff --git a/src/General/Util.hs b/src/General/Util.hs --- a/src/General/Util.hs +++ b/src/General/Util.hs @@ -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 diff --git a/src/General/Web.hs b/src/General/Web.hs --- a/src/General/Web.hs +++ b/src/General/Web.hs @@ -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) diff --git a/src/Input/Cabal.hs b/src/Input/Cabal.hs --- a/src/Input/Cabal.hs +++ b/src/Input/Cabal.hs @@ -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"]]] diff --git a/src/Input/Download.hs b/src/Input/Download.hs --- a/src/Input/Download.hs +++ b/src/Input/Download.hs @@ -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 diff --git a/src/Input/Haddock.hs b/src/Input/Haddock.hs --- a/src/Input/Haddock.hs +++ b/src/Input/Haddock.hs @@ -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 = "package <0>" ++ escapeHTML x ++ "" -renderModule (breakEnd (== '.') -> (pre,post)) = "module " ++ escapeHTML pre ++ "<0>" ++ escapeHTML post ++ "" +renderPackage x = "package " ++ escapeHTML (strUnpack x) ++ "" +renderModule (breakEnd (== '.') . strUnpack -> (pre,post)) = "module " ++ escapeHTML pre ++ "" ++ escapeHTML post ++ "" renderItem :: Entry -> String @@ -104,16 +104,16 @@ focus (EDecl x) = pretty x highlight :: String -> String - highlight x = "<0>" ++ escapeHTML x ++ "" + highlight x = "" ++ escapeHTML x ++ "" 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 diff --git a/src/Input/Item.hs b/src/Input/Item.hs --- a/src/Input/Item.hs +++ b/src/Input/Item.hs @@ -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 @\@ for the name and @\@ 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 diff --git a/src/Input/Reorder.hs b/src/Input/Reorder.hs --- a/src/Input/Reorder.hs +++ b/src/Input/Reorder.hs @@ -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) diff --git a/src/Output/Items.hs b/src/Output/Items.hs --- a/src/Output/Items.hs +++ b/src/Output/Items.hs @@ -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 diff --git a/src/Output/Names.hs b/src/Output/Names.hs --- a/src/Output/Names.hs +++ b/src/Output/Names.hs @@ -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 -> diff --git a/src/Output/Tags.hs b/src/Output/Tags.hs --- a/src/Output/Tags.hs +++ b/src/Output/Tags.hs @@ -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 diff --git a/src/Output/Types.hs b/src/Output/Types.hs --- a/src/Output/Types.hs +++ b/src/Output/Types.hs @@ -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)) diff --git a/src/Query.hs b/src/Query.hs --- a/src/Query.hs +++ b/src/Query.hs @@ -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,