    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE RecordWildCards #-}

    module GHC.Toolchain.Tools.Ar (Ar(..), findAr) where

    import Control.Monad
    import System.FilePath
    import Data.List (isInfixOf)

    import GHC.Toolchain.Prelude
    import GHC.Toolchain.Utils
    import GHC.Toolchain.Program

    data Ar = Ar { Ar -> Program
    arMkArchive :: Program
                 , Ar -> Bool
    arIsGnu :: Bool
                 , Ar -> Bool
    arSupportsAtFile :: Bool
                 , Ar -> Bool
    arSupportsDashL :: Bool
                 , Ar -> Bool
    arNeedsRanlib :: Bool
                 }
        deriving (ReadPrec [Ar]
    ReadPrec Ar
    Int -> ReadS Ar
    ReadS [Ar]
    (Int -> ReadS Ar)
    -> ReadS [Ar] -> ReadPrec Ar -> ReadPrec [Ar] -> Read Ar
    forall a.
    (Int -> ReadS a)
    -> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
    $creadsPrec :: Int -> ReadS Ar
    readsPrec :: Int -> ReadS Ar
    $creadList :: ReadS [Ar]
    readList :: ReadS [Ar]
    $creadPrec :: ReadPrec Ar
    readPrec :: ReadPrec Ar
    $creadListPrec :: ReadPrec [Ar]
    readListPrec :: ReadPrec [Ar]
    Read, Ar -> Ar -> Bool
    (Ar -> Ar -> Bool) -> (Ar -> Ar -> Bool) -> Eq Ar
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: Ar -> Ar -> Bool
    == :: Ar -> Ar -> Bool
    $c/= :: Ar -> Ar -> Bool
    /= :: Ar -> Ar -> Bool
    Eq, Eq Ar
    Eq Ar =>
    (Ar -> Ar -> Ordering)
    -> (Ar -> Ar -> Bool)
    -> (Ar -> Ar -> Bool)
    -> (Ar -> Ar -> Bool)
    -> (Ar -> Ar -> Bool)
    -> (Ar -> Ar -> Ar)
    -> (Ar -> Ar -> Ar)
    -> Ord Ar
    Ar -> Ar -> Bool
    Ar -> Ar -> Ordering
    Ar -> Ar -> Ar
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: Ar -> Ar -> Ordering
    compare :: Ar -> Ar -> Ordering
    $c< :: Ar -> Ar -> Bool
    < :: Ar -> Ar -> Bool
    $c<= :: Ar -> Ar -> Bool
    <= :: Ar -> Ar -> Bool
    $c> :: Ar -> Ar -> Bool
    > :: Ar -> Ar -> Bool
    $c>= :: Ar -> Ar -> Bool
    >= :: Ar -> Ar -> Bool
    $cmax :: Ar -> Ar -> Ar
    max :: Ar -> Ar -> Ar
    $cmin :: Ar -> Ar -> Ar
    min :: Ar -> Ar -> Ar
    Ord)

    -- These instances are more suitable for diffing
    instance Show Ar where
      show :: Ar -> String
    show Ar{Bool
    Program
    arMkArchive :: Ar -> Program
    arIsGnu :: Ar -> Bool
    arSupportsAtFile :: Ar -> Bool
    arSupportsDashL :: Ar -> Bool
    arNeedsRanlib :: Ar -> Bool
    arMkArchive :: Program
    arIsGnu :: Bool
    arSupportsAtFile :: Bool
    arSupportsDashL :: Bool
    arNeedsRanlib :: Bool
    ..} = [String] -> String
    unlines
        [ String
    "Ar"
        , String
    "{ arMkArchive = " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Program -> String
    forall a. Show a => a -> String
    show Program
    arMkArchive
        , String
    ", arIsGnu = " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Bool -> String
    forall a. Show a => a -> String
    show Bool
    arIsGnu
        , String
    ", arSupportsAtFile = " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Bool -> String
    forall a. Show a => a -> String
    show Bool
    arSupportsAtFile
        , String
    ", arSupportsDashL = " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Bool -> String
    forall a. Show a => a -> String
    show Bool
    arSupportsDashL
        , String
    ", arNeedsRanlib = " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ Bool -> String
    forall a. Show a => a -> String
    show Bool
    arNeedsRanlib
        , String
    "}"
        ]

    findAr :: Maybe String -- ^ Vendor name from the target triple, if specified
           -> ProgOpt -> M Ar
    findAr :: Maybe String -> ProgOpt -> M Ar
    findAr Maybe String
    vendor ProgOpt
    progOpt = String -> M Ar -> M Ar
    forall a. Show a => String -> M a -> M a
    checking String
    "for 'ar'" (M Ar -> M Ar) -> M Ar -> M Ar
    forall a b. (a -> b) -> a -> b
    $ do
        bareAr <- String -> ProgOpt -> [String] -> M Program
    findProgram String
    "ar archiver" ProgOpt
    progOpt [String
    "ar", String
    "llvm-ar"]
        arIsGnu <- ("GNU" `isInfixOf`) <$> readProgramStdout bareAr ["--version"]

        -- Figure out how to invoke ar to create archives...
        mkArchive <- checking "for how to make archives"
            $ makeArchiveProgram arIsGnu bareAr

        arSupportsAtFile <- checkArSupportsAtFile bareAr mkArchive <|> return False
        arSupportsDashL <- checkArSupportsDashL bareAr <|> return False
        let arNeedsRanlib
              | Bool
    arIsGnu = Bool
    False
              -- TODO: It'd be better not to handle Apple specifically here?
              -- It's quite tedious to check for Apple's crazy timestamps in
              -- .a files, so we hardcode it.
              | Maybe String
    vendor Maybe String -> Maybe String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String -> Maybe String
    forall a. a -> Maybe a
    Just String
    "apple" = Bool
    True
              | String
    mode:[String]
    _ <- Program -> [String]
    prgFlags Program
    mkArchive
              , Char
    's' Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    mode = Bool
    False
              | Bool
    otherwise = Bool
    True

        return $ Ar { arMkArchive = mkArchive
                    , arIsGnu
                    , arSupportsAtFile
                    , arSupportsDashL
                    , arNeedsRanlib
                    }

    makeArchiveProgram :: Bool  -- ^ is GNU ar?
                       -> Program -> M Program
    makeArchiveProgram :: Bool -> Program -> M Program
    makeArchiveProgram Bool
    isGnuAr Program
    ar
      | Bool
    isGnuAr =
        -- GNU ar needs special treatment: it appears to have problems with
        -- object files with the same name if you use the 's' modifier, but
        -- simple 'ar q' works fine, and doesn't need a separate ranlib.
        Program -> M Program
    check (Lens Program [String] -> [String] -> Program -> Program
    forall a b. Lens a b -> b -> a -> a
    set Lens Program [String]
    _prgFlags [String
    "q"] Program
    ar)
      | Bool
    otherwise =
        String -> [M Program] -> M Program
    forall b. String -> [M b] -> M b
    oneOf String
    err
          ((String -> M Program) -> [String] -> [M Program]
    forall a b. (a -> b) -> [a] -> [b]
    map (\String
    flag -> Program -> M Program
    check (Program -> M Program) -> Program -> M Program
    forall a b. (a -> b) -> a -> b
    $ Lens Program [String] -> [String] -> Program -> Program
    forall a b. Lens a b -> b -> a -> a
    set Lens Program [String]
    _prgFlags [String
    flag] Program
    ar)
               [String
    "qclsZ", String
    "qcls", String
    "qcs", String
    "qcl", String
    "qc"])
      where
        check :: Program -> M Program
    check Program
    ar' = Program
    ar' Program -> M () -> M Program
    forall a b. a -> M b -> M a
    forall (f :: * -> *) a b. Functor f => a -> f b -> f a
    <$ Program -> M ()
    checkArWorks Program
    ar'
        err :: String
    err = String
    "Failed to figure out how to make archives"

    checkArWorks :: Program -> M ()
    checkArWorks :: Program -> M ()
    checkArWorks Program
    prog = String -> M () -> M ()
    forall a. Show a => String -> M a -> M a
    checking String
    "that ar works" (M () -> M ()) -> M () -> M ()
    forall a b. (a -> b) -> a -> b
    $ (String -> M ()) -> M ()
    forall a. (String -> M a) -> M a
    withTempDir ((String -> M ()) -> M ()) -> (String -> M ()) -> M ()
    forall a b. (a -> b) -> a -> b
    $ \String
    dir -> do
        let dummy :: String
    dummy = String
    dir String -> ShowS
    </> String
    "conftest.dummy"
            archive :: String
    archive = String
    dir String -> ShowS
    </> String
    "conftest.a"
        String -> M ()
    createFile String
    dummy
        Program -> [String] -> M ()
    callProgram Program
    prog [String
    archive, String
    dummy]
        -- Check that result was created as some llvm-ar versions exit with code
        -- zero even if they fail to parse the command-line.
        String -> String -> M ()
    expectFileExists String
    archive String
    "ar didn't create an archive"

    checkArSupportsDashL :: Program -> M Bool
    checkArSupportsDashL :: Program -> M Bool
    checkArSupportsDashL Program
    bareAr = String -> M Bool -> M Bool
    forall a. Show a => String -> M a -> M a
    checking String
    "that ar supports -L" (M Bool -> M Bool) -> M Bool -> M Bool
    forall a b. (a -> b) -> a -> b
    $ (String -> M Bool) -> M Bool
    forall a. (String -> M a) -> M a
    withTempDir ((String -> M Bool) -> M Bool) -> (String -> M Bool) -> M Bool
    forall a b. (a -> b) -> a -> b
    $ \String
    dir -> do
        let file :: ShowS
    file String
    ext = String
    dir String -> ShowS
    </> String
    "conftest" String -> ShowS
    <.> String
    ext
            archive1 :: String
    archive1 = String
    dir String -> ShowS
    </> String
    "conftest-a.a"
            archive2 :: String
    archive2 = String
    dir String -> ShowS
    </> String
    "conftest-b.a"
            merged :: String
    merged   = String
    dir String -> ShowS
    </> String
    "conftest.a"
        (String -> M ()) -> [String] -> M ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    (a -> m b) -> t a -> m ()
    mapM_ (String -> M ()
    createFile (String -> M ()) -> ShowS -> String -> M ()
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ShowS
    file) [String
    "file", String
    "a0", String
    "a1", String
    "b0", String
    "b1"]
        -- Build two archives, merge them, and check that the
        -- result contains the original files rather than the two
        -- archives.
        Program -> [String] -> M ()
    callProgram Program
    bareAr [String
    "qc", String
    archive1, ShowS
    file String
    "a0", ShowS
    file String
    "a1"]
        Program -> [String] -> M ()
    callProgram Program
    bareAr [String
    "qc", String
    archive2, ShowS
    file String
    "b0", ShowS
    file String
    "b1"]
        String -> [M Bool] -> M Bool
    forall b. String -> [M b] -> M b
    oneOf String
    "trying -L"
            [ do Program -> [String] -> M ()
    callProgram Program
    bareAr [String
    "qcL", String
    merged, String
    archive1, String
    archive2]
                 contents <- Program -> [String] -> M String
    readProgramStdout Program
    bareAr [String
    "t", String
    merged]
                 return $ "conftest.a1" `isInfixOf` contents
            , Bool -> M Bool
    forall a. a -> M a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Bool
    False
            ]

    checkArSupportsAtFile :: Program -> Program -> M Bool
    checkArSupportsAtFile :: Program -> Program -> M Bool
    checkArSupportsAtFile Program
    bareAr Program
    mkArchive = String -> M Bool -> M Bool
    forall a. Show a => String -> M a -> M a
    checking String
    "that ar supports @-files" (M Bool -> M Bool) -> M Bool -> M Bool
    forall a b. (a -> b) -> a -> b
    $ (String -> M Bool) -> M Bool
    forall a. (String -> M a) -> M a
    withTempDir ((String -> M Bool) -> M Bool) -> (String -> M Bool) -> M Bool
    forall a b. (a -> b) -> a -> b
    $ \String
    dir -> do
        let conftest :: String
    conftest = String
    "conftest.file"
            f :: String
    f = String
    dir String -> ShowS
    </> String
    conftest
            atfile :: String
    atfile = String
    dir String -> ShowS
    </> String
    "conftest.atfile"
            archive :: String
    archive = String
    dir String -> ShowS
    </> String
    "conftest.a"
            objs :: [String]
    objs = Int -> String -> [String]
    forall a. Int -> a -> [a]
    replicate Int
    2 String
    f
        String -> M ()
    createFile String
    f
        String -> String -> M ()
    writeFile String
    atfile ([String] -> String
    unlines [String]
    objs)
        Program -> [String] -> M ()
    callProgram Program
    mkArchive [String
    archive, String
    "@" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    atfile]
        contents <- Program -> [String] -> M String
    readProgramStdout Program
    bareAr [String
    "t", String
    archive]
        -- Careful: The files output by `ar t` use relative paths, so we can't
        -- compare against `objs`
        if lines contents == replicate 2 conftest
          then return True
          else logDebug "Contents didn't match" >> return False