summaryrefslogtreecommitdiff
path: root/Coolbal
diff options
context:
space:
mode:
Diffstat (limited to 'Coolbal')
-rw-r--r--Coolbal/FindRoot.hs83
-rw-r--r--Coolbal/FindSpec.hs61
-rw-r--r--Coolbal/Options.hs10
-rw-r--r--Coolbal/Target.hs94
-rw-r--r--Coolbal/Target/Executable.hs1
5 files changed, 174 insertions, 75 deletions
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
})
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-22 06:15:39 +0100