Second

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
             })