hoogle 5.0.18.4 → 5.0.19.0
raw patch · 25 files changed
+989/−182 lines, 25 filesdep +Cabal-syntaxdep +ansi-terminaldep +data-default-classdep −foundationdep ~aesondep ~basedep ~crypton-connectionnew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: Cabal-syntax, ansi-terminal, data-default-class, ghc-lib-parser, hackage-revdeps, temporary
Dependencies removed: foundation
Dependency ranges changed: aeson, base, crypton-connection, haskell-src-exts, text, utf8-string, warp-tls
API changes (from Hackage documentation)
- Hoogle: targetInfo :: Target -> String
+ Hoogle: targetInfo :: Bool -> [Query] -> Target -> String
- Hoogle: targetResultDisplay :: Bool -> Target -> String
+ Hoogle: targetResultDisplay :: Bool -> Bool -> [Query] -> Target -> String
Files
- CHANGES.txt +9/−0
- LICENSE +1/−1
- README.md +1/−1
- hoogle.cabal +20/−11
- misc/sample-data/emily-1.11/emily.txt +9/−0
- misc/sample-data/emily-1.2/emily.txt +7/−0
- misc/sample-data/henry.txt +6/−0
- src/Action/CmdLine.hs +21/−2
- src/Action/Generate.hs +21/−22
- src/Action/Search.hs +31/−12
- src/Action/Server.hs +5/−18
- src/General/Store.hs +7/−2
- src/General/Str.hs +8/−9
- src/General/Util.hs +3/−2
- src/General/Web.hs +1/−1
- src/Input/Cabal.hs +75/−44
- src/Input/Download.hs +3/−1
- src/Input/Haddock.hs +102/−35
- src/Input/Item.hs +34/−8
- src/Input/ParseDecl.hs +609/−0
- src/Input/Reorder.hs +4/−3
- src/Input/Set.hs +2/−1
- src/Input/Settings.hs +2/−2
- src/Output/Tags.hs +7/−6
- src/Output/Types.hs +1/−1
CHANGES.txt view
@@ -1,5 +1,14 @@ Changelog for Hoogle (* = API change, @ = database format change) +5.0.19, released 2026-01-19+ Migrate (half of) parsing from haskell-src-exts to ghc-lib-parser+ Support hyperlinks in search output+ Colorize search output+ Use --count when --info is passed+ Change DB format to fix sizeOf in instance Storable Fingerprint+ Do not force 'upgrade-insecure-requests' if we ourselves are running an HTTP server+ #411, switched to xdg directory and deprecated legacy location+ Require and support crypton-connection >= 0.4.1 5.0.18.4, released 2024-01-14 Don't test on GHC 9.2 or earlier Fix up the output of /stats to account for API changes
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2004-2024.+Copyright Neil Mitchell 2004-2026. All rights reserved. Redistribution and use in source and binary forms, with or without
README.md view
@@ -89,7 +89,7 @@ # Background -Hoogle work is licensed under the [BSD-3-Clause license](https://github.com/ndmitchell/hoogle/blob/master/docs/LICENSE).+Hoogle work is licensed under the [BSD-3-Clause license](https://github.com/ndmitchell/hoogle/blob/master/LICENSE). ## Theoretical Foundations
hoogle.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.18 build-type: Simple name: hoogle-version: 5.0.18.4+version: 5.0.19.0 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2004-2024+copyright: Neil Mitchell 2004-2026 synopsis: Haskell API Search description: Hoogle is a Haskell API search engine, which allows you to@@ -23,6 +23,9 @@ cbits/*.h cbits/*.c data-files:+ misc/sample-data/henry.txt+ misc/sample-data/emily-1.11/emily.txt+ misc/sample-data/emily-1.2/emily.txt misc/settings.txt html/*.js html/*.png@@ -43,22 +46,26 @@ build-depends: QuickCheck,- aeson,- base > 4 && < 5,+ aeson >= 2,+ ansi-terminal,+ base >= 4 && < 5, blaze-html, blaze-markup, binary, bytestring >= 0.10.2.0,+ Cabal-syntax >= 3.8, cmdargs, conduit >= 1.3.0, conduit-extra >= 1.2.3.2, containers >= 0.5,- crypton-connection,+ crypton-connection >= 0.4.1,+ data-default-class, deepseq, directory, extra >= 1.6.6, filepath,- foundation >= 0.0.13,+ ghc-lib-parser >= 9.6.5 && < 9.16,+ hackage-revdeps >= 0.3 && < 0.4, old-locale, hashable, haskell-src-exts >= 1.22 && < 1.24,@@ -73,16 +80,17 @@ storable-tuple, tar, template-haskell,- text,+ temporary,+ text >= 2, time >= 1.5, transformers, uniplate,- utf8-string,+ utf8-string >= 0.3.1, vector, wai, wai-logger, warp,- warp-tls,+ warp-tls >= 3.4.2, zlib c-sources: cbits/text_search.c@@ -109,6 +117,7 @@ Input.Download Input.Haddock Input.Item+ Input.ParseDecl Input.Reorder Input.Set Input.Settings@@ -131,8 +140,8 @@ executable hoogle main-is: src/Main.hs default-language: Haskell2010- ghc-options: -threaded+ ghc-options: -threaded -rtsopts build-depends:- base > 4 && < 5,+ base >= 4 && < 5, hoogle
+ misc/sample-data/emily-1.11/emily.txt view
@@ -0,0 +1,9 @@+@url http://eghmitchell.com/+@package emily+@version 1.11++module Mitchell++@url #a_wife+type family Wife (a :: Mother)+paleo :: Bool
+ misc/sample-data/emily-1.2/emily.txt view
@@ -0,0 +1,7 @@+@url http://eghmitchell.co.uk/+@package emily+@version 1.2++module Mitchell+@url #a_wife+type family Wife (a :: Mother)
+ misc/sample-data/henry.txt view
@@ -0,0 +1,6 @@+@package henry++module Mitchell++@url http://henry.com?too_long+__prefix__really_long_string_take_might_overflow_any_poorly_chosen_word8_buffers_because_someone_decided_their_identifiers_should_be_untypeable_by_mere_humans__infix__and_that_their_sample_code_should_not_fit_into_tweets_or_even_single_lines_because_they_are_definitely_too_long__suffix__ :: a -> b
src/Action/CmdLine.hs view
@@ -16,6 +16,7 @@ import System.Directory import System.Environment import System.FilePath+import System.IO data Language = Haskell | Frege deriving (Data,Typeable,Show,Eq,Enum,Bounded) @@ -80,7 +81,25 @@ defaultDatabaseLang :: Language -> IO FilePath defaultDatabaseLang lang = do- dir <- getAppUserDataDirectory "hoogle"+ xdgLocation <- getXdgDirectory XdgData "hoogle"+ legacyLocation <- getAppUserDataDirectory "hoogle"+ doesXdgPathExist <- doesPathExist xdgLocation+ doesLegacyPathExist <- doesPathExist legacyLocation++ dir <- case (doesXdgPathExist, doesLegacyPathExist) of+ -- On Windows XDG location and legacy location are identical+ _ | xdgLocation == legacyLocation -> pure xdgLocation+ (_, False) -> pure xdgLocation+ (True, True) -> do+ hPutStrLn stderr $+ "Warning: Legacy location ignored (" ++ legacyLocation ++ "),"+ ++ "since xdg location is available (" ++ xdgLocation ++")."+ pure xdgLocation+ (False, True) -> do+ -- TODO: renable after release+ --hPutStrLn stderr $ "Warning: " ++ legacyLocation ++ " is deprecated."+ -- ++ "Consider moving it to $XDG_DATA_HOME/hoogle (" ++ xdgLocation ++ ")"+ pure legacyLocation pure $ dir </> "default-" ++ lower (show lang) ++ "-" ++ showVersion (trimVersion 3 version) ++ ".hoo" getCmdLine :: [String] -> IO CmdLine@@ -115,7 +134,7 @@ ,jsonl = def &= name "jsonl" &= help "Get result as JSONL (JSON Lines)" ,link = def &= help "Give URL's for each result" ,numbers = def &= help "Give counter for each result"- ,info = def &= help "Give extended information about the first result"+ ,info = def &= help "Give extended information about the first n results (set n with --count, default is 1)" ,database = def &= typFile &= help "Name of database to use (use .hoo extension)" ,count = Nothing &= name "n" &= help "Maximum number of results to return (defaults to 10)" ,query = def &= args &= typ "QUERY"
src/Action/Generate.hs view
@@ -36,6 +36,7 @@ import Action.CmdLine import General.Conduit import Control.DeepSeq+import Distribution.Package (mkPackageName, unPackageName) {- @@ -101,12 +102,12 @@ hoogles <- download "haskell-hoogle.tar.gz" "https://hackage.haskell.org/packages/hoogle.tar.gz" -- peakMegabytesAllocated = 2- setStackage <- Set.map strPack <$> (Set.union <$> setStackage stackageLts <*> setStackage stackageNightly)- setPlatform <- Set.map strPack <$> setPlatform platform- setGHC <- Set.map strPack <$> setGHC platform+ setStackage <- Set.map mkPackageName <$> (Set.union <$> setStackage stackageLts <*> setStackage stackageNightly)+ setPlatform <- Set.map mkPackageName <$> setPlatform platform+ setGHC <- Set.map mkPackageName <$> setGHC platform cbl <- timed timing "Reading Cabal" $ parseCabalTarball settings cabals- let want = Set.insert (strPack "ghc") $ Set.unions [setStackage, setPlatform, setGHC]+ let want = Set.insert (mkPackageName "ghc") $ Set.unions [setStackage, setPlatform, setGHC] cbl <- pure $ flip Map.mapWithKey cbl $ \name p -> p{packageTags = [(strPack "set",strPack "included-with-ghc") | name `Set.member` setGHC] ++@@ -116,7 +117,7 @@ let source = do tar <- liftIO $ tarballReadFiles hoogles- forM_ tar $ \(strPack . takeBaseName -> name, src) ->+ forM_ tar $ \(mkPackageName . takeBaseName -> name, src) -> yield (name, hackagePackageURL name, src) pure (cbl, want, source) @@ -129,22 +130,23 @@ -- 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 (strPack . takeBaseName &&& id) $ sortOn (map order . splitDirectories) $ filter ((==) ".txt" . takeExtension) files+ let packages = map (mkPackageName . 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 $ bstrReadFile file dir <- liftIO $ canonicalizePath $ takeDirectory file let url = "file://" ++ ['/' | not $ "/" `isPrefixOf` dir] ++ replace "\\" "/" dir ++ "/"- yield (name, url, lbstrFromChunks [src])+ when (isJust $ bstrSplitInfix (bstrPack "@package " <> bstrPack (unPackageName name)) src) $+ yield (name, url, lbstrFromChunks [src]) pure (Map.union (Map.fromList cabals) (Map.fromListWith (<>) $ map generateBarePackage packages) ,Set.fromList $ map fst packages, source) where parseCabal fp = do- src <- readFileUTF8' fp+ src <- bstrReadFile fp let pkg = readCabal settings src- pure (strPack $ takeBaseName fp, pkg)+ pure (mkPackageName $ takeBaseName fp, pkg) generateBarePackage (name, file) = (name, mempty{packageTags = (strPack "set", strPack "all") : sets})@@ -154,11 +156,11 @@ 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"+ frege <- download "frege-frege.txt" "https://github.com/Frege/try-frege/raw/refs/heads/master/try-frege-web/src/main/webapp/hoogle-frege.txt" let source = do src <- liftIO $ bstrReadFile frege- yield (strPack "frege", "http://google.com/", lbstrFromChunks [src])- pure (Map.empty, Set.singleton $ strPack "frege", source)+ yield (mkPackageName "frege", "http://google.com/", lbstrFromChunks [src])+ pure (Map.empty, Set.singleton $ mkPackageName "frege", source) readHaskellGhcpkg :: Timing -> Settings -> IO (Map.Map PkgName Package, Set.Set PkgName, ConduitT () (PkgName, URL, LBStr) IO ())@@ -166,7 +168,7 @@ cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings let source = forM_ (Map.toList cbl) $ \(name,Package{..}) -> whenJust packageDocs $ \docs -> do- let file = docs </> strUnpack name <.> "txt"+ let file = docs </> unPackageName name <.> "txt" whenM (liftIO $ doesFileExist file) $ do src <- liftIO $ bstrReadFile file docs <- liftIO $ canonicalizePath docs@@ -203,8 +205,8 @@ cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings let source = forM_ (Map.toList cbl) $ \(name, p@Package{..}) -> do- let docs = docDir (strUnpack name) p- file = docBaseDir </> docs </> (strUnpack name) <.> "txt"+ let docs = docDir (unPackageName name) p+ file = docBaseDir </> docs </> unPackageName name <.> "txt" whenM (liftIO $ doesFileExist file) $ do src <- liftIO $ bstrReadFile file let url = ['/' | not $ all isPathSeparator $ take 1 docs] ++@@ -249,10 +251,7 @@ 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 <- pure $ if include /= [] then Set.fromList $ map strPack include else want+ want <- pure $ if include /= [] then Set.fromList $ map mkPackageName include else want want <- pure $ case count of Nothing -> want; Just count -> Set.fromList $ take count $ Set.toList want (stats, _) <- storeWriteFile database $ \store -> do@@ -265,7 +264,7 @@ let warning msg = do modifyIORef itemWarn succ; hPutStrLn warnings msg let consume :: ConduitM (Int, (PkgName, URL, LBStr)) (Maybe Target, [Item]) IO ()- consume = awaitForever $ \(i, (strUnpack -> pkg, url, body)) -> do+ consume = awaitForever $ \(i, (unPackageName -> pkg, url, body)) -> do timedOverwrite timing ("[" ++ show i ++ "/" ++ show (Set.size want) ++ "] " ++ pkg) $ parseHoogle (\msg -> warning $ pkg ++ ":" ++ msg) url body @@ -275,12 +274,12 @@ filterC (flip Set.member want . fst3) .| void ((|$|) (zipFromC 1 .| consume)- (do seen <- fmap Set.fromList $ mapMC (evaluate . force . strCopy . fst3) .| sinkList+ (do seen <- fmap Set.fromList $ mapMC (evaluate . force . 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 $ map strUnpack missing)+ putStrLn $ "Packages missing documentation: " ++ unwords (sortOn lower $ map unPackageName 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
src/Action/Search.hs view
@@ -21,6 +21,11 @@ import System.Directory import Text.Blaze.Renderer.Utf8 import Safe+import System.Console.ANSI+ (hSupportsANSI, hyperlinkCode, setSGRCode+ ,SGR (SetColor), ConsoleLayer (Foreground)+ ,ColorIntensity (Vivid, Dull), Color (Yellow))+import System.IO (stdout) import Action.CmdLine import General.Store@@ -44,16 +49,21 @@ 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+ color' <- case color of+ Just b -> pure b+ Nothing -> hSupportsANSI stdout+ let (shown, hidden) = splitAt count' $ nubOrd $ map (targetResultDisplay link color' q) res if null res then putStrLn "No results found" else if info then do- putStr $ targetInfo $ headErr res+ mapM_ (putStr . targetInfo color' q)+ $ (case count of+ Just c -> take c+ Nothing -> singleton . headErr) res else do- let toShow = if numbers && not info then addCounter shown else shown if | json -> LBS.putStrLn $ JSON.encode $ maybe id take count $ map unHTMLtargetItem res | jsonl -> mapM_ (LBS.putStrLn . JSON.encode) $ maybe id take count $ map unHTMLtargetItem res- | otherwise -> putStr $ unlines toShow+ | otherwise -> putStr $ unlines $ if numbers then addCounter shown else shown when (hidden /= [] && not json) $ do whenNormal $ putStrLn $ "-- plus more results not shown, pass --count=" ++ show (count'+10) ++ " to see more" else do@@ -63,21 +73,30 @@ putStr $ unlines $ searchFingerprintsDebug store (parseType $ unwords query) (map parseType compare_) -- | Returns the details printed out when hoogle --info is called-targetInfo :: Target -> String-targetInfo Target{..} =- unlines $ [ unHTML targetItem ] +++targetInfo :: Bool -> [Query] -> Target -> String+targetInfo color qs Target{..} =+ unlines $ [ unHTML . (if color then ansiHighlight qs else id) $ targetItem ] ++ [ unwords packageModule | not $ null packageModule] ++ [ unHTML targetDocs ] where packageModule = map 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 $+-- | Bool arguments decide whether links and colors are shown+targetResultDisplay :: Bool -> Bool -> [Query] -> Target -> String+targetResultDisplay link color qs Target{..} = unHTML $ unwords $ map fst (maybeToList targetModule) ++- [targetItem] +++ [if color then highlightFull targetItem else targetItem] ++ ["-- " ++ targetURL | link]+ where+ highlightFull = hyperlinkCode targetURL . ansiHighlight qs +ansiHighlight :: [Query] -> String -> String+ansiHighlight = highlightItem id id ((dull ++) . (++ rst)) ((bold ++) . (++ rst))+ where+ dull = setSGRCode [SetColor Foreground Dull Yellow]+ bold = setSGRCode [SetColor Foreground Vivid Yellow]+ rst = setSGRCode []+ unHTMLtargetItem :: Target -> Target unHTMLtargetItem target = target {targetItem = unHTML $ targetItem target} @@ -149,7 +168,7 @@ "Ord" === hackage "base/docs/Prelude.html#t:Ord" ">>=" === hackage "base/docs/Prelude.html#v:-62--62--61-" "sequen" === hackage "base/docs/Prelude.html#v:sequence"- "foldl'" === hackage "base/docs/Data-List.html#v:foldl-39-"+ "foldl'" === hackage "base/docs/Prelude.html#v:foldl-39-" -- since base-4.20 "Action package:shake" === "https://hackage.haskell.org/package/shake/docs/Development-Shake.html#t:Action" "Action package:shake set:stackage" === "https://hackage.haskell.org/package/shake/docs/Development-Shake.html#t:Action" "map -package:base" ==$ \x -> not $ "/base/" `isInfixOf` x
src/Action/Server.hs view
@@ -200,9 +200,10 @@ H.div ! H.class_ "links" $ H.a ! H.href (H.stringValue link) $ "Uses" H.div ! H.class_ "from" $ showFroms local haddock is H.div ! H.class_ "doc newline shut" $ H.preEscapedString targetDocs- H.ul ! H.id "left" $ do- H.li $ H.b "Packages"- mconcat [H.li $ f cat val | (cat,val) <- itemCategories $ concat results, QueryScope True cat val `notElem` query]+ H.ul ! H.id "left" $ -- if there's already a scope query we don't show subquery links because bots will get lost in a maze of links.+ if (any isQueryScope query) then pure () else do+ H.li $ H.b "Packages"+ mconcat [H.li $ f cat val | (cat,val) <- itemCategories $ concat results, QueryScope True cat val `notElem` query] where useLink :: [Target] -> Maybe String@@ -254,23 +255,9 @@ ------------------------------------------------------------- -- DISPLAY AN ITEM (bold keywords etc) -highlightItem :: [Query] -> String -> Markup-highlightItem qs x- | Just (pre,x) <- stripInfix "<s0>" x, Just (name,post) <- stripInfix "</s0>" x- = H.preEscapedString pre <> highlight (unescapeHTML name) <> H.preEscapedString post- | otherwise = H.string x- where- 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)- where m = maximum $ 0 : [length y | QueryName y <- qs, lower y `isPrefixOf` lower (x:xs)]- f (x:xs) = False : f xs- f [] = [] displayItem :: [Query] -> String -> Markup-displayItem = highlightItem-+displayItem = highlightItem H.string H.preEscapedString H.string (H.b . H.string) action_server_test_ :: IO () action_server_test_ = do
src/General/Store.hs view
@@ -33,8 +33,11 @@ import Numeric.Extra import Paths_hoogle import Prelude-import System.IO.Extra+import System.Directory (renameFile)+import System.FilePath (takeDirectory, takeFileName)+import System.IO.Extra (Handle, hTell, hClose, hPutBuf) import System.IO.MMap+import System.IO.Temp (withTempFile) import System.IO.Unsafe -- Ensure the string is always 25 chars long, so version numbers don't change its size@@ -108,7 +111,7 @@ storeWriteFile file act = do atoms <- newIORef Map.empty parts <- newIORef Nothing- withBinaryFile file WriteMode $ \h -> do+ withTempFile (takeDirectory file) (takeFileName file) $ \tmpFile h -> do -- put the version string at the start and end, so we can tell truncation vs wrong version BS.hPut h verString ref <- newIORef $ SW h (BS.length verString) []@@ -130,6 +133,8 @@ let stats = prettyTable 0 "Bytes" $ ("Overheads", intToDouble $ fromIntegral final - sum (map atomSize $ Map.elems atoms)) : [(name ++ " :: " ++ atomType, intToDouble atomSize) | (name, Atom{..}) <- Map.toList atoms]+ hClose h+ renameFile tmpFile file pure (stats, res) storeWrite :: (Typeable (t a), Typeable a, Stored a) => StoreWrite -> t a -> a -> IO ()
src/General/Str.hs view
@@ -8,12 +8,11 @@ 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 qualified Data.Text as T import Control.DeepSeq import Data.Char import Data.Data@@ -23,8 +22,8 @@ import Prelude -newtype Str = Str {fromStr :: Fdn.String}- deriving (Data,Typeable,Eq,Ord,Semigroup,Monoid)+newtype Str = Str { fromStr :: T.Text }+ deriving (Data, Typeable, Eq, Ord, Semigroup, Monoid) instance Show Str where show = strUnpack instance NFData Str where rnf x = x `seq` ()@@ -36,19 +35,19 @@ strPack :: String -> Str-strPack = Str . fromString+strPack = Str . T.pack strUnpack :: Str -> String-strUnpack = Fdn.toList . fromStr+strUnpack = T.unpack . fromStr strCons :: Char -> Str -> Str-strCons c = Str . Fdn.cons c . fromStr+strCons c = Str . T.cons c . fromStr strCopy :: Str -> Str-strCopy = Str . Fdn.copy . fromStr+strCopy = Str . T.copy . fromStr strNull :: Str -> Bool-strNull = Fdn.null . fromStr+strNull = T.null . fromStr bstrPack :: String -> BStr bstrPack = US.fromString
src/General/Util.hs view
@@ -56,9 +56,10 @@ import Prelude import qualified Network.HTTP.Types.URI as URI import qualified Data.ByteString.UTF8 as UTF8+import Distribution.Types.PackageName (PackageName, unPackageName) -type PkgName = Str+type PkgName = PackageName type ModName = Str -- | A URL, complete with a @https:@ prefix.@@ -320,7 +321,7 @@ hackagePackageURL :: PkgName -> URL-hackagePackageURL x = "https://hackage.haskell.org/package/" ++ strUnpack x+hackagePackageURL x = "https://hackage.haskell.org/package/" ++ unPackageName x hackageModuleURL :: ModName -> URL hackageModuleURL x = "/docs/" ++ ghcModuleURL x
src/General/Web.hs view
@@ -125,7 +125,7 @@ <> " form-action 'self';" -- Any request originating from this page and specifying http as -- its protocol will be automatically upgraded to https.- <> " upgrade-insecure-requests;"+ <> (if https then " upgrade-insecure-requests;" else mempty) -- Do not display http content if the page was loaded under -- https. <> " block-all-mixed-content"),
src/Input/Cabal.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, RecordWildCards, ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wall -Wno-name-shadowing #-} -- | Module for reading Cabal files. module Input.Cabal(@@ -12,7 +13,6 @@ import Data.List.Extra import System.FilePath import Control.DeepSeq-import Control.Exception import Control.Exception.Extra import Control.Monad import System.IO.Extra@@ -21,16 +21,26 @@ import qualified System.Process.ByteString as BS import qualified Data.ByteString.UTF8 as UTF8 import System.Directory-import Data.Char import Data.Maybe import Data.Tuple.Extra import qualified Data.Map.Strict as Map import General.Util-import General.Conduit import Data.Semigroup import Control.Applicative import Prelude +import Distribution.Compat.Lens (toListOf)+import qualified Distribution.PackageDescription as PD+import qualified Distribution.PackageDescription.Configuration as PD+import qualified Distribution.PackageDescription.Parsec as PD+import qualified Distribution.Pretty+import qualified Distribution.Types.BuildInfo.Lens as Lens+import Distribution.Types.PackageName (mkPackageName, unPackageName)+import Distribution.Types.Version (versionNumbers)+import Distribution.Utils.ShortText (fromShortText)+import Hackage.RevDeps (lastVersionsOfPackages)+import qualified Distribution.SPDX as SPDX+ --------------------------------------------------------------------- -- DATA TYPE @@ -66,7 +76,7 @@ packagePopularity cbl = mp `seq` (errs, mp) where mp = Map.map length good- errs = [ strUnpack user ++ ".cabal: Import of non-existant package " ++ strUnpack name +++ errs = [ unPackageName user ++ ".cabal: Import of non-existant package " ++ unPackageName 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) $@@ -80,70 +90,91 @@ readGhcPkg :: Settings -> IO (Map.Map PkgName Package) readGhcPkg settings = do topdir <- findExecutable "ghc-pkg"+ (exit, stdout, stderr) <-+ -- From GHC 9.0.1, the `haddock-html` field in `*.conf` files for GHC boot+ -- libraries has used `${pkgroot}`, which can be expanded in the output.++ -- On Windows, the `haddock-html` field in `*.conf` files for GHC boot+ -- libraries for GHC >= 9.0 && < 9.10 contain errors. For example, this may+ -- be specified:+ --+ -- haddock-html: ${pkgroot}/../../doc/html/libraries/base-4.18.0.0+ --+ -- when the correct specification would be:+ --+ -- haddock-html: ${pkgroot}/../doc/html/libraries/base-4.18.0.0+ --+ -- However haddock does not seek to correct that. It assumes that users will+ -- correct manually the affected `*.conf` files.+ -- important to use BS process reading so it's in Binary format, see #194- (exit, stdout, stderr) <- BS.readProcessWithExitCode "ghc-pkg" ["dump"] mempty+ BS.readProcessWithExitCode "ghc-pkg" ["dump", "--expand-pkgroot"] mempty when (exit /= ExitSuccess) $ errorIO $ "Error when reading from ghc-pkg, " ++ show exit ++ "\n" ++ UTF8.toString stderr let g (stripPrefix "$topdir" -> Just x) | Just t <- topdir = takeDirectory t ++ x+ -- ^ Backwards compatibility with GHC < 9.0 g x = x let fixer p = p{packageLibrary = True, packageDocs = g <$> packageDocs p}- let f ((stripPrefix "name: " -> Just x):xs) = Just (strPack $ trimStart x, fixer $ readCabal settings $ unlines xs)- f xs = Nothing+ let f ((stripPrefix "name: " -> Just x):xs) = Just (mkPackageName $ trimStart x, fixer $ readCabal settings $ bstrPack $ unlines xs)+ f _ = Nothing 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. parseCabalTarball :: Settings -> FilePath -> IO (Map.Map PkgName Package)--- items are stored as:--- QuickCheck/2.7.5/QuickCheck.cabal--- QuickCheck/2.7.6/QuickCheck.cabal--- rely on the fact the highest version is last (using lastValues) parseCabalTarball settings tarfile = do- res <- runConduit $- (sourceList =<< liftIO (tarballReadFiles tarfile)) .|- mapC (first takeBaseName) .| groupOnLastC fst .| mapMC (evaluate . force) .|- pipelineC 10 (mapC (strPack *** readCabal settings . lbstrUnpack) .| mapMC (evaluate . force) .| sinkList)- pure $ Map.fromList res+ lastVersions <- lastVersionsOfPackages (const True) tarfile Nothing+ pure $ Map.map (readCabal settings) lastVersions --------------------------------------------------------------------- -- PARSERS --- | Cabal information, plus who I depend on-readCabal :: Settings -> String -> Package-readCabal Settings{..} src = Package{..}+readCabal :: Settings -> BStr -> Package+readCabal settings src = case PD.parseGenericPackageDescriptionMaybe src of+ Nothing -> Package+ { packageTags = []+ , packageLibrary = False+ , packageSynopsis = mempty+ , packageVersion = strPack "0.0"+ , packageDepends = []+ , packageDocs = Nothing+ }+ Just gpd -> readCabal' settings gpd++readCabal' :: Settings -> PD.GenericPackageDescription -> Package+readCabal' Settings{..} gpd = Package{..} where- mp = Map.fromListWith (++) $ lexCabal src- ask x = Map.findWithDefault [] x mp+ pd = PD.flattenPackageDescription gpd+ pkgId = PD.package pd - packageDepends =- 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 $ headDef "0.0" $ dropWhile null (ask "version")- packageSynopsis = strPack $ unwords $ words $ unwords $ ask "synopsis"- packageLibrary = "library" `elem` map (lower . trim) (lines src)- packageDocs = find (not . null) $ ask "haddock-html"+ packageDepends = nubOrd $ foldMap (map (\(PD.Dependency pkg _ _) -> pkg) . PD.targetBuildDepends) $ toListOf Lens.traverseBuildInfos gpd+ packageVersion = strPack $ intercalate "." $ map show $ versionNumbers $ PD.pkgVersion pkgId+ packageSynopsis = strPack $ fromShortText $ PD.synopsis pd+ packageLibrary = PD.hasPublicLib pd+ packageDocs = Nothing + unpackLicenseExpression (SPDX.EOr x y) = unpackLicenseExpression x ++ unpackLicenseExpression y+ unpackLicenseExpression x = [x]++ packageLicenses = case PD.license pd of+ SPDX.NONE -> []+ SPDX.License licExpr -> map (show . Distribution.Pretty.pretty) $+ unpackLicenseExpression licExpr+ packageCategories =+ filter (not . null) $ split (`elem` " ,") $+ fromShortText $ PD.category pd+ packageAuthor = fromShortText $ PD.author pd+ packageMaintainer = fromShortText $ PD.maintainer pd+ packageTags = map (both strPack) $ nubOrd $ concat- [ map (x,) $ concatMap cleanup $ concatMap ask xs- | xs@(x:_) <- [["license"],["category"],["author","maintainer"]]]+ [ map ("license",) packageLicenses+ , map ("category",) packageCategories+ , map ("author",) (concatMap cleanup [packageAuthor, packageMaintainer])+ ] -- split on things like "," "&" "and", then throw away email addresses, replace spaces with "-" and rename cleanup = filter (/= "") . map (renameTag . intercalate "-" . filter ('@' `notElem`) . words . takeWhile (`notElem` "<(")) . concatMap (map unwords . split (== "and") . words) . split (`elem` ",&")----- Ignores nesting beacuse it's not interesting for any of the fields I care about-lexCabal :: String -> [(String, [String])]-lexCabal = f . lines- where- f (x:xs) | (white,x) <- span isSpace x- , (name@(_:_),x) <- span (\c -> isAlpha c || c == '-') x- , ':':x <- trim x- , (xs1,xs2) <- span (\s -> length (takeWhile isSpace s) > length white) xs- = (lower name, trim x : replace ["."] [""] (map (trim . fst . breakOn "--") xs1)) : f xs2- f (x:xs) = f xs- f [] = []
src/Input/Download.hs view
@@ -6,6 +6,7 @@ import Control.Monad.Extra import System.Directory import Data.Conduit.Binary (sinkFile)+import Data.Default.Class import qualified Network.HTTP.Conduit as C import Network.Connection import qualified Data.Conduit as C@@ -45,7 +46,8 @@ (TLSSettingsSimple { settingDisableCertificateValidation = insecure, settingDisableSession = False,- settingUseServerName = False+ settingUseServerName = False,+ settingClientSupported = def }) Nothing runResourceT $ do response <- C.http request manager
src/Input/Haddock.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, OverloadedStrings, Rank2Types, DeriveDataTypeable #-}+{-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, OverloadedStrings, Rank2Types, DeriveDataTypeable, LambdaCase #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-name-shadowing #-} module Input.Haddock(parseHoogle, fakePackage, input_haddock_test) where @@ -8,22 +10,23 @@ import Data.Maybe import Data.Data import Input.Item+import Input.ParseDecl import General.Util import Control.DeepSeq import Control.Monad.Trans.Class import General.Conduit import Control.Monad.Extra import Control.Exception.Extra-import Data.Generics.Uniplate.Data import General.Str import Safe+import Distribution.Types.PackageName (unPackageName, mkPackageName) -- | An entry in the Hoogle DB data Entry = EPackage PkgName | EModule ModName | EDecl (Decl ())- deriving (Data,Typeable,Show)+ deriving (Data, Show) fakePackage :: PkgName -> String -> (Maybe Target, [Item])@@ -39,8 +42,12 @@ f com url = do x <- await whenJust x $ \(i,s) -> case () of- _ | Just s <- bstrStripPrefix "-- | " s -> f [ignoreMath s] url+ _ | s == "}" -> f [] ""+ -- Skip default methods like ($dmliftEq) and ($dmdisplayExceptionAnnotation)+ | Just{} <- bstrStripPrefix "($dm" s -> f [] ""+ | 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 " --" 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@@ -61,11 +68,11 @@ = fromMaybe x $ ". " `bstrStripPrefix` x ignoreMath x = x --typeItem (EPackage x) = "package"-typeItem (EModule x) = "module"-typeItem _ = ""-+typeItem :: Entry -> String+typeItem = \case+ EPackage{} -> "package"+ EModule{} -> "module"+ EDecl{} -> "" -- FIXME: used to be in two different modules, now does and then undoes lots of stuff reformat :: [BStr] -> String@@ -75,11 +82,11 @@ hierarchyC :: Monad m => URL -> ConduitM (Target, Entry) (Maybe Target, [Item]) m () hierarchyC packageUrl = void $ mapAccumC f (Nothing, Nothing) where- f (pkg, mod) (t, EPackage x) = ((Just (strUnpack x, url), Nothing), (Just t{targetURL=url}, [IPackage x]))+ f (_pkg, _mod) (t, EPackage x) = ((Just (unPackageName x, url), Nothing), (Just t{targetURL=url}, [IPackage x])) where url = targetURL t `orIfNull` packageUrl- f (pkg, mod) (t, EModule x) = ((pkg, Just (strUnpack x, url)), (Just t{targetPackage=pkg, targetURL=url}, [IModule x]))+ f (pkg, _mod) (t, EModule x) = ((pkg, Just (strUnpack x, url)), (Just t{targetPackage=pkg, targetURL=url}, [IModule x])) where url = targetURL t `orIfNull` (if isGhc then ghcModuleURL x else hackageModuleURL x)- f (pkg, mod) (t, EDecl i@InstDecl{}) = ((pkg, mod), (Nothing, hseToItem_ i))+ f (pkg, mod) (_t, EDecl i@InstDecl{}) = ((pkg, mod), (Nothing, hseToItem_ i)) f (pkg, mod) (t, EDecl x) = ((pkg, mod), (Just t{targetPackage=pkg, targetModule=mod, targetURL=url}, hseToItem_ x)) where url = targetURL t `orIfNull` case x of _ | [n] <- declNames x -> hackageDeclURL (isTypeSig x) n@@ -91,8 +98,10 @@ infix 1 `orIfNull` orIfNull x y = if null x then y else x +renderPackage :: PkgName -> [Char]+renderPackage x = "<b>package</b> <span class=name><s0>" ++ escapeHTML (unPackageName x) ++ "</s0></span>" -renderPackage x = "<b>package</b> <span class=name><s0>" ++ escapeHTML (strUnpack x) ++ "</s0></span>"+renderModule :: Str -> [Char] renderModule (breakEnd (== '.') . strUnpack -> (pre,post)) = "<b>module</b> " ++ escapeHTML pre ++ "<span class=name><s0>" ++ escapeHTML post ++ "</s0></span>" @@ -121,7 +130,7 @@ parseLine :: String -> Either String [Entry] parseLine x@('@':str) = case a of- "package" | [b] <- words b, b /= "" -> Right [EPackage $ strPack b]+ "package" | [b] <- words b, b /= "" -> Right [EPackage $ mkPackageName b] "version" -> Right [] _ -> Left $ "unknown attribute: " ++ x where (a,b) = word1 str@@ -140,42 +149,36 @@ fixLine (stripPrefix "(#) " -> Just x) = "( # ) " ++ x fixLine ('[':x:xs) | isAlpha x || x `elem` ("_(" :: String), (a,']':b) <- break (== ']') xs = x : a ++ b fixLine ('[':':':xs) | (a,']':b) <- break (== ']') xs = "(:" ++ a ++ ")" ++ b+-- Record field accessor can start from '$', such as ($*) in algebra-4.3.1+fixLine ('[':'$':xs) | (a,']':b) <- break (== ']') xs = "($" ++ a ++ ")" ++ b+-- Record field accessor can start from '>', such as (>>-) in turtle-1.6.2+fixLine ('[':'>':xs) | (a,']':b) <- break (== ']') xs = "(>" ++ a ++ ")" ++ b fixLine x | "class " `isPrefixOf` x = fst $ breakOn " where " x fixLine x = x readItem :: String -> Maybe (Decl ())-readItem x | ParseOk y <- myParseDecl x = Just $ unGADT y readItem x -- newtype | Just x <- stripPrefix "newtype " x , ParseOk (DataDecl an _ b c d e) <- fmap unGADT $ myParseDecl $ "data " ++ x = Just $ DataDecl an (NewType ()) b c d e-readItem x -- constructors- | ParseOk (GDataDecl _ _ _ _ _ [GadtDecl s name _ _ _ ty] _) <- myParseDecl $ "data Data where " ++ x+readItem x@(x0 : _) -- constructors+ | isUpper x0 || x0 == '('+ , ParseOk (GDataDecl _ _ _ _ _ [GadtDecl s name _ _ _ ty] _) <- myParseDecl $ "data Data where " ++ x , let f (TyBang _ _ _ (TyParen _ x@TyApp{})) = x+ f (TyParen _ x@TyApp{}) = x f (TyBang _ _ _ x) = x f x = x = Just $ TypeSig s [name] $ applyFun1 $ map f $ unapplyFun ty-readItem ('(':xs) -- tuple constructors- | (com,')':rest) <- span (== ',') xs- , ParseOk (TypeSig s [Ident{}] ty) <- myParseDecl $ replicate (length com + 2) 'a' ++ rest- = Just $ TypeSig s [Ident s $ '(':com++")"] ty-readItem (stripPrefix "data (" -> Just xs) -- tuple data type- | (com,')':rest) <- span (== ',') xs- , ParseOk (DataDecl a b c d e f) <- fmap unGADT $ myParseDecl $- "data " ++ replicate (length com + 2) 'A' ++ rest- = Just $ DataDecl a b c (transform (op $ '(':com++")") d) e f- where op s DHead{} = DHead () $ Ident () s- op s x = x+readItem x | ParseOk y <- myParseDecl x = Just $ unGADT y readItem _ = Nothing -myParseDecl = fmap (fmap $ const ()) . parseDeclWithMode parseMode -- partial application, to share the initialisation cost-+unGADT :: Decl l -> Decl l unGADT (GDataDecl a b c d _ [] e) = DataDecl a b c d [] e unGADT x = x prettyItem :: Entry -> String-prettyItem (EPackage x) = "package " ++ strUnpack x+prettyItem (EPackage x) = "package " ++ unPackageName x prettyItem (EModule x) = "module " ++ strUnpack x prettyItem (EDecl x) = pretty x @@ -192,16 +195,80 @@ test "newtype Identity a" test "foo :: Int# -> b" test "(,,) :: a -> b -> c -> (a, b, c)"- test "data (,,) a b"+ "data (,,) a b" === "data Tuple3 a b" -- when ghc-lib-parser >= 9.8 test "reverse :: [a] -> [a]"- test "reverse :: [:a:] -> [:a:]"+ -- Parallel Haskell has never been implemented+ -- test "reverse :: [:a:] -> [:a:]" test "module Foo.Bar" test "data Char" "data Char :: *" === "data Char" "newtype ModuleName :: *" === "newtype ModuleName" "Progress :: !(Maybe String) -> {-# UNPACK #-} !Int -> !(Int -> Bool) -> Progress" === "Progress :: Maybe String -> Int -> (Int -> Bool) -> Progress"- -- Broken in the last HSE release, fixed in HSE HEAD- -- test "quotRemInt# :: Int# -> Int# -> (# Int#, Int# #)"+ test "quotRemInt# :: Int# -> Int# -> (# Int#, Int# #)" test "( # ) :: Int" test "pattern MyPattern :: ()"+ test "degrees :: Floating x => Radians x -> Degrees x"+ test "class Angle a"+ test "instance Eq x => Eq (Degrees x)"+ test "instance Angle Degrees"+ test "type Queue a = Deque Nonthreadsafe Nonthreadsafe SingleEnd SingleEnd Grow Safe a"+ test "class DequeClass d => PopL d"+ test "tests_fifo :: DequeClass d => (forall elt . IO (d elt)) -> Test"+ test "class ParUnsafe iv p | p -> iv"+ test "(##) :: Diagram -> Diagram -> Diagram"+ test "instance LayoutClass Positioned []"+ test "data Ord a => Range a"+ test "aPair :: Proxy (,)"+ test "aTriple :: Proxy (,,)"+ test "qop :: (Ord a, Show qtyp, Show (QFlipTyp qtyp), QFlipTyp (QFlipTyp qtyp) ~ qtyp) => Set (QueryRep QAtomTyp a) -> Set (QueryRep (QFlipTyp qtyp) a) -> QueryRep qtyp a"+ test "reorient :: (Unbox a) => Bernsteinp Int a -> Bernsteinp Int a"+ "type family PrimM a :: * -> *;" === "type family PrimM a :: * -> *"+ test "HSNil :: HSet '[]"+ "HSCons :: !elem -> HSet elems -> HSet (elem : elems)" === "HSCons :: elem -> HSet elems -> HSet (elem : elems)"+ test "instance Data.HSet.Reverse.HReverse '[e] els1 els2 => Data.HSet.Reverse.HReverse '[] (e : els1) els2"+ test "instance Data.HSet.Remove.HRemove (e : els) els 'TypeFun.Data.Peano.Z"+ test "Free :: (forall m . Monad m => Effects effects m -> m a) -> Free effects a"+ test "infixl 3 <||"+ test "instance Data.String.IsString t => Data.String.IsString (t Yi.MiniBuffer.::: doc)"+ test "runValueExpression :: (Functor f) => Expression a ((->) b) f r -> f ((a -> b) -> r)"+ test "HCons :: (x :: *) -> HList xs -> HList (x : xs)"+ test "instance forall k (key :: k) . Data.Traversable.Traversable (Data.ComposableAssociation.Association key)"+ test "ReflH :: forall (k :: *) (t :: k) . HetEq t t"+ test "egcd :: (PID d, (Euclidean d)) => d -> d -> (d, d, d)"+ test "proc :: FilePath -> [String] -> CreateProcess"+ test "unitTests :: Proxy '()"+ test "type OneToFour = '[1, 2, 3, 4]"+ test "data family Prio pol item :: *"+ test "set :: (Monad m, ToByteString a) => Key -> a -> Opts \"SET\" -> Redis m Bool"+ test "by :: ByteString -> Opts \"SORT\""+ test "infixr 9 :+:"+ test "instance forall k1 k2 (expectation1 :: k2) (expectation2 :: k1) . (Test.TypeSpec.Core.PrettyTypeSpec expectation1, Test.TypeSpec.Core.PrettyTypeSpec expectation2) => Test.TypeSpec.Core.PrettyTypeSpec '(expectation1, expectation2)"+ test "SomeFoo :: Foo a => m a -> SomeFoo m"+ test "(@~?) :: (HasCallStack, Ord a, Num a, Show a, ?epsilon :: a) => a -> a -> Assertion"+ test "data Data where { Idx :: {idxChildren :: Index key (Node height key val)} -> Node ('S height) key val}"+ test "UnexpectedResponse :: forall k a b . () => Host -> Response k a b -> ProtocolError"+ test "(.) :: Category k cat => forall (b :: k) (c :: k) (a :: k) . cat b c -> cat a b -> cat a c"+ test "infixl 3 `And`"+ test "infix 1 `shouldBe`"+ test "pattern The :: The d a => a -> d"+ test "Html :: Element \"html\" '[] (Elements [\"head\", \"body\"]) (ManifestA & '[])"+ test "instance forall k1 v1 (pk :: k1 -> GHC.Types.Constraint) (k2 :: k1) (pv :: v1 -> GHC.Types.Constraint) (v2 :: v1) . (pk k2, pv v2) => Type.Membership.KeyTargetAre pk pv (k2 'Type.Membership.Internal.:> v2)"+ -- The following no longer parses since GHC 9.14 (which is the correct behaviour)+ -- test "crDoubleBuffer :: CompactorReturn s -> {-# UNPACK #-} !DoubleBuffer s"+ test "expectationFailure :: (?callStack :: CallStack) => String -> Expectation"+ test "type family MapTyCon t xs = r | r -> xs"+ test "pattern Id :: CRCategory k => (β ~ α, Object k α) => k α β"+ test "pattern Stream :: () => () => Repetition"+ test "In# :: (# #) -> In (a :: Effects) (b :: Effects)"+ test "anyAsciiDecimalWord# :: Addr# -> Addr# -> (# (# #) | (# Word#, Addr# #) #)"+ test "class SymbolToField (sym :: Symbol) rec typ | sym rec -> typ"+ test "closestPairDist_spec :: _ => ([r] -> r) -> (r -> t) -> [b] -> Property"+ -- Cannot faithfully represent ConstraintKind with ImplicitParams in HSE+ -- test "type HasCallStack = ?callStack :: CallStack"+ -- Cannot faithfully represent @r in HSE+ -- test "Maybe# :: forall (r :: RuntimeRep) (a :: TYPE r). (# (# #) | a #) -> Maybe# @r a"+ -- Cannot faithfully represent visible binders in HSE+ -- test "data NDFamily_ :: forall (name :: Name) -> forall (ks :: Params name). ParamsProxy name ks -> Res name ks Any :~: r -> Args name ks -> Exp r"+ -- Cannot faithfully represent standalone kind signatures in HSE+ -- test "type MinBound :: a;"
src/Input/Item.hs view
@@ -4,7 +4,7 @@ -- | Types used to generate the input. module Input.Item( Sig(..), Ctx(..), Ty(..), prettySig,- Item(..), itemName,+ Item(..), itemName, highlightItem, Target(..), targetExpandURL, TargetId(..), splitIPackage, splitIModule, hseToSig, hseToItem, item_test,@@ -30,6 +30,9 @@ import qualified Data.Aeson as J import Data.Aeson.Types import Test.QuickCheck+import Distribution.Types.PackageName (unPackageName, mkPackageName)+import Query+ --------------------------------------------------------------------- -- TYPES @@ -90,7 +93,7 @@ rnf (IInstance a) = rnf a itemName :: Item -> Maybe Str-itemName (IPackage x) = Just x+itemName (IPackage x) = Just $ strPack $ unPackageName x itemName (IModule x) = Just x itemName (IName x) = Just x itemName (ISignature _) = Nothing@@ -174,20 +177,43 @@ unHTMLTarget :: Target -> Target unHTMLTarget t@Target {..} = t{targetItem=unHTML targetItem, targetDocs=unHTML targetDocs} -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+splitIPackage :: [(a, Item)] -> [(PkgName, [(a, Item)])]+splitIPackage = splitUsing (mkPackageName "") $ \x -> case snd x of+ IPackage x -> Just x+ _ -> Nothing -splitUsing :: (a -> Maybe Str) -> [a] -> [(Str, [a])]-splitUsing f = repeatedly $ \(x:xs) ->+splitIModule :: [(a, Item)] -> [(Str, [(a, Item)])]+splitIModule = splitUsing mempty $ \x -> case snd x of+ IModule x -> Just x+ _ -> Nothing++splitUsing :: b -> (a -> Maybe b) -> [a] -> [(b, [a])]+splitUsing def f = repeatedly $ \(x:xs) -> let (a,b) = break (isJust . f) xs- in ((fromMaybe mempty $ f x, x:a), b)+ in ((fromMaybe def $ 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'++highlightItem:: Monoid m => (String -> m) -> (String -> m) -> (String -> m) -> (String -> m) -> [Query] -> String -> m+highlightItem plain safe dull bold qs x+ | Just (pre,x) <- stripInfix "<s0>" x, Just (name,post) <- stripInfix "</s0>" x+ = safe pre <> highlight (unescapeHTML name) <> safe post+ | otherwise = plain x+ where+ highlight x = mconcatMap (\xs@((b,_):_) -> let s = map snd xs in if b then bold s else dull s) $+ groupOn fst $ zip (findQueries x) x+ where+ -- generates a bool mask, which is only true for charachters that compose given queries+ -- e.g. [ "query" "ya" ] -> [ "AqUeRyAA" ] -> 01111110+ findQueries :: String -> [Bool]+ findQueries (x:xs) | m > 0 = replicate m True ++ drop (m - 1) (findQueries xs)+ where m = maximum $ 0 : [length y | QueryName y <- qs, lower y `isPrefixOf` lower (x:xs)]+ findQueries (x:xs) = False : findQueries xs+ findQueries [] = [] --------------------------------------------------------------------- -- HSE CONVERSION
+ src/Input/ParseDecl.hs view
@@ -0,0 +1,609 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# OPTIONS_GHC -Wall #-}+{-# OPTIONS_GHC -Wno-missing-signatures -Wno-missing-pattern-synonym-signatures #-}++module Input.ParseDecl (myParseDecl) where++import Prelude hiding (Foldable(..))+import Data.Char (isAlphaNum, isUpper)+import Data.Foldable (Foldable(..))+import Data.List.Extra (dropEnd1, drop1, enumerate, stripPrefix, unsnoc, isInfixOf)+import Data.List.NonEmpty qualified as NE (toList)+import Data.Maybe (isNothing)+import GHC.Data.EnumSet qualified as EnumSet+import GHC.Data.FastString (unpackFS)+import GHC.Data.StringBuffer (stringToStringBuffer)+import GHC.Hs+import GHC.LanguageExtensions.Type (Extension (..))+import GHC.Parser (parseDeclaration)+import GHC.Parser.Lexer (P (..), ParseResult (..), initParserState, mkParserOpts)+import GHC.Types.Fixity (Fixity (..), FixityDirection (..))+import GHC.Types.Name (nameOccName, tvName)+import GHC.Types.Name.Occurrence (OccName (..), occNameString)+import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc, rdrNameSpace)+import GHC.Types.SourceText (SourceText (..))+import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc, unLoc)+import GHC.Unit (GenModule (..))+import GHC.Utils.Error+import GHC.Utils.Outputable (Outputable (..), defaultSDocContext, runSDoc)+import Language.Haskell.Exts qualified as HSE+import Text.Read (readMaybe)++#if !MIN_VERSION_ghc_lib_parser(9,12,0)+pattern HsBang x y <- HsSrcBang _ x y+#endif++#if MIN_VERSION_ghc_lib_parser(9,12,0)+pattern MyFixity x y <- Fixity x y+#else+pattern MyFixity x y <- Fixity _ x y+#endif++#if MIN_VERSION_ghc_lib_parser(9,10,0)+pattern MyPrefixConGADT x <- PrefixConGADT _ x+pattern MyRecConGADT x <- RecConGADT _ x+#else+pattern MyPrefixConGADT x <- PrefixConGADT x+pattern MyRecConGADT x <- RecConGADT x _+#endif++#if !MIN_VERSION_ghc_lib_parser(9,14,0)+#define con_outer_bndrs con_bndrs+#endif++myParseDecl :: String -> HSE.ParseResult (HSE.Decl ())+myParseDecl str = case runGhcLibParser str of+ POk _state x -> case hsDeclToDecl (unLoc x) of+ Nothing -> HSE.ParseFailed HSE.noLoc str+ Just res -> HSE.ParseOk res+ PFailed _state -> HSE.ParseFailed HSE.noLoc str++hsDeclToDecl :: HsDecl GhcPs -> Maybe (HSE.Decl ())+hsDeclToDecl (TyClD _ (SynDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdRhs})) =+ Just $+ HSE.TypeDecl+ ()+ ( foldl'+ (\acc (L _ tv) -> HSE.DHApp () acc (hsTyVarBndrToTyVarBind tv))+ (HSE.DHead () $ rdrNameToName $ unLoc tcdLName)+ hsq_explicit+ )+ (hsTypeToType $ unLoc tcdRhs)+hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdDataDefn = HsDataDefn{dd_cons = DataTypeCons _ [], dd_ctxt, dd_kindSig = Nothing}})) =+ Just $+ HSE.DataDecl+ ()+ (HSE.DataType ())+ (fmap (hsTypesToContext . unLoc) dd_ctxt)+ ( foldl'+ (\acc (L _ tv) -> HSE.DHApp () acc (hsTyVarBndrToTyVarBind tv))+ (HSE.DHead () $ rdrNameToName $ unLoc tcdLName)+ hsq_explicit+ )+ []+ []+hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdDataDefn = HsDataDefn{dd_cons = DataTypeCons _ [], dd_kindSig = Just kind}})) =+ Just $+ HSE.GDataDecl+ ()+ (HSE.DataType ())+ Nothing+ ( foldl'+ (\acc (L _ tv) -> HSE.DHApp () acc (hsTyVarBndrToTyVarBind tv))+ (HSE.DHead () $ rdrNameToName $ unLoc tcdLName)+ hsq_explicit+ )+ (Just $ hsTypeToType $ unLoc kind)+ []+ []+hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdDataDefn = HsDataDefn{dd_cons = DataTypeCons _ [L _ (ConDeclGADT{con_names, con_outer_bndrs, con_g_args = MyPrefixConGADT args, con_res_ty, con_mb_cxt})]}})) =+ Just $+ HSE.GDataDecl+ ()+ (HSE.DataType ())+ Nothing+ ( foldl'+ (\acc (L _ tv) -> HSE.DHApp () acc (hsTyVarBndrToTyVarBind tv))+ (HSE.DHead () $ rdrNameToName $ unLoc tcdLName)+ hsq_explicit+ )+ Nothing+ ( map+ ( \con_name ->+ HSE.GadtDecl+ ()+ (rdrNameToName $ unLoc con_name)+ Nothing+ Nothing+ Nothing+ ( maybe id (\bs -> applyTyForall (Just bs) Nothing) (hsOuterTyVarBndrsToFoo $ unLoc con_outer_bndrs) $+ maybe id (applyTyForall Nothing . Just . hsTypesToContext . unLoc) con_mb_cxt $+ foldr+#if MIN_VERSION_ghc_lib_parser(9,14,0)+ (\CDF{cdf_type} -> HSE.TyFun () (hsTypeToType $ unLoc cdf_type))+#else+ (\(HsScaled _ a) -> HSE.TyFun () (hsTypeToType $ unLoc a))+#endif+ (hsTypeToType $ unLoc con_res_ty)+ args+ )+ )+ (NE.toList con_names)+ )+ []+hsDeclToDecl (TyClD _ (GHC.Hs.DataDecl{tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdDataDefn = HsDataDefn{dd_cons = DataTypeCons _ [L _ (ConDeclGADT{con_names, con_outer_bndrs, con_g_args = MyRecConGADT (L _ args), con_res_ty, con_mb_cxt})]}})) =+ Just $+ HSE.GDataDecl+ ()+ (HSE.DataType ())+ Nothing+ ( foldl'+ (\acc (L _ tv) -> HSE.DHApp () acc (hsTyVarBndrToTyVarBind tv))+ (HSE.DHead () $ rdrNameToName $ unLoc tcdLName)+ hsq_explicit+ )+ Nothing+ ( map+ ( \con_name ->+ HSE.GadtDecl+ ()+ (rdrNameToName $ unLoc con_name)+ Nothing+ Nothing+ (Just $ map (conDeclFieldToFieldDecl . unLoc) args)+ ( maybe id (HSE.TyForall () Nothing . Just . hsTypesToContext . unLoc) con_mb_cxt $+ maybe id (\bs -> HSE.TyForall () (Just bs) Nothing) (hsOuterTyVarBndrsToFoo $ unLoc con_outer_bndrs) $+ hsTypeToType $+ unLoc con_res_ty+ )+ )+ (NE.toList con_names)+ )+ []+hsDeclToDecl (TyClD _ (FamDecl{tcdFam = FamilyDecl{fdLName, fdInfo = DataFamily, fdTyVars = HsQTvs{hsq_explicit}, fdResultSig}})) =+ Just $+ HSE.DataFamDecl+ ()+ Nothing+ ( foldl'+ (\acc (L _ tv) -> HSE.DHApp () acc (hsTyVarBndrToTyVarBind tv))+ (HSE.DHead () $ rdrNameToName $ unLoc fdLName)+ hsq_explicit+ )+ (familyResultSigToResultSig $ unLoc fdResultSig)+hsDeclToDecl (TyClD _ (FamDecl{tcdFam = FamilyDecl{fdLName, fdTyVars = HsQTvs{hsq_explicit}, fdResultSig, fdInjectivityAnn}})) =+ Just $+ HSE.TypeFamDecl+ ()+ ( foldl'+ (\acc (L _ tv) -> HSE.DHApp () acc (hsTyVarBndrToTyVarBind tv))+ (HSE.DHead () $ rdrNameToName $ unLoc fdLName)+ hsq_explicit+ )+ (familyResultSigToResultSig $ unLoc fdResultSig)+ (fmap (injectivityAnnToInjectivityInfo . unLoc) fdInjectivityAnn)+hsDeclToDecl (TyClD _ (GHC.Hs.ClassDecl{tcdCtxt, tcdLName, tcdTyVars = HsQTvs{hsq_explicit}, tcdFDs})) =+ Just $+ HSE.ClassDecl+ ()+ (fmap (hsTypesToContext . unLoc) tcdCtxt)+ ( foldl'+ (\acc (L _ tv) -> HSE.DHApp () acc (hsTyVarBndrToTyVarBind tv))+ (HSE.DHead () $ rdrNameToName $ unLoc tcdLName)+ hsq_explicit+ )+ (map (funDepToFunDep . unLoc) tcdFDs)+ Nothing+hsDeclToDecl (SigD _ (GHC.Hs.TypeSig _ names (HsWC{hswc_body = L _ HsSig{sig_body}}))) =+ Just $+ HSE.TypeSig+ ()+ (map (rdrNameToName . unLoc) names)+ (hsTypeToType $ unLoc sig_body)+hsDeclToDecl (SigD _ (GHC.Hs.PatSynSig _ names (L _ HsSig{sig_body}))) =+ Just $ case hsTypeToType (unLoc sig_body) of+ HSE.TyForall () Nothing (Just ctx1) (HSE.TyForall () Nothing (Just ctx2) ty) ->+ HSE.PatSynSig+ ()+ (map (rdrNameToName . unLoc) names)+ Nothing+ (Just ctx1)+ Nothing+ (Just ctx2)+ ty+ HSE.TyForall () Nothing (Just ctx) ty ->+ HSE.PatSynSig+ ()+ (map (rdrNameToName . unLoc) names)+ Nothing+ (Just ctx)+ Nothing+ Nothing+ ty+ ty ->+ HSE.PatSynSig+ ()+ (map (rdrNameToName . unLoc) names)+ Nothing+ Nothing+ Nothing+ Nothing+ ty+hsDeclToDecl (SigD _ (FixSig _ (FixitySig _ names (MyFixity priority direction)))) =+ Just $+ HSE.InfixDecl+ ()+ (fixityDirectionToAssoc direction)+ (Just priority)+ (map (varOpOrConOp . rdrNameToName . unLoc) names)+hsDeclToDecl (InstD _ (ClsInstD{cid_inst = ClsInstDecl{cid_poly_ty = (L _ HsSig{sig_bndrs, sig_body})}})) =+ Just $ case hsTypeToType (unLoc sig_body) of+ HSE.TyForall () Nothing ctxt body ->+ HSE.InstDecl+ ()+ Nothing+ (HSE.IRule () (hsOuterTyVarBndrsToFoo sig_bndrs) ctxt (typeToInstHead body))+ Nothing+ body ->+ HSE.InstDecl+ ()+ Nothing+ (HSE.IRule () (hsOuterTyVarBndrsToFoo sig_bndrs) Nothing (typeToInstHead body))+ Nothing+hsDeclToDecl _ = Nothing++injectivityAnnToInjectivityInfo :: InjectivityAnn GhcPs -> HSE.InjectivityInfo ()+injectivityAnnToInjectivityInfo = \case+ InjectivityAnn _ lhs rhs ->+ HSE.InjectivityInfo () (rdrNameToName $ unLoc lhs) (map (rdrNameToName . unLoc) rhs)++#if MIN_VERSION_ghc_lib_parser(9,14,0)+conDeclFieldToFieldDecl :: HsConDeclRecField GhcPs -> HSE.FieldDecl ()+conDeclFieldToFieldDecl = \case+ HsConDeclRecField{cdrf_names, cdrf_spec = CDF{cdf_type}} ->+ HSE.FieldDecl+ ()+ (map (fieldOccToName . unLoc) cdrf_names)+ (hsTypeToType $ unLoc cdf_type)+#else+conDeclFieldToFieldDecl :: ConDeclField GhcPs -> HSE.FieldDecl ()+conDeclFieldToFieldDecl = \case+ ConDeclField{cd_fld_names, cd_fld_type} ->+ HSE.FieldDecl+ ()+ (map (fieldOccToName . unLoc) cd_fld_names)+ (hsTypeToType $ unLoc cd_fld_type)+#endif++fieldOccToName :: FieldOcc GhcPs -> HSE.Name ()+fieldOccToName = \case+ FieldOcc{foLabel} -> rdrNameToName $ unLoc foLabel++varOpOrConOp :: HSE.Name () -> HSE.Op ()+varOpOrConOp name = case name of+ HSE.Symbol () (':' : _) -> HSE.ConOp () name+ HSE.Ident () (c : _)+ | isUpper c -> HSE.ConOp () name+ | otherwise -> HSE.VarOp () name+ _ -> HSE.VarOp () name++familyResultSigToResultSig :: FamilyResultSig GhcPs -> Maybe (HSE.ResultSig ())+familyResultSigToResultSig = \case+ NoSig{} -> Nothing+ GHC.Hs.KindSig _ kind ->+ Just $ HSE.KindSig () $ hsTypeToType $ unLoc kind+ GHC.Hs.TyVarSig _ tvb ->+ Just $ HSE.TyVarSig () $ hsTyVarBndrToTyVarBind $ unLoc tvb++hsOuterTyVarBndrsToFoo :: HsOuterSigTyVarBndrs GhcPs -> Maybe [HSE.TyVarBind ()]+hsOuterTyVarBndrsToFoo = \case+ HsOuterImplicit{} -> Nothing+ HsOuterExplicit{hso_bndrs} -> Just $ map (hsTyVarBndrToTyVarBind . unLoc) hso_bndrs++funDepToFunDep :: GHC.Hs.FunDep GhcPs -> HSE.FunDep ()+funDepToFunDep = \case+ GHC.Hs.FunDep _ lhs rhs ->+ HSE.FunDep () (map (rdrNameToName . unLoc) lhs) (map (rdrNameToName . unLoc) rhs)++fixityDirectionToAssoc :: FixityDirection -> HSE.Assoc ()+fixityDirectionToAssoc = \case+ InfixL -> HSE.AssocLeft ()+ InfixR -> HSE.AssocRight ()+ InfixN -> HSE.AssocNone ()++hsTyVarBndrToTyVarBind ::+ HsTyVarBndr a GhcPs ->+ HSE.TyVarBind ()+#if MIN_VERSION_ghc_lib_parser(9,12,0)+hsTyVarBndrToTyVarBind = \case+ HsTvb _ _ (HsBndrVar _ (L _ var)) HsBndrNoKind{} ->+ HSE.UnkindedVar () (rdrNameToName var)+ HsTvb _ _ (HsBndrVar _ (L _ var)) (HsBndrKind _ (L _ kind)) ->+ HSE.KindedVar () (rdrNameToName var) (hsTypeToType kind)+ HsTvb _ _ (HsBndrWildCard _) _ ->+ HSE.UnkindedVar () (HSE.Ident () "_")+#else+hsTyVarBndrToTyVarBind = \case+ UserTyVar _ _ (L _ var) ->+ HSE.UnkindedVar () (rdrNameToName var)+ KindedTyVar _ _ (L _ var) (L _ kind) ->+ HSE.KindedVar () (rdrNameToName var) (hsTypeToType kind)+#endif++occNameToName :: OccName -> HSE.Name ()+occNameToName occ = case occNameString occ of+ xs@(x : _)+ | not (isAlphaNum x) && x /= '(' && x /= '_' -> HSE.Symbol () xs+ xs -> HSE.Ident () xs++rdrNameToName :: RdrName -> HSE.Name ()+rdrNameToName = occNameToName . rdrNameOcc++rdrNameToQName :: RdrName -> HSE.QName ()+rdrNameToQName = \case+ Unqual occName ->+ HSE.UnQual () $ occNameToName occName+ GHC.Types.Name.Reader.Qual modName occName ->+ HSE.Qual+ ()+ (HSE.ModuleName () (moduleNameString modName))+ (occNameToName occName)+ Orig modul occName ->+ HSE.Qual+ ()+ (HSE.ModuleName () (moduleNameString $ moduleName modul))+ (occNameToName occName)+ Exact name ->+ HSE.UnQual () $ occNameToName (nameOccName name)++hsTypeToType :: HsType GhcPs -> HSE.Type ()+hsTypeToType = \case+ HsListTy _ x ->+ HSE.TyList () $ hsTypeToType $ unLoc x+ HsTyVar _ _ (L _ (Exact x))+ | show (runSDoc (ppr x) defaultSDocContext) == "[]" ->+ HSE.TyCon () $ HSE.Special () $ HSE.ListCon ()+ | show (runSDoc (ppr x) defaultSDocContext) == "->" ->+ HSE.TyCon () $ HSE.Special () $ HSE.FunCon ()+ | Just n <- stripPrefix "Tuple" (occNameString (nameOccName x))+ , Just n' <- readMaybe n ->+ HSE.TyCon () $ HSE.Special () $ HSE.TupleCon () HSE.Boxed n'+ HsTyVar _ IsPromoted (L _ x) ->+ HSE.TyPromoted () $ HSE.PromotedCon () True $ rdrNameToQName x+ HsTyVar _ NotPromoted (L _ x) ->+ case rdrNameSpace x of+ ns+ | ns == tvName ->+ HSE.TyVar () $ rdrNameToName x+ _ -> HSE.TyCon () $ rdrNameToQName x+ HsAppTy _ x y ->+ HSE.TyApp () (hsTypeToType $ unLoc x) (hsTypeToType $ unLoc y)+ HsFunTy _ _ x y ->+ HSE.TyFun () (hsTypeToType $ unLoc x) (hsTypeToType $ unLoc y)+ HsTupleTy _ HsBoxedOrConstraintTuple [] ->+ HSE.TyCon () $ HSE.Special () $ HSE.UnitCon ()+ HsTupleTy _ HsUnboxedTuple [] ->+ HSE.TyCon () $ HSE.Special () $ HSE.UnboxedSingleCon ()+ HsTupleTy _ boxed xs ->+ HSE.TyTuple () (hsTupleSortToBoxed boxed) (map (hsTypeToType . unLoc) xs)+ HsStarTy _ _ ->+ HSE.TyStar ()+#if !MIN_VERSION_ghc_lib_parser(9,14,0)+ HsBangTy _ (HsBang unpackedness strictness) x ->+ applyTyBang+ (srcStrictnessToBangType strictness)+ (srcUnpackednessToUnpackedness unpackedness)+ (hsTypeToType $ unLoc x)+#endif+ HsParTy _ x -> case hsTypeToType (unLoc x) of+ x'@HSE.TyKind{} -> x'+ x' -> HSE.TyParen () x'+ HsQualTy{hst_ctxt, hst_body} ->+ applyTyForall Nothing (Just $ hsTypesToContext $ unLoc hst_ctxt) $+ hsTypeToType $+ unLoc hst_body+ HsForAllTy{hst_tele = HsForAllInvis{hsf_invis_bndrs}, hst_body} ->+ applyTyForall+ (Just $ map (hsTyVarBndrToTyVarBind . unLoc) hsf_invis_bndrs)+ Nothing+ (hsTypeToType $ unLoc hst_body)+ -- TODO FIXME when migrating to ghc-lib-parser completely:+ -- HSE does not support forall with visible binders+ HsForAllTy{hst_tele = HsForAllVis{hsf_vis_bndrs}, hst_body} ->+ applyTyForall+ (Just $ map (hsTyVarBndrToTyVarBind . unLoc) hsf_vis_bndrs)+ Nothing+ (hsTypeToType $ unLoc hst_body)+ HsExplicitListTy _ IsPromoted xs ->+ HSE.TyPromoted () $ HSE.PromotedList () True (map (hsTypeToType . unLoc) xs)+ HsExplicitListTy _ NotPromoted [x] ->+ HSE.TyList () $ hsTypeToType $ unLoc x+ HsExplicitListTy _ NotPromoted xs ->+ HSE.TyPromoted () $ HSE.PromotedList () False (map (hsTypeToType . unLoc) xs)++#if MIN_VERSION_ghc_lib_parser(9,12,0)+ HsExplicitTupleTy _ IsPromoted [] ->+ HSE.TyPromoted () $ HSE.PromotedCon () True $ HSE.Special () $ HSE.UnitCon ()+ HsExplicitTupleTy _ IsPromoted xs ->+ HSE.TyPromoted () $ HSE.PromotedTuple () $ map (hsTypeToType . unLoc) xs+ HsExplicitTupleTy _ NotPromoted xs ->+ HSE.TyTuple () HSE.Boxed (map (hsTypeToType . unLoc) xs)+#else+ HsExplicitTupleTy _ [] ->+ HSE.TyPromoted () $ HSE.PromotedCon () True $ HSE.Special () $ HSE.UnitCon ()+ HsExplicitTupleTy _ xs ->+ HSE.TyPromoted () $ HSE.PromotedTuple () $ map (hsTypeToType . unLoc) xs+#endif++ HsOpTy _ _ x (L _ (Unqual y)) z+ | occNameString y == "~" ->+ HSE.TyEquals () (hsTypeToType $ unLoc x) (hsTypeToType $ unLoc z)+ HsOpTy _ promotion x (L _ (Exact y)) z+ | occNameString (nameOccName y) == ":" ->+ HSE.TyInfix+ ()+ (hsTypeToType $ unLoc x)+ (promotionFlagToMaybePromotedName promotion $ HSE.Special () $ HSE.Cons ())+ (hsTypeToType $ unLoc z)+ HsOpTy _ promotion x y z ->+ HSE.TyInfix+ ()+ (hsTypeToType $ unLoc x)+ (promotionFlagToMaybePromotedName promotion $ rdrNameToQName $ unLoc y)+ (hsTypeToType $ unLoc z)+ HsKindSig _ lhs rhs ->+ HSE.TyKind () (hsTypeToType $ unLoc lhs) (hsTypeToType $ unLoc rhs)+ HsTyLit _ (HsNumTy (SourceText txt) val) ->+ HSE.TyPromoted () $ HSE.PromotedInteger () val (unpackFSOrId txt)+ HsTyLit _ (HsStrTy (SourceText txt) val) ->+ HSE.TyPromoted () $ HSE.PromotedString () (unpackFS val) (drop1 $ dropEnd1 $ unpackFSOrId txt)+ HsSumTy _ xs ->+ HSE.TyUnboxedSum () $ map (hsTypeToType . unLoc) xs+ HsWildCardTy _ ->+ HSE.TyWildCard () Nothing+ -- Everything else cannot be represented in HSE, so replacing with a wildcard+ _ -> HSE.TyWildCard () Nothing++promotionFlagToMaybePromotedName ::+ PromotionFlag -> HSE.QName () -> HSE.MaybePromotedName ()+promotionFlagToMaybePromotedName = \case+ NotPromoted -> HSE.UnpromotedName ()+ IsPromoted -> HSE.PromotedName ()++applyTyForall ::+ Maybe [HSE.TyVarBind ()] -> Maybe (HSE.Context ()) -> HSE.Type () -> HSE.Type ()+applyTyForall mArg1 mArg2 = \case+ HSE.TyForall () Nothing mArg2' ty+ | isNothing mArg2 -> HSE.TyForall () mArg1 mArg2' ty+ ty -> HSE.TyForall () mArg1 mArg2 ty++#if !MIN_VERSION_ghc_lib_parser(9,14,0)+applyTyBang ::+ HSE.BangType () -> HSE.Unpackedness () -> HSE.Type () -> HSE.Type ()+applyTyBang bang unpack = \case+ HSE.TyBang () (HSE.NoStrictAnnot ()) unpack' ty+ | unpack == HSE.NoUnpackPragma () -> HSE.TyBang () bang unpack' ty+ HSE.TyBang () bang' (HSE.NoUnpackPragma ()) ty+ | bang == HSE.NoStrictAnnot () -> HSE.TyBang () bang' unpack ty+ HSE.TyApp () x y -> HSE.TyApp () (applyTyBang bang unpack x) y+ ty -> HSE.TyBang () bang unpack ty++srcStrictnessToBangType :: SrcStrictness -> HSE.BangType ()+srcStrictnessToBangType = \case+ SrcLazy -> HSE.LazyTy ()+ SrcStrict -> HSE.BangedTy ()+ NoSrcStrict -> HSE.NoStrictAnnot ()++srcUnpackednessToUnpackedness :: SrcUnpackedness -> HSE.Unpackedness ()+srcUnpackednessToUnpackedness = \case+ SrcUnpack -> HSE.Unpack ()+ SrcNoUnpack -> HSE.NoUnpack ()+ NoSrcUnpack -> HSE.NoUnpackPragma ()+#endif++typeToInstHead :: HSE.Type () -> HSE.InstHead ()+typeToInstHead = \case+ HSE.TyApp () x y -> HSE.IHApp () (typeToInstHead x) y+ HSE.TyCon () x -> HSE.IHCon () x+ HSE.TyInfix () x (HSE.UnpromotedName () y) z -> HSE.IHApp () (HSE.IHInfix () x y) z+ -- The rest happens only in ghc-prim, which are likely some magical forms.+ -- Let's skip them.+ _ -> HSE.IHCon () $ HSE.Special () $ HSE.UnitCon ()++hsTypesToContext ::+ [GenLocated SrcSpanAnnA (HsType GhcPs)] ->+ HSE.Context ()+hsTypesToContext = \case+ [] -> HSE.CxEmpty ()+ [x] -> HSE.CxSingle () $ hsTypeToAsst $ unLoc x+ xs -> HSE.CxTuple () $ map (hsTypeToAsst . unLoc) xs++hsTypeToAsst :: HsType GhcPs -> HSE.Asst ()+hsTypeToAsst = \case+ HsIParamTy _ name t ->+ HSE.IParam () (hsIPNameToIPName $ unLoc name) (hsTypeToType $ unLoc t)+ HsParTy _ t ->+ HSE.ParenA () $ hsTypeToAsst $ unLoc t+ t -> case hsTypeToType t of+ HSE.TyParen () ty -> HSE.ParenA () $ HSE.TypeA () ty+ ty -> HSE.TypeA () ty++hsIPNameToIPName :: HsIPName -> HSE.IPName ()+hsIPNameToIPName = HSE.IPDup () . unpackFS . hsIPNameFS++hsTupleSortToBoxed :: HsTupleSort -> HSE.Boxed+hsTupleSortToBoxed = \case+ HsUnboxedTuple -> HSE.Unboxed+ HsBoxedOrConstraintTuple -> HSE.Boxed++runGhcLibParser ::+ String ->+ GHC.Parser.Lexer.ParseResult (GenLocated SrcSpanAnnA (HsDecl GhcPs))+runGhcLibParser str+ | Just (str', ';') <- unsnoc str =+ runGhcLibParser str'+runGhcLibParser str = case runGhcLibParserWithExtensions almostAllExtensions str of+ PFailed{}+ | '#' `elem` str -> runGhcLibParserWithExtensions noUnboxed str+ | '*' `elem` str -> runGhcLibParserWithExtensions noStarIsType str+ | "pattern" `isInfixOf` str -> runGhcLibParserWithExtensions noPatternSynonyms str+ res -> res++allExtensions :: EnumSet.EnumSet Extension+allExtensions = EnumSet.fromList enumerate++almostAllExtensions :: EnumSet.EnumSet Extension+almostAllExtensions =+ foldr+ EnumSet.delete+ allExtensions+ [ Arrows -- makes "proc" a keyword+ , RecursiveDo -- makes "mdo" and "rec" keywords+ , StaticPointers -- makes "static" a keyword+ , TransformListComp -- makes "by", "group" and "using" keywords+ ]++noUnboxed :: EnumSet.EnumSet Extension+noUnboxed =+ foldr+ EnumSet.delete+ almostAllExtensions+ [ UnboxedSums+ , UnboxedTuples+ ]++noPatternSynonyms :: EnumSet.EnumSet Extension+noPatternSynonyms = EnumSet.delete PatternSynonyms almostAllExtensions++noStarIsType :: EnumSet.EnumSet Extension+noStarIsType = EnumSet.delete StarIsType almostAllExtensions++runGhcLibParserWithExtensions ::+ EnumSet.EnumSet Extension ->+ String ->+ GHC.Parser.Lexer.ParseResult (GenLocated SrcSpanAnnA (HsDecl GhcPs))+runGhcLibParserWithExtensions extensions str = unP parseDeclaration parseState+ where+#if MIN_VERSION_ghc_lib_parser(9,14,0)+ opts = mkParserOpts extensions emptyDiagOpts False False False False+#else+ opts = mkParserOpts extensions emptyDiagOpts [] False False False False+#endif+ dummyLocation = mkRealSrcLoc mempty 1 1+ buffer = stringToStringBuffer str+ parseState = initParserState opts buffer dummyLocation++#if !MIN_VERSION_ghc_lib_parser(9,8,0)+emptyDiagOpts :: DiagOpts+emptyDiagOpts = DiagOpts mempty mempty False False Nothing defaultSDocContext+#endif++#if MIN_VERSION_ghc_lib_parser(9,8,0)+unpackFSOrId = unpackFS+#else+unpackFSOrId = id+#endif
src/Input/Reorder.hs view
@@ -8,15 +8,16 @@ import Data.Tuple.Extra import General.Util import General.Str+import Distribution.Types.PackageName (mkPackageName, unPackageName) pkgGhc :: PkgName-pkgGhc = strPack "ghc"+pkgGhc = mkPackageName "ghc" packageOrderHacks :: (PkgName -> Int) -> PkgName -> Int -- 'ghc' is the canonical module that both 'ghc-lib-parser' and 'ghc-lib' copy from, so better to pick that -- even though ghc-lib-* are used more on Stackage (but a lot less on Hackage)-packageOrderHacks f x | x == pkgGhc = min (f x) $ min (f $ strPack "ghc-lib-parser") (f $ strPack "ghc-lib") - 1+packageOrderHacks f x | x == pkgGhc = min (f x) $ min (f $ mkPackageName "ghc-lib-parser") (f $ mkPackageName "ghc-lib") - 1 packageOrderHacks f x = f x @@ -28,4 +29,4 @@ where refunc = map $ second $ \(x:xs) -> x : sortOn (itemName . snd) xs rebase (x, xs) = (x, concatMap snd $ sortOn (((negate . f . strUnpack) &&& id) . fst) $ refunc $ splitIModule xs)- where f = reorderModule (strUnpack x)+ where f = reorderModule (unPackageName x)
src/Input/Set.hs view
@@ -27,7 +27,8 @@ setPlatformWith :: FilePath -> [String] -> IO (Set.Set String) setPlatformWith file names = do src <- lines <$> readFile' file- pure $ Set.fromList [read lib | ",":name:lib:_ <- map words src, name `elem` names]+ pure $ Set.delete "bin-package-db" $+ 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
@@ -1,4 +1,4 @@-{-# LANGUAGE RecordWildCards, PatternGuards, TemplateHaskell, CPP #-}+{-# LANGUAGE PackageImports, RecordWildCards, PatternGuards, TemplateHaskell, CPP #-} -- | Module for reading settings files.@@ -9,7 +9,7 @@ import Control.Exception (catch, throwIO) import Data.List.Extra import Data.Maybe-import Language.Haskell.TH.Syntax (lift, runIO)+import "template-haskell" Language.Haskell.TH.Syntax (lift, runIO) import System.FilePath import System.IO.Error (isDoesNotExistError) import System.IO.Extra
src/Output/Tags.hs view
@@ -18,6 +18,7 @@ import General.Util import General.Store import General.Str+import Distribution.Types.PackageName (unPackageName, mkPackageName) --------------------------------------------------------------------- -- DATA TYPE@@ -43,23 +44,23 @@ 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 (bstr0Join $ map (strUnpack . fst) packages, V.fromList $ map snd packages)+ let packages = addRange (== mkPackageName "") splitPkg+ storeWrite store Packages (bstr0Join $ map (unPackageName . fst) packages, V.fromList $ map snd packages) let categories = map (bimap snd reverse) $ Map.toList $ Map.fromListWith (++) [(((weightTag ex, both lower ex), joinPair ":" ex),[rng]) | (p,rng) <- packages, ex <- extra p] storeWrite store Categories (bstr0Join $ map fst categories, jaggedFromList $ map snd categories) - let modules = addRange $ concatMap (splitIModule . snd) splitPkg+ let modules = addRange strNull $ concatMap (splitIModule . snd) splitPkg storeWrite store Modules (bstr0Join $ map (lower . strUnpack . fst) modules, V.fromList $ map snd modules) storeWrite store Completions $ bstr0Join $ takeWhile ("set:" `isPrefixOf`) (map fst categories) ++- map ("package:"++) (sortOn lower $ map strUnpack $ nubOrd $ filter keep $ map fst packages) +++ map ("package:"++) (sortOn lower $ map unPackageName $ 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 :: [(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 /= []]+ addRange :: (str -> Bool) -> [(str, [(Maybe TargetId,a)])] -> [(str, (TargetId, TargetId))]+ addRange isNull xs = [(a, (minimum' is, maximum' is)) | (a,b) <- xs, let is = mapMaybe fst b, not (isNull a), is /= []] weightTag ("set",x) = fromMaybe 0.9 $ lookup x [("stackage",0.0),("haskell-platform",0.1)] weightTag ("package",x) = 1
src/Output/Types.hs view
@@ -267,7 +267,7 @@ fpRaresFold g f Fingerprint{..} = f fpRare1 `g` f fpRare2 `g` f fpRare3 instance Storable Fingerprint where- sizeOf _ = 3*sizeOf name0 + 2+ sizeOf _ = 4 * sizeOf name0 alignment _ = 4 peekByteOff ptr i = Fingerprint <$> peekByteOff ptr (i+0) <*> peekByteOff ptr (i+1*w) <*> peekByteOff ptr (i+2*w)