buildwrapper-0.8.8: src/Language/Haskell/BuildWrapper/Cabal.hs
{-# LANGUAGE PatternGuards,ScopedTypeVariables,CPP #-}
-- |
-- Module : Language.Haskell.BuildWrapper.Cabal
-- Copyright : (c) JP Moresmau 2011
-- License : BSD3
--
-- Maintainer : jpmoresmau@gmail.com
-- Stability : beta
-- Portability : portable
--
-- Cabal operations: configure, build, retrieve information from build info, parse errors and warnings
module Language.Haskell.BuildWrapper.Cabal where
import Language.Haskell.BuildWrapper.Base
import Language.Haskell.BuildWrapper.Packages
import Control.Monad.State
import Data.Char
import Data.Ord (comparing)
import Data.List
import Data.Maybe
import qualified Data.Map as DM
import qualified Data.Set as DS
import Exception (ghandle)
import Distribution.ModuleName
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Parse as PD
import Distribution.Package
import Distribution.InstalledPackageInfo as IPI
import Distribution.Version
import Distribution.Text (display,simpleParse)
import qualified Distribution.Simple.Configure as DSC
import qualified Distribution.Verbosity as V
import Text.Regex.TDFA
import System.Directory
import System.Exit
import System.FilePath
import System.Process
import Data.Functor.Identity (runIdentity)
import qualified Distribution.Client.Dynamic as DCD
-- | get the version of the cabal library
getCabalLibraryVersion :: String
getCabalLibraryVersion = VERSION_Cabal
-- | get all files to copy to temp folder
getFilesToCopy :: BuildWrapper(OpResult [FilePath])
getFilesToCopy =do
(mfps,bwns)<-withCabal Source getAllFiles
return $ case mfps of
Just fps->(nub $ concatMap (map snd . cbiModulePaths) fps,bwns)
Nothing ->([],bwns);
-- | get cabal verbose level
cabalV :: BuildWrapper V.Verbosity
cabalV =do
v<-gets verbosity
return $ toCabalV v
where
toCabalV Silent =V.silent
toCabalV Normal =V.normal
toCabalV Verbose =V.verbose
toCabalV Deafening =V.deafening
-- | run cabal build
cabalBuild :: Bool -- ^ do we want output (True) or just compilation without linking?
-> WhichCabal -- ^ use original cabal or temp cabal file
-> BuildWrapper (OpResult BuildResult)
cabalBuild = cabalBuild' True
-- | run cabal build
cabalBuild' :: Bool -- ^ can we rerun configure again
-> Bool -- ^ do we want output (True) or just compilation without linking?
-> WhichCabal -- ^ use original cabal or temp cabal file
-> BuildWrapper (OpResult BuildResult)
cabalBuild' reRun output srcOrTgt= do
dist_dir<-getDistDir
(mr,n)<-withCabal srcOrTgt (\_->do
cf<-getCabalFile srcOrTgt
cp<-gets cabalPath
v<-cabalV
logC<-gets logCabalArgs
copts<-gets cabalOpts
let args=[
"build",
"--verbose=" ++ show (fromEnum v),
"--builddir="++dist_dir
] ++ (if output
then []
else ["--ghc-option=-c"])
++ copts
liftIO $ do
when logC (putStrLn $ showCommandForUser cp args)
cd<-getCurrentDirectory
setCurrentDirectory (takeDirectory cf)
(ex,out,err)<-readProcessWithExitCode cp args ""
putStrLn err
if isInfixOf "cannot satisfy -package-id" err || isInfixOf "re-run the 'configure'" err
then
return Nothing
else
do
let fps=mapMaybe getBuiltPath (lines out)
let ret=parseBuildMessages (takeFileName cf) (takeFileName cp) dist_dir err
setCurrentDirectory cd
return $ Just (ex==ExitSuccess,ret,fps)
)
case mr of
Nothing -> return (BuildResult False [],n)
Just Nothing->if reRun
then do
let setup_config = DSC.localBuildInfoFile dist_dir
liftIO $ removeFile setup_config
cabalBuild' False output srcOrTgt
else return (BuildResult False [],n)
Just (Just (r,n2,fps)) -> return (BuildResult r fps, n ++ n2)
-- | the file where we save the targets
targetFile :: String
targetFile="dynamic_targets"
-- | run cabal configure
cabalConfigure :: WhichCabal -- ^ use original cabal or temp cabal file
-> BuildWrapper (OpResult (Maybe [DCD.Target])) -- ^ return the build info on success, or Nothing on failure
cabalConfigure srcOrTgt= do
cf<-getCabalFile srcOrTgt
cp<-gets cabalPath
okCF<-liftIO $ doesFileExist cf
if okCF
then
do
v<-cabalV
dist_dir<-getDistDir
uf<-gets cabalFlags
logC<-gets logCabalArgs
copts<-gets cabalOpts
let sb = (takeDirectory cf) </> "cabal.sandbox.config"
hasSb <- liftIO $ doesFileExist sb
let args=[
"configure",
"--verbose=" ++ show (fromEnum v),
"--enable-tests",
"--enable-benchmarks",
"--builddir="++dist_dir
]
++ (if null uf then [] else ["--flags="++uf])
++ copts
++ if hasSb then [] else ["--user"]
liftIO $ do
when logC (putStrLn $ showCommandForUser cp args)
cd<-getCurrentDirectory
setCurrentDirectory (takeDirectory cf)
(ex,_,err)<-readProcessWithExitCode cp args ""
putStrLn err
let msgs=parseCabalMessages (takeFileName cf) (takeFileName cp) err -- ++ (parseCabalMessages (takeFileName cf) out)
ret<-case ex of
ExitSuccess -> if any isBWNoteError msgs
then return (Nothing,msgs)
else do
let mghcp=fmap (tail . dropWhile (/= '=')) $ listToMaybe $ filter ("--with-ghc=" `isPrefixOf`) copts
--lbi<-DSC.getPersistBuildConfig dist_dir
let setup_config = DSC.localBuildInfoFile dist_dir
tgs <- DCD.runQuery (DCD.on DCD.localPkgDesc DCD.targets) setup_config
tgs'<- setOptions dist_dir mghcp tgs
let tgsF=dist_dir </> targetFile
Prelude.writeFile tgsF $ show tgs'
return (Just tgs',msgs)
ExitFailure ec -> return $ if null msgs
then (Nothing,[BWNote BWError ("Cabal configure returned error code " ++ show ec) (mkEmptySpan cf 1 1)])
else (Nothing, msgs)
setCurrentDirectory cd
return ret
else do
let err="Cabal file"++ cf ++" does not exist"
liftIO $ putStrLn err
return (Nothing,[BWNote BWError err (mkEmptySpan cf 0 1)])
-- | get the full path to the cabal file
getCabalFile :: WhichCabal -- ^ use original cabal or temp cabal file
-> BuildWrapper FilePath
getCabalFile Source= gets cabalFile
getCabalFile Target= fmap takeFileName (gets cabalFile)
>>=getTargetPath
-- | get package name from cabal file
getPackageName :: BuildWrapper String
getPackageName = do
cf<-gets cabalFile
gpd<-liftIO $ PD.readPackageDescription V.silent cf
return $ display $ packageId $ PD.packageDescription gpd
-- | get Cabal build info, running configure if needed
cabalInit :: WhichCabal -- ^ use original cabal or temp cabal file
-> BuildWrapper (OpResult (Maybe [DCD.Target]))
cabalInit srcOrTgt= do
cabal_file<-getCabalFile srcOrTgt
dist_dir<-getDistDir
-- let setup_config = DSC.localBuildInfoFile dist_dir
let tgtF=dist_dir </> targetFile
conf'd <- liftIO $ doesFileExist tgtF
if not conf'd
then do
liftIO $ putStrLn "configuring because setup_config not present"
cabalConfigure srcOrTgt
else do
cabal_time <- liftIO $ getModificationTime cabal_file
conf_time <- liftIO $ getModificationTime tgtF
if cabal_time > conf_time
then do
liftIO $ putStrLn "configuring because setup_config too old"
cabalConfigure srcOrTgt
else do
tgs <-liftM tryReadList $ liftIO $ Prelude.readFile tgtF
-- tgs <- liftIO $ DCD.runQuery (DCD.on DCD.localPkgDesc DCD.targets) setup_config
--mb_lbi <- liftIO $ DSC.maybeGetPersistBuildConfig dist_dir
case tgs of
[] -> do
liftIO $ putStrLn "configuring because persist build config not present"
cabalConfigure srcOrTgt
_ -> return (Just tgs, [])
-- | run a action with the cabal build info
withCabal :: WhichCabal -- ^ use original cabal or temp cabal file
-> ([DCD.Target] -> BuildWrapper a) -- ^ action to run if we get a build info
-> BuildWrapper (OpResult (Maybe a)) -- ^ the result of the action, or Nothing if we could get Cabal info
withCabal srcOrTgt f=do
(mlbi,notes)<-cabalInit srcOrTgt
case mlbi of
Nothing-> return (Nothing, notes)
Just lbi ->do
r<-f lbi
return (Just r, notes)
-- | parse cabal error messages and transform them in notre
parseCabalMessages :: FilePath -- ^ cabal file
-> FilePath -- ^ path to cabal executable
-> String -- ^ error output
-> [BWNote]
parseCabalMessages cf cabalExe s=let
(m,ls)=foldl parseCabalLine (Nothing,[]) $ lines s
in nub $ case m of
Nothing -> ls
Just (bwn,msgs)->ls++[makeNote bwn msgs]
where
parseCabalLine :: (Maybe (BWNote,[String]),[BWNote]) -> String ->(Maybe (BWNote,[String]),[BWNote])
parseCabalLine (currentNote,ls) l
| "Error:" `isPrefixOf` l=(Just (BWNote BWError "" (mkEmptySpan cf 1 1),[dropWhile isSpace $ drop 6 l]),addCurrent currentNote ls)
| "Warning:" `isPrefixOf` l=let
msg=(dropWhile isSpace $ drop 8 l)
msg2=if cf `isPrefixOf` msg
then dropWhile isSpace $ drop (length cf + 1) msg
else msg
in (Just (BWNote BWWarning "" (mkEmptySpan cf (extractLine msg2) 1),[msg2]),addCurrent currentNote ls)
| Just (bw,n)<- cabalErrorLine cf cabalExe l (not (any isBWNoteError ls))=(Just (bw,n),addCurrent currentNote ls)
| Just (jcn,msgs)<-currentNote=
if not $ null l
then (Just (jcn,l:msgs),ls)
else (Nothing,ls++[makeNote jcn msgs])
| otherwise =(Nothing,ls)
extractLine el=let
(_,_,_,ls)=el =~ "\\(line ([0-9]*)\\)" :: (String,String,String,[String])
in if null ls
then 1
else readInt (head ls) 1
-- | get the setup exe file name
setupExe :: FilePath -- ^ path to cabal executable
-> FilePath
setupExe cabalExe=addExtension "setup" $ takeExtension cabalExe
-- | get cabal executable from cabal-dev
fromCabalDevExe :: FilePath -- ^ path to cabal executable
-> FilePath
fromCabalDevExe cabalExe | "cabal-dev"<-dropExtension cabalExe=addExtension "cabal" $ takeExtension cabalExe
fromCabalDevExe cabalExe=cabalExe
-- | drop all potential prefixes from the given string
dropPrefixes :: [String] -> String -> Maybe String
dropPrefixes prfxs s2=foldr (stripPrefixIfNeeded s2) Nothing prfxs
-- | stop prefix if the given string starts by it
stripPrefixIfNeeded :: String -> String -> Maybe String -> Maybe String
stripPrefixIfNeeded _ _ j@(Just _)=j
stripPrefixIfNeeded s3 prfx _=stripPrefix prfx s3
-- | add a note with a potential additional message
addCurrent :: Maybe (BWNote, [String]) -> [BWNote] -> [BWNote]
addCurrent Nothing xs=xs
addCurrent (Just (n,msgs)) xs=xs++[makeNote n msgs]
-- | parse a Cabal error line
cabalErrorLine :: FilePath -- ^ cabal file
-> FilePath -- ^ path to cabal executable
-> String -- ^ line
-> Bool -- ^ first error?
-> Maybe (BWNote,[String])
cabalErrorLine cf cabalExe l fstErr
| Just s4 <- dropPrefixes [cabalExe,setupExe cabalExe,fromCabalDevExe cabalExe] l=
let
s2=dropWhile isSpace $ drop 1 s4 -- drop 1 for ":" that follows file name
in if "At least the following" `isPrefixOf` s2
then Just (BWNote BWError "" (mkEmptySpan cf 1 1), [s2])
else
let
(loc1,_)=span (/= '\'') s2
(loc2,rest2)=span (/= ':') s2
(loc,rest)=if length loc1<length loc2 then (s2,"") else (loc2,rest2)
(realloc,line,msg)=if null rest || ":"==rest
then (cf,"1",s2)
else
let tr=tail rest
(line',msg')=span (/= ':') tr
in if null msg'
then (loc,"1",tr)
else if readInt line' (-1)==(-1)
then (cf,"1",s2)
else (loc,line',tail msg')
in Just (BWNote BWError "" (mkEmptySpan realloc (readInt line 1) 1),[msg])
| not fstErr=cabalErrorLine cf cabalExe (cabalExe ++ ":" ++ l) False
| otherwise=Nothing
-- | parse messages from build
parseBuildMessages :: FilePath -- ^ cabal file
-> FilePath -- ^ path to cabal executable
-> FilePath -- ^ the dist directory
-> String -- ^ the build output
-> [BWNote]
parseBuildMessages cf cabalExe distDir s=let
(m,ls)=foldl parseBuildLine (Nothing,[]) $ lines s
in (nub $
case m of
Nothing -> ls
Just (bwn, msgs) -> ls ++ [makeNote bwn msgs])
where
parseBuildLine :: (Maybe (BWNote,[String]),[BWNote]) -> String ->(Maybe (BWNote,[String]),[BWNote])
parseBuildLine (currentNote,ls) l
| Just (jcn,msgs)<-currentNote=
if not (null l) && ((' ' == head l) || (')' == last l))
then (Just (jcn,l:msgs),ls)
else (Nothing,ls++[makeNote jcn msgs])
-- | Just fp<-getBuiltPath l=(currentNote,ls,fp:fps)
| Just n<-extractLocation l=(Just (n,[bwnTitle n]),ls)
| Just (bw,n)<- cabalErrorLine cf cabalExe l (not (any isBWNoteError ls))=(Just (bw,n),addCurrent currentNote ls)
| otherwise =(Nothing,ls)
extractLocation el=let
(_,_,aft,ls)=el =~ "(.+):([0-9]+):([0-9]+):" :: (String,String,String,[String])
in case ls of
(loc:line:col:[])-> Just $ BWNote BWError (dropWhile isSpace aft) (mkEmptySpan loc (readInt line 1) (readInt col 1))
_ -> let
(_,_,_,ls2)=el =~ "(.+)(\\(.+\\)):(.+):(.+):" :: (String,String,String,[String])
in case ls2 of
(loc2:ext1:_:_:[])-> Just $ BWNote BWError (drop (length loc2 + length ext1 + 1) el) (mkEmptySpan (validLoc cf distDir loc2) 1 1)
_ -> Nothing
-- | get a valid path
validLoc :: FilePath -- ^ the cabal file
-> FilePath -- ^ the dist dir
-> FilePath
-> FilePath
validLoc cf distDir f=if distDir `isPrefixOf` f
then cf
else f
-- | read an integer and return a default value if not readable
readInt :: String -> Int -> Int
readInt s def=let parses=reads s ::[(Int,String)]
in if null parses
then def
else fst $ head parses
-- | read a list and return the empty list if not readable
tryReadList :: Read a => String -> [a]
tryReadList s=let parses=reads s
in if null parses
then []
else fst $ head parses
-- | add a message to the note
makeNote :: BWNote -- ^ original note
-> [String] -- ^ message lines
->BWNote
makeNote bwn msgs=let
title=dropWhile isSpace $ unlines $ reverse msgs
in if "Warning:" `isPrefixOf` title
then bwn{bwnTitle=dropWhile isSpace $ drop 8 title,bwnStatus=BWWarning}
else bwn{bwnTitle=title}
-- | get the path of a file getting compiled
getBuiltPath :: String -- ^ the message line
-> Maybe FilePath -- ^ the path if we could parse it
getBuiltPath line=let
(_,_,_,ls)=line =~ "\\[[0-9]+ of [0-9]+\\] Compiling .+\\( (.+), (.+)\\)" :: (String,String,String,[String])
in case ls of
(src:_:[])->Just src
_ -> Nothing
-- | the cabal build info for a specific component
data CabalBuildInfo=CabalBuildInfo {
cbiTarget :: DCD.Target -- ^ the target
,cbiBuildFolder::FilePath -- ^ the folder to build that component into
,cbiIsLibrary::Bool -- ^ is the component the library
,cbiModulePaths::[(Maybe ModuleName,FilePath)] -- ^ the module name and corresponding source file for each contained Haskell module
,cbiComponent::CabalComponent -- ^ the component handle
}
deriving (Read,Show)
-- | canonicalize the paths in the build info
canonicalizeBuildInfo :: CabalBuildInfo -> BuildWrapper CabalBuildInfo
canonicalizeBuildInfo =onModulePathsM (mapM (\(m,path)->do
pathC<-canonicalizeFullPath path
return (m,pathC)))
-- | apply a function on the build info modules and paths, in a monad
onModulePathsM :: (Monad a)
=>([(Maybe ModuleName,FilePath)] -> a [(Maybe ModuleName,FilePath)]) -- ^ the function to apply
-> CabalBuildInfo -- ^ the original build info
-> a CabalBuildInfo -- ^ the result
onModulePathsM f cbi=do
let ls=cbiModulePaths cbi
fls<-f ls
return cbi{cbiModulePaths=fls}
-- | apply a function on the build info modules and paths
onModulePaths :: ([(Maybe ModuleName,FilePath)] -> [(Maybe ModuleName,FilePath)]) -- ^ the function to apply
-> CabalBuildInfo -- ^ the original build info
-> CabalBuildInfo -- ^ the result
onModulePaths f =runIdentity . onModulePathsM (return . f)
-- | get the build info for a given source file
-- if a source file is in several component, get the first one
getBuildInfo :: FilePath -- ^ the source file
-> Maybe String -- ^ the cabal component to use, or Nothing if not specified
-> BuildWrapper (OpResult (Maybe ([DCD.Target],CabalBuildInfo)))
getBuildInfo fp mccn=
case mccn of
Nothing -> do
(mmr,bwns)<-go getReferencedFiles Nothing
case mmr of
Just (Just a)->return (Just a, bwns)
_ -> do
(mmr2,bwns2)<-go getAllFiles Nothing -- no component found for the asked name
return $ case mmr2 of
Just (Just a)-> (Just a,bwns2)
_-> (Nothing,bwns)
_ -> do
(mmr2,bwns2)<-go getAllFiles mccn
return $ case mmr2 of
Just (Just a)-> (Just a,bwns2)
_-> (Nothing,bwns2)
where
go f mccn2=withCabal Source (\lbi->do
fps<-f lbi
fpsC<-mapM canonicalizeBuildInfo fps
ok<-getComp mccn2 fpsC
return $ if null ok
then Nothing
else Just (lbi, head ok))
getComp :: Maybe String -> [CabalBuildInfo] -> BuildWrapper [CabalBuildInfo]
getComp Nothing fps=do
fpC<-canonicalizeFullPath fp
fpsC<-mapM canonicalizeBuildInfo fps
return $ filter (not . null . cbiModulePaths) $
map (onModulePaths (filter (\(_,b)->equalFilePath fpC b))) fpsC
getComp (Just ccn) fps=
return $ filter (\cbi->cabalComponentName (cbiComponent cbi) == ccn) fps
-- | set the GHC options on targets
setOptions
:: FilePath -- ^ dist directory
-> Maybe FilePath -- ^ path to GHC if explicitely specified
-> [DCD.Target] -- ^ targets to set options onto
-> IO [DCD.Target]
setOptions dist_dir mghcp tgs=do
let setup_config = DSC.localBuildInfoFile dist_dir
cv<-DCD.getCabalVersion setup_config
let optStr1 | cv>=Version [1,19,0] [] ="(compiler,_ ,_)<-configure normal ("++ (show mghcp) ++ ") Nothing defaultProgramDb"
| otherwise =""
let optStr | cv>=Version [1,19,0] [] ="renderGhcOptions compiler $ componentGhcOptions V.silent lbi{withOptimization=NoOptimisation} b clbi fp"
| cv>=Version [1,15,0] [] ="renderGhcOptions ((fst $ head $ readP_to_S parseVersion \""++VERSION_ghc++"\") :: Version) $ componentGhcOptions V.silent lbi{withOptimization=NoOptimisation} b clbi fp"
| otherwise ="ghcOptions lbi{withOptimization=NoOptimisation} b clbi fp"
let withStr=if cv>=Version [1,17,0] []
then "withAllComponentsInBuildOrder"
else "withComponentsLBI"
let bd=dist_dir </> "build"
let fmp=foldr (\t m->DM.insert (DCD.targetName t) (getBuildDir bd t) m) DM.empty tgs
let src= unlines [
"module DynamicCabalQuery where"
,"import Distribution.PackageDescription"
,"import Distribution.Simple.LocalBuildInfo"
,"import Data.IORef"
,"import qualified Data.Map as DM"
,"import qualified Distribution.Verbosity as V"
,"import Data.Version (parseVersion)"
,"import Text.ParserCombinators.ReadP(readP_to_S)"
,"import Distribution.Simple.Program.GHC"
,"import Distribution.Simple.GHC"
,"import Distribution.Version"
,"import Control.Monad"
,"import Distribution.Simple.Compiler(OptimisationLevel(..))"
,"import Distribution.Simple.Program.Db(defaultProgramDb)"
,"import Distribution.Verbosity(normal)"
,"import Data.Maybe"
,""
,"result :: IO (DM.Map String [String])"
,"result=do"
,"lbi<-liftM (read . Prelude.unlines . drop 1 . lines) $ Prelude.readFile "++show setup_config
,"let pkg=localPkgDescr lbi"
,"r<-newIORef DM.empty"
,"let fmp=DM."++ show fmp
, optStr1
,withStr++" pkg lbi (\\c clbi->do"
," let b=componentBuildInfo c"
," let n=foldComponent (const \"\") exeName testName benchmarkName c"
," let fp=fromJust $ DM.lookup n fmp"
," let opts=" ++ optStr
," modifyIORef r (DM.insert n opts)"
," return ()"
," )"
,"readIORef r" ]
-- print src
m::DM.Map String [String]<-liftIO $ DCD.runRawQuery src setup_config
return $ map (set m)tgs
where
set mOpts t=case DM.lookup (DCD.targetName t) mOpts of
Just opts->t{DCD.ghcOptions=opts}
_->t
-- | get GHC options for a file
fileGhcOptions :: CabalBuildInfo -- ^ the cabal info
-> BuildWrapper [String] -- ^ the module name and the options to pass GHC
fileGhcOptions (CabalBuildInfo tgt _ isLib _ _)=do
dist_dir<-getDistDir
let inplace=dist_dir </> "package.conf.inplace"
inplaceExist<-liftIO $ doesFileExist inplace
n<-getPackageName
let pkg
| isLib =
["-package-name",n]
#if __GLASGOW_HASKELL__ < 706
| inplaceExist = ["-package-conf", inplace]
#else
| inplaceExist = ["-package-db", inplace]
#endif
| otherwise = []
return (pkg ++ DCD.ghcOptions tgt)
-- | get CPP options for a file
fileCppOptions :: CabalBuildInfo -- ^ the cabal info
-> [String] -- ^ the list of CPP options
fileCppOptions cbi=DCD.cppOptions $ cbiTarget cbi
-- | get the cabal extensions
cabalExtensions :: CabalBuildInfo -- ^ the cabal info
-> (ModuleName,[String]) -- ^ the module name and cabal extensions
cabalExtensions CabalBuildInfo{cbiTarget=bi,cbiModulePaths=ls}=(fromJust $ fst $ head ls,DCD.extensions bi)
-- | get the source directory from a build info
getSourceDirs :: DCD.Target -- ^ the build info
-> [FilePath] -- ^ the source paths, guaranteed non null
getSourceDirs bi=let
hsd=DCD.sourceDirs bi
in case hsd of
[] -> ["."]
_ -> hsd
-- | get all components, referencing all the files found in the source folders
getAllFiles :: [DCD.Target] -- ^ the build info
-> BuildWrapper [CabalBuildInfo]
getAllFiles tgs= do
dist_dir<-getDistDir
let bd=dist_dir </> "build"
let libs=map (extractFromLib bd) $ filter DCD.isLibrary tgs
let exes=map (extractFromExe bd) $ filter DCD.isExecutable tgs
let tests=map (extractFromTest bd) $ filter DCD.isTest tgs
let benches=map (extractFromBench bd) $ filter DCD.isBench tgs
cbis<-mapM (\(a,c,isLib,d,cc)->do
mf<-copyAll d
return (CabalBuildInfo a c isLib mf cc)) (libs ++ exes ++ tests ++benches)
cbis2<-getReferencedFiles tgs
return $ zipWith (\c1@CabalBuildInfo{cbiModulePaths=cb1} CabalBuildInfo{cbiModulePaths=cb2}->c1{cbiModulePaths=nubOrd $ cb1++cb2}) cbis cbis2
-- return cbis
where
extractFromLib :: FilePath-> DCD.Target -> (DCD.Target,FilePath,Bool,[FilePath],CabalComponent)
extractFromLib bd l=(l,bd, True, getSourceDirs l,cabalComponentFromLibrary l)
extractFromExe :: FilePath-> DCD.Target -> (DCD.Target,FilePath,Bool,[FilePath],CabalComponent)
extractFromExe bd e=let
exeDir = getBuildDir bd e
hsd=getSourceDirs e
in (e,exeDir,False, hsd,cabalComponentFromExecutable e)
extractFromTest :: FilePath-> DCD.Target -> (DCD.Target,FilePath,Bool,[FilePath],CabalComponent)
extractFromTest bd t=let
testDir = getBuildDir bd t
hsd=getSourceDirs t
in (t,testDir,False,hsd,cabalComponentFromTestSuite t)
extractFromBench :: FilePath-> DCD.Target -> (DCD.Target,FilePath,Bool,[FilePath],CabalComponent)
extractFromBench bd t=let
benchDir = getBuildDir bd t
hsd=getSourceDirs t
in (t,benchDir,False,hsd,cabalComponentFromBenchmark t)
copyAll :: [FilePath] -> BuildWrapper [(Maybe ModuleName,FilePath)]
copyAll fps= do
allF<-mapM copyAll' fps
return $ concat allF
copyAll' :: FilePath -> BuildWrapper [(Maybe ModuleName,FilePath)]
copyAll' fp=do
cf<-gets cabalFile
let dir=takeDirectory cf
fullFP<-getFullSrc fp
allF<-liftIO $ getRecursiveContents fullFP
tf<-gets tempFolder
let cabalDist=takeDirectory tf </> "dist"
let cabalDevDist=takeDirectory tf </> "cabal-dev"
-- exclude every file containing the temp folder name (".buildwrapper" by default)
-- which may happen if . is a source path
let notMyself=filter (\x->not $ any (`isInfixOf` x) [cabalDevDist, cabalDist, tf]) allF
return $ map (\f->(simpleParse $ fileToModule $ makeRelative fullFP f,makeRelative dir f)) notMyself
-- return $ map (\(x,y)->(fromJust x,y)) $ filter (isJust . fst) $ map (\f->(simpleParse $ fileToModule $ makeRelative fullFP f,makeRelative dir f)) notMyself
-- | get build dir for a target
getBuildDir :: FilePath -> DCD.Target -> FilePath
getBuildDir bd t=case DCD.info t of
DCD.Library _-> bd
DCD.Executable n _->bd </> n </> (n ++ "-tmp")
DCD.TestSuite n _->bd </> n </> (n ++ "-tmp")
DCD.BenchSuite n _->bd </> n </> (n ++ "-tmp")
-- | get all components, referencing only the files explicitely indicated in the cabal file
getReferencedFiles :: [DCD.Target] -> BuildWrapper [CabalBuildInfo]
getReferencedFiles tgs= do
dist_dir<-getDistDir
let bd=dist_dir </> "build"
let libs=map (extractFromLib bd) $ filter DCD.isLibrary tgs
let exes=map (extractFromExe bd) $ filter DCD.isExecutable tgs
let tests=map (extractFromTest bd) $ filter DCD.isTest tgs
let benches=map (extractFromBench bd) $ filter DCD.isBench tgs
let cbis=libs ++ exes ++ tests ++ benches
mapM (\c1@CabalBuildInfo{cbiModulePaths=cb1}->do
cb2<-filterM (\(_,f)->do
fs<-getFullSrc f
liftIO $ doesFileExist fs) cb1
return c1{cbiModulePaths=cb2}) cbis
where
extractFromLib :: FilePath -> DCD.Target -> CabalBuildInfo
extractFromLib bd l=let
DCD.Library mods=DCD.info l
modules=mods ++ DCD.otherModules l
in CabalBuildInfo l
bd True (copyModules modules (getSourceDirs l)) (cabalComponentFromLibrary l)
extractFromExe :: FilePath -> DCD.Target ->CabalBuildInfo
extractFromExe bd e=let
DCD.Executable _ mp=DCD.info e
exeDir = getBuildDir bd e
modules= DCD.otherModules e
hsd=getSourceDirs e
in CabalBuildInfo e exeDir False (copyMain mp hsd ++ copyModules modules hsd) (cabalComponentFromExecutable e)
extractFromTest :: FilePath -> DCD.Target -> CabalBuildInfo
extractFromTest bd t =let
DCD.TestSuite _ mmp=DCD.info t
testDir = getBuildDir bd t
modules= DCD.otherModules t
hsd=getSourceDirs t
extras=case mmp of
Just mp -> copyMain mp hsd
_ -> []
in CabalBuildInfo t testDir False (extras ++ copyModules modules hsd) (cabalComponentFromTestSuite t)
extractFromBench :: FilePath -> DCD.Target -> CabalBuildInfo
extractFromBench bd t =let
DCD.BenchSuite _ mmp=DCD.info t
benchDir = getBuildDir bd t
modules= DCD.otherModules t
hsd=getSourceDirs t
extras=case mmp of
Just mp -> copyMain mp hsd
_ -> []
in CabalBuildInfo t benchDir False (extras ++ copyModules modules hsd) (cabalComponentFromBenchmark t)
copyModules :: [String] -> [FilePath] -> [(Maybe ModuleName,FilePath)]
copyModules mods=copyFiles (concatMap (\m->[toFilePath m <.> "hs", toFilePath m <.> "lhs"]) $ mapMaybe stringToModuleName mods)
copyFiles :: [FilePath] -> [FilePath] -> [(Maybe ModuleName,FilePath)]
copyFiles mods dirs=let
rmods=filter (isJust . snd ) $ map (\x->(x,simpleParse $ fileToModule x)) mods
in [(Just modu,d </> m) | (m,Just modu)<-rmods, d<-dirs]
copyMain :: FilePath ->[FilePath] -> [(Maybe ModuleName,FilePath)]
copyMain fs = map (\ d -> (Just $ fromString "Main", d </> fs))
-- | parse a string into a module name
stringToModuleName :: String -> Maybe ModuleName
stringToModuleName=simpleParse
-- | convert a ModuleName to a String
moduleToString :: ModuleName -> String
moduleToString = intercalate "." . components
-- | get all components in the Cabal file
cabalComponents :: BuildWrapper (OpResult [CabalComponent])
cabalComponents = do
(rs,ns)<-withCabal Source (return . cabalComponentsFromDescription)
return (fromMaybe [] rs,ns)
-- | get all the dependencies in the cabal file
cabalDependencies :: Maybe FilePath -- ^ the path to the cabal-dev sandbox if any
-> BuildWrapper (OpResult [(FilePath,[CabalPackage])]) -- ^ the result is an array of tuples: the path to the package database, the list of packages in that db that the Cabal file references
cabalDependencies msandbox= do
(rs,ns)<-withCabal Source (\tgs-> liftIO $
ghandle
(\ (e :: IOError) ->
do print e
return [])
$
do
pkgs <- liftIO $ getPkgInfos msandbox
--let m=cabalComponentsDependencies tgs
--print msandbox
--let deps=PD.buildDepends (localPkgDescr lbi)
--print deps
--liftIO $ mapM_ (\d->print $ (show d) ++ (show $ DM.lookup (show $ simplifyDependency d) m)) deps
return $ dependencies tgs pkgs
)
return (fromMaybe [] rs,ns)
-- | get all dependencies from the package description and the list of installed packages
dependencies :: [DCD.Target] -- ^ the cabal description
-> [(FilePath,[InstalledPackageInfo])] -- ^ the installed packages, by package database location
-> [(FilePath,[CabalPackage])] -- ^ the referenced packages, by package database location
dependencies pd pkgs=let
pkgsMap=foldr buildPkgMap DM.empty pkgs -- build the map of package by name with ordered version (more recent first)
-- allC= cabalComponentsFromDescription pd
compDeps=cabalComponentsDependencies pd
-- gdeps=PD.buildDepends pd
cpkgs=concat $ DM.elems $ DM.map (\ipis->getDep compDeps ipis []) pkgsMap
in DM.assocs $ DM.fromListWith (++)
(map (\ (a, b) -> (a, [b])) cpkgs ++
map (\ (a, _) -> (a, [])) pkgs)
where
buildPkgMap :: (FilePath,[InstalledPackageInfo]) -> DM.Map String [(FilePath,InstalledPackageInfo)] -> DM.Map String [(FilePath,InstalledPackageInfo)]
buildPkgMap (fp,ipis) m=foldr (\i dm->let
key=display $ pkgName $ sourcePackageId i
vals=DM.lookup key dm
newvals=case vals of
Nothing->[(fp,i)]
Just l->sortBy (flip (comparing (pkgVersion . sourcePackageId . snd))) ((fp,i):l)
in DM.insert key newvals dm
) m ipis
getDep :: DM.Map CabalComponent [(String, Maybe Version)] -> [(FilePath,InstalledPackageInfo)] -> [(FilePath,CabalPackage)] -> [(FilePath,CabalPackage)]
getDep _ [] acc= acc
getDep allC ((fp,InstalledPackageInfo{sourcePackageId=i,exposed=e,IPI.exposedModules=ems,IPI.hiddenModules=hms}):xs) acc= let
(s,m)=DM.foldrWithKey (splitMatching i) (DS.empty,DM.empty) allC
--(ds,deps2)=partition (\(Dependency n v)->(pkgName i == n) && withinRange (pkgVersion i) v) deps -- find if version is referenced, remove the referencing component so that it doesn't match an older version
cps=DS.elems s
--if null ds then [] else allC
--filter (\c->not $ null ((PD.targetBuildDepends c) `intersect` ds)) allC
mns=map display (ems++hms)
in getDep m xs ((fp,CabalPackage (display $ pkgName i) (display $ pkgVersion i) e cps mns): acc) -- build CabalPackage structure
splitMatching pkgId comp deps (s,m)=let
(ds,_)=partition (\(n,mv)->(pkgName pkgId == PackageName n) && isJust mv && pkgVersion pkgId == fromJust mv) deps
s'=if null ds
then s
else DS.insert comp s
m'=DM.insertWith (++) comp deps m
in (s',m')
-- | get all components from the package description
cabalComponentsFromDescription :: [DCD.Target] -- ^ the package description
-> [CabalComponent]
cabalComponentsFromDescription = map cabalComponentFromTarget
-- | get dependencies for all stanzas
cabalComponentsDependencies :: [DCD.Target] -- ^ the package description
-> DM.Map CabalComponent [(String, Maybe Version)]
cabalComponentsDependencies =foldr f DM.empty
where
f tg =DM.insert (cabalComponentFromTarget tg) (DCD.dependencies tg)
-- let
-- mLib=case PD.library pd of
-- Nothing -> DM.empty
-- Just lib->DM.singleton (cabalComponentFromLibrary lib) (PD.targetBuildDepends $ PD.libBuildInfo lib)
-- mExe=DM.fromList $ map (\e->((cabalComponentFromExecutable e),(PD.targetBuildDepends $ PD.buildInfo e))) (PD.executables pd)
-- mTs=DM.fromList $ map (\ts->((cabalComponentFromTestSuite ts),(PD.targetBuildDepends $ PD.testBuildInfo ts))) (PD.testSuites pd)
-- in DM.unionWith (++) mTs $ DM.unionWith (++) mLib mExe
-- where mapDep cc bi=DM.fromList $ map (\x->(cc)) (PD.targetBuildDepends bi)
-- | convert a dynamic cabla target into a CabalComponent
cabalComponentFromTarget :: DCD.Target -> CabalComponent
cabalComponentFromTarget t=let
b=DCD.buildable t
in case DCD.info t of
DCD.Library _-> CCLibrary b
DCD.Executable n _->CCExecutable n b
DCD.TestSuite n _->CCTestSuite n b
DCD.BenchSuite n _->CCBenchmark n b
-- | transform a library target into a CabalComponent
cabalComponentFromLibrary :: DCD.Target -> CabalComponent
cabalComponentFromLibrary =CCLibrary . DCD.buildable
-- | transform an executable target into a CabalComponent
cabalComponentFromExecutable :: DCD.Target -> CabalComponent
cabalComponentFromExecutable e =let
DCD.Executable exeName' _=DCD.info e
in CCExecutable exeName' (DCD.buildable e)
-- | transform a test suite target into a CabalComponent
cabalComponentFromTestSuite :: DCD.Target -> CabalComponent
cabalComponentFromTestSuite ts=let
DCD.TestSuite testName' _=DCD.info ts
in CCTestSuite testName' (DCD.buildable ts)
-- | transform a benchmark target into a CabalComponent
cabalComponentFromBenchmark :: DCD.Target -> CabalComponent
cabalComponentFromBenchmark ts=let
DCD.BenchSuite benchName' _=DCD.info ts
in CCBenchmark benchName' (DCD.buildable ts)