{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
module Data.ProtoLens.Setup
( defaultMainGeneratingProtos
, defaultMainGeneratingSpecificProtos
, generatingProtos
, generatingSpecificProtos
, generateProtosWithImports
, generateProtos
) where
import Control.Monad (filterM, forM_, when)
import qualified Data.ByteString as BS
import qualified Data.Map as Map
import Data.Maybe (maybeToList)
import qualified Data.Set as Set
import Distribution.ModuleName (ModuleName)
import qualified Distribution.ModuleName as ModuleName
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import Distribution.PackageDescription
( PackageDescription(..)
, benchmarkBuildInfo
, benchmarkName
, buildInfo
, exeName
, exposedModules
, extraSrcFiles
#if MIN_VERSION_Cabal(2,4,0)
, specVersion
#endif
, libBuildInfo
, otherModules
, testBuildInfo
, testBuildInfo
, testName
)
import Distribution.Simple.BuildPaths (autogenComponentModulesDir)
import Distribution.Simple.InstallDirs (datadir)
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..)
, absoluteInstallDirs
, ComponentName(..)
, ComponentLocalBuildInfo
, componentPackageDeps
, allComponentsInBuildOrder
, componentNameMap
#if MIN_VERSION_Cabal(3,0,0)
, LibraryName(..)
#endif
)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Setup (fromFlag, copyDest, copyVerbosity)
import Distribution.Simple.Utils
( createDirectoryIfMissingVerbose
, installOrdinaryFile
#if MIN_VERSION_Cabal(2,4,0)
#else
, matchFileGlob
#endif
)
#if MIN_VERSION_Cabal(2,4,0)
import Distribution.Simple.Glob (matchDirFileGlob)
#endif
import Distribution.Simple
( defaultMainWithHooks
, simpleUserHooks
, UserHooks(..)
)
import Distribution.Verbosity
( Verbosity
#if MIN_VERSION_Cabal(2,4,0)
, normal
#endif
)
import System.FilePath
( (</>)
, (<.>)
, equalFilePath
, isRelative
, makeRelative
, takeDirectory
, takeExtension
)
import System.Directory
( copyFile
, createDirectoryIfMissing
, doesDirectoryExist
, doesFileExist
, findExecutable
, removeDirectoryRecursive
)
import System.IO (hPutStrLn, stderr)
import System.IO.Temp (withSystemTempDirectory)
import System.Process (callProcess)
import Data.ProtoLens.Compiler.ModuleName (protoModuleName)
defaultMainGeneratingProtos
:: FilePath
-> IO ()
defaultMainGeneratingProtos root
= defaultMainWithHooks $ generatingProtos root simpleUserHooks
defaultMainGeneratingSpecificProtos
:: FilePath
-> (LocalBuildInfo -> IO [FilePath])
-> IO ()
defaultMainGeneratingSpecificProtos root getProtos
= defaultMainWithHooks
$ generatingSpecificProtos root getProtos simpleUserHooks
generatingProtos
:: FilePath
-> UserHooks -> UserHooks
generatingProtos root = generatingSpecificProtos root getProtos
where
getProtos l = do
files <- concat <$> mapM (match $ localPkgDescr l)
(extraSrcFiles $ localPkgDescr l)
pure
. filter (\f -> takeExtension f == ".proto")
. map (makeRelative root)
. filter (isSubdirectoryOf root)
$ files
match :: PackageDescription -> FilePath -> IO [FilePath]
#if MIN_VERSION_Cabal(2,4,0)
match desc f = matchDirFileGlob normal (specVersion desc) "." f
#else
match _ f = matchFileGlob f
#endif
generatingSpecificProtos
:: FilePath
-> (LocalBuildInfo -> IO [FilePath])
-> UserHooks -> UserHooks
generatingSpecificProtos root getProtos hooks = hooks
{ buildHook = \p l h f -> generate l >> buildHook hooks p l h f
, haddockHook = \p l h f -> generate l >> haddockHook hooks p l h f
, replHook = \p l h f args -> generate l >> replHook hooks p l h f args
, postCopy = \a flags pkg lbi -> do
let verb = fromFlag $ copyVerbosity flags
let destDir = datadir (absoluteInstallDirs pkg lbi
$ fromFlag $ copyDest flags)
</> protoLensImportsPrefix
getProtos lbi >>= copyProtosToDataDir verb root destDir
postCopy hooks a flags pkg lbi
}
where
generate l = getProtos l >>= generateSources root l
generateSources :: FilePath
-> LocalBuildInfo
-> [FilePath]
-> IO ()
generateSources root l files = withSystemTempDirectory "protoc-out" $ \tmpDir -> do
importDirs <- filterM doesDirectoryExist
[ InstalledPackageInfo.dataDir info </> protoLensImportsPrefix
| info <- collectDeps l
]
let activeModules = collectActiveModules l
let allModules = Set.fromList . concat . map snd $ activeModules
let usedInComponent f = ModuleName.fromString (protoModuleName f)
`Set.member` allModules
generateProtosWithImports (root : importDirs) tmpDir
$ map (root </>) $ filter usedInComponent files
forM_ activeModules $ \(compBI, mods) -> forM_ mods $ \m -> do
let f = ModuleName.toFilePath m <.> ".hs"
let sourcePath = tmpDir </> f
sourceExists <- doesFileExist sourcePath
when sourceExists $ do
let dest = autogenComponentModulesDir l compBI </> f
copyIfDifferent sourcePath dest
copyIfDifferent :: FilePath -> FilePath -> IO ()
copyIfDifferent sourcePath targetPath = do
targetExists <- doesFileExist targetPath
identical <- do
if not targetExists
then return False
else do
sourceContents <- BS.readFile sourcePath
targetContents <- BS.readFile targetPath
return (sourceContents == targetContents)
when (not identical) $ do
createDirectoryIfMissing True (takeDirectory targetPath)
copyFile sourcePath targetPath
copyProtosToDataDir :: Verbosity
-> FilePath
-> FilePath
-> [FilePath]
-> IO ()
copyProtosToDataDir verb root destDir files = do
exists <- doesDirectoryExist destDir
when exists $ removeDirectoryRecursive destDir
forM_ files $ \f -> do
let srcFile = root </> f
let destFile = destDir </> f
createDirectoryIfMissingVerbose verb True
(takeDirectory destFile)
installOrdinaryFile verb srcFile destFile
protoLensImportsPrefix :: FilePath
protoLensImportsPrefix = "proto-lens-imports"
isSubdirectoryOf :: FilePath -> FilePath -> Bool
isSubdirectoryOf root f
= isRelative f
&& equalFilePath f (root </> makeRelative root f)
generateProtos
:: FilePath
-> FilePath
-> [FilePath]
-> IO ()
generateProtos root = generateProtosWithImports [root]
generateProtosWithImports
:: [FilePath]
-> FilePath
-> [FilePath]
-> IO ()
generateProtosWithImports _ _ [] = return ()
generateProtosWithImports imports output files = do
protoLensProtoc
<- findExecutableOrDie "proto-lens-protoc"
$ "Please file a bug at "
++ "https://github.com/google/proto-lens/issues ."
protoc <- findExecutableOrDie "protoc"
$ "Follow the installation instructions at "
++ "https://google.github.io/proto-lens/installing-protoc.html ."
createDirectoryIfMissing True output
callProcess protoc $
[ "--plugin=protoc-gen-haskell=" ++ protoLensProtoc
, "--haskell_out=" ++ output
]
++ ["--proto_path=" ++ p | p <- imports]
++ files
findExecutableOrDie :: String -> String -> IO FilePath
findExecutableOrDie name debugMsg = do
maybePath <- findExecutable name
case maybePath of
Just path -> return path
Nothing -> do
let sep = "=========="
hPutStrLn stderr sep
hPutStrLn stderr $ "Error: couldn't find the executable " ++ show name
++ " in your $PATH."
++ "\n " ++ debugMsg
hPutStrLn stderr sep
error $ "Missing executable " ++ show name
collectActiveModules
:: LocalBuildInfo -> [(ComponentLocalBuildInfo, [ModuleName])]
collectActiveModules l = map (\(n, c) -> (c, f n)) $ Map.toList $ allComponents l
where
p = localPkgDescr l
#if MIN_VERSION_Cabal(3,0,0)
f (CLibName LMainLibName)
#else
f CLibName
#endif
= maybeToList (library p) >>=
\lib -> exposedModules lib
++ otherModules (libBuildInfo lib)
f (CExeName n) = otherModules . buildInfo $ exes Map.! n
f (CTestName n) = otherModules . testBuildInfo $ tests Map.! n
f (CBenchName n) = otherModules . benchmarkBuildInfo $ benchs Map.! n
f _ = []
exes = Map.fromList [(exeName e, e) | e <- executables p]
tests = Map.fromList [(testName e, e) | e <- testSuites p]
benchs = Map.fromList [(benchmarkName e, e) | e <- benchmarks p]
collectDeps :: LocalBuildInfo -> [InstalledPackageInfo.InstalledPackageInfo]
collectDeps l = do
c <- allComponentsInBuildOrder l
(i,_) <- componentPackageDeps c
Just p <- [PackageIndex.lookupUnitId (installedPkgs l) i]
return p
allComponents :: LocalBuildInfo -> Map.Map ComponentName ComponentLocalBuildInfo
allComponents l = fmap requireOne $ componentNameMap l
where
requireOne [x] = x
requireOne xs = error $ "Data.ProtoLens.Setup.allComponents: expected one "
++ "component per name, got " ++ show xs