module CabalCargs.Spec
( Spec(..)
, fromCmdArgs
) where
import Distribution.PackageDescription (GenericPackageDescription)
import Distribution.PackageDescription.Parse (parsePackageDescription, ParseResult(..))
import qualified Distribution.System as Sys
import CabalCargs.Args (Args)
import qualified CabalCargs.Args as A
import qualified CabalCargs.Fields as F
import qualified CabalLenses as CL
import qualified System.IO.Strict as Strict
import Control.Monad.Trans.Either (EitherT, left, right, runEitherT)
import Control.Monad.IO.Class
import Control.Monad (filterM)
import Control.Applicative ((<$>))
import Control.Lens
import System.Directory (getCurrentDirectory)
import qualified Filesystem.Path.CurrentOS as FP
import Filesystem.Path.CurrentOS ((</>))
import qualified Filesystem as FS
import qualified Data.Text as T
import Data.List (find, isPrefixOf, (\\))
import qualified Data.List as L
import Data.Maybe (isJust)
data Spec = Spec
{ sections :: [CL.Section]
, fields :: F.Fields
, condVars :: CL.CondVars
, pkgDescrp :: GenericPackageDescription
, cabalFile :: FilePath
, distDir :: Maybe FilePath
, packageDB :: Maybe FilePath
, relativePaths :: Bool
}
type Error = String
io :: MonadIO m => IO a -> m a
io = liftIO
fromCmdArgs :: Args -> IO (Either Error Spec)
fromCmdArgs args
| Just cabalFile <- A.cabalFile args = runEitherT $ do
spec <- fromCabalFile cabalFile
srcSections <- io $ case A.sourceFile args of
Just srcFile -> findSections srcFile cabalFile (pkgDescrp spec)
_ -> return []
right $ applyCondVars $ spec { sections = combineSections (args, pkgDescrp spec) srcSections
, fields = fields_ args
, relativePaths = A.relative args
}
| Just sourceFile <- A.sourceFile args = runEitherT $ do
spec <- fromSourceFile sourceFile
right $ applyCondVars $ spec { sections = combineSections (args, pkgDescrp spec) (sections spec)
, fields = fields_ args
, relativePaths = A.relative args
}
| otherwise = runEitherT $ do
curDir <- io getCurrentDirectory
cabalFile <- findCabalFile curDir
spec <- fromCabalFile cabalFile
right $ applyCondVars $ spec { sections = sections_ args (pkgDescrp spec)
, fields = fields_ args
, relativePaths = A.relative args
}
where
applyCondVars = applyFlags args . applyOS args . applyArch args
fromCabalFile :: FilePath -> EitherT Error IO Spec
fromCabalFile file = do
pkgDescrp <- packageDescription file
pkgDB <- findPackageDB file
distDir <- io $ findDistDir file
absFile <- FP.encodeString <$> io (absoluteFile file)
right $ Spec
{ sections = CL.allSections pkgDescrp
, fields = F.allFields
, condVars = CL.fromDefaults pkgDescrp
, pkgDescrp = pkgDescrp
, cabalFile = absFile
, distDir = distDir
, packageDB = pkgDB
, relativePaths = False
}
fromSourceFile :: FilePath -> EitherT Error IO Spec
fromSourceFile file = do
cabalFile <- findCabalFile file
pkgDB <- findPackageDB cabalFile
distDir <- io $ findDistDir cabalFile
pkgDescrp <- packageDescription cabalFile
srcSections <- io $ findSections file cabalFile pkgDescrp
right $ Spec
{ sections = srcSections
, fields = F.allFields
, condVars = CL.fromDefaults pkgDescrp
, pkgDescrp = pkgDescrp
, cabalFile = cabalFile
, distDir = distDir
, packageDB = pkgDB
, relativePaths = False
}
applyFlags :: Args -> Spec -> Spec
applyFlags args spec =
spec { condVars = disableFlags . enableFlags $ condVars spec }
where
disableFlags condVars = foldr CL.disableFlag condVars (A.disable args)
enableFlags condVars = foldr CL.enableFlag condVars (A.enable args)
applyOS :: Args -> Spec -> Spec
applyOS (A.Args { A.os = os }) spec
| Just str <- os
, [(name, _)] <- reads str :: [(Sys.OS, String)]
= setOS name
| Just str <- os
= setOS $ Sys.OtherOS str
| otherwise
= spec
where
setOS name = spec { condVars = (condVars spec) { CL.os = name } }
applyArch :: Args -> Spec -> Spec
applyArch (A.Args { A.arch = arch }) spec
| Just str <- arch
, [(name, _)] <- reads str :: [(Sys.Arch, String)]
= setArch name
| Just str <- arch
= setArch $ Sys.OtherArch str
| otherwise
= spec
where
setArch name = spec { condVars = (condVars spec) { CL.arch = name } }
packageDescription :: FilePath -> EitherT Error IO GenericPackageDescription
packageDescription file = do
contents <- io $ Strict.readFile file
case parsePackageDescription contents of
ParseFailed error -> left $ show error
ParseOk _ pkgDescrp -> right pkgDescrp
findSections :: FilePath -> FilePath -> GenericPackageDescription -> IO [CL.Section]
findSections srcFile cabalFile pkgDescrp = do
absSrcFile <- absoluteFile srcFile
cabalDir <- absoluteDirectory cabalFile
let sections = filter (fittingSection absSrcFile cabalDir) (allHsSourceDirs pkgDescrp)
return $ map fst sections
where
fittingSection srcFile cabalDir (_, []) =
isJust $ FP.stripPrefix (cabalDir </> FP.empty) srcFile
fittingSection srcFile cabalDir (_, srcDirs) = any samePrefix srcDirs
where samePrefix srcDir = isJust $ FP.stripPrefix (cabalDir </> srcDir </> FP.empty) srcFile
type HsSourceDirs = [FP.FilePath]
allHsSourceDirs :: GenericPackageDescription -> [(CL.Section, HsSourceDirs)]
allHsSourceDirs pkgDescrp = zip sections hsSourceDirs
where
sections = CL.allSections pkgDescrp
hsSourceDirs = map (\section -> toFPs $ pkgDescrp ^. CL.buildInfoIf condVars section . CL.hsSourceDirsL) sections
where
toFPs = map FP.decodeString
condVars = CL.fromDefaults pkgDescrp
findCabalFile :: FilePath -> EitherT Error IO FilePath
findCabalFile file = do
cabalFile <- io $ do
dir <- absoluteDirectory file
findCabalFile' dir
if cabalFile == FP.empty
then left "Couldn't find Cabal file!"
else right . FP.encodeString $ cabalFile
where
findCabalFile' dir = do
files <- filterM FS.isFile =<< (FS.listDirectory dir)
case find isCabalFile files of
Just file -> return $ dir </> file
_ -> do
let parent = FP.parent dir
if parent == dir
then return FP.empty
else findCabalFile' parent
isCabalFile file
| Just ext <- FP.extension file
= ext == cabalExt
| otherwise
= False
cabalExt = T.pack "cabal"
findPackageDB :: FilePath -> EitherT Error IO (Maybe FilePath)
findPackageDB cabalFile = do
cabalDir <- io $ absoluteDirectory cabalFile
let sandboxConfig = cabalDir </> sandbox_config
isFile <- io $ FS.isFile sandboxConfig
if isFile
then do
packageDB <- io $ readPackageDB sandboxConfig
case packageDB of
Just db -> right . Just $ stripPrefix cabalDir db
_ -> left $ "Couldn't find field 'package-db: ' in " ++ (show sandboxConfig)
else
right Nothing
where
readPackageDB :: FP.FilePath -> IO (Maybe FP.FilePath)
readPackageDB sandboxConfig = do
lines <- lines <$> Strict.readFile (FP.encodeString sandboxConfig)
return $ do
line <- find (package_db `L.isPrefixOf`) lines
packageDB <- L.stripPrefix package_db line
return $ FP.decodeString packageDB
sandbox_config = FP.decodeString "cabal.sandbox.config"
package_db = "package-db: "
findDistDir :: FilePath -> IO (Maybe FilePath)
findDistDir cabalFile = do
cabalDir <- absoluteDirectory cabalFile
let distDir = cabalDir </> FP.decodeString "dist"
hasDistDir <- FS.isDirectory distDir
if hasDistDir
then do
files <- filterM FS.isDirectory =<< (FS.listDirectory distDir)
return $ (stripPrefix cabalDir) <$> maybe (Just distDir) Just (find isSandboxDistDir files)
else return Nothing
where
isSandboxDistDir file =
"dist-sandbox-" `isPrefixOf` (FP.encodeString . FP.filename $ file)
absoluteDirectory :: FilePath -> IO FP.FilePath
absoluteDirectory file = do
absFile <- absoluteFile file
isDir <- FS.isDirectory absFile
if isDir
then return absFile
else return . FP.directory $ absFile
absoluteFile :: FilePath -> IO FP.FilePath
absoluteFile = FS.canonicalizePath . FP.decodeString
stripPrefix :: FP.FilePath -> FP.FilePath -> FilePath
stripPrefix prefix file
| Just stripped <- FP.stripPrefix prefix file
= FP.encodeString stripped
| otherwise
= FP.encodeString file
combineSections :: (Args, GenericPackageDescription) -> [CL.Section] -> [CL.Section]
combineSections (args, pkgDescrp) sections
| A.allSections args
= CL.allSections pkgDescrp
| [] <- explicitSections args
, null sections
= CL.allSections pkgDescrp
| otherwise
= L.nub $ explicitSections args ++ sections
fields_ :: Args -> F.Fields
fields_ args
| fs@(_:_) <- A.only args
= fs
| fs@(_:_) <- A.ignore args
= F.allFields \\ fs
| otherwise
= F.allFields
sections_ :: Args -> GenericPackageDescription -> [CL.Section]
sections_ args pkgDescrp
| A.allSections args
= CL.allSections pkgDescrp
| ss@(_:_) <- explicitSections args
= ss
| otherwise
= CL.allSections pkgDescrp
explicitSections :: Args -> [CL.Section]
explicitSections args =
concat [ [CL.Library | A.library args]
, map CL.Executable (A.executable args)
, map CL.TestSuite (A.testSuite args)
, map CL.Benchmark (A.benchmark args)
]