diff --git a/hi.cabal b/hi.cabal --- a/hi.cabal +++ b/hi.cabal @@ -1,5 +1,5 @@ name: hi -version: 0.0.6 +version: 0.0.7 synopsis: Generate scaffold for cabal project license: BSD3 license-file: LICENSE @@ -53,13 +53,13 @@ exposed-modules: Hi Hi.Config - Hi.Context Hi.Directory Hi.FilePath - Hi.Flag + Hi.Git Hi.Option Hi.Template Hi.Types + Hi.Utils Hi.Version ghc-options: -Wall @@ -113,9 +113,11 @@ , HUnit , bytestring , directory + , filepath , hspec >= 1.7.2 , parsec , process + , split , template == 0.2.* , temporary , text diff --git a/src/Hi.hs b/src/Hi.hs --- a/src/Hi.hs +++ b/src/Hi.hs @@ -1,37 +1,44 @@ -{-# LANGUAGE NamedFieldPuns #-} module Hi ( run + , process ) where -import Hi.Context (context) +import Hi.Directory (inDirectory) import Hi.FilePath (rewritePath) +import qualified Hi.Git as Git import Hi.Template (readTemplates) import Hi.Types +import Hi.Utils import Control.Applicative +import Control.Monad import Data.List (isSuffixOf) +import Data.Maybe (fromJust) import qualified Data.Text as T import qualified Data.Text.Lazy as LT -import Data.Text.Template (substitute) +import Data.Text.Template (Context, substitute) import System.Directory (createDirectoryIfMissing) import System.FilePath (dropFileName) +import System.Process (system) +-- | Run 'hi'. +run :: [Option] -> IO () +run options = do + putStrLn $ "Creating new project from repository: " ++ Git.expandUrl repository + writeFiles =<< showFileList =<< process options <$> readTemplates repository + postProcess options + where + repository = fromJust $ lookupArg "repository" options + +-- |Write given 'Files' to filesystem. writeFiles :: Files -> IO () writeFiles = mapM_ (uncurry write) where write :: FilePath -> String -> IO () - write path content = do - createDirectoryIfMissing True $ dropFileName path - writeFile path content - -process :: InitFlags -> Files -> Files -process initFlags files = map go $ filter isTemplate files - where - isTemplate (path,_) = ".template" `isSuffixOf` path - go (path, content) = (rewritePath initFlags path, substitute' content) - substitute' t = LT.unpack $ substitute (T.pack t) (context initFlags) + write path content = createDirectoryIfMissing True (dropFileName path) >> writeFile path content +-- | Show 'Files' to stdout. showFileList :: Files -> IO Files showFileList files = do mapM_ (showFile . fst) files @@ -39,11 +46,29 @@ where showFile :: FilePath -> IO () showFile path = putStrLn $ " " ++ green "create" ++ " " ++ path + green :: String -> String + green x = "\x1b[32m" ++ x ++ "\x1b[0m" -green :: String -> String -green x = "\x1b[32m" ++ x ++ "\x1b[0m" +-- |Process given 'Files' and return result. it does +-- +-- 1. rewrite path +-- +-- 2. substitute arguments +process :: [Option] -> Files -> Files +process options files = map go $ filter (isTemplate . fst) files + where + isTemplate path = ".template" `isSuffixOf` path + go (path, content) = (rewritePath options path, substitute' content) + substitute' text = LT.unpack $ substitute (T.pack text) (context options) -run :: InitFlags -> IO () -run initFlags@(InitFlags {repository}) = do - putStrLn $ "Creating new project from repository: " ++ repository - writeFiles =<< showFileList =<< process initFlags <$> readTemplates repository +-- | Return 'Context' obtained by given 'Options' +context :: [Option] -> Context +context options x = T.pack (fromJust $ lookup (T.unpack x) [(k,v) | (Arg k v) <- options]) + +postProcess :: [Option] -> IO () +postProcess options = do + when (InitializeGitRepository `elem` options) $ + -- TODO This wont' work unless template has `package-name` as root dir. + inDirectory (fromJust $ lookupArg "packageName" options) $ + void $ system "git init && git add . && git commit -m \"Initial commit\"" + return () diff --git a/src/Hi/Config.hs b/src/Hi/Config.hs --- a/src/Hi/Config.hs +++ b/src/Hi/Config.hs @@ -10,11 +10,20 @@ import Text.Parsec import Text.Parsec.String +-- | Parse config file and return 'Option's. +parseConfig :: String -> [(String, String)] +parseConfig x = case parse configFile "ERROR" x of -- TODO Error message + Left l -> error $ show l + Right xs -> xs + +configFile :: Parser [(String, String)] +configFile = catMaybes <$> many line <* eof + sep :: Parser Char sep = char ':' name :: Parser String -name = many (oneOf $ ['a'..'z'] ++ ['A'..'Z']) +name = many (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['-']) eol :: Parser Char eol = newline <|> (eof >> return '\n') @@ -36,11 +45,3 @@ v <- many (noneOf "\n") eol return (n, v) - -configFile :: Parser [(String, String)] -configFile = catMaybes <$> many line <* eof - -parseConfig :: String -> [Arg] -parseConfig x = case parse configFile "ERROR" x of -- TODO Error message - Left l -> error $ show l - Right xs -> map (uncurry Val) xs diff --git a/src/Hi/Context.hs b/src/Hi/Context.hs deleted file mode 100644 --- a/src/Hi/Context.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -module Hi.Context - ( - context - ) where - -import Hi.Types -import qualified Data.Text as T -import Data.Text.Template (Context) - --- | Create a 'Context' from 'InitFlags Will raise error if the key was not found. -context :: InitFlags -> Context -context (InitFlags {..}) x = T.pack . lookup' $ T.unpack x - -- TODO FIXME boilerplate - where lookup' "packageName" = packageName - lookup' "moduleName" = moduleName - lookup' "author" = author - lookup' "email" = email - lookup' "repository" = repository - lookup' "year" = year - lookup' k = error $ "Key is not defined: " ++ k diff --git a/src/Hi/FilePath.hs b/src/Hi/FilePath.hs --- a/src/Hi/FilePath.hs +++ b/src/Hi/FilePath.hs @@ -3,25 +3,28 @@ rewritePath ) where +import Hi.Template (untemplate) import Hi.Types -import Hi.Template (untemplate) +import Hi.Utils + import Data.List -import Data.List.Split (splitOn) -import System.FilePath (joinPath) +import Data.List.Split (splitOn) +import Data.Maybe (fromJust) +import System.FilePath (joinPath) -- | Convert given path to the destination path, with given options. -rewritePath :: InitFlags -> FilePath -> FilePath -rewritePath InitFlags {moduleName=m, packageName=p} = +rewritePath :: [Option] -> FilePath -> FilePath +rewritePath options = rename1 . rename2 . untemplate where - rename1 = replace "package-name" p - rename2 = replace "ModuleName" (toDir m) + rename1 = replace "package-name" $ fromJust $ lookupArg "packageName" options + rename2 = replace "ModuleName" $ toDir . fromJust $ lookupArg "moduleName" options -- | Convert module name to path -- @ -- toDir "Foo.bar" # => "Foo/Bar" -- @ -toDir :: String -> String +toDir :: String -> FilePath toDir = joinPath . splitOn "." replace :: Eq a => [a] -> [a] -> [a] -> [a] diff --git a/src/Hi/Flag.hs b/src/Hi/Flag.hs deleted file mode 100644 --- a/src/Hi/Flag.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Hi.Flag - ( - extractInitFlags - ) where - -import Hi.Types - --- | Extract 'InitFlags' from a list of 'Arg' -extractInitFlags :: [Arg] -> InitFlags -extractInitFlags args = InitFlags { packageName = lookupPackageName - , moduleName = lookupModuleName - , author = lookupAuthor - , email = lookupEmail - , repository = lookupRepository - , year = lookupYear - } - where - lookupPackageName = lookup' "packageName" - lookupModuleName = lookup' "moduleName" - lookupAuthor = lookup' "author" - lookupEmail = lookup' "email" - lookupRepository = lookup' "repository" - lookupYear = lookup' "year" - lookup' label = case lookup label $ [(l, v) | (Val l v) <- args] of - Just v -> v - Nothing -> if label == "repository" - then defaultRepo - else error $ errorMessageFor label - errorMessageFor l = concat [ "Could not find option: " - , l - , "\n (Run with no arguments to see usage)" - ] - -defaultRepo :: String -defaultRepo = "git://github.com/fujimura/hi-hspec.git" diff --git a/src/Hi/Git.hs b/src/Hi/Git.hs new file mode 100644 --- /dev/null +++ b/src/Hi/Git.hs @@ -0,0 +1,30 @@ +module Hi.Git + ( + clone + , lsFiles + , expandUrl + ) where + +import Hi.Types +import Hi.Utils + +import Control.Applicative +import Data.List (isPrefixOf) +import System.Exit (ExitCode) +import System.Process (readProcess, system) + +expandUrl :: String -> String +expandUrl url = if "gh:" `isPrefixOf` url + then expand url + else url + where expand (_:_:_:xs) = "git@github.com:" ++ xs ++ ".git" + +-- | Clone given repository to current directory +clone :: String -> IO ExitCode +clone repoUrl = do + _ <- system $ "git clone --no-checkout --quiet --depth=1 " ++ repoUrl ++ " " ++ "./" + system "git checkout HEAD --quiet" + +-- | Return file list by `git ls-files` +lsFiles :: IO [String] +lsFiles = lines <$> readProcess "git" ["ls-files"] [] diff --git a/src/Hi/Option.hs b/src/Hi/Option.hs --- a/src/Hi/Option.hs +++ b/src/Hi/Option.hs @@ -2,54 +2,102 @@ module Hi.Option ( - getInitFlags + getOptions , getMode + , options + , usage ) where -import Control.Applicative -import Data.Maybe (fromMaybe) -import Data.Time.Calendar (toGregorian) -import Data.Time.Clock (getCurrentTime, utctDay) -import Hi.Config (parseConfig) -import Hi.Flag (extractInitFlags) +import Hi.Config (parseConfig) import Hi.Types -import System.Console.GetOpt -import System.Directory (getHomeDirectory, doesFileExist) -import System.Environment (getArgs) -import System.FilePath (joinPath) +import Hi.Utils +import Control.Applicative +import Data.Char (isUpper, toLower) +import Data.List (intercalate) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Time.Calendar (toGregorian) +import Data.Time.Clock (getCurrentTime, utctDay) +import System.Console.GetOpt +import System.Directory (doesFileExist, getHomeDirectory) +import qualified System.Environment +import System.FilePath (joinPath) -- | Available options. -options :: [OptDescr Arg] +options :: [OptDescr Option] options = - [ Option ['p'] ["package-name"](ReqArg (Val "packageName") "package-name") "Name of package" - , Option ['m'] ["module-name"] (ReqArg (Val "moduleName") "Module.Name") "Name of Module" - , Option ['a'] ["author"] (ReqArg (Val "author") "NAME") "Name of the project's author" - , Option ['e'] ["email"] (ReqArg (Val "email") "EMAIL") "Email address of the maintainer" - , Option ['r'] ["repository"] (ReqArg (Val "repository") "REPOSITORY") "Template repository(optional)" - , Option ['v'] ["version"] (NoArg Version) "Show version number" - , Option [] ["no-configuration-file"] (NoArg NoConfigurationFile) "Run without configuration file" - , Option [] ["configuration-file"] (ReqArg (Val "configFile") "CONFIGFILE") "Run with configuration file" + [ Option ['m'] ["module-name"] (ReqArg (Arg "moduleName" ) "Module.Name" ) "Name of Module" + , Option ['p'] ["package-name"] (ReqArg (Arg "packageName") "package-name") "Name of package ( optional )" + , Option ['a'] ["author"] (ReqArg (Arg "author" ) "NAME" ) "Name of the project's author" + , Option ['e'] ["email"] (ReqArg (Arg "email" ) "EMAIL" ) "Email address of the maintainer" + , Option ['r'] ["repository"] (ReqArg (Arg "repository" ) "REPOSITORY" ) "Template repository ( optional )" + , Option [] ["configuration-file"] (ReqArg (Arg "configFile" ) "CONFIGFILE" ) "Run with configuration file" + , Option ['v'] ["version"] (NoArg Version) "Show version number" + , Option [] ["initialize-git-repository"] (NoArg InitializeGitRepository) "Initialize with git repository" + , Option ['h'] ["help"] (NoArg Help) "Display this help and exit" ] --- | Returns 'InitFlags'. -getInitFlags :: IO InitFlags -getInitFlags = do - mode <- getMode - case mode of - Run -> runWithConfigurationFile - RunWithNoConfigurationFile -> runWithNoConfigurationFile - _ -> error "Unexpected run mode" +toOption :: (String, String) -> Maybe Option +toOption (key, value) = maybe err ok $ key `lookupOption` options where - runWithNoConfigurationFile = getInitFlags' =<< getArgs - runWithConfigurationFile = do - xs <- parseArgs <$> getArgs + err = error $ "Invalid options \"" ++ key ++ "\" was specified" + ok (Option _ _ argDescr _) = toOption' argDescr value + lookupOption :: String -> [OptDescr Option] -> Maybe (OptDescr Option) + lookupOption k opts = k `lookup` map (\x@(Option _ (longOpt:_) _ _) -> (longOpt,x)) opts + toOption' :: ArgDescr Option -> String -> Maybe Option + toOption' (NoArg opt) "True" = Just opt + toOption' (NoArg _) _ = Nothing + toOption' (ReqArg f _) val = Just $ f val + +-- | Returns 'Options'. +getOptions :: IO [Option] +getOptions = handleError + <$> validateOptions + =<< addDefaultRepo + =<< addPackageNameIfMissing + =<< addOptionsFromConfigFile + =<< addYear + =<< parseOptions + <$> System.Environment.getArgs + where + addYear :: [Option] -> IO [Option] + addYear vals = do y <- getCurrentYear - ys <- do + return $ vals ++ [y] + + addOptionsFromConfigFile :: [Option] -> IO [Option] + addOptionsFromConfigFile vals = do + repo <- do mfile <- readFileMaybe =<< getConfigFileName - return $ fromMaybe [] (parseConfig <$> mfile) - return $ extractInitFlags (xs ++ ys ++ [y]) + return $ mapMaybe toOption $ fromMaybe [] (parseConfig <$> mfile) + return $ vals ++ repo + addDefaultRepo :: [Option] -> IO [Option] + addDefaultRepo vals = return $ vals ++ [Arg "repository" defaultRepo] + + addPackageNameIfMissing :: [Option] -> IO [Option] + addPackageNameIfMissing vals = + return $ case ("packageName" `lookupArg` vals, "moduleName" `lookupArg` vals) of + (Nothing, Just m) -> vals ++ [Arg "packageName" $ (removeDup . hyphenize) m] + _ -> vals + where + removeDup [] = [] + removeDup [x] = [x] + removeDup ('-':'-':xs) = removeDup('-':xs) + removeDup (x:xs) = x: removeDup xs + hyphenize [] = [] + hyphenize (x:xs) = hyphenize' $ toLower x:xs + hyphenize' [] = [] + hyphenize' (x:[]) = [toLower x] + hyphenize' (x:xs) | isUpper x = '-':toLower x:hyphenize' xs + | x == '.' = '-':hyphenize' xs + | otherwise = x:hyphenize' xs + + handleError :: Either [String] [Option] -> IO [Option] + handleError result = case result of + Left errors -> error $ (intercalate "\n" errors) ++ "\n (Run with no arguments to see usage)" + Right x -> return x + -- | Return file contents in Maybe String or Nothing. -- readFileMaybe :: FilePath -> IO (Maybe String) @@ -57,31 +105,35 @@ e <- doesFileExist f if e then Just <$> readFile f else return Nothing --- | Returns `InitFlags` from given args, attaching year if it's missing in --- args -getInitFlags' :: [String] -> IO InitFlags -getInitFlags' args = do - y <- getCurrentYear - return $ extractInitFlags $ (parseArgs $ args) ++ [y] - -- | Returns 'Mode'. getMode :: IO Mode getMode = do - go . parseArgs <$> getArgs + args <- parseOptions <$> System.Environment.getArgs + return $ modeFor args where - go [] = Run - go (Version:_) = ShowVersion - go (NoConfigurationFile:_) = RunWithNoConfigurationFile - go (_:xs) = go xs + modeFor args | Help `elem` args = ShowHelp + | Version `elem` args = ShowVersion + | otherwise = Run -parseArgs :: [String] -> [Arg] -parseArgs argv = - case getOpt Permute options argv of - ([],_,errs) -> error $ concat errs ++ usageInfo header options - (o,_,[] ) -> o - (_,_,errs ) -> error $ concat errs ++ usageInfo header options +parseOptions :: [String] -> [Option] +parseOptions argv = + case getOpt Permute options argv of + ([],_,errs) -> error $ concat errs ++ usage + (o,_,[] ) -> o + (_,_,errs ) -> error $ concat errs ++ usage + +usage :: String +usage = usageInfo header options ++ footer where - header = "Usage: hi [OPTION...]" + header = "Usage: hi [OPTION...]\n" ++ + "Generate a haskell project based on a template from github.\n" + footer = "\n" ++ + "If repository is not provided, it defaults to the repository at\n" ++ + defaultRepo ++ ".\n" ++ + "\n" ++ + "Example:\n" ++ + " hi --module-name 'Foo.Bar' " ++ + "--author 'you' --email 'you@gmail.com'" defaultConfigFilePath :: IO FilePath defaultConfigFilePath = do @@ -91,15 +143,37 @@ defaultConfigFileName :: FilePath defaultConfigFileName = ".hirc" +defaultRepo :: String +defaultRepo = "git://github.com/fujimura/hi-hspec.git" + getConfigFileName :: IO FilePath -getConfigFileName = do - go =<< parseArgs <$> getArgs +getConfigFileName = go =<< parseOptions <$> System.Environment.getArgs where go [] = defaultConfigFilePath - go ((Val "configFile" p):_) = return p + go ((Arg "configFile" p):_) = return p go (_:xs) = go xs -getCurrentYear :: IO Arg +getCurrentYear :: IO Option getCurrentYear = do (y,_,_) <- (toGregorian . utctDay) <$> getCurrentTime - return $ (Val "year" $ show y) + return (Arg "year" $ show y) + +-- | Validate given options +validateOptions :: [Option] -> Either [Error] [Option] +validateOptions values = case mapMaybe ($ values) validations of + [] -> Right values + errors -> Left errors + +validations ::[[Option] -> Maybe String] +validations = [ hasKey "packageName" + , hasKey "moduleName" + , hasKey "author" + , hasKey "email" + , hasKey "repository" + , hasKey "year" + ] + +hasKey :: String -> [Option] -> Maybe String +hasKey k options = case lookupArg k options of + Just _ -> Nothing + Nothing -> Just $ "Could not find option: " ++ k diff --git a/src/Hi/Template.hs b/src/Hi/Template.hs --- a/src/Hi/Template.hs +++ b/src/Hi/Template.hs @@ -4,32 +4,22 @@ , untemplate ) where -import Hi.Directory (inTemporaryDirectory) +import Hi.Directory (inTemporaryDirectory) +import qualified Hi.Git as Git import Hi.Types -import Control.Applicative -import Data.List.Split (splitOn) -import System.Exit (ExitCode) -import System.Process (system, readProcess) -readTemplates :: String -> IO Files +import Data.List.Split (splitOn) + +-- | Read templates in given 'FilePath' +readTemplates :: FilePath -> IO Files readTemplates repo = inTemporaryDirectory "hi" $ do -- TODO Handle error - _ <- cloneRepo repo - paths <- lsFiles + _ <- Git.clone $ Git.expandUrl repo + paths <- Git.lsFiles contents <- mapM readFile paths return $ zip paths contents -- | Remove \".template\" from 'FilePath' untemplate :: FilePath -> FilePath untemplate = head . splitOn ".template" - --- | Clone given repository to current directory -cloneRepo :: String -> IO ExitCode -cloneRepo repoUrl = do - _ <- system $ "git clone --no-checkout --quiet --depth=1 " ++ repoUrl ++ " " ++ "./" - system "git checkout HEAD --quiet" - --- | Return file list by `git ls-files` -lsFiles :: IO [String] -lsFiles = lines <$> readProcess "git" ["ls-files"] [] diff --git a/src/Hi/Types.hs b/src/Hi/Types.hs --- a/src/Hi/Types.hs +++ b/src/Hi/Types.hs @@ -1,32 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} module Hi.Types - ( - Flag - , InitFlags(..) - , Label - , Arg(..) + ( Label + , Option(..) , Mode(..) , Files + , Error ) where type Files = [(FilePath, String)] -type Flag = String - -data InitFlags = - InitFlags { packageName :: !Flag - , moduleName :: !Flag - , author :: !Flag - , email :: !Flag - , repository :: !Flag - , year :: !Flag - } deriving(Eq, Show) +type Error = String type Label = String --- | Arguments. -data Arg = Version | NoConfigurationFile | Val Label String deriving(Eq, Show) +-- | Options +data Option = Version | Help | InitializeGitRepository | Arg Label String deriving(Eq, Show) -- | Run mode. -data Mode = ShowVersion | Run | RunWithNoConfigurationFile deriving(Eq, Show) +data Mode = ShowVersion | ShowHelp | Run deriving(Eq, Show) diff --git a/src/Hi/Utils.hs b/src/Hi/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Hi/Utils.hs @@ -0,0 +1,6 @@ +module Hi.Utils where + +import Hi.Types + +lookupArg :: String -> [Option] -> Maybe String +lookupArg key xs = lookup key [(k,v) | (Arg k v) <- xs] diff --git a/src/Hi/Version.hs b/src/Hi/Version.hs --- a/src/Hi/Version.hs +++ b/src/Hi/Version.hs @@ -4,4 +4,4 @@ ) where version :: String -version = "0.0.6" +version = "0.0.7" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,7 @@ module Main where import Hi (run) -import Hi.Option (getInitFlags, getMode) +import Hi.Option (getOptions, getMode, usage) import Hi.Types import Hi.Version (version) @@ -9,6 +9,6 @@ main = do mode <- getMode case mode of - ShowVersion -> putStrLn version - RunWithNoConfigurationFile -> run =<< getInitFlags - Run -> run =<< getInitFlags + ShowHelp -> putStrLn usage + ShowVersion -> putStrLn version + _ -> run =<< getOptions