Use System.FilePath Library (#50)

Author: jhb563

haskellings.cabal

@@ -39,6 +39,7 @@ library
     , containers
     , directory
     , extra
+    , filepath
     , fsnotify
     , tasty
     , tasty-hunit
@@ -71,6 +72,7 @@ test-suite haskellings-tests
       base >=4.7 && <5
     , containers
     , directory
+    , filepath
     , haskellings
     , hspec
     , HUnit
@@ -87,6 +89,7 @@ test-suite unit-tests
       base >=4.7 && <5
     , containers
     , directory
+    , filepath
     , haskellings
     , tasty
     , tasty-hunit

haskellings.nix

@@ -1,5 +1,5 @@
 { mkDerivation, aeson, ansi-terminal, base, containers, directory
-, extra, fsnotify, hspec, HUnit, lib, process, tasty, tasty-hunit
+, extra, filepath, fsnotify, hspec, HUnit, lib, process, tasty, tasty-hunit
 , time, yaml
 }:
 mkDerivation {
@@ -10,12 +10,12 @@ mkDerivation {
   isExecutable = true;
   doCheck = false;
   libraryHaskellDepends = [
-    aeson ansi-terminal base containers directory extra fsnotify
+    aeson ansi-terminal base containers directory extra filepath fsnotify
     process tasty tasty-hunit time yaml
   ];
   executableHaskellDepends = [ base containers extra ];
   testHaskellDepends = [
-    base containers directory hspec HUnit tasty tasty-hunit time
+    base containers directory filepath hspec HUnit tasty tasty-hunit time
   ];
   homepage = "https://github.com/MondayMorningHaskell/haskellings#readme";
   license = lib.licenses.bsd3;

src/Config.hs

@@ -14,6 +14,7 @@ import           Data.Yaml           (decodeFileEither)
 import           System.Console.ANSI
 import           System.Directory
 import           System.Environment  (lookupEnv)
+import           System.FilePath     (takeDirectory, takeFileName, (</>))
 import           System.IO
 
 import           DirectoryUtils
@@ -44,7 +45,7 @@ haskellingsVersion :: String
 haskellingsVersion = "0.8.0.0"
 
 mainProjectExercisesDir :: String
-mainProjectExercisesDir = makeRelative "exercises"
+mainProjectExercisesDir = "exercises"
 
 -- A listing of packages required by exercises, so we can use them
 -- to filter Stack snapshots
@@ -151,12 +152,12 @@ loadBaseConfigPaths :: IO (Either ConfigError (FilePath, FilePath, FilePath))
 loadBaseConfigPaths = do
   projectRoot' <- findProjectRoot
   case projectRoot' of
-    Nothing -> return (Left NoProjectRootError)
+    Nothing          -> return (Left NoProjectRootError)
     Just projectRoot -> loadBaseConfigPathsWithProjectRoot projectRoot
 
 loadBaseConfigPathsWithProjectRoot :: FilePath -> IO (Either ConfigError (FilePath, FilePath, FilePath))
 loadBaseConfigPathsWithProjectRoot projectRoot = do
-  let configPath = projectRoot `pathJoin` configFileName
+  let configPath = projectRoot </> configFileName
   configExists <- doesFileExist configPath
   baseConfig <- if configExists
     then do
@@ -185,17 +186,17 @@ findGhc = do
     Just ghcSearchDir -> do
       nextDirs <- listDirectory ghcSearchDir
       results <- forM nextDirs $ \subPath -> do
-        let fullPath = ghcSearchDir `pathJoin` subPath
+        let fullPath = ghcSearchDir </> subPath
         subContents <- safeListDirectory fullPath
-        return $ fmap (pathJoin fullPath) (find ghcPred subContents)
+        return $ fmap (fullPath </>) (find ghcPred subContents)
       case catMaybes results of
         []       -> return Nothing
-        (fp : _) -> return $ Just (fp `pathJoin` "bin" `pathJoin` "ghc")
+        (fp : _) -> return $ Just (fp </> "bin" </> "ghc")
 
 -- Determine a directory is a valid "ghc" directory.
 -- It must start with "ghc" and end with our version number.
 ghcPred :: FilePath -> Bool
-ghcPred path = isPrefixOf "ghc" (basename path) && isSuffixOf ghcVersionNumber path
+ghcPred path = isPrefixOf "ghc" (takeFileName path) && isSuffixOf ghcVersionNumber path
 
 findStackPackageDb :: IO (Maybe FilePath)
 findStackPackageDb = do
@@ -212,7 +213,7 @@ findStackPackageDb = do
 -- The GHC version path might look like {hash}/8.10.4/lib/x86_64-linux-ghc-8.10.4
 -- We want to get the package path, at {hash}/8.10.4/pkgdb
 pkgPathFromGhcPath :: FilePath -> FilePath
-pkgPathFromGhcPath ghcVersionDir = pathJoin (dropDirectoryLevel (dropDirectoryLevel ghcVersionDir)) "pkgdb"
+pkgPathFromGhcPath ghcVersionDir = takeDirectory (takeDirectory ghcVersionDir) </> "pkgdb"
 
 snapshotPackagePredicate :: FilePath -> IO Bool
 snapshotPackagePredicate fp = if not (ghcVersion `isSuffixOf` fp)
@@ -241,15 +242,15 @@ findStackSnapshotsDir = if isWindows
 findStackSnapshotsDirUnix :: IO (Maybe FilePath)
 findStackSnapshotsDirUnix = do
   homeDir <- getHomeDirectory
-  let dir = homeDir `pathJoin` ".stack" `pathJoin` "snapshots"
+  let dir = homeDir </> ".stack" </> "snapshots"
   returnIfDirExists dir
 
 findStackSnapshotsDirWindows :: IO (Maybe FilePath)
 findStackSnapshotsDirWindows = do
   dir' <- lookupEnv "STACK_ROOT"
   case dir' of
     Nothing  -> return Nothing
-    Just dir -> returnIfDirExists (dir `pathJoin` "snapshots")
+    Just dir -> returnIfDirExists (dir </> "snapshots")
 
 findGhcSearchDir :: IO (Maybe FilePath)
 findGhcSearchDir = if isWindows
@@ -261,9 +262,9 @@ findGhcSearchDirUnix = do
   isCi <- envIsCi
   homeDir <- if isCi
     -- Unintuitively, "/home" is not the same as "~" on Circle CI
-    then return ("/home" `pathJoin` "stackage")
+    then return ("/home" </> "stackage")
     else getHomeDirectory
-  let dir = homeDir `pathJoin` ".stack" `pathJoin` "programs"
+  let dir = homeDir </> ".stack" </> "programs"
   returnIfDirExists dir
 
 findGhcSearchDirWindows :: IO (Maybe FilePath)
@@ -272,5 +273,5 @@ findGhcSearchDirWindows = do
   case localAppDataDir' of
     Nothing -> return Nothing
     Just localAppDataDir -> do
-      let dir = localAppDataDir `pathJoin` "Programs" `pathJoin` "stack"
+      let dir = localAppDataDir </> "Programs" </> "stack"
       returnIfDirExists dir

src/DirectoryUtils.hs

@@ -5,63 +5,12 @@ import           Data.List         (dropWhileEnd, isInfixOf, isSuffixOf)
 import           Data.List.Extra   (takeWhileEnd)
 import qualified Data.Sequence     as S
 import           System.Directory
+import           System.FilePath   (takeDirectory, takeFileName, (</>))
 import           System.Info       (os)
 
 isWindows :: Bool
 isWindows = os `notElem` ["linux", "unix", "darwin"]
 
-basename :: FilePath -> FilePath
-basename fp = takeWhileEnd (\c -> c /= '/' && c /= '\\') trimmedFp
-  where
-    trimmedFp = if isRelativeEnd fp then init fp else fp
-
--- Like doing "cd .." with this filepath
-dropDirectoryLevel :: FilePath -> FilePath
-dropDirectoryLevel fp = init $ dropWhileEnd (\c -> c /= '/' && c /= '\\') trimmedFp
-  where
-    trimmedFp = if isRelativeEnd fp then init fp else fp
-
-makeRelative :: FilePath -> FilePath
-makeRelative path = if isWindows
-  then makeRelativeWindows path
-  else makeRelativeUnix path
-
-makeRelativeWindows :: FilePath -> FilePath
-makeRelativeWindows = makeRelative' '\\'
-
-makeRelativeUnix :: FilePath -> FilePath
-makeRelativeUnix = makeRelative' '/'
-
-makeRelative' :: Char -> FilePath -> FilePath
-makeRelative' delimiter fp = if head fp == delimiter
-  then fp
-  else delimiter : fp
-
-isRelativeEnd :: FilePath -> Bool
-isRelativeEnd "" = False
-isRelativeEnd fp = last fp == '/' || last fp == '\\'
-
-isRelativeBegin :: FilePath -> Bool
-isRelativeBegin "" = False
-isRelativeBegin fp = head fp == '/' || head fp == '\\'
-
-pathJoin :: FilePath -> FilePath -> FilePath
-pathJoin fp1 fp2 = if isWindows
-  then pathJoinWindows fp1 fp2
-  else pathJoinUnix fp1 fp2
-
-pathJoinUnix :: FilePath -> FilePath -> FilePath
-pathJoinUnix = pathJoin' '/'
-
-pathJoinWindows :: FilePath -> FilePath -> FilePath
-pathJoinWindows = pathJoin' '\\'
-
-pathJoin' :: Char -> FilePath -> FilePath -> FilePath
-pathJoin' delimiter fp1 fp2 = case (isRelativeEnd fp1, isRelativeBegin fp2) of
-  (True, True)   -> fp1 ++ tail fp2
-  (False, False) -> fp1 ++ makeRelative' delimiter fp2
-  _              -> fp1 ++ fp2
-
 returnIfDirExists :: FilePath -> IO (Maybe FilePath)
 returnIfDirExists fp = do
   exists <- doesDirectoryExist fp
@@ -74,7 +23,7 @@ searchForDirectoryContaining searchRoot directoryToFind = fpBFS predicate (S.sin
   where
     predicate fp = do
       isDirectory <- doesDirectoryExist fp
-      return $ isDirectory && makeRelative directoryToFind `isSuffixOf` fp
+      return $ isDirectory && directoryToFind == takeFileName fp
 
 -- Given a "file predicate" function
 fpBFS :: (FilePath -> IO Bool) -> S.Seq FilePath -> IO (Maybe FilePath)
@@ -89,7 +38,7 @@ fpBFS predicate searchQueue = case S.viewl searchQueue of
         if currentIsDir
           then do
             contents <- safeListDirectory currentRoot
-            let results = map (pathJoin currentRoot) contents
+            let results = map (currentRoot </>) contents
             fpBFS predicate $ rest S.>< S.fromList results
           else fpBFS predicate rest
 

src/RunCommands.hs

@@ -6,6 +6,7 @@ import           Data.List          (maximumBy)
 import qualified Data.Map           as M
 import           Data.Yaml          (encodeFile)
 import           System.Directory
+import           System.FilePath    ((</>))
 import           System.Process
 
 import           Config
@@ -78,7 +79,7 @@ runConfigureWithProjectRoot projectRoot = do
   ghc <- getLine
   putStrLn "Please enter Stack package DB path (or leave blank): "
   stackPath <- getLine
-  let configPath = projectRoot `pathJoin` configFileName
+  let configPath = projectRoot </> configFileName
   alreadyExists <- doesFileExist configPath
   when alreadyExists $ removeFile configPath
   let config = BaseConfig

src/Utils.hs

@@ -7,6 +7,7 @@ import           Data.List.Extra
 import           Data.Maybe       (fromJust, isJust)
 import           System.Directory
 import           System.Exit
+import           System.FilePath  (takeBaseName, (</>))
 import           System.IO
 import           System.Process
 
@@ -19,7 +20,7 @@ isHaskellFile = isSuffixOf ".hs"
 
 -- Probably a good idea to first check that it is a Haskell file first
 haskellModuleName :: FilePath -> FilePath
-haskellModuleName fp = dropEnd 3 (basename fp)
+haskellModuleName = takeBaseName
 
 haskellFileName :: FilePath -> FilePath
 haskellFileName exName = exName ++ ".hs"
@@ -55,9 +56,9 @@ createExerciseProcess config (ExerciseInfo exerciseName exDirectory exType _) =
     exIsRunnable = exType /= CompileOnly
     exFilename = haskellFileName exerciseName
     root = projectRoot config
-    fullSourcePath = root `pathJoin` exercisesExt config `pathJoin` exDirectory `pathJoin` exFilename
-    genDirPath = root `pathJoin` "/generated_files/" `pathJoin` exDirectory
-    genExecutablePath = genDirPath `pathJoin` haskellModuleName exFilename
+    fullSourcePath = root </> exercisesExt config </> exDirectory </> exFilename
+    genDirPath = root </> "generated_files" </> exDirectory
+    genExecutablePath = genDirPath </> haskellModuleName exFilename
     baseArgs = [fullSourcePath, "-odir", genDirPath, "-hidir", genDirPath]
     execArgs = if exIsRunnable then baseArgs ++ ["-o", genExecutablePath] else baseArgs
     finalArgs = execArgs ++ ["-package-db", packageDb config]
@@ -158,4 +159,4 @@ fileContainsNotDone fullFp = do
     isDoneLine l = (upper . filter (not . isSpace) $ l) == "--IAMNOTDONE"
 
 fullExerciseFp :: FilePath -> FilePath -> ExerciseInfo -> FilePath
-fullExerciseFp projectRoot exercisesExt (ExerciseInfo exName exDir _ _) = projectRoot `pathJoin` exercisesExt `pathJoin` exDir `pathJoin` haskellFileName exName
+fullExerciseFp projectRoot exercisesExt (ExerciseInfo exName exDir _ _) = projectRoot </> exercisesExt </> exDir </> haskellFileName exName

src/Watcher.hs

@@ -4,6 +4,7 @@ import           Control.Concurrent
 import           Control.Monad      (forever, unless, void, when)
 import qualified Data.Map           as M
 import           System.Exit
+import           System.FilePath    (takeFileName, (</>))
 import           System.FSNotify
 import           System.IO          (hIsEOF)
 
@@ -16,8 +17,8 @@ watchExercises :: ProgramConfig -> IO ()
 watchExercises config = runExerciseWatch config allExercises
 
 shouldCheckFile :: ExerciseInfo -> Event -> Bool
-shouldCheckFile (ExerciseInfo exName _ _ _) (Added fp _ _) = basename fp == haskellFileName exName
-shouldCheckFile (ExerciseInfo exName _ _ _) (Modified fp _ _) = basename fp == haskellFileName exName
+shouldCheckFile (ExerciseInfo exName _ _ _) (Added fp _ _) = takeFileName fp == haskellFileName exName
+shouldCheckFile (ExerciseInfo exName _ _ _) (Modified fp _ _) = takeFileName fp == haskellFileName exName
 shouldCheckFile _ _ = False
 
 -- This event should be a modification of one of our exercise files
@@ -50,7 +51,7 @@ runExerciseWatch config (firstEx : restExs) = do
       let conf = defaultConfig { confDebounce = Debounce 1 }
       withManagerConf conf $ \mgr -> do
         signalMVar <- newEmptyMVar
-        stopAction <- watchTree mgr (projectRoot config `pathJoin` exercisesExt config) (shouldCheckFile firstEx)
+        stopAction <- watchTree mgr (projectRoot config </> exercisesExt config) (shouldCheckFile firstEx)
           (processEvent config firstEx signalMVar)
         userInputThread <- forkIO $ forever (watchForUserInput config firstEx)
         takeMVar signalMVar

tests/Main.hs

@@ -4,6 +4,7 @@ import qualified Data.Map           as M
 import           Data.Time
 import           System.Directory
 import           System.Exit
+import           System.FilePath    ((</>))
 import           System.IO
 import           Test.Hspec
 import           Test.HUnit
@@ -21,7 +22,7 @@ main = do
   case loadResult of
     Left _ -> error "Unable to find project root or GHC 8.8.4!"
     Right paths@(root, _, _) -> do
-      createDirectoryIfMissing True (root `pathJoin` "tests" `pathJoin` "test_gen")
+      createDirectoryIfMissing True (root </> "tests" </> "test_gen")
       hspec $ describe "Basic Compile Tests" $ do
         compileTests1 paths
         compileTests2 paths
@@ -38,9 +39,9 @@ main = do
 
 compileBeforeHook :: (FilePath, FilePath, FilePath) -> ExerciseInfo -> FilePath -> IO (String, RunResult)
 compileBeforeHook (projectRoot, ghcPath, packageDb) exInfo outFile = do
-  let fullFp = projectRoot `pathJoin` "tests" `pathJoin` "test_gen" `pathJoin` outFile
+  let fullFp = projectRoot </> "tests" </> "test_gen" </> outFile
   outHandle <- openFile fullFp WriteMode
-  let conf = ProgramConfig projectRoot ghcPath packageDb "/tests/exercises/" stdin outHandle stderr M.empty
+  let conf = ProgramConfig projectRoot ghcPath packageDb ("tests" </> "exercises") stdin outHandle stderr M.empty
   resultExit <- compileAndRunExercise conf exInfo
   hClose outHandle
   programOutput <- readFile fullFp
@@ -237,8 +238,8 @@ beforeWatchHook (projectRoot, ghcPath, stackPackageDb) outFile = do
   copyFile (addFullDirectory "Types1Orig.hs") fullDest1
   copyFile (addFullDirectory "Types2Orig.hs") fullDest2
   -- Build Configuration
-  let fullFp = projectRoot `pathJoin` "tests" `pathJoin` "test_gen" `pathJoin` outFile
-  let fullIn = projectRoot `pathJoin` "tests" `pathJoin` "watcher_tests.in"
+  let fullFp = projectRoot </> "tests" </> "test_gen" </> outFile
+  let fullIn = projectRoot </> "tests" </> "watcher_tests.in"
   outHandle <- openFile fullFp WriteMode
   inHandle <- openFile fullIn ReadMode
   lock1 <- newEmptyMVar
@@ -255,9 +256,9 @@ beforeWatchHook (projectRoot, ghcPath, stackPackageDb) outFile = do
   removeFile fullDest2
   readFile fullFp
   where
-    testExercisesDir = makeRelative ("tests" `pathJoin` "exercises")
-    watcherTypesDir = "tests" `pathJoin` "exercises" `pathJoin` "watcher_types"
-    addFullDirectory = pathJoin (projectRoot `pathJoin` watcherTypesDir)
+    testExercisesDir = "tests" </> "exercises"
+    watcherTypesDir = "tests" </> "exercises" </> "watcher_types"
+    addFullDirectory = (</>) (projectRoot </> watcherTypesDir)
     fullDest1 = addFullDirectory "Types1.hs"
     fullDest2 = addFullDirectory "Types2.hs"
     modifications =
@@ -281,9 +282,9 @@ listTestExercises =
 
 listBeforeHook :: (FilePath, FilePath, FilePath) -> FilePath -> IO String
 listBeforeHook (projectRoot, ghcPath, stackPackageDb) outFile = do
-  let fullFp = projectRoot `pathJoin` "tests" `pathJoin` "test_gen" `pathJoin` outFile
+  let fullFp = projectRoot </> "tests" </> "test_gen" </> outFile
   outHandle <- openFile fullFp WriteMode
-  let conf = ProgramConfig projectRoot ghcPath stackPackageDb ("tests" `pathJoin` "exercises") stdin outHandle stderr M.empty
+  let conf = ProgramConfig projectRoot ghcPath stackPackageDb ("tests" </> "exercises") stdin outHandle stderr M.empty
   listExercises' listTestExercises conf
   hClose outHandle
   readFile fullFp