Use PackageName from Cabal-syntax for PkgName instead of plain Str

Now that we depend on Cabal-syntax anyway, why not use a proper
type to represent package names?

Author: Bodigrim

src/Action/Generate.hs

@@ -36,6 +36,7 @@ import General.Str
 import Action.CmdLine
 import General.Conduit
 import Control.DeepSeq
+import Distribution.Package (mkPackageName, unPackageName)
 
 {-
 
@@ -101,12 +102,12 @@ readHaskellOnline timing settings download = do
     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 @@ readHaskellOnline timing settings download = do
 
     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,13 +130,13 @@ readHaskellDirs timing settings dirs = do
     -- 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 ++ "/"
-            when (isJust $ bstrSplitInfix (bstrPack "@package " <> bstrPack (strUnpack name)) src) $
+            when (isJust $ bstrSplitInfix (bstrPack "@package " <> bstrPack (unPackageName name)) src) $
                 yield (name, url, lbstrFromChunks [src])
     pure (Map.union
                 (Map.fromList cabals)
@@ -145,7 +146,7 @@ readHaskellDirs timing settings dirs = do
     parseCabal fp = do
         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})
@@ -158,16 +159,16 @@ readFregeOnline timing download = do
     frege <- download "frege-frege.txt" "http://try.frege-lang.org/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 ())
 readHaskellGhcpkg timing settings = do
     cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings
     let source =
             forM_ (Map.toList cbl) $ \(name,Package{..}) -> whenJust packageDocs $ \docs -> do
-                let file = docs </> strUnpack name <.> "txt"
+                let file = docs </> unPackageName name <.> "txt"
                 whenM (liftIO $ doesFileExist file) $ do
                     src <- liftIO $ bstrReadFile file
                     docs <- liftIO $ canonicalizePath docs
@@ -204,8 +205,8 @@ readHaskellHaddock timing settings docBaseDir = do
     cbl <- timed timing "Reading ghc-pkg" $ readGhcPkg settings
     let source =
             forM_ (Map.toList cbl) $ \(name, p@Package{..}) -> do
-                let docs = docDir (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] ++
@@ -250,7 +251,7 @@ actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtensio
     cbl <- evaluate $ Map.map (\p -> p{packageDepends=[]}) cbl -- clear the memory, since the information is no longer used
     evaluate 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
@@ -263,7 +264,7 @@ actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtensio
             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
 
@@ -273,12 +274,12 @@ actionGenerate g@Generate{..} = withTiming (if debug then Just $ replaceExtensio
                     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/General/Util.hs

@@ -56,9 +56,10 @@ import General.Str
 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 @@ minimum' = minimumBy' compare
 
 
 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/Input/Cabal.hs

@@ -34,7 +34,7 @@ import Distribution.Compat.Lens (toListOf)
 import qualified Distribution.PackageDescription as PD
 import qualified Distribution.PackageDescription.Parsec as PD
 import qualified Distribution.Types.BuildInfo.Lens as Lens
-import Distribution.Types.PackageName (unPackageName)
+import Distribution.Types.PackageName (mkPackageName, unPackageName)
 import Hackage.RevDeps (lastVersionsOfPackages)
 
 ---------------------------------------------------------------------
@@ -72,7 +72,7 @@ packagePopularity :: Map.Map PkgName Package -> ([String], Map.Map PkgName Int)
 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) $
@@ -111,7 +111,7 @@ readGhcPkg settings = do
         -- ^ 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 $ bstrPack $ unlines xs)
+    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
 
@@ -120,7 +120,7 @@ readGhcPkg settings = do
 parseCabalTarball :: Settings -> FilePath -> IO (Map.Map PkgName Package)
 parseCabalTarball settings tarfile = do
     lastVersions <- lastVersionsOfPackages (const True) tarfile Nothing
-    pure $ Map.mapKeys (strPack . unPackageName) $ Map.map (readCabal settings) lastVersions
+    pure $ Map.map (readCabal settings) lastVersions
 
 
 ---------------------------------------------------------------------
@@ -141,7 +141,7 @@ readCabal settings src = case PD.parseGenericPackageDescriptionMaybe src of
 readCabal' :: Settings -> PD.GenericPackageDescription -> String -> Package
 readCabal' Settings{..} gpd src = Package{..}
     where
-        packageDepends = nubOrd $ foldMap (map (\(PD.Dependency pkg _ _) -> strPack $ unPackageName pkg) . PD.targetBuildDepends) $ toListOf Lens.traverseBuildInfos gpd
+        packageDepends = nubOrd $ foldMap (map (\(PD.Dependency pkg _ _) -> pkg) . PD.targetBuildDepends) $ toListOf Lens.traverseBuildInfos gpd
 
         mp = Map.fromListWith (++) $ lexCabal src
         ask x = Map.findWithDefault [] x mp

src/Input/Haddock.hs

@@ -18,6 +18,7 @@ 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
@@ -76,7 +77,7 @@ reformat = unlines . map bstrUnpack
 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]))
             where url = targetURL t `orIfNull` (if isGhc then ghcModuleURL x else hackageModuleURL x)
@@ -92,8 +93,8 @@ hierarchyC packageUrl = void $ mapAccumC f (Nothing, Nothing)
         infix 1 `orIfNull`
         orIfNull x y = if null x then y else x
 
-
-renderPackage x = "<b>package</b> <span class=name><s0>" ++ escapeHTML (strUnpack x) ++ "</s0></span>"
+renderPackage :: PkgName -> [Char]
+renderPackage x = "<b>package</b> <span class=name><s0>" ++ escapeHTML (unPackageName x) ++ "</s0></span>"
 renderModule (breakEnd (== '.') . strUnpack -> (pre,post)) = "<b>module</b> " ++ escapeHTML pre ++ "<span class=name><s0>" ++ escapeHTML post ++ "</s0></span>"
 
 
@@ -122,7 +123,7 @@ renderItem = keyword . focus
 
 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
@@ -174,7 +175,7 @@ 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
 

src/Input/Item.hs

@@ -30,6 +30,8 @@ import Prelude
 import qualified Data.Aeson as J
 import Data.Aeson.Types
 import Test.QuickCheck
+import Distribution.Types.PackageName (unPackageName, mkPackageName)
+
 ---------------------------------------------------------------------
 -- TYPES
 
@@ -90,7 +92,7 @@ instance NFData Item where
     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,14 +176,20 @@ targetExpandURL t@Target{..} = t{targetURL = url, targetModule = second (const m
 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
+
+splitIModule :: [(a, Item)] -> [(Str, [(a, Item)])]
+splitIModule = splitUsing mempty $ \x -> case snd x of
+    IModule x -> Just x
+    _ -> Nothing
 
-splitUsing :: (a -> Maybe Str) -> [a] -> [(Str, [a])]
-splitUsing f = repeatedly $ \(x:xs) ->
+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

src/Input/Reorder.hs

@@ -8,15 +8,16 @@ import Data.List.Extra
 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 @@ reorderItems Settings{..} packageOrder xs =
     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/Output/Tags.hs

@@ -18,6 +18,7 @@ import Query
 import General.Util
 import General.Store
 import General.Str
+import Distribution.Types.PackageName (unPackageName, mkPackageName)
 
 ---------------------------------------------------------------------
 -- DATA TYPE
@@ -43,23 +44,23 @@ data Completions a where Completions :: Completions BStr0 deriving Typeable
 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