From e3ab394665c2c308cab6fffb41b3acc66d0ca989 Mon Sep 17 00:00:00 2001 From: Tom Smeding 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-54-g00ecf