diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | Coolbal/CabalPlan.hs | 66 | ||||
| -rw-r--r-- | Coolbal/Configure.hs | 41 | ||||
| -rw-r--r-- | Coolbal/Directory.hs | 13 | ||||
| -rw-r--r-- | Coolbal/FindSpec.hs | 61 | ||||
| -rw-r--r-- | Coolbal/Options.hs | 42 | ||||
| -rw-r--r-- | Coolbal/Target.hs | 112 | ||||
| -rw-r--r-- | Coolbal/Target/Executable.hs | 40 | ||||
| -rw-r--r-- | Coolbal/Util.hs | 6 | ||||
| -rw-r--r-- | Main.hs | 78 | ||||
| -rw-r--r-- | coolbal.cabal | 40 |
11 files changed, 501 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..33b2d71 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist-newstyle/ +dist-coolbal/ diff --git a/Coolbal/CabalPlan.hs b/Coolbal/CabalPlan.hs new file mode 100644 index 0000000..6d0bd04 --- /dev/null +++ b/Coolbal/CabalPlan.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE ViewPatterns #-} +module Coolbal.CabalPlan ( + CabalPlan(..), + PlanPackage(..), + parseCabalPlan, +) where + +import qualified Data.Bytes as Bytes +import Data.Foldable (toList) +import Data.List (find) +import qualified GHC.Exts as IsList (IsList(..)) +import qualified Json + + +data CabalPlan = CabalPlan + { planCompiler :: String + , planPackages :: [PlanPackage] } + deriving (Show) + +data PlanPackage + = PreExisting + { ppName :: String + , ppVersion :: String + , ppDepends :: [String] } + | Configured + { ppName :: String + , ppVersion :: String + , ppLocal :: Bool + , ppComponent :: String + , ppDepends :: [String] } + deriving (Show) + + +parseCabalPlan :: FilePath -> IO (Maybe CabalPlan) +parseCabalPlan fpath = parseFromValue <$> Bytes.readFile fpath + where + parseFromValue (Json.decode -> Right toplevel) = do + Json.Object obj <- return toplevel + Json.String compiler <- locate "compiler-id" obj + Json.Array pkgs <- locate "install-plan" obj + CabalPlan (IsList.toList compiler) <$> mapM parsePackage (toList pkgs) + parseFromValue _ = Nothing + + parsePackage value = do + Json.Object obj <- return value + Json.String typ <- locate "type" obj + Json.String name <- locate "pkg-name" obj + Json.String version <- locate "pkg-version" obj + Json.Array dependsArr <- locate "depends" obj + depends <- mapM (\case Json.String s -> Just s ; _ -> Nothing) (toList dependsArr) + if | typ == IsList.fromList "pre-existing" -> + return (PreExisting (IsList.toList name) (IsList.toList version) (map IsList.toList depends)) + | typ == IsList.fromList "configured" -> do + Json.String style <- locate "style" obj + Json.String component <- locate "component-name" obj + return (Configured (IsList.toList name) (IsList.toList version) + (style == IsList.fromList "local") + (IsList.toList component) + (map IsList.toList depends)) + | otherwise -> + Nothing + +locate :: Foldable f => String -> f Json.Member -> Maybe Json.Value +locate key = fmap (\(Json.Member _ v) -> v) . find (\(Json.Member k _) -> k == IsList.fromList key) diff --git a/Coolbal/Configure.hs b/Coolbal/Configure.hs new file mode 100644 index 0000000..92865e7 --- /dev/null +++ b/Coolbal/Configure.hs @@ -0,0 +1,41 @@ +module Coolbal.Configure (configure) where + +import Distribution.PackageDescription.Configuration (finalizePD) +import Distribution.PackageDescription.Parsec (readGenericPackageDescription) +import Distribution.Simple.Compiler (compilerInfo) +import qualified Distribution.Simple.Configure as Cabal (configure) +import qualified Distribution.Simple.GHC as GHC (configure) +import Distribution.Simple.Program.Db (restoreProgramDb, emptyProgramDb) +import Distribution.Simple.Program.Builtin (builtinPrograms) +import Distribution.Simple.Setup (defaultConfigFlags) +import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec(..)) +import Distribution.Types.Flag (mkFlagAssignment) +import Distribution.Types.HookedBuildInfo (emptyHookedBuildInfo) +import Distribution.Types.LocalBuildInfo (hostPlatform) +import Distribution.Types.PackageDescription (PackageDescription) +import qualified Distribution.Verbosity as V +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) + + +configure :: FilePath -> IO PackageDescription +configure fname = do + gpd <- readGenericPackageDescription V.normal fname + -- print gpd + (compiler, mplatform, programdb) <- GHC.configure V.normal Nothing Nothing (restoreProgramDb builtinPrograms emptyProgramDb) + platform <- maybe (hostPlatform <$> Cabal.configure (gpd, emptyHookedBuildInfo) (defaultConfigFlags programdb)) return mplatform + let mpd = finalizePD (mkFlagAssignment []) + (ComponentRequestedSpec { testsRequested = False, benchmarksRequested = False }) + (const True) -- is a dependency available in the package set? + platform + (compilerInfo compiler) + [] + gpd + case mpd of + Left deps -> do + hPutStrLn stderr "Configuration failed due to the following packages:" + mapM_ (\d -> hPutStrLn stderr ("- " ++ show d)) deps + exitFailure + Right (pd, _flags) -> do + -- putStrLn ("Configured with flags: " ++ show flags) + return pd diff --git a/Coolbal/Directory.hs b/Coolbal/Directory.hs new file mode 100644 index 0000000..c2a53cc --- /dev/null +++ b/Coolbal/Directory.hs @@ -0,0 +1,13 @@ +module Coolbal.Directory where + +import System.Environment (lookupEnv) +import System.Exit (die) +import System.IO.Unsafe (unsafePerformIO) + + +currentHomeDirectory :: String +currentHomeDirectory = unsafePerformIO $ do + var <- lookupEnv "HOME" + case var of + Just s -> return s + Nothing -> die "Cannot get home directory from $HOME environment variable" diff --git a/Coolbal/FindSpec.hs b/Coolbal/FindSpec.hs new file mode 100644 index 0000000..ce9ab45 --- /dev/null +++ b/Coolbal/FindSpec.hs @@ -0,0 +1,61 @@ +module Coolbal.FindSpec (findCabalSpec, FoundCabalSpec(..)) where + +import Data.List (unfoldr) +import System.Directory +import System.Exit (exitFailure) +import System.FilePath ((</>)) +import System.IO (hPutStrLn, stderr) + + +data FoundCabalSpec = FoundCabalSpec + { foundcsRootDir :: FilePath + , foundcsCabal :: FilePath } + deriving (Show) + +findCabalSpec :: IO FoundCabalSpec +findCabalSpec = do + cwd <- getCurrentDirectory >>= makeAbsolute + mfound <- findCabalSpecInDirs (ancestors cwd) + case mfound of + Just found -> do + putStrLn ("Found .cabal file: " ++ foundcsCabal found) + return found + Nothing -> do + hPutStrLn stderr (".cabal file not found in ancestors of PWD: " ++ cwd) + exitFailure + +findCabalSpecInDirs :: [FilePath] -> IO (Maybe FoundCabalSpec) +findCabalSpecInDirs [] = return Nothing +findCabalSpecInDirs (p:ps) = + findCabalSpecInDir p >>= maybe (findCabalSpecInDirs ps) (return . Just) + +findCabalSpecInDir :: FilePath -> IO (Maybe FoundCabalSpec) +findCabalSpecInDir dir = do + files <- filter (`endsWith` ".cabal") <$> listDirectory dir + case files of + [fname] -> do + exists <- doesFileExist (dir </> fname) + return (if exists then Just (FoundCabalSpec { foundcsRootDir = dir + , foundcsCabal = dir </> fname }) + else Nothing) + [] -> return Nothing + _ -> do + hPutStrLn stderr "Ambiguous cabal file! Found files:" + mapM_ (\p -> hPutStrLn stderr ("- " ++ (dir </> p))) files + exitFailure + +parentDir :: FilePath -> Maybe FilePath +parentDir s = case reverse s of + "/" -> Nothing + '/' : s' -> Just (reverse (dropWhile (/= '/') s')) + s' -> case dropWhile (/= '/') s' of + "/" -> Just "/" + _ : s'' -> Just (reverse s'') + "" -> Nothing + +-- Includes the path itself as first element +ancestors :: FilePath -> [FilePath] +ancestors p = p : unfoldr (fmap (\x -> (x,x)) . parentDir) p + +endsWith :: String -> String -> Bool +s `endsWith` s' = reverse (take (length s') (reverse s)) == s' diff --git a/Coolbal/Options.hs b/Coolbal/Options.hs new file mode 100644 index 0000000..35b774c --- /dev/null +++ b/Coolbal/Options.hs @@ -0,0 +1,42 @@ +module Coolbal.Options ( + Options(..), + BuildOptions(..), + optionParser, +) where + +import Options.Applicative + + +data Options + = Build BuildOptions + | Clean + | Configure + deriving (Show) + +data BuildOptions = BuildOptions (Maybe String) + deriving (Show) + +optionParser :: ParserInfo Options +optionParser = + info (root <**> helper) + (fullDesc + <> header "coolbal - Faster cabal for common cases" + <> progDesc "Some simple Haskell projects don't need all the complexity of \ + \Cabal's re-configuration logic. Coolbal can take an already-built \ + \Cabal project and rebuild it as long as you don't change the \ + \configuration too much, and as long as you don't use too-special \ + \Cabal features. Always check that coolbal gives you the expected \ + \result.") + +root :: Parser Options +root = + hsubparser ( + command "build" (info (Build <$> buildOptions) + (progDesc "Build the project")) + <> command "clean" (info (pure Clean) + (progDesc "Clean coolbal's files for this project")) + <> command "configure" (info (pure Configure) + (progDesc "Initialise coolbal for this project"))) + +buildOptions :: Parser BuildOptions +buildOptions = BuildOptions <$> optional (argument str (metavar "TARGET")) diff --git a/Coolbal/Target.hs b/Coolbal/Target.hs new file mode 100644 index 0000000..c698ceb --- /dev/null +++ b/Coolbal/Target.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +module Coolbal.Target ( + IsTarget(..), + AnyTarget(..), + ExeTarget(..), + useAnyTarget, +) where + +import Data.Char (ord) +import Data.List (intercalate) +import Numeric (showHex) +import System.Directory (createDirectoryIfMissing) +import System.Exit (ExitCode(..), die) +import System.FilePath ((</>)) +import System.Process (rawSystem) + +import Coolbal.Util + + +class IsTarget a where + -- | The name of the target. + targetName :: a -> String + + -- | The name of the target, qualified with a cabal-style prefix indicating the kind of target. + targetNameQualified :: a -> String + + -- | The name of the target, qualified with a cabal-style prefix indicating + -- the kind of target, except that the ':' is rendered as a '-'. + targetNameQualifiedFilename :: a -> FilePath + targetNameQualifiedFilename tg = case break (== ':') (targetNameQualified tg) of + (pre, ':' : post) -> pre ++ '-' : post + _ -> error "targetNameQualifiedFilename: unexpected form of targetNameQualified" + + -- | Check whether the target must be recompiled due to changes on disk. + -- Argument is the root directory of the project. + targetCheckOld :: FilePath -> a -> IO Bool + + -- | Recompile the target. Argument is the root directory of the project. + targetBuild :: FilePath -> a -> IO () + +data AnyTarget = forall a. (Show a, IsTarget a) => AnyTarget a + +deriving instance Show AnyTarget + +useAnyTarget :: (forall a. (Show a, IsTarget a) => a -> r) -> AnyTarget -> r +useAnyTarget f (AnyTarget x) = f x + +data ExeTarget = ExeTarget + { exeTargetName :: String + -- ^ Target name, and name of output executable file + , exeTargetPkgDbDir :: FilePath + -- ^ Absolute path to the package.db directory + , exeTargetDeps :: [String] + -- ^ Package identifiers of dependencies (for -package-id flags) + , exeTargetLanguage :: String + -- ^ Haskell language (e.g. Haskell2010) + , exeTargetMain :: FilePath + -- ^ Main file + , exeTargetModules :: [[String]] + -- ^ Other modules in the target + , exeTargetFlags :: [String] + -- ^ User-specified compiler flags + } + deriving (Show) + +instance IsTarget ExeTarget where + targetName = exeTargetName + targetNameQualified e = "exe:" ++ targetName e + + targetCheckOld _ _ = return True + + targetBuild projdir tg = do + let buildDir = projdir </> "dist-coolbal/build" + </> escapeFileName (targetNameQualifiedFilename tg) + binDir = projdir </> "dist-coolbal/bin" + binName = binDir </> escapeFileName (exeTargetName tg) + createDirectoryIfMissing True binDir + rawSystem "ghc" (concat + [["--make", "-static"] + ,concat [[flag, buildDir] + | flag <- ["-outputdir", "-odir", "-hidir", "-stubdir"]] + ,["-i" ++ buildDir, "-I" ++ buildDir] + ,["-hide-all-packages", "-Wmissing-home-modules", "-no-user-package-db"] + ,["-package-db", exeTargetPkgDbDir tg] + ,concat [["-package-id", dep] | dep <- exeTargetDeps tg] + ,["-X" ++ exeTargetLanguage tg] + ,[exeTargetMain tg] + ,map (intercalate ".") (exeTargetModules tg) + ,["-o", binName] + ,exeTargetFlags tg]) + >>= checkExitCode "ghc" + +checkExitCode :: String -> ExitCode -> IO () +checkExitCode _ ExitSuccess = return () +checkExitCode procname (ExitFailure c) = + die (procname ++ " exited with code " ++ show c) + +escapeFileName :: String -> FilePath +escapeFileName = + -- NTFS/POSIX not allows: 0x00-0x1F 0x7F- : / " * < > ? \ | + -- We use ! as an escape character, and hence disallow that too. + genericEscapeString + (\c -> let n = ord c + in n <= 0x1F || n >= 0x7F || c `elem` ":/\"*<>?\\|!") + (\c -> case (c, ord c) of + ('!', _) -> "!!" + (_, n) | n <= 0xFF -> '!' : showHex n "" + | n <= 0xFFFF -> '!' : 'u' : showHex n "" + | n <= 0xFFFFFF -> '!' : 'U' : showHex n "" + | otherwise -> error "Super-high unicode?") diff --git a/Coolbal/Target/Executable.hs b/Coolbal/Target/Executable.hs new file mode 100644 index 0000000..2e62953 --- /dev/null +++ b/Coolbal/Target/Executable.hs @@ -0,0 +1,40 @@ +module Coolbal.Target.Executable (makeExeTarget) where + +import Data.List (find) +import Distribution.Compiler (perCompilerFlavorToList, CompilerFlavor(GHC)) +import qualified Distribution.ModuleName as Module +import Distribution.Types.BuildInfo (BuildInfo(..)) +import Distribution.Types.Executable (Executable(..)) +import Distribution.Types.ExecutableScope (ExecutableScope(ExecutablePublic)) +import Distribution.Types.UnqualComponentName (unUnqualComponentName) +import Language.Haskell.Extension (knownLanguages) + +import Coolbal.CabalPlan +import Coolbal.Directory +import Coolbal.Target + + +makeExeTarget :: Executable -> CabalPlan -> Maybe ExeTarget +makeExeTarget exe plan + | exeScope exe == ExecutablePublic + , let bi = buildInfo exe + , buildable bi + , all (null . ($ bi)) [asmSources, cmmSources, cSources, cxxSources, jsSources] + , all (null . ($ bi)) [virtualModules, autogenModules] + , null (defaultExtensions bi) + , all (null . ($ bi)) [extraLibs, extraBundledLibs] + , let name = unUnqualComponentName (exeName exe) + , Just planpkg@Configured{} <- find ((== name) . ppName) (planPackages plan) + , Just language <- defaultLanguage bi + , True <- language `elem` knownLanguages + , Just flags <- lookup GHC (perCompilerFlavorToList (options bi)) + = Just (ExeTarget + { exeTargetName = unUnqualComponentName (exeName exe) + , exeTargetPkgDbDir = currentHomeDirectory ++ "/.cabal/store/" ++ planCompiler plan ++ "/package.db" + , exeTargetDeps = ppDepends planpkg + , exeTargetLanguage = show language + , exeTargetMain = modulePath exe + , exeTargetModules = map Module.components (otherModules bi) + , exeTargetFlags = flags + }) + | otherwise = Nothing diff --git a/Coolbal/Util.hs b/Coolbal/Util.hs new file mode 100644 index 0000000..f617614 --- /dev/null +++ b/Coolbal/Util.hs @@ -0,0 +1,6 @@ +module Coolbal.Util where + + +genericEscapeString :: (Char -> Bool) -> (Char -> String) -> String -> String +genericEscapeString isReserved escape = + concatMap (\c -> if isReserved c then escape c else [c]) @@ -0,0 +1,78 @@ +module Main where + +import Data.List (intercalate) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import qualified Distribution.Types.PackageDescription as PD +import Distribution.Types.PackageDescription (PackageDescription) +import Distribution.Types.BuildType (BuildType(Simple)) +import Options.Applicative (execParser) +import System.Directory (removeDirectoryRecursive) +import System.Exit (die) +import System.FilePath ((</>)) + +import Coolbal.CabalPlan +import Coolbal.Configure (configure) +import Coolbal.FindSpec +import Coolbal.Options +import Coolbal.Target +import Coolbal.Target.Executable (makeExeTarget) + + +checkCompatibleSpec :: PackageDescription -> IO () +checkCompatibleSpec pd + | PD.buildType pd /= Simple = die ("Only build type Simple is supported; package uses " ++ show (PD.buildType pd)) + | not (null (PD.setupBuildInfo pd)) = die "Custom setup build info unsupported" + | otherwise = return () + +compatibleTargets :: PackageDescription -> CabalPlan -> [AnyTarget] +compatibleTargets pd plan = + catMaybes (map (\e -> AnyTarget <$> makeExeTarget e plan) (PD.executables pd)) + +parseCabalPlan' :: FoundCabalSpec -> IO CabalPlan +parseCabalPlan' foundSpec = + parseCabalPlan (foundcsRootDir foundSpec </> "dist-newstyle/cache/plan.json") + >>= maybe (die "Cabal plan.json not found; make sure to run 'cabal build' beforehand") + return + +doConfigure :: IO () +doConfigure = do + foundSpec <- findCabalSpec + pd <- configure (foundcsCabal foundSpec) + checkCompatibleSpec pd + plan <- parseCabalPlan' foundSpec + -- print pd + let names = map (useAnyTarget (\t -> targetName t ++ " (" ++ targetNameQualified t ++ ")")) + (compatibleTargets pd plan) + putStrLn ("Supported targets: " ++ intercalate ", " names) + +doClean :: IO () +doClean = do + foundSpec <- findCabalSpec + removeDirectoryRecursive (foundcsRootDir foundSpec </> "dist-coolbal") + +doBuild :: BuildOptions -> IO () +doBuild (BuildOptions mtarget) = do + foundSpec <- findCabalSpec + pd <- configure (foundcsCabal foundSpec) + checkCompatibleSpec pd + plan <- parseCabalPlan' foundSpec + let targets = compatibleTargets pd plan + targetsForName = Map.fromListWith (++) $ concat + [[(targetName t, [at]), (targetNameQualified t, [at])] + | at@(AnyTarget t) <- targets] + toBuild <- case mtarget of + Nothing -> return targets + Just name -> case Map.lookup name targetsForName of + Nothing -> die ("Target not found: '" ++ name ++ "'") + Just [t] -> return [t] + Just _ -> die ("Ambiguous target name: '" ++ name ++ "'") + mapM_ (useAnyTarget (targetBuild (foundcsRootDir foundSpec))) toBuild + +main :: IO () +main = do + options <- execParser optionParser + case options of + Configure -> doConfigure + Clean -> doClean + Build opts -> doBuild opts diff --git a/coolbal.cabal b/coolbal.cabal new file mode 100644 index 0000000..7ddf99c --- /dev/null +++ b/coolbal.cabal @@ -0,0 +1,40 @@ +cabal-version: >=1.10 +name: coolbal +synopsis: Minimal Cabal client +version: 0.1.0.0 +license: MIT +author: Tom Smeding +maintainer: tom@tomsmeding.com +build-type: Simple + +executable coolbal + main-is: Main.hs + other-modules: + Coolbal.CabalPlan + Coolbal.Configure + Coolbal.Directory + Coolbal.FindSpec + Coolbal.Options + Coolbal.Target + Coolbal.Target.Executable + Coolbal.Util + build-depends: base >= 4.13 && < 4.15, + Cabal >= 3.2.1.0 && < 3.3.0.0, + bytestring >= 0.10.12 && < 0.11, + directory, + filepath, + binary >= 0.8.8.0 && < 0.9, + process >= 1.6.9.0 && < 1.7, + json-syntax >= 0.1.2.0 && < 0.2, + byteslice, + array-chunks, + optparse-applicative >= 0.16.1.0 && < 0.17, + containers >= 0.6.2.1 && < 0.7 + -- mtl >= 2.2.2 && < 2.3, + -- parsec >= 3.1.14.0 && < 3.2, + -- stm >= 2.5.0.0 && < 2.6, + -- text >= 1.2.4.1 && < 1.3, + -- time >= 1.9.3 && < 1.11 + hs-source-dirs: . + default-language: Haskell2010 + ghc-options: -Wall -O2 -threaded |