hoogle 5.0.17.15 → 5.0.18
raw patch · 24 files changed
+168/−145 lines, 24 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGES.txt +6/−1
- hoogle.cabal +2/−2
- src/Action/CmdLine.hs +7/−7
- src/Action/Generate.hs +17/−17
- src/Action/Search.hs +17/−16
- src/Action/Server.hs +14/−14
- src/General/Conduit.hs +1/−1
- src/General/Log.hs +8/−8
- src/General/Store.hs +4/−4
- src/General/Template.hs +7/−6
- src/General/Timing.hs +4/−4
- src/General/Util.hs +4/−4
- src/General/Web.hs +2/−2
- src/Input/Cabal.hs +5/−5
- src/Input/Download.hs +1/−1
- src/Input/Haddock.hs +12/−2
- src/Input/Item.hs +3/−3
- src/Input/Set.hs +1/−1
- src/Input/Settings.hs +4/−4
- src/Output/Items.hs +3/−3
- src/Output/Names.hs +2/−2
- src/Output/Tags.hs +3/−3
- src/Output/Types.hs +40/−34
- src/Query.hs +1/−1
CHANGES.txt view
@@ -1,5 +1,10 @@-Changelog for Hoogle (* = breaking change)+Changelog for Hoogle (* = API change, @ = database format change) +5.0.18, released 2020-07-19+ #356, make server --haddock work better+@ #339, support enough names to index all of Hackage+ #353, remove leading latex comments+ #351, partially fixed ghc-pkg output parsing for GHC 8.8 5.0.17.15, released 2020-02-15 #342, have --local flag generate a set with the directory name Consider packages in Stackage Nightly and LTS part of Stackage
hoogle.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.18 build-type: Simple name: hoogle-version: 5.0.17.15+version: 5.0.18 license: BSD3 license-file: LICENSE category: Development@@ -15,7 +15,7 @@ or by approximate type signature. homepage: https://hoogle.haskell.org/ bug-reports: https://github.com/ndmitchell/hoogle/issues-tested-with: GHC==8.8.1, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2+tested-with: GHC==8.10.1, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2 extra-doc-files: README.md CHANGES.txt
src/Action/CmdLine.hs view
@@ -79,24 +79,24 @@ defaultDatabaseLang :: Language -> IO FilePath defaultDatabaseLang lang = do dir <- getAppUserDataDirectory "hoogle"- return $ dir </> "default-" ++ lower (show lang) ++ "-" ++ showVersion (trimVersion 3 version) ++ ".hoo"+ pure $ dir </> "default-" ++ lower (show lang) ++ "-" ++ showVersion (trimVersion 3 version) ++ ".hoo" getCmdLine :: [String] -> IO CmdLine getCmdLine args = do args <- withArgs args $ cmdArgsRun cmdLineMode -- fill in the default database- args <- if database args /= "" then return args else do- db <- defaultDatabaseLang $ language args; return args{database=db}+ args <- if database args /= "" then pure args else do+ db <- defaultDatabaseLang $ language args; pure args{database=db} -- fix up people using Hoogle 4 instructions args <- case args of Generate{..} | "all" `elem` include -> do putStrLn "Warning: 'all' argument is no longer required, and has been ignored."- return $ args{include = delete "all" include}- _ -> return args+ pure $ args{include = delete "all" include}+ _ -> pure args - return args+ pure args defaultGenerate :: CmdLine@@ -117,7 +117,7 @@ ,count = Nothing &= name "n" &= help "Maximum number of results to return (defaults to 10)" ,query = def &= args &= typ "QUERY" ,repeat_ = 1 &= help "Number of times to repeat (for benchmarking)"- ,language = enum [x &= explicit &= name (lower $ show x) &= help ("Work with " ++ show x) | x <- [minBound..maxBound]] &= groupname "Language"+ ,language = enum [x &= explicit &= name (lower $ show x) &= help ("Work with " ++ show x) | x <- enumerate] &= groupname "Language" ,compare_ = def &= help "Type signatures to compare against" } &= help "Perform a search"
src/Action/Generate.hs view
@@ -107,7 +107,7 @@ cbl <- timed timing "Reading Cabal" $ parseCabalTarball settings cabals let want = Set.insert (strPack "ghc") $ Set.unions [setStackage, setPlatform, setGHC]- cbl <- return $ flip Map.mapWithKey cbl $ \name p ->+ cbl <- pure $ flip Map.mapWithKey cbl $ \name p -> p{packageTags = [(strPack "set",strPack "included-with-ghc") | name `Set.member` setGHC] ++ [(strPack "set",strPack "haskell-platform") | name `Set.member` setPlatform] ++@@ -118,7 +118,7 @@ tar <- liftIO $ tarballReadFiles hoogles forM_ tar $ \(strPack . takeBaseName -> name, src) -> yield (name, hackagePackageURL name, src)- return (cbl, want, source)+ pure (cbl, want, source) readHaskellDirs :: Timing -> Settings -> [FilePath] -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ())@@ -136,15 +136,15 @@ dir <- liftIO $ canonicalizePath $ takeDirectory file let url = "file://" ++ ['/' | not $ "/" `isPrefixOf` dir] ++ replace "\\" "/" dir ++ "/" yield (name, url, lbstrFromChunks [src])- return (Map.union+ pure (Map.union (Map.fromList cabals)- (Map.fromList $ map generateBarePackage packages)+ (Map.fromListWith (<>) $ map generateBarePackage packages) ,Set.fromList $ map fst packages, source) where parseCabal fp = do src <- readFileUTF8' fp let pkg = readCabal settings src- return (strPack $ takeBaseName fp, pkg)+ pure (strPack $ takeBaseName fp, pkg) generateBarePackage (name, file) = (name, mempty{packageTags = (strPack "set", strPack "all") : sets})@@ -158,7 +158,7 @@ let source = do src <- liftIO $ bstrReadFile frege yield (strPack "frege", "http://google.com/", lbstrFromChunks [src])- return (Map.empty, Set.singleton $ strPack "frege", source)+ pure (Map.empty, Set.singleton $ strPack "frege", source) readHaskellGhcpkg :: Timing -> Settings -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ())@@ -173,9 +173,9 @@ let url = "file://" ++ ['/' | not $ all isPathSeparator $ take 1 docs] ++ replace "\\" "/" (addTrailingPathSeparator docs) yield (name, url, lbstrFromChunks [src])- cbl <- return $ let ts = map (both strPack) [("set","stackage"),("set","installed")]+ cbl <- pure $ 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)+ pure (cbl, Map.keysSet cbl, source) readHaskellHaddock :: Timing -> Settings -> FilePath -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ()) readHaskellHaddock timing settings docBaseDir = do@@ -189,9 +189,9 @@ let url = ['/' | not $ all isPathSeparator $ take 1 docs] ++ replace "\\" "/" (addTrailingPathSeparator docs) yield (name, url, lbstrFromChunks [src])- cbl <- return $ let ts = map (both strPack) [("set","stackage"),("set","installed")]+ cbl <- pure $ 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)+ pure (cbl, Map.keysSet cbl, source) where docDir name Package{..} = name ++ "-" ++ strUnpack packageVersion @@ -201,7 +201,7 @@ createDirectoryIfMissing True $ takeDirectory database whenLoud $ putStrLn $ "Generating files to " ++ takeDirectory database - download <- return $ downloadInput timing insecure download (takeDirectory database)+ download <- pure $ downloadInput timing insecure download (takeDirectory database) settings <- loadSettings (cbl, want, source) <- case language of Haskell | Just dir <- haddock -> readHaskellHaddock timing settings dir@@ -217,8 +217,8 @@ -- 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 $ case count of Nothing -> want; Just count -> Set.fromList $ take count $ Set.toList want+ want <- pure $ if include /= [] then Set.fromList $ map strPack include else want+ want <- pure $ case count of Nothing -> want; Just count -> Set.fromList $ take count $ Set.toList want (stats, _) <- storeWriteFile database $ \store -> do xs <- withBinaryFile (database `replaceExtension` "warn") WriteMode $ \warnings -> do@@ -258,24 +258,24 @@ else if null include then ret "Not on Stackage, so not searched.\n" else- return ()+ pure () )) .| pipelineC 10 (items .| sinkList) itemWarn <- readIORef itemWarn when (itemWarn > 0) $ putStrLn $ "Found " ++ show itemWarn ++ " warnings when processing items"- return [(a,b) | (a,bs) <- xs, b <- bs]+ pure [(a,b) | (a,bs) <- xs, b <- bs] itemsMemory <- getStatsCurrentLiveBytes- xs <- timed timing "Reordering items" $ return $! reorderItems settings (\s -> maybe 1 negate $ Map.lookup s popularity) xs+ xs <- timed timing "Reordering items" $ pure $! reorderItems settings (\s -> maybe 1 negate $ Map.lookup s popularity) 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 x <- getVerbosity when (x >= Loud) $- maybe (return ()) print =<< getStatsDebug+ whenJustM getStatsDebug print when (x >= Normal) $ do whenJustM getStatsPeakAllocBytes $ \x -> putStrLn $ "Peak of " ++ x ++ ", " ++ fromMaybe "unknown" itemsMemory ++ " for items"
src/Action/Search.hs view
@@ -39,8 +39,8 @@ actionSearch Search{..} = replicateM_ repeat_ $ -- deliberately reopen the database each time withSearch database $ \store -> if null compare_ then do- count' <- return $ fromMaybe 10 count- (q, res) <- return $ search store $ parseQuery $ unwords query+ count' <- pure $ fromMaybe 10 count+ (q, res) <- pure $ search store $ parseQuery $ unwords query whenLoud $ putStrLn $ "Query: " ++ unescapeHTML (LBS.unpack $ renderMarkup $ renderQuery q) let (shown, hidden) = splitAt count' $ nubOrd $ map (targetResultDisplay link) res if null res then@@ -78,7 +78,7 @@ unHTMLtargetItem target = target {targetItem = unHTML $ targetItem target} addCounter :: [String] -> [String]-addCounter = zipWith (\i x -> show i ++ ") " ++ x) [1..]+addCounter = zipWithFrom (\i x -> show i ++ ") " ++ x) 1 withSearch :: NFData a => FilePath -> (StoreRead -> IO a) -> IO a withSearch database act = do@@ -90,26 +90,26 @@ search :: StoreRead -> [Query] -> ([Query], [Target]) search store qs = runIdentity $ do- (qs, exact, filt, list) <- return $ applyTags store qs+ (qs, exact, filt, list) <- pure $ applyTags store qs is <- case (filter isQueryName qs, filter isQueryType qs) of- ([], [] ) -> return list- ([], t:_) -> return $ searchTypes store $ hseToSig $ fromQueryType t- (xs, [] ) -> return $ searchNames store exact $ map fromQueryName xs+ ([], [] ) -> pure list+ ([], t:_) -> pure $ searchTypes store $ hseToSig $ fromQueryType t+ (xs, [] ) -> pure $ searchNames store exact $ map fromQueryName xs (xs, t:_) -> do- nam <- return $ Set.fromList $ searchNames store exact $ map fromQueryName xs- return $ filter (`Set.member` nam) $ searchTypes store $ hseToSig $ fromQueryType t+ nam <- pure $ Set.fromList $ searchNames store exact $ map fromQueryName xs+ pure $ filter (`Set.member` nam) $ searchTypes store $ hseToSig $ fromQueryType t let look = lookupItem store- return (qs, map look $ filter filt is)+ pure (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- res <- return $ snd $ search store (parseQuery a)+ res <- pure $ snd $ search store (parseQuery a) case res of [] -> putChar '.' _ -> errorIO $ "Searching for: " ++ show a ++ "\nGot: " ++ show (take 1 res) ++ "\n expected none" let a ==$ f = do- res <- return $ snd $ search store (parseQuery a)+ res <- pure $ snd $ search store (parseQuery a) case res of Target{..}:_ | f targetURL -> putChar '.' _ -> errorIO $ "Searching for: " ++ show a ++ "\nGot: " ++ show (take 1 res)@@ -264,8 +264,9 @@ query "a -> m a" -- see GitHub issue #180 [ InTop 20 ("pure" `inPackage` "base") , InTop 50 ("return" `inPackage` "base")- , InTop 5 ("pure" `inPackage` "base") , KnownFailure "GitHub issue #267" $+ InTop 5 ("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@@ -282,7 +283,7 @@ TopHit ("fromInteger" `inPackage` "base") ] query "[Parser a] -> Parser a" -- see GitHub issue #90- [ InTop 10 ("choice" `inPackage` "attoparsec")+ [ KnownFailure "Todo" $ InTop 10 ("choice" `inPackage` "attoparsec") ] let tags = completionTags store@@ -336,7 +337,7 @@ UnexpectedSuccess -> Failure where success p = if p then Success else Failure- matchIdx tm = fmap fst $ find (runTargetMatcher tm . snd) (zip [0..] $ concat res)+ matchIdx tm = fmap fst $ find (runTargetMatcher tm . snd) (zipFrom 0 $ concat res) data TargetMatcher = MatchFunctionInModule String String@@ -368,7 +369,7 @@ where tgtMap :: Map.Map Target (Int, [Target]) tgtMap = Map.fromListWith (\(n, ts) (n', ts') -> (min n n', ts ++ ts'))- $ zipWith (\n t -> (simple t, (n, [t]))) [0..] tgts+ $ zipWithFrom (\n t -> (simple t, (n, [t]))) 0 tgts simple :: Target -> Target simple t = t { targetURL = "", targetPackage = Nothing, targetModule = Nothing }
src/Action/Server.hs view
@@ -61,8 +61,8 @@ \x -> BS.pack "hoogle=" `BS.isInfixOf` x && not (BS.pack "is:ping" `BS.isInfixOf` x) putStrLn . showDuration =<< time evaluate spawned- dataDir <- maybe getDataDir return datadir- haddock <- maybe (return Nothing) (fmap Just . canonicalizePath) haddock+ dataDir <- maybe getDataDir pure datadir+ haddock <- maybe (pure Nothing) (fmap Just . canonicalizePath) haddock withSearch database $ \store -> server log cmd $ replyServer log local links haddock store cdn home (dataDir </> "html") scope @@ -118,9 +118,9 @@ filteredResults = take count $ drop start results in case lookup "format" inputArgs of Just "text" -> pure $ OutputJSON $ JSON.toEncoding $ map unHTMLTarget filteredResults- Just f -> return $ OutputFail $ lbstrPack $ "Format mode " ++ f ++ " not (currently) supported"+ Just f -> pure $ OutputFail $ lbstrPack $ "Format mode " ++ f ++ " not (currently) supported" Nothing -> pure $ OutputJSON $ JSON.toEncoding filteredResults- Just m -> return $ OutputFail $ lbstrPack $ "Mode " ++ m ++ " not (currently) supported"+ Just m -> pure $ 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@@ -130,7 +130,7 @@ summ <- logSummary log let errs = sum [summaryErrors | Summary{..} <- summ, summaryDate >= pred (utctDay now)] let alive = fromRational $ toRational $ (now `diffUTCTime` spawned) / (24 * 60 * 60)- return $ (if errs == 0 && alive < 1.5 then OutputText else OutputFail) $ lbstrPack $+ pure $ (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" @@ -141,24 +141,24 @@ OutputJavascript <$> templateRender templateLogJs [("data",html $ H.preEscapedString log)] ["stats"] -> do stats <- getStatsDebug- return $ case stats of+ pure $ case stats of Nothing -> OutputFail $ lbstrPack "GHC Statistics is not enabled, restart with +RTS -T"- Just x -> OutputText $ lbstrPack $ replace ", " "\n" $ takeWhile (/= '}') $ drop 1 $ dropWhile (/= '{') $ show x+ Just x -> OutputText $ lbstrPack $ replace ", " "\n" $ takeWhile (/= '}') $ drop1 $ dropWhile (/= '{') $ show x "haddock":xs | Just x <- haddock -> do let file = intercalate "/" $ x:xs- return $ OutputFile $ file ++ (if hasTrailingPathSeparator file then "index.html" else "")+ pure $ OutputFile $ file ++ (if hasTrailingPathSeparator file then "index.html" else "") "file":xs | local -> do let x = ['/' | not isWindows] ++ intercalate "/" (dropWhile null xs) let file = x ++ (if hasTrailingPathSeparator x then "index.html" else "") if takeExtension file /= ".html" then- return $ OutputFile file+ pure $ OutputFile file else do src <- readFile file -- Haddock incorrectly generates file:// on Windows, when it should be file:/// -- so replace on file:// and drop all leading empty paths above- return $ OutputHTML $ lbstrPack $ replace "file://" "/file/" src+ pure $ OutputHTML $ lbstrPack $ replace "file://" "/file/" src xs ->- return $ OutputFile $ joinPath $ htmlDir : xs+ pure $ OutputFile $ joinPath $ htmlDir : xs where html = templateMarkup text = templateMarkup . H.string@@ -241,11 +241,11 @@ let ms = filter ((==) p . targetPackage) xs in mconcat $ intersperse " " [H.a ! H.href (H.stringValue $ showURL local haddock b) $ H.string a | (a,b) <- catMaybes $ p : map remod ms] where- remod Target{..} = do (a,_) <- targetModule; return (a,targetURL)+ remod Target{..} = do (a,_) <- targetModule; pure (a,targetURL) pkgs = nubOrd $ map targetPackage xs showURL :: Bool -> Maybe FilePath -> URL -> String-showURL _ (Just _) x = "haddock" ++ x+showURL _ (Just _) x = "haddock/" ++ dropPrefix "file:///" x showURL True _ (stripPrefix "file:///" -> Just x) = "file/" ++ x showURL _ _ x = x @@ -259,7 +259,7 @@ = H.preEscapedString pre <> highlight (unescapeHTML name) <> H.preEscapedString post | otherwise = H.string x where- highlight = mconcat . map (\xs@((b,_):_) -> let s = H.string $ map snd xs in if b then H.b s else s) .+ highlight = mconcatMap (\xs@((b,_):_) -> let s = H.string $ map snd xs in if b then H.b s else s) . groupOn fst . (\x -> zip (f x) x) where f (x:xs) | m > 0 = replicate m True ++ drop (m - 1) (f xs)
src/General/Conduit.hs view
@@ -74,7 +74,7 @@ x <- liftIO $ readChan chan liftIO $ signalQSem sem whenJust x yield- return $ isJust x) .|+ pure $ isJust x) .| sink awaitForever $ \x -> liftIO $ do waitQSem sem
src/General/Log.hs view
@@ -22,7 +22,7 @@ import General.Util import Data.Maybe import Data.List-import Data.IORef+import Data.IORef.Extra import Prelude @@ -36,23 +36,23 @@ showTime = showUTCTime "%Y-%m-%dT%H:%M:%S%Q" logNone :: IO Log-logNone = do ref <- newIORef Map.empty; return $ Log Nothing ref (const False)+logNone = do ref <- newIORef Map.empty; pure $ Log Nothing ref (const False) logCreate :: Either Handle FilePath -> (BS.ByteString -> Bool) -> IO Log logCreate store interesting = do (h, old) <- case store of- Left h -> return (h, Map.empty)+ Left h -> pure (h, Map.empty) Right file -> do b <- doesFileExist file- mp <- if not b then return Map.empty else withFile file ReadMode $ \h -> do+ mp <- if not b then pure Map.empty else withFile file ReadMode $ \h -> do src <- LBS.hGetContents h let xs = mapMaybe (parseLogLine interesting . LBS.toStrict) $ LBS.lines src- return $! foldl' (\mp (k,v) -> Map.alter (Just . maybe v (<> v)) k mp) Map.empty xs+ pure $! foldl' (\mp (k,v) -> Map.alter (Just . maybe v (<> v)) k mp) Map.empty xs (,mp) <$> openFile file AppendMode hSetBuffering h LineBuffering var <- newVar h ref <- newIORef old- return $ Log (Just var) ref (interesting . BS.pack)+ pure $ Log (Just var) ref (interesting . BS.pack) logAddMessage :: Log -> String -> IO () logAddMessage Log{..} msg = do@@ -63,13 +63,13 @@ logAddEntry :: Log -> String -> String -> Double -> Maybe String -> IO () logAddEntry Log{..} user question taken err = do time <- getCurrentTime- let add v = atomicModifyIORef logCurrent $ \mp -> (Map.alter (Just . maybe v (<> v)) (utctDay time) mp, ())+ let add v = atomicModifyIORef_ logCurrent $ \mp -> Map.alter (Just . maybe v (<> v)) (utctDay time) mp if logInteresting question then 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- return ()+ pure () whenJust logOutput $ \var -> withVar var $ \h -> hPutStrLn h $ unwords $ [showTime time, user, showDP 3 taken, question] ++ maybeToList (fmap ((++) "ERROR: " . unwords . words) err)
src/General/Store.hs view
@@ -90,7 +90,7 @@ storeWriteAtom store k part (castPtr ptr, V.length v * sizeOf (undefined :: a)) storedRead store k = storeReadAtom store k $ \(ptr, len) -> do ptr <- newForeignPtr_ $ castPtr ptr- return $ V.unsafeFromForeignPtr0 ptr (len `div` sizeOf (undefined :: a))+ pure $ V.unsafeFromForeignPtr0 ptr (len `div` sizeOf (undefined :: a)) ---------------------------------------------------------------------@@ -130,7 +130,7 @@ let stats = prettyTable 0 "Bytes" $ ("Overheads", intToDouble $ fromIntegral final - sum (map atomSize $ Map.elems atoms)) : [(name ++ " :: " ++ atomType, intToDouble atomSize) | (name, Atom{..}) <- Map.toList atoms]- return (stats, res)+ pure (stats, res) storeWrite :: (Typeable (t a), Typeable a, Stored a) => StoreWrite -> t a -> a -> IO () storeWrite store k = storedWrite store k False@@ -151,8 +151,8 @@ (keyOld,a):xs | part, key == keyOld -> do let size = atomSize a + len evaluate size- return $ (key,a{atomSize=size}) : xs- _ -> return $ (key, Atom val swPosition len) : swAtoms+ pure $ (key,a{atomSize=size}) : xs+ _ -> pure $ (key, Atom val swPosition len) : swAtoms writeIORef' ref sw{swPosition = swPosition + len, swAtoms = atoms}
src/General/Template.hs view
@@ -9,6 +9,7 @@ import Text.Blaze import Text.Blaze.Renderer.Utf8 import General.Str+import Data.List.Extra import Control.Exception import Data.Generics.Uniplate.Data import Control.Applicative@@ -34,7 +35,7 @@ treeRemoveLam = transformM f where f (Lam file) = List . parse <$> bstrReadFile file- f x = return x+ f x = pure x parse x | Just (a,b) <- bstrSplitInfix (bstrPack "#{") x , Just (b,c) <- bstrSplitInfix (bstrPack "}") b@@ -60,7 +61,7 @@ g [] = [] g (x:xs) | not $ isLit x = x : g xs- g xs = [Lit x | let x = mconcat $ map fromLit a, x /= mempty] ++ g b+ g xs = [Lit x | let x = mconcatMap fromLit a, x /= mempty] ++ g b where (a,b) = span isLit xs treeEval :: Tree -> [BStr]@@ -81,16 +82,16 @@ treeCache t0 = unsafePerformIO $ do let files = [x | Lam x <- universe t0] ref <- newIORef ([], treeOptimise t0)- return $ do+ pure $ do (old,t) <- readIORef ref new <- forM files $ \file -> -- the standard getModificationTime message on Windows doesn't say the file getModificationTime file `catch` \(e :: IOException) -> fail $ "Failed: getModificationTime on " ++ file ++ ", " ++ show e- if old == new then return t else do+ if old == new then pure t else do t <- treeOptimise <$> treeRemoveLam t0 writeIORef ref (new,t)- return t+ pure t templateTree :: Tree -> Template templateTree t = Template t $ treeCache t@@ -110,5 +111,5 @@ templateRender :: Template -> [(String, Template)] -> IO LBStr templateRender (Template _ t) args = do t <- t- let Template t2 _ = templateApply (Template t $ return t) args+ let Template t2 _ = templateApply (Template t $ pure t) args lbstrFromChunks . treeEval <$> treeRemoveLam t2
src/General/Timing.hs view
@@ -33,10 +33,10 @@ -- 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 $ sortOn (negate . snd) $ ("Unrecorded", total - sum (map snd xs)) : xs+ xs <- pure $ sortOn (negate . snd) $ ("Unrecorded", total - sum (map snd xs)) : xs writeFile file $ unlines $ prettyTable 2 "Secs" xs putStrLn $ "Took " ++ showDuration total- return res+ pure res -- skip it if have written out in the last 1s and takes < 0.1@@ -57,7 +57,7 @@ else putStrLn "" - let out msg = liftIO $ putStr msg >> return (length msg)+ let out msg = liftIO $ putStr msg >> pure (length msg) undo1 <- out $ msg ++ "... " liftIO $ hFlush stdout @@ -76,4 +76,4 @@ else do writeIORef timingOverwrite Nothing putStrLn ""- return res+ pure res
src/General/Util.hs view
@@ -78,10 +78,10 @@ #if RTS_STATS withRTSStats :: (RTSStats -> a) -> IO (Maybe a)-withRTSStats f = ifM getRTSStatsEnabled (Just . f <$> getRTSStats) (return Nothing)+withRTSStats f = ifM getRTSStatsEnabled (Just . f <$> getRTSStats) (pure Nothing) #else withGCStats :: (GCStats -> a) -> IO (Maybe a)-withGCStats f = ifM getGCStatsEnabled (Just . f <$> getGCStats) (return Nothing)+withGCStats f = ifM getGCStatsEnabled (Just . f <$> getGCStats) (pure Nothing) #endif getStatsCurrentLiveBytes :: IO (Maybe String)@@ -103,7 +103,7 @@ getStatsDebug :: IO (Maybe String) getStatsDebug = do- let dump = replace ", " "\n" . takeWhile (/= '}') . drop 1 . dropWhile (/= '{') . show+ let dump = replace ", " "\n" . takeWhile (/= '}') . drop1 . dropWhile (/= '{') . show #if RTS_STATS withRTSStats dump #else@@ -210,7 +210,7 @@ innerTextHTML :: String -> String-innerTextHTML ('<':xs) = innerTextHTML $ drop 1 $ dropWhile (/= '>') xs+innerTextHTML ('<':xs) = innerTextHTML $ drop1 $ dropWhile (/= '>') xs innerTextHTML (x:xs) = x : innerTextHTML xs innerTextHTML [] = []
src/General/Web.hs view
@@ -161,10 +161,10 @@ let pq = BS.unpack $ rawPathInfo req <> rawQueryString req putStrLn pq (time, res) <- duration $ case readInput pq of- Nothing -> return $ Right (OutputFail "", LBS.pack $ "Bad URL: " ++ pq)+ Nothing -> pure $ Right (OutputFail "", LBS.pack $ "Bad URL: " ++ pq) Just pay -> handle_ (fmap Left . showException) $ do- s <- act pay; bs <- evaluate $ forceBS s; return $ Right (s, bs)+ s <- act pay; bs <- evaluate $ forceBS s; pure $ Right (s, bs) logAddEntry log (showSockAddr $ remoteHost req) pq time (either Just (const Nothing) res) case res of Left s -> reply $ responseLBS status500 [] $ LBS.pack s
src/Input/Cabal.hs view
@@ -87,9 +87,9 @@ 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 (strPack x, fixer $ readCabal settings $ unlines xs)+ let f ((stripPrefix "name: " -> Just x):xs) = Just (strPack $ trimStart x, fixer $ readCabal settings $ unlines xs) f xs = Nothing- return $ Map.fromList $ mapMaybe f $ splitOn ["---"] $ lines $ filter (/= '\r') $ UTF8.toString stdout+ pure $ Map.fromList $ mapMaybe f $ splitOn ["---"] $ lines $ filter (/= '\r') $ UTF8.toString stdout -- | Given a tarball of Cabal files, parse the latest version of each package.@@ -103,7 +103,7 @@ (sourceList =<< liftIO (tarballReadFiles tarfile)) .| mapC (first takeBaseName) .| groupOnLastC fst .| mapMC (evaluate . force) .| pipelineC 10 (mapC (strPack *** readCabal settings . lbstrUnpack) .| mapMC (evaluate . force) .| sinkList)- return $ Map.fromList res+ pure $ Map.fromList res ---------------------------------------------------------------------@@ -120,10 +120,10 @@ map strPack $ nubOrd $ filter (/= "") $ map (intercalate "-" . takeWhile (all isAlpha . take 1) . splitOn "-" . fst . word1) $ concatMap (split (== ',')) (ask "build-depends") ++ concatMap words (ask "depends")- packageVersion = strPack $ head $ dropWhile null (ask "version") ++ ["0.0"]+ packageVersion = strPack $ headDef "0.0" $ dropWhile null (ask "version") packageSynopsis = strPack $ unwords $ words $ unwords $ ask "synopsis" packageLibrary = "library" `elem` map (lower . trim) (lines src)- packageDocs = listToMaybe $ ask "haddock-html"+ packageDocs = find (not . null) $ ask "haddock-html" packageTags = map (both strPack) $ nubOrd $ concat [ map (head xs,) $ concatMap cleanup $ concatMap ask xs
src/Input/Download.hs view
@@ -26,7 +26,7 @@ timed timing ("Downloading " ++ url) $ do downloadFile insecure (file <.> "part") url renameFile (file <.> "part") file- return file+ pure file downloadFile :: Bool -> FilePath -> String -> IO () downloadFile insecure file url = do
src/Input/Haddock.hs view
@@ -5,6 +5,7 @@ import Language.Haskell.Exts as HSE import Data.Char import Data.List.Extra+import Data.Maybe import Data.Data import Input.Item import General.Util@@ -37,7 +38,7 @@ f com url = do x <- await whenJust x $ \(i,s) -> case () of- _ | Just s <- bstrStripPrefix "-- | " s -> f [s] url+ _ | Just s <- bstrStripPrefix "-- | " s -> f [ignoreMath 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 [] ""@@ -46,10 +47,19 @@ Left y -> lift $ warning $ show i ++ ":" ++ y -- only check Nothing as some items (e.g. "instance () :> Foo a") -- don't roundtrip but do come out equivalent- Right [EDecl InfixDecl{}] -> return () -- can ignore infix constructors+ Right [EDecl InfixDecl{}] -> pure () -- can ignore infix constructors Right xs -> forM_ xs $ \x -> yield (Target url Nothing Nothing (typeItem x) (renderItem x) $ reformat $ reverse com, x) -- descendBi stringShare x) f [] ""+++-- See https://github.com/ndmitchell/hoogle/issues/353+-- for functions like `tail` which start <math>.+ignoreMath :: BStr -> BStr+ignoreMath x | Just x <- "<math>" `bstrStripPrefix` x+ = fromMaybe x $ ". " `bstrStripPrefix` x+ignoreMath x = x+ typeItem (EPackage x) = "package" typeItem (EModule x) = "module"
src/Input/Item.hs view
@@ -143,11 +143,11 @@ <*> o .: ("docs" :: T.Text) where namedUrl o' n = do mObj <- o' .: n- if null mObj then return Nothing+ if null mObj then pure Nothing else do pkName <- mObj .: ("name" :: T.Text) pkUrl <- mObj .: ("url" :: T.Text)- return $ Just (pkName, pkUrl)+ pure $ Just (pkName, pkUrl) instance Arbitrary Target where arbitrary = Target <$> a@@ -158,7 +158,7 @@ <*> a where a = arbitrary mNurl = do- oneof [return Nothing+ oneof [pure Nothing , Just <$> liftA2 (,) a a] targetExpandURL :: Target -> Target
src/Input/Set.hs view
@@ -27,7 +27,7 @@ setPlatformWith :: FilePath -> [String] -> IO (Set.Set String) setPlatformWith file names = do src <- lines <$> readFile' file- return $ Set.fromList [read lib | ",":name:lib:_ <- map words src, name `elem` names]+ pure $ Set.fromList [read lib | ",":name:lib:_ <- map words src, name `elem` names] setGHC :: FilePath -> IO (Set.Set String) setGHC file = setPlatformWith file ["incGHCLib"]
src/Input/Settings.hs view
@@ -38,9 +38,9 @@ readFileSettings file backup = do src <- readFileUTF8 file `catch` \e -> if isDoesNotExistError e- then return backup+ then pure backup else throwIO e- return $ concat $ zipWith f [1..] $ map trim $ lines src+ pure $ concat $ zipWithFrom f 1 $ map trim $ lines src where f i s | null s = [] | "--" `isPrefixOf` s = []@@ -60,7 +60,7 @@ let backup = $(runIO (readFileUTF8 "misc/settings.txt") >>= lift) #endif src <- readFileSettings (dataDir </> "misc/settings.txt") backup- return $ createSettings src+ pure $ createSettings src createSettings :: [Setting] -> Settings createSettings xs = Settings{..}@@ -71,7 +71,7 @@ reorderModule = \pkg -> case f pkg of [] -> const 0 xs -> let f = wildcards xs- in \mod -> last $ 0 : f mod+ in \mod -> lastDef 0 (f mod) where f = wildcards [(a,(b,c)) | ReorderModule a b c <- xs]
src/Output/Items.hs view
@@ -40,14 +40,14 @@ writeItems :: StoreWrite -> (ConduitM (Maybe Target, item) (Maybe TargetId, item) IO () -> IO a) -> IO a writeItems store act = act $ do void $ (\f -> mapAccumMC f 0) $ \pos (target, item) -> case target of- Nothing -> return (pos, (Nothing, item))+ Nothing -> pure (pos, (Nothing, item)) Just target -> do let bs = LBS.toStrict $ GZip.compress $ lbstrPack $ unlines $ outputItem target liftIO $ do storeWritePart store Items $ intToBS $ BS.length bs storeWritePart store Items bs let pos2 = pos + fromIntegral (intSize + BS.length bs)- return (pos2, (Just $ TargetId pos, item))+ pure (pos2, (Just $ TargetId pos, item)) listItems :: StoreRead -> [Target]@@ -66,4 +66,4 @@ in \(TargetId i) -> let i2 = fromIntegral i n = intFromBS $ BS.take intSize $ BS.drop i2 x- in inputItem $ lines $ UTF8.toString $ GZip.decompress $ LBS.fromChunks $ return $ BS.take n $ BS.drop (i2 + intSize) x+ in inputItem $ lines $ UTF8.toString $ GZip.decompress $ LBS.fromChunks $ pure $ BS.take n $ BS.drop (i2 + intSize) x
src/Output/Names.hs view
@@ -46,7 +46,7 @@ searchNames store exact (filter (/= "") . map trim -> xs) = unsafePerformIO $ do let vs = storeRead store NamesItems -- if there are no questions, we will match everything, which exceeds the result buffer- if null xs then return $ V.toList vs else do+ if null xs then pure $ V.toList vs else do let tweak x = bstrPack $ [' ' | isUpper1 x] ++ lower x ++ "\0" bracket (mallocArray $ storeRead store NamesSize) free $ \result -> BS.unsafeUseAsCString (storeRead store NamesText) $ \haystack ->@@ -54,7 +54,7 @@ withArray0 nullPtr needles $ \needles -> do found <- c_text_search haystack needles (if exact then 1 else 0) result xs <- peekArray (fromIntegral found) result- return $ map ((vs V.!) . fromIntegral) xs+ pure $ map ((vs V.!) . fromIntegral) xs {-# NOINLINE c_text_search #-} -- for profiling c_text_search a b c d = text_search a b c d
src/Output/Tags.hs view
@@ -116,7 +116,7 @@ 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..] $ bstr0Split packageNames, val `BS.isPrefixOf` x]+ | res@(_:_) <- [(BS.length x, (i,x)) | (i,x) <- zipFrom 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) $ bstr0Split moduleNames)@@ -165,7 +165,7 @@ getRestriction (QueryScope sense cat val) = do tag <- parseTag cat val ranges <- snd $ resolveTag ts tag- return (sense, ranges)+ pure (sense, ranges) -- | Given a search which has no type or string in it, run the query on the tag bits.@@ -174,4 +174,4 @@ searchTags ts qs | x:xs <- [map fst $ maybe [] (fromMaybe [] . snd . resolveTag ts) $ parseTag cat val | QueryScope True cat val <- qs] = if null xs then x else filter (`Set.member` foldl1' Set.intersection (map Set.fromList xs)) x-searchTags ts _ = map fst $ fromMaybe [] $ snd $ resolveTag ts IsPackage+searchTags ts _ = maybe [] (map fst) $ snd $ resolveTag ts IsPackage
src/Output/Types.hs view
@@ -44,10 +44,10 @@ writeTypes :: StoreWrite -> Maybe FilePath -> [(Maybe TargetId, Item)] -> IO () writeTypes store debug xs = do let debugger ext body = whenJust debug $ \file -> writeFileUTF8 (file <.> ext) body- inst <- return $ Map.fromListWith (+) [(fromIString x,1) | (_, IInstance (Sig _ [TCon x _])) <- xs]+ inst <- pure $ Map.fromListWith (+) [(fromIString x,1) | (_, IInstance (Sig _ [TCon x _])) <- xs] xs <- writeDuplicates store [(i, fromIString <$> t) | (Just i, ISignature t) <- xs] names <- writeNames store debugger inst xs- xs <- return $ map (lookupNames names (error "Unknown name in writeTypes")) xs+ xs <- pure $ map (lookupNames names (error "Unknown name in writeTypes")) xs writeFingerprints store xs writeSignatures store xs @@ -101,7 +101,7 @@ 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+ f False "Query" query : zipWithFrom (\i -> f True ("Answer " ++ show i)) 1 answers where qsig = lookupNames names name0 $ strPack <$> snd query names = readNames store@@ -128,11 +128,15 @@ data TypesNames a where TypesNames :: TypesNames (BStr0, V.Vector Name) deriving Typeable +-- At around 7000 packages, Word16 becomes insufficient+-- because there are more than 2^16 Names, so we use Word32.+type NameWord = Word32+ -- Must be a unique Name per String. -- First 0-99 are variables, rest are constructors. -- More popular type constructors have higher numbers. -- There are currently about 14K names, so about 25% of the bit patterns are taken-newtype Name = Name Word16 deriving (Eq,Ord,Show,Data,Typeable,Storable,Binary)+newtype Name = Name NameWord deriving (Eq,Ord,Show,Data,Typeable,Storable,Binary) name0 = Name 0 -- use to represent _ @@ -150,7 +154,7 @@ -- | Give a name a popularity, where 0 is least popular, 1 is most popular popularityName :: Name -> Double popularityName (Name n) | isVar $ Name n = error "Can't call popularityName on a Var"- | otherwise = fromIntegral (n - 100) / fromIntegral (maxBound - 100 :: Word16)+ | otherwise = fromIntegral (n - 100) / fromIntegral (maxBound - 100 :: NameWord) newtype Names = Names {lookupName :: Str -> Maybe Name} @@ -177,10 +181,10 @@ Map.fromListWith (+) $ map (,1::Int) $ concatMap sigNames xs let names = spreadNames $ Map.toList freq debug "names" $ unlines [strUnpack s ++ " = " ++ show n ++ " (" ++ show (freq Map.! s) ++ " uses)" | (s,n) <- names]- names <- return $ sortOn fst names+ names <- pure $ sortOn fst 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+ pure $ Names $ \x -> Map.lookup x mp2 -- | Given a list of names, spread them out uniquely over the range [Name 100 .. Name maxBound]@@ -190,10 +194,10 @@ 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"+ | otherwise = error $ "Invalid spreadNames, length=" ++ show (length xs) -- I can only assign values between mn and mx inclusive- f :: Word16 -> Word16 -> [(a, Int)] -> [(a, Name)]+ f :: NameWord -> NameWord -> [(a, Int)] -> [(a, Name)] f !mn !mx [] = [] f mn mx ((a,i):xs) = (a, Name real) : f (mn-1) (real-1) xs where real = fromIntegral $ max mn $ min mx ideal@@ -226,12 +230,12 @@ writeDuplicates :: Ord a => StoreWrite -> [(TargetId, Sig a)] -> IO [Sig a] writeDuplicates store xs = do -- s=signature, t=targetid, p=popularity (incoing index), i=index (outgoing index)- xs <- return $ map (second snd) $ sortOn (fst . snd) $ Map.toList $+ xs <- pure $ map (second snd) $ sortOn (fst . snd) $ Map.toList $ Map.fromListWith (\(x1,x2) (y1,y2) -> (, x2 ++ y2) $! min x1 y1)- [(s,(p,[t])) | (p,(t,s)) <- zip [0::Int ..] xs]+ [(s,(p,[t])) | (p,(t,s)) <- zipFrom (0::Int) xs] -- give a list of TargetId's at each index storeWrite store TypesDuplicates $ jaggedFromList $ map (reverse . snd) xs- return $ map fst xs+ pure $ map fst xs readDuplicates :: StoreRead -> Duplicates readDuplicates store = Duplicates $ V.toList . ask@@ -262,14 +266,16 @@ fpRaresFold g f Fingerprint{..} = f fpRare1 `g` f fpRare2 `g` f fpRare3 instance Storable Fingerprint where- sizeOf _ = 64+ sizeOf _ = 3*sizeOf name0 + 2 alignment _ = 4 peekByteOff ptr i = Fingerprint- <$> peekByteOff ptr (i+0) <*> peekByteOff ptr (i+2) <*> peekByteOff ptr (i+4)- <*> peekByteOff ptr (i+6) <*> peekByteOff ptr (i+7)+ <$> peekByteOff ptr (i+0) <*> peekByteOff ptr (i+1*w) <*> peekByteOff ptr (i+2*w)+ <*> peekByteOff ptr (i+3*w) <*> peekByteOff ptr (i+3*w + 1)+ where w = sizeOf name0 pokeByteOff ptr i Fingerprint{..} = do- pokeByteOff ptr (i+0) fpRare1 >> pokeByteOff ptr (i+2) fpRare2 >> pokeByteOff ptr (i+4) fpRare3- pokeByteOff ptr (i+6) fpArity >> pokeByteOff ptr (i+7) fpTerms+ pokeByteOff ptr (i+0) fpRare1 >> pokeByteOff ptr (i+1*w) fpRare2 >> pokeByteOff ptr (i+2*w) fpRare3+ pokeByteOff ptr (i+3*w) fpArity >> pokeByteOff ptr (i+3*w + 1) fpTerms+ where w = sizeOf name0 toFingerprint :: Sig Name -> Fingerprint toFingerprint sig = Fingerprint{..}@@ -362,7 +368,7 @@ writeSignatures :: StoreWrite -> [Sig Name] -> IO () writeSignatures store xs = do v <- VM.new $ length xs- forM_ (zip [0..] xs) $ \(i,x) -> do+ forM_ (zipFrom 0 xs) $ \(i,x) -> do let b = encodeBS x storeWritePart store TypesSigData b VM.write v i $ fromIntegral $ BS.length b@@ -400,7 +406,7 @@ 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, (i, sigIdx, f)) | (i, (sigIdx, f)) <- zipFrom 0 db , fv <- maybeToList (matchFp f) ] where matchFp = matchFingerprint sig@@ -422,7 +428,7 @@ (qry, qryC) <- lift (refTyp True lhs lctx) (ans, ansC) <- lift (refTyp False rhs rctx) unifyTyp qry ans >>= \case- False -> return False+ False -> pure False True -> do -- Normalize constraints let normalize (Ctx c a) = lift (Ctx <$> getName c <*> getName a)@@ -441,11 +447,11 @@ workDelta (Work (3 * length addl)) - return True+ pure True getWork action = action >>= \case True -> Just <$> get- False -> return Nothing+ False -> pure Nothing normalizeTy = \case TyVar n tys -> TyVar <$> getName n <*> mapM normalizeTy tys@@ -533,11 +539,11 @@ findRep ref = do ni <- readSTRef ref case niParent ni of- Nothing -> return ref+ Nothing -> pure ref Just p -> do root <- findRep p writeSTRef ref (ni { niParent = Just root })- return root+ pure root -- The "union" part of union-find, with union-by-rank. -- Each unification is given a cost of 1 work unit.@@ -563,17 +569,17 @@ lift $ modifySTRef' child (\n -> n { niParent = Just root }) when (lRank == rRank) $ lift $ modifySTRef' root (\n -> n { niRank = lRank + 1 }) - return ok+ pure 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 [])+ evalStateT go Map.empty where go = do ty <- mkRefs t ctx <- forM cs $ \(Ctx c a) -> Ctx <$> getRef c <*> getRef a- return (ty, ctx)+ pure (ty, ctx) mkRefs = foldTy $ \case TyVarF n args -> TyVar <$> getRef n <*> sequence args@@ -583,11 +589,11 @@ getRef n = do known <- get case Map.lookup n known of- Just ref -> return ref+ Just ref -> pure ref Nothing -> do ref <- lift (newNameInfo fixed n) put (Map.insert n ref known)- return ref+ pure ref -- Unify two types. unifyTyp :: Typ (NameRef s) -> Typ (NameRef s) -> StateT Work (ST s) Bool@@ -595,28 +601,28 @@ (TyCon n tys, TyVar n' tys') | length tys == length tys' -> do ok <- unifyName n n' if not ok- then return False+ then pure 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+ then pure 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+ then pure 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+ then pure False else and <$> zipWithM unifyTyp args args' - _ -> return False+ _ -> pure False -- The total cost of a unification operation. newtype Work = Work Int
src/Query.hs view
@@ -78,7 +78,7 @@ lexer x | Just s <- (bs !!) <$> findIndex (`isPrefixOf` x) bs = s : lexer (drop (length s) x) where bs = zipWith (++) openBrackets shutBrackets ++ openBrackets ++ shutBrackets lexer (x:xs)- | isSpace x = " " : lexer (dropWhile isSpace xs)+ | isSpace x = " " : lexer (trimStart xs) | isAlpha x || x == '_' = let (a,b) = span (\x -> isAlphaNum x || x `elem` ("_'#-" :: String)) xs (a1,a2) = spanEnd (== '-') a