{-# 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