summaryrefslogtreecommitdiff
path: root/Coolbal
diff options
context:
space:
mode:
Diffstat (limited to 'Coolbal')
-rw-r--r--Coolbal/CabalPlan.hs66
-rw-r--r--Coolbal/Configure.hs41
-rw-r--r--Coolbal/Directory.hs13
-rw-r--r--Coolbal/FindSpec.hs61
-rw-r--r--Coolbal/Options.hs42
-rw-r--r--Coolbal/Target.hs112
-rw-r--r--Coolbal/Target/Executable.hs40
-rw-r--r--Coolbal/Util.hs6
8 files changed, 381 insertions, 0 deletions
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])
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-25 06:59:16 +0100