1  {-# LANGUAGE LambdaCase #-}
  2  {-# LANGUAGE OverloadedStrings #-}
  3  
  4  {- |
  5  Module      : Main
  6  Description : Combine Abseil's ~130 static libraries into one
  7  
  8  This script replaces combine-archive.sh with typed Haskell.
  9  It parses pkg-config files, builds a dependency graph,
 10  topologically sorts using Kahn's algorithm, and combines
 11  archives using ar.
 12  
 13  Usage: combine-archive <output-dir> [ar-prefix]
 14  -}
 15  module Main where
 16  
 17  import Aleph.Script hiding (length)
 18  import qualified Aleph.Script as W
 19  import Data.List (sort)
 20  import qualified Data.Map.Strict as Map
 21  import qualified Data.Set as Set
 22  import qualified Data.Text as T
 23  import System.Environment (getArgs)
 24  import Prelude hiding (FilePath)
 25  
 26  -- | Dependency graph: library name -> set of dependencies
 27  type DepsGraph = Map.Map Text (Set.Set Text)
 28  
 29  -- | In-degree map for Kahn's algorithm
 30  type InDegree = Map.Map Text Int
 31  
 32  main :: IO ()
 33  main = script $ do
 34      args <- liftIO getArgs
 35      case args of
 36          [outDir] -> combineArchive outDir ""
 37          [outDir, arPrefix] -> combineArchive outDir arPrefix
 38          _ -> die "Usage: combine-archive <output-dir> [ar-prefix]"
 39  
 40  combineArchive :: FilePath -> String -> Sh ()
 41  combineArchive outDir arPrefix = do
 42      let libDir = outDir </> "lib"
 43          pkgconfigDir = libDir </> "pkgconfig"
 44          ar = arPrefix <> "ar"
 45  
 46      cd libDir
 47  
 48      echo "// extracting dependencies from pkg-config files..."
 49  
 50      -- Find all absl_*.pc files
 51      pcFiles <- findPkgConfigFiles pkgconfigDir
 52  
 53      -- Parse dependencies and build graph
 54      (graph, allLibs, privateDeps) <- buildDepsGraph pcFiles
 55  
 56      echo $ "// found " <> pack (show (Set.size allLibs)) <> " libraries"
 57  
 58      -- Topologically sort libraries
 59      sortedLibs <- kahnSort graph allLibs
 60  
 61      -- Verify we got all libraries
 62      actualLibs <- findAbseilArchives
 63      let sortedCount = length sortedLibs
 64          actualCount = length actualLibs
 65  
 66      libs <-
 67          if sortedCount /= actualCount
 68              then do
 69                  echoErr $
 70                      "// warning: dependency sort found "
 71                          <> pack (show sortedCount)
 72                          <> " libraries but "
 73                          <> pack (show actualCount)
 74                          <> " exist"
 75                  echoErr "// falling back to simple sort"
 76                  pure $ sort actualLibs
 77              else pure sortedLibs
 78  
 79      -- Write manifest for debugging
 80      writeManifest libs
 81  
 82      -- Create ar script and combine archives
 83      createCombinedArchive ar libs
 84  
 85      -- Verify output
 86      exists <- test_f "libabseil.a"
 87      unless exists $ die "libabseil.a was not created"
 88  
 89      -- Cleanup individual archives
 90      forM_ actualLibs rm
 91  
 92      -- Remove individual pkg-config files
 93      forM_ pcFiles $ \pc -> do
 94          let name = basename pc
 95          when ("absl_" `isPrefixOf` pack name) $ rm pc
 96  
 97      -- Generate combined pkg-config file
 98      generatePkgConfig outDir privateDeps
 99  
100      -- Report success
101      size <- getFileSize "libabseil.a"
102      echo $ "// created libabseil.a (" <> formatSize size <> ")"
103      echo $ "// dependencies: " <> T.unwords (Set.toList privateDeps)
104      echo "// success: archive ready for hypermodern computing"
105  
106  -- | Find all absl_*.pc files in pkgconfig directory
107  findPkgConfigFiles :: FilePath -> Sh [FilePath]
108  findPkgConfigFiles dir = do
109      exists <- test_d dir
110      if exists
111          then do
112              files <- ls dir
113              pure $
114                  filter
115                      ( \f ->
116                          "absl_" `isPrefixOf` pack (takeFileName f)
117                              && ".pc" `isSuffixOf` pack f
118                      )
119                      files
120          else pure []
121  
122  -- | Find all libabsl_*.a files in current directory
123  findAbseilArchives :: Sh [FilePath]
124  findAbseilArchives = do
125      files <- ls "."
126      -- Use takeFileName to handle paths like "./libabsl_foo.a"
127      pure $
128          filter
129              ( \f ->
130                  "libabsl_" `isPrefixOf` pack (takeFileName f)
131                      && ".a" `isSuffixOf` pack f
132              )
133              files
134  
135  -- | Parse pkg-config files and build dependency graph
136  buildDepsGraph :: [FilePath] -> Sh (DepsGraph, Set.Set Text, Set.Set Text)
137  buildDepsGraph pcFiles = do
138      -- Collect private dependencies (pthread, m, rt, dl, etc.)
139      privateDeps <- collectPrivateDeps pcFiles
140  
141      -- Build dependency graph
142      results <- forM pcFiles $ \pc -> do
143          let libName = pack $ dropExtension $ takeFileName pc
144              libFile = "lib" <> unpack libName <> ".a"
145  
146          exists <- test_f libFile
147          if exists
148              then do
149                  deps <- extractAbslDeps pc
150                  pure $ Just (libName, deps)
151              else pure Nothing
152  
153      let validResults = catMaybes results
154          graph = Map.fromList validResults
155          allLibs = Set.fromList $ map fst validResults
156  
157      pure (graph, allLibs, privateDeps)
158  
159  -- | Extract Libs.private dependencies from all pkg-config files
160  collectPrivateDeps :: [FilePath] -> Sh (Set.Set Text)
161  collectPrivateDeps pcFiles = do
162      deps <- forM pcFiles $ \pc -> do
163          content <- liftIO $ Prelude.readFile pc
164          pure $ extractPrivateLibs (pack content)
165  
166      -- Always include common system libraries
167      let baseDeps = Set.fromList ["pthread", "m", "rt", "dl"]
168      pure $ Set.union baseDeps (Set.unions deps)
169  
170  -- | Extract -l flags from Libs.private line
171  extractPrivateLibs :: Text -> Set.Set Text
172  extractPrivateLibs content =
173      let contentLines = T.lines content
174          privLines = filter ("Libs.private:" `isInfixOf`) contentLines
175          tokens = concatMap T.words privLines
176          libs = mapMaybe extractLib tokens
177       in Set.fromList libs
178    where
179      extractLib t
180          | "-l" `isPrefixOf` t = Just (T.drop 2 t)
181          | otherwise = Nothing
182  
183  -- | Extract absl_* dependencies from Requires fields
184  extractAbslDeps :: FilePath -> Sh (Set.Set Text)
185  extractAbslDeps pc = do
186      content <- liftIO $ Prelude.readFile pc
187      let contentLines = T.lines (pack content)
188          reqLines =
189              filter
190                  ( \l ->
191                      "Requires:" `isPrefixOf` l
192                          || "Requires.private:" `isPrefixOf` l
193                  )
194                  contentLines
195          tokens = concatMap (T.words . snd . breakOn ":") reqLines
196          -- Remove commas and filter for absl_* names
197          cleaned = map (W.replace "," "") tokens
198          abslDeps = filter ("absl_" `isPrefixOf`) cleaned
199      pure $ Set.fromList abslDeps
200  
201  -- | Kahn's algorithm for topological sort
202  kahnSort :: DepsGraph -> Set.Set Text -> Sh [FilePath]
203  kahnSort graph allLibs = do
204      let
205          -- Initialize in-degrees to 0
206          initDegrees :: InDegree
207          initDegrees = Map.fromList [(lib, 0) | lib <- Set.toList allLibs]
208  
209          -- Calculate in-degrees: for each lib, increment degree of its deps
210          inDegrees = Map.foldrWithKey countDeps initDegrees graph
211  
212          countDeps _lib deps acc =
213              Set.foldr
214                  ( \dep m ->
215                      if Set.member dep allLibs
216                          then Map.adjust (+ 1) dep m
217                          else m
218                  )
219                  acc
220                  deps
221  
222          -- Initial queue: nodes with in-degree 0
223          initialQueue = [lib | (lib, deg) <- Map.toList inDegrees, deg == 0]
224  
225      go inDegrees (sort initialQueue) []
226    where
227      go _ [] sorted = pure $ reverse $ map toArchive sorted
228      go degrees (current : rest) sorted = do
229          let sorted' = current : sorted
230  
231              -- Find all nodes that depend on current
232              -- and decrement their in-degree
233              (degrees', newReady) =
234                  Map.foldrWithKey
235                      ( \lib deps (d, ready) ->
236                          if Set.member current deps
237                              then
238                                  let newDeg = Map.findWithDefault 0 lib d - 1
239                                      d' = Map.insert lib newDeg d
240                                      ready' =
241                                          if newDeg == 0
242                                              then lib : ready
243                                              else ready
244                                   in (d', ready')
245                              else (d, ready)
246                      )
247                      (degrees, [])
248                      graph
249  
250              -- Add newly ready nodes to queue (sorted for determinism)
251              queue' = sort (rest ++ newReady)
252  
253          go degrees' queue' sorted'
254  
255      toArchive libName = "lib" <> unpack libName <> ".a"
256  
257  -- | Write manifest file for debugging
258  writeManifest :: [FilePath] -> Sh ()
259  writeManifest libs = do
260      cwd <- pwd
261      let content = T.unlines $ ["Libraries combined:"] ++ map pack libs
262      liftIO $ Prelude.writeFile (cwd </> "libabseil.manifest") (unpack content)
263  
264  -- | Create combined archive using ar -M script
265  createCombinedArchive :: String -> [FilePath] -> Sh ()
266  createCombinedArchive ar libs = do
267      -- Get current directory (we need absolute paths for ar)
268      cwd <- pwd
269  
270      -- Write ar script with absolute paths
271      let arScript =
272              T.unlines $
273                  ["CREATE " <> pack cwd <> "/libabseil.a"]
274                      ++ ["ADDLIB " <> pack cwd <> "/" <> pack lib | lib <- libs]
275                      ++ ["SAVE", "END"]
276  
277      -- Write to /tmp since nix store paths may be read-only during fixup
278      let arScriptPath = "/tmp/combine-archive.ar"
279      liftIO $ Prelude.writeFile arScriptPath (unpack arScript)
280  
281      -- Run ar -M with stdin from file
282      _ <- errExit False $ bash $ pack ar <> " -M < " <> pack arScriptPath
283      code <- exitCode
284  
285      when (code /= 0) $ die "failed to combine archives"
286  
287  -- | Generate combined pkg-config file
288  generatePkgConfig :: FilePath -> Set.Set Text -> Sh ()
289  generatePkgConfig outDir privateDeps = do
290      let privateLibs = T.unwords ["-l" <> dep | dep <- sort $ Set.toList privateDeps]
291          content =
292              T.unlines
293                  [ "prefix=" <> pack outDir
294                  , "exec_prefix=${prefix}"
295                  , "libdir=${prefix}/lib"
296                  , "includedir=${prefix}/include"
297                  , ""
298                  , "Name: libabseil"
299                  , "Description: Abseil C++ libraries (libmodern combined archive)"
300                  , "Version: 20250127.1"
301                  , "URL: https://abseil.io/"
302                  , "Libs: -L${libdir} -labseil"
303                  , "Libs.private: -L${libdir} " <> privateLibs
304                  , "Cflags: -I${includedir}"
305                  ]
306  
307      -- Ensure pkgconfig directory exists (we may have deleted all files in it)
308      -- Use absolute path since Prelude.writeFile doesn't respect Shelly's cd
309      cwd <- pwd
310      mkdirP "pkgconfig"
311      liftIO $ Prelude.writeFile (cwd </> "pkgconfig" </> "abseil.pc") (unpack content)
312  
313  -- | Get file size
314  getFileSize :: FilePath -> Sh Integer
315  getFileSize path = do
316      output <- run "stat" ["-c", "%s", pack path]
317      pure $ read $ unpack $ strip output
318  
319  -- | Format file size for display
320  formatSize :: Integer -> Text
321  formatSize bytes
322      | bytes >= 1024 * 1024 = pack (show (bytes `div` (1024 * 1024))) <> "MB"
323      | bytes >= 1024 = pack (show (bytes `div` 1024)) <> "KB"
324      | otherwise = pack (show bytes) <> "B"