Initial

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])
diff --git a/Main.hs b/Main.hs
new file mode 100644
index 0000000..0ed4f4c
--- /dev/null
+++ b/Main.hs
@@ -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