Initial

1 files changed, 61 insertions, 0 deletions

diff --git a/Coolbal/FindSpec.hs b/Coolbal/FindSpec.hs
new file mode 100644
index 0000000..ce9ab45
--- /dev/null
+++ b/Coolbal/FindSpec.hs
@@ -0,0 +1,61 @@
+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'