module-fixer.hs

{-# 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)