1 files changed, 83 insertions, 0 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'