Second

7 files changed, 233 insertions, 102 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
             })
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