From e3ab394665c2c308cab6fffb41b3acc66d0ca989 Mon Sep 17 00:00:00 2001
From: Tom Smeding <tom@tomsmeding.com>
Date: Thu, 18 Feb 2021 12:11:48 +0100
Subject: Second
---
Coolbal/FindRoot.hs | 83 ++++++++++++++++++++++++++++++++++++++
Coolbal/FindSpec.hs | 61 ----------------------------
Coolbal/Options.hs | 10 +++++
Coolbal/Target.hs | 94 +++++++++++++++++++++++++++++++++++++-------
Coolbal/Target/Executable.hs | 1 +
Main.hs | 78 +++++++++++++++++++++++++-----------
coolbal.cabal | 8 ++--
7 files changed, 233 insertions(+), 102 deletions(-)
create mode 100644 Coolbal/FindRoot.hs
delete mode 100644 Coolbal/FindSpec.hs
diff --git a/Coolbal/FindRoot.hs b/Coolbal/FindRoot.hs
new file mode 100644
index 0000000..ea6e297
--- /dev/null
+++ b/Coolbal/FindRoot.hs
@@ -0,0 +1,83 @@
+module Coolbal.FindRoot (
+ findCabalSpec,
+ FoundCabalSpec(..),
+ findDist,
+ FoundRootDir(..),
+) 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 <- findThingInDirs "cabal file" (`endsWith` ".cabal") doesFileExist FoundCabalSpec (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
+
+data FoundRootDir = FoundRootDir FilePath
+ deriving (Show)
+
+findDist :: IO FoundRootDir
+findDist = do
+ cwd <- getCurrentDirectory >>= makeAbsolute
+ mfound <- findThingInDirs "dist-coolbal directory" (== "dist-coolbal") doesDirectoryExist (\p _ -> FoundRootDir p) (ancestors cwd)
+ case mfound of
+ Just found -> return found
+ Nothing -> do
+ hPutStrLn stderr ("dist-coolbal directory not found in ancestors of PWD: " ++ cwd)
+ exitFailure
+
+-- | Argument semantics are the same as 'findThingInDir'.
+findThingInDirs :: String -> (FilePath -> Bool) -> (FilePath -> IO Bool) -> (FilePath -> FilePath -> a) -> [FilePath] -> IO (Maybe a)
+findThingInDirs _ _ _ _ [] = return Nothing
+findThingInDirs description namePred typePred constructor (p:ps) =
+ findThingInDir description namePred typePred constructor p
+ >>= maybe (findThingInDirs description namePred typePred constructor ps)
+ (return . Just)
+
+-- | 'namePred' gets the file name, 'typePred' gets the full path.
+-- 'constructor' gets the root dir path and the name of the file found.
+findThingInDir :: String -> (FilePath -> Bool) -> (FilePath -> IO Bool) -> (FilePath -> FilePath -> a) -> FilePath -> IO (Maybe a)
+findThingInDir description namePred typePred constructor dir = do
+ files <- filter namePred <$> listDirectory dir
+ case files of
+ [fname] -> do
+ ok <- typePred (dir </> fname)
+ return (if ok then Just (constructor dir (dir </> fname))
+ else Nothing)
+ [] -> return Nothing
+ _ -> do
+ hPutStrLn stderr ("Ambiguity when searching for " ++ description ++ "! 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/FindSpec.hs b/Coolbal/FindSpec.hs
deleted file mode 100644
index ce9ab45..0000000
--- a/Coolbal/FindSpec.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-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
index 35b774c..8b1f807 100644
--- a/Coolbal/Options.hs
+++ b/Coolbal/Options.hs
@@ -1,6 +1,7 @@
module Coolbal.Options (
Options(..),
BuildOptions(..),
+ RunOptions(..),
optionParser,
) where
@@ -11,11 +12,15 @@ data Options
= Build BuildOptions
| Clean
| Configure
+ | Run RunOptions
deriving (Show)
data BuildOptions = BuildOptions (Maybe String)
deriving (Show)
+data RunOptions = RunOptions (Maybe String) [String]
+ deriving (Show)
+
optionParser :: ParserInfo Options
optionParser =
info (root <**> helper)
@@ -33,6 +38,8 @@ root =
hsubparser (
command "build" (info (Build <$> buildOptions)
(progDesc "Build the project"))
+ <> command "run" (info (Run <$> runOptions)
+ (progDesc "Run an executable from the project"))
<> command "clean" (info (pure Clean)
(progDesc "Clean coolbal's files for this project"))
<> command "configure" (info (pure Configure)
@@ -40,3 +47,6 @@ root =
buildOptions :: Parser BuildOptions
buildOptions = BuildOptions <$> optional (argument str (metavar "TARGET"))
+
+runOptions :: Parser RunOptions
+runOptions = RunOptions <$> optional (argument str (metavar "TARGET")) <*> many (argument str (metavar "ARGS..."))
diff --git a/Coolbal/Target.hs b/Coolbal/Target.hs
index c698ceb..761f19d 100644
--- a/Coolbal/Target.hs
+++ b/Coolbal/Target.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE StandaloneDeriving #-}
module Coolbal.Target (
IsTarget(..),
AnyTarget(..),
@@ -8,12 +8,16 @@ module Coolbal.Target (
useAnyTarget,
) where
+import Data.Binary (Binary)
import Data.Char (ord)
import Data.List (intercalate)
+import Data.Time.Clock (UTCTime)
+import GHC.Generics (Generic)
import Numeric (showHex)
-import System.Directory (createDirectoryIfMissing)
-import System.Exit (ExitCode(..), die)
+import System.Directory (createDirectoryIfMissing, doesFileExist, getModificationTime)
+import System.Exit (ExitCode(..), die, exitWith)
import System.FilePath ((</>))
+import System.IO.Error (catchIOError)
import System.Process (rawSystem)
import Coolbal.Util
@@ -40,12 +44,18 @@ class IsTarget a where
-- | 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
+ -- | If the target is an executable target, return an IO action that runs
+ -- the executable with the specified arguments. The 'FilePath' is the root
+ -- directory of the project.
+ targetExecute :: a -> Maybe (FilePath -> [String] -> IO ())
-deriving instance Show AnyTarget
+data AnyTarget = AnyTargetExe ExeTarget
+ deriving (Show, Generic)
-useAnyTarget :: (forall a. (Show a, IsTarget a) => a -> r) -> AnyTarget -> r
-useAnyTarget f (AnyTarget x) = f x
+instance Binary AnyTarget
+
+useAnyTarget :: (forall a. (Show a, Binary a, IsTarget a) => a -> r) -> AnyTarget -> r
+useAnyTarget f (AnyTargetExe x) = f x
data ExeTarget = ExeTarget
{ exeTargetName :: String
@@ -58,18 +68,29 @@ data ExeTarget = ExeTarget
-- ^ Haskell language (e.g. Haskell2010)
, exeTargetMain :: FilePath
-- ^ Main file
+ , exeTargetSrcDirs :: [FilePath]
+ -- ^ Source directories
, exeTargetModules :: [[String]]
-- ^ Other modules in the target
, exeTargetFlags :: [String]
-- ^ User-specified compiler flags
}
- deriving (Show)
+ deriving (Show, Generic)
+
+instance Binary ExeTarget
instance IsTarget ExeTarget where
targetName = exeTargetName
targetNameQualified e = "exe:" ++ targetName e
- targetCheckOld _ _ = return True
+ targetCheckOld projdir tg = do
+ mbinTm <- maybeModificationTime (projdir </> "dist-coolbal/bin" </> escapeFileName (exeTargetName tg))
+ case mbinTm of
+ Just binTm -> do
+ anyNewerThan binTm (findFile' (exeTargetSrcDirs tg) (exeTargetMain tg)
+ : [findSourceFile' (exeTargetSrcDirs tg) m | m <- exeTargetModules tg])
+ Nothing ->
+ return True
targetBuild projdir tg = do
let buildDir = projdir </> "dist-coolbal/build"
@@ -81,7 +102,7 @@ instance IsTarget ExeTarget where
[["--make", "-static"]
,concat [[flag, buildDir]
| flag <- ["-outputdir", "-odir", "-hidir", "-stubdir"]]
- ,["-i" ++ buildDir, "-I" ++ buildDir]
+ ,["-i" ++ dir | dir <- exeTargetSrcDirs tg]
,["-hide-all-packages", "-Wmissing-home-modules", "-no-user-package-db"]
,["-package-db", exeTargetPkgDbDir tg]
,concat [["-package-id", dep] | dep <- exeTargetDeps tg]
@@ -92,6 +113,11 @@ instance IsTarget ExeTarget where
,exeTargetFlags tg])
>>= checkExitCode "ghc"
+ targetExecute tg = Just $ \projdir args -> do
+ let filename = escapeFileName (exeTargetName tg)
+ rawSystem (projdir </> "dist-coolbal/bin" </> filename) args
+ >>= exitWith
+
checkExitCode :: String -> ExitCode -> IO ()
checkExitCode _ ExitSuccess = return ()
checkExitCode procname (ExitFailure c) =
@@ -106,7 +132,47 @@ escapeFileName =
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 ""
+ (_, n) | n <= 0xFF -> '!' : leftPad 2 '0' (showHex n "")
+ | n <= 0xFFFF -> '!' : 'u' : leftPad 4 '0' (showHex n "")
+ | n <= 0xFFFFFF -> '!' : 'U' : leftPad 6 '0' (showHex n "")
| otherwise -> error "Super-high unicode?")
+ where
+ leftPad n c s = replicate (max 0 (n - length s)) c ++ s
+
+maybeModificationTime' :: FilePath -> IO UTCTime
+maybeModificationTime' path = maybeModificationTime path >>= \case
+ Just tm -> return tm
+ Nothing -> die ("File not found: '" ++ path ++ "'")
+
+maybeModificationTime :: FilePath -> IO (Maybe UTCTime)
+maybeModificationTime path =
+ catchIOError (Just <$> getModificationTime path) (\_ -> return Nothing)
+
+findSourceFile' :: [FilePath] -> [String] -> IO FilePath
+findSourceFile' ds m = findSourceFile ds m >>= \case
+ Just fp -> return fp
+ Nothing -> die ("Module not found in source directories: " ++ intercalate "." m)
+
+findSourceFile :: [FilePath] -> [String] -> IO (Maybe FilePath)
+findSourceFile dirs modname = findFile dirs (foldr (</>) "" modname ++ ".hs")
+
+findFile' :: [FilePath] -> FilePath -> IO FilePath
+findFile' ds fname = findFile ds fname >>= \case
+ Just fp -> return fp
+ Nothing -> die ("File not found in source directories: '" ++ fname ++ "'")
+
+findFile :: [FilePath] -> FilePath -> IO (Maybe FilePath)
+findFile [] _ = return Nothing
+findFile (dir:ds) fname = do
+ ok <- doesFileExist (dir </> fname)
+ if ok then return (Just (dir </> fname))
+ else findFile ds fname
+
+anyNewerThan :: UTCTime -> [IO FilePath] -> IO Bool
+anyNewerThan _ [] = return False
+anyNewerThan reftm (fp:fps) = do
+ fp' <- fp
+ tm <- maybeModificationTime' fp'
+ if tm > reftm
+ then return True
+ else anyNewerThan reftm fps
diff --git a/Coolbal/Target/Executable.hs b/Coolbal/Target/Executable.hs
index 2e62953..6358ab7 100644
--- a/Coolbal/Target/Executable.hs
+++ b/Coolbal/Target/Executable.hs
@@ -34,6 +34,7 @@ makeExeTarget exe plan
, exeTargetDeps = ppDepends planpkg
, exeTargetLanguage = show language
, exeTargetMain = modulePath exe
+ , exeTargetSrcDirs = hsSourceDirs bi
, exeTargetModules = map Module.components (otherModules bi)
, exeTargetFlags = flags
})
diff --git a/Main.hs b/Main.hs
index 0ed4f4c..5cbf592 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,19 +1,22 @@
module Main where
-import Data.List (intercalate)
-import qualified Data.Map.Strict as Map
-import Data.Maybe (catMaybes)
+import Control.Monad (forM_, when)
+import qualified Data.Binary as B
+import Data.Function (on)
+import Data.List (intercalate, groupBy, sortBy)
+import Data.Maybe (catMaybes, fromJust, isJust)
+import Data.Ord (comparing)
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.Directory (createDirectoryIfMissing, removeDirectoryRecursive)
import System.Exit (die)
import System.FilePath ((</>))
import Coolbal.CabalPlan
import Coolbal.Configure (configure)
-import Coolbal.FindSpec
+import Coolbal.FindRoot
import Coolbal.Options
import Coolbal.Target
import Coolbal.Target.Executable (makeExeTarget)
@@ -27,7 +30,7 @@ checkCompatibleSpec pd
compatibleTargets :: PackageDescription -> CabalPlan -> [AnyTarget]
compatibleTargets pd plan =
- catMaybes (map (\e -> AnyTarget <$> makeExeTarget e plan) (PD.executables pd))
+ catMaybes (map (\e -> AnyTargetExe <$> makeExeTarget e plan) (PD.executables pd))
parseCabalPlan' :: FoundCabalSpec -> IO CabalPlan
parseCabalPlan' foundSpec =
@@ -35,6 +38,26 @@ parseCabalPlan' foundSpec =
>>= maybe (die "Cabal plan.json not found; make sure to run 'cabal build' beforehand")
return
+readCachedTargets :: (AnyTarget -> Bool) -> IO (FilePath, [AnyTarget], [(String, [AnyTarget])])
+readCachedTargets predicate = do
+ FoundRootDir rootdir <- findDist
+ allTargets <- B.decodeFile (rootdir </> "dist-coolbal/targets.bin")
+ let targets = filter predicate allTargets
+ targetsForName = map ((,) <$> fst . head <*> map snd)
+ $ groupBy ((==) `on` fst)
+ $ sortBy (comparing fst)
+ $ concat
+ [[(useAnyTarget targetName t, t), (useAnyTarget targetNameQualified t, t)]
+ | t <- targets]
+ return (rootdir, targets, targetsForName)
+
+targetsToBuild :: [(String, [AnyTarget])] -> String -> IO [AnyTarget]
+targetsToBuild targetsForName name =
+ case lookup name targetsForName of
+ Nothing -> die ("Target not found: '" ++ name ++ "'")
+ Just [t] -> return [t]
+ Just _ -> die ("Ambiguous target name: '" ++ name ++ "'")
+
doConfigure :: IO ()
doConfigure = do
foundSpec <- findCabalSpec
@@ -42,10 +65,13 @@ doConfigure = do
checkCompatibleSpec pd
plan <- parseCabalPlan' foundSpec
-- print pd
- let names = map (useAnyTarget (\t -> targetName t ++ " (" ++ targetNameQualified t ++ ")"))
- (compatibleTargets pd plan)
+ let targets = compatibleTargets pd plan
+ names = map (useAnyTarget (\t -> targetName t ++ " (" ++ targetNameQualified t ++ ")")) targets
putStrLn ("Supported targets: " ++ intercalate ", " names)
+ createDirectoryIfMissing True (foundcsRootDir foundSpec </> "dist-coolbal")
+ B.encodeFile (foundcsRootDir foundSpec </> "dist-coolbal/targets.bin") targets
+
doClean :: IO ()
doClean = do
foundSpec <- findCabalSpec
@@ -53,21 +79,26 @@ doClean = do
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
+ (rootdir, targets, targetsForName) <- readCachedTargets (const True)
+ toBuild <- maybe (return targets) (targetsToBuild targetsForName) mtarget
+ forM_ toBuild $ useAnyTarget $ \tg -> do
+ old <- targetCheckOld rootdir tg
+ when old $ targetBuild rootdir tg
+
+doRun :: RunOptions -> IO ()
+doRun (RunOptions mtarget args) = do
+ (rootdir, targets, targetsForName) <- readCachedTargets (isJust . useAnyTarget targetExecute)
+ toBuild <- maybe (return targets) (targetsToBuild targetsForName) mtarget
+ case toBuild of
+ [tg] -> do
+ useAnyTarget (\tg' -> do old <- targetCheckOld rootdir tg'
+ when old $ targetBuild rootdir tg'
+ -- when (not old) $ putStrLn "Up to date"
+ fromJust (targetExecute tg') rootdir args)
+ tg
+
+ _ -> do
+ die "Cannot determine which target to run, multiple executables found"
main :: IO ()
main = do
@@ -76,3 +107,4 @@ main = do
Configure -> doConfigure
Clean -> doClean
Build opts -> doBuild opts
+ Run opts -> doRun opts
diff --git a/coolbal.cabal b/coolbal.cabal
index 7ddf99c..70e6c46 100644
--- a/coolbal.cabal
+++ b/coolbal.cabal
@@ -13,7 +13,7 @@ executable coolbal
Coolbal.CabalPlan
Coolbal.Configure
Coolbal.Directory
- Coolbal.FindSpec
+ Coolbal.FindRoot
Coolbal.Options
Coolbal.Target
Coolbal.Target.Executable
@@ -29,12 +29,12 @@ executable coolbal
byteslice,
array-chunks,
optparse-applicative >= 0.16.1.0 && < 0.17,
- containers >= 0.6.2.1 && < 0.7
+ time
+ -- 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
+ -- text >= 1.2.4.1 && < 1.3
hs-source-dirs: .
default-language: Haskell2010
ghc-options: -Wall -O2 -threaded
--
cgit v1.2.3-70-g09d2