Last active
August 29, 2015 14:01
-
-
Save bheklilr/3e8875f0e3cb60184f42 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| {-# LANGUAGE DeriveFunctor #-} | |
| {-# LANGUAGE DeriveFoldable #-} | |
| {-# LANGUAGE DeriveTraversable #-} | |
| module Main where | |
| import System.Directory | |
| import System.FilePath | |
| import System.Environment | |
| import Data.List (intercalate, isPrefixOf) | |
| import Data.Maybe (catMaybes) | |
| import qualified Data.Foldable as F | |
| import qualified Data.Traversable as T | |
| import Control.Monad (void, forM, liftM2, when) | |
| import Control.Applicative ((<$>)) | |
| main :: IO () | |
| main = do | |
| args <- getArgs | |
| case args of | |
| (root:_) -> updateProject root | |
| _ -> return () | |
| -- A quick tree structure for mimicking our files on disk | |
| data Tree a | |
| = Elem a | |
| | Branch a [Tree a] | |
| deriving | |
| ( Eq | |
| , Ord | |
| , Show | |
| , Read | |
| , Functor | |
| , F.Foldable | |
| , T.Traversable | |
| ) | |
| -- I like these combinators, these specifically work on (a -> Bool) functions | |
| (<&&>) :: Monad m => m Bool -> m Bool -> m Bool | |
| (<&&>) = liftM2 (&&) | |
| (<||>) :: Monad m => m Bool -> m Bool -> m Bool | |
| (<||>) = liftM2 (||) | |
| -- Gets every path in a given tree that is a .hs file, building up the full | |
| -- paths as it goes because why do that in two steps? | |
| getDirectoryTree :: FilePath -> IO (Tree FilePath) | |
| getDirectoryTree filepath = do | |
| -- filter out the current and parent directories | |
| children <- filter ((/= ".") <&&> (/= "..")) <$> getDirectoryContents filepath | |
| root <- forM children $ \child -> do | |
| -- Build the full path | |
| let fullpath = filepath </> child | |
| -- If it's a directory | |
| isDir <- doesDirectoryExist fullpath | |
| if isDir | |
| -- Return it's subtree | |
| then Just <$> getDirectoryTree fullpath | |
| else do | |
| -- If it's a .hs file | |
| let (_, ext) = splitExtension fullpath | |
| return $ if ext `elem` [".hs"] -- Add lhs later | |
| -- Return the full path as a single element | |
| then Just $ Elem fullpath | |
| else Nothing | |
| -- Remove the `Nothing`s | |
| let valid = catMaybes root | |
| return $ Branch filepath valid | |
| -- Create module names from the path. This doesn't check that the file names | |
| -- make valid haskell module names, so watch out | |
| createModuleNames :: Tree FilePath -> Tree (FilePath, String) | |
| createModuleNames = fmap createModuleName | |
| where | |
| createModuleName path = | |
| let parts = splitDirectories path | |
| (filename, _) = splitExtension $ last parts | |
| newMod = intercalate "." $ filter (not . null) [intercalate "." $ init parts, filename] | |
| in (path, newMod) | |
| -- Strips out the current module name and replaces it with the new one if it | |
| -- detects a valid module. Current only supports files that start with "module" | |
| updateModuleName :: String -> String -> Maybe String | |
| updateModuleName newMod modTxt = (("module " ++ newMod) ++) <$> removeHeader modTxt | |
| where | |
| removeHeader :: String -> Maybe String | |
| removeHeader txt = | |
| if "module " `isPrefixOf` txt | |
| -- length "module " == 7 | |
| then Just $ dropWhile ((/= ' ') <&&> (/= ')') <&&> (/= '\n')) $ drop 7 txt | |
| else Nothing | |
| -- Updates the module name in a file, creating a backup before potentially | |
| -- breaking something | |
| updateModuleNameInFile :: FilePath -> String -> IO () | |
| updateModuleNameInFile file newMod = do | |
| isFile <- doesFileExist file | |
| when isFile $ do | |
| contents <- readFile file | |
| let updated = updateModuleName newMod contents | |
| case updated of | |
| Just newContents -> do | |
| writeFile (file <.> "bak") contents | |
| writeFile file newContents | |
| Nothing -> return () | |
| -- Get the directory tree, clean up the paths, assign module names, and write | |
| -- them out. Thanks Traversable for giving me forM for free | |
| updateProject :: FilePath -> IO () | |
| updateProject root = do | |
| dirTree <- fmap (makeRelative root) <$> getDirectoryTree root | |
| let modNames = createModuleNames dirTree | |
| void $ T.forM modNames $ uncurry (updateModuleNameInFile . combine root) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment