diff --git a/hi.cabal b/hi.cabal --- a/hi.cabal +++ b/hi.cabal @@ -1,29 +1,24 @@ -name: hi -version: 0.0.8.2 -synopsis: Generate scaffold for cabal project -license: BSD3 -license-file: LICENSE -author: Fujimura Daisuke -maintainer: me@fujimuradaisuke.com -category: Distribution -build-type: Simple -cabal-version: >=1.8 -homepage: https://github.com/fujimura/hi +name: hi +version: 1.0.0.0 +cabal-version: >=1.8 +build-type: Simple +license: BSD3 +license-file: LICENSE +maintainer: me@fujimuradaisuke.com +homepage: https://github.com/fujimura/hi +bug-reports: https://github.com/fujimura/hi/issues +synopsis: Generate scaffold for cabal project description: This application generates a scaffold for Haskell project from a Git repository. - . This command . - . - > $ hi --package-name "foo-bar-baz" --module-name "Foo.Bar.Baz" --author "Fujimura Daisuke" --email "me@fujimuradaisuke.com" + > $ hi foo-bar-baz . - . will generate: . - . > $ tree . > . @@ -43,100 +38,101 @@ > │ └── BazSpec.hs > └── Spec.hs . - . See for further usage. . - - +category: Distribution +author: Fujimura Daisuke + +source-repository head + type: git + location: https://github.com/fujimura/hi.git + library - exposed-modules: - Hi - Hi.Config - Hi.Directory - Hi.FilePath - Hi.Git - Hi.Option - Hi.Template - Hi.Types - Hi.Utils - Hi.Version - ghc-options: - -Wall - hs-source-dirs: - src - build-depends: - base == 4.* - , bytestring - , directory - , filepath - , parsec - , process - , split - , template == 0.2.* - , temporary-rc >= 1.2.0.3 - , text > 1.0 - , time - + build-depends: + base ==4.*, + ansi-wl-pprint -any, + bytestring -any, + directory -any, + filepath -any, + optparse-applicative >=0.10.0, + parsec -any, + process -any, + split -any, + template ==0.2.*, + temporary >=1.2.0.3, + text >1.0, + time -any + exposed-modules: + Hi + Hi.Cli + Hi.Config + Hi.Directory + Hi.FilePath + Hi.Git + Hi.Option + Hi.CommandLineOption + Hi.Template + Hi.Types + exposed: True + buildable: True + hs-source-dirs: src + other-modules: + Paths_hi + ghc-options: -Wall + executable hi - main-is: - Main.hs - ghc-options: - -Wall - hs-source-dirs: - src - build-depends: - base == 4.* - , bytestring - , directory - , filepath - , parsec - , process - , split - , template == 0.2.* - , temporary-rc == 1.2.0.3 - , text > 1.0 - , time - + build-depends: + base ==4.*, + ansi-wl-pprint -any, + bytestring -any, + directory -any, + filepath -any, + optparse-applicative >=0.10.0, + parsec -any, + process -any, + split -any, + template ==0.2.*, + temporary ==1.2.0.3, + text >1.0, + time -any + main-is: Main.hs + buildable: True + hs-source-dirs: src + ghc-options: -Wall + test-suite spec - main-is: - Spec.hs - type: - exitcode-stdio-1.0 - ghc-options: - -Wall - hs-source-dirs: - src - , test - build-depends: - base - , HUnit - , bytestring - , directory - , doctest - , filepath - , hspec >= 1.7.2 - , parsec - , process - , split - , template == 0.2.* - , temporary-rc == 1.2.0.3 - , text > 1.0 - , time - + build-depends: + base -any, + ansi-wl-pprint -any, + HUnit -any, + bytestring -any, + directory -any, + doctest -any, + filepath -any, + hspec >=2.0.0, + optparse-applicative >=0.10.0, + parsec -any, + process -any, + silently -any, + split -any, + template ==0.2.*, + temporary ==1.2.0.3, + text >1.0, + time -any + type: exitcode-stdio-1.0 + main-is: Spec.hs + buildable: True + hs-source-dirs: src test + ghc-options: -Wall test-suite doctests - type: - exitcode-stdio-1.0 - ghc-options: - -threaded - hs-source-dirs: - src - , test - main-is: - doctests.hs - build-depends: - base, doctest >= 0.8, process - -source-repository head - type: git - location: https://github.com/fujimura/hi.git + build-depends: + base -any, + doctest >=0.8, + process -any + type: exitcode-stdio-1.0 + main-is: doctests.hs + buildable: True + hs-source-dirs: src test + ghc-options: -threaded + diff --git a/src/Hi.hs b/src/Hi.hs --- a/src/Hi.hs +++ b/src/Hi.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns, RecordWildCards #-} module Hi ( run @@ -9,7 +10,6 @@ import qualified Hi.Git as Git import Hi.Template (readTemplates) import Hi.Types -import Hi.Utils import Control.Applicative import Control.Monad @@ -21,17 +21,17 @@ import Data.Text.Lazy.Encoding (encodeUtf8) import Data.Text.Template (Context, substitute) import System.Directory (createDirectoryIfMissing) -import System.FilePath (dropFileName) +import System.FilePath (dropFileName, joinPath, splitPath, normalise) 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 +run :: Option -> IO () +run option@(Option {templateSource}) = do + putStrLn $ "Creating new project with " ++ sourceName templateSource + writeFiles =<< showFileList =<< process option . dropExtraRegularFiles <$> readTemplates templateSource + postProcess option where - repository = fromJust $ lookupArg "repository" options + sourceName (FromRepo repository) = "git repository:" ++ Git.expandUrl repository -- |Write given 'Files' to filesystem. writeFiles :: Files -> IO () @@ -46,7 +46,7 @@ -- | Show 'Files' to stdout. showFileList :: Files -> IO Files showFileList files = do - mapM_ (showFile . getFilePath) files + mapM_ (showFile . normalise. getFilePath) files return files where showFile :: FilePath -> IO () @@ -59,23 +59,39 @@ -- 1. rewrite path -- -- 2. substitute arguments -process :: [Option] -> Files -> Files -process options = map go +process :: Option -> Files -> Files +process Option {..} = map go where go (TemplateFile path content) = TemplateFile (rewritePath' path) (substitute' content) go (RegularFile path content) = RegularFile (rewritePath' path) content - rewritePath' = rewritePath options + rewritePath' path = joinPath $ packageName : splitPath (rewritePath packageName moduleName path) substitute' text = BS.concat . LBS.toChunks . encodeUtf8 $ substitute (decodeUtf8 text) (context options) + options = [("packageName", packageName) + ,("moduleName", moduleName) + ,("author", author) + ,("email", email) + ,("year", year) + ] -- | 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]) +context :: [(String, String)] -> Context +context opts x = T.pack . fromJust $ lookup (T.unpack x) opts -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) $ +postProcess :: Option -> IO () +postProcess Option {initializeGitRepository, packageName} = do + when initializeGitRepository $ + inDirectory packageName $ void $ system "git init && git add . && git commit -m \"Initial commit\"" return () + +-- | Drop 'RegularFile's if there is a 'TemplateFile' which has same name +dropExtraRegularFiles :: Files -> Files +dropExtraRegularFiles [] = [] +dropExtraRegularFiles xs = go (map getFilePath xs) xs + where + go _ [] = [] + go paths (y@(RegularFile p _):ys) = if p `elem` paths + then go paths ys + else y : go paths ys + go paths (y@(TemplateFile _ _):ys) = y : go paths ys diff --git a/src/Hi/Cli.hs b/src/Hi/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Hi/Cli.hs @@ -0,0 +1,48 @@ +module Hi.Cli + ( run + ) where + +import qualified Hi +import Hi.CommandLineOption (CommandLineOption, + commandLineOption, defaultRepo) +import Hi.Option (buildOption) +import Hi.Types + +import Data.Monoid (mempty) +import Data.Version (showVersion) +import Options.Applicative +import qualified Text.PrettyPrint.ANSI.Leijen as PP + +import qualified Paths_hi (version) + +run :: [String] -> IO () +run [] = showHelpText (prefs idm) opts +run args = parseArgs args >>= Hi.run + +parseArgs :: [String] -> IO Option +parseArgs args = handleParseResult (execParserPure (prefs idm) opts args) >>= buildOption + +opts :: ParserInfo CommandLineOption +opts = info (helper <*> (version <*> commandLineOption)) + ( fullDesc + <> header "Generate a haskell project based on a template from github." + <> footerDoc (Just (PP.text footerText))) + +footerText :: String +footerText = unlines [ "" + , "If repository is not provided, it defaults to the repository at" + , defaultRepo ++ "." + , "" + , "Example:" + , " hi foo-bar" + ] + +version :: Parser (a -> a) +version = infoOption (showVersion Paths_hi.version) + ( short 'v' + <> long "version" + <> help "Print version information" ) + +showHelpText :: ParserPrefs -> ParserInfo a -> IO () +showHelpText pprefs pinfo = handleParseResult . Failure $ + parserFailure pprefs pinfo ShowHelpText mempty diff --git a/src/Hi/CommandLineOption.hs b/src/Hi/CommandLineOption.hs new file mode 100644 --- /dev/null +++ b/src/Hi/CommandLineOption.hs @@ -0,0 +1,30 @@ +module Hi.CommandLineOption + ( CommandLineOption(..) + , commandLineOption + , defaultRepo + ) where + +import Options.Applicative + +data CommandLineOption = CommandLineOption + { packageName :: String + , moduleName :: Maybe String + , author :: Maybe String + , email :: Maybe String + , repository :: String + , configFilePath :: Maybe String + , initializeGitRepository :: Maybe Bool + } deriving (Eq, Ord, Show) + +commandLineOption :: Parser CommandLineOption +commandLineOption = CommandLineOption + <$> (strOption (short 'p' <> long "package-name" <> help "Name of package") <|> argument str (help "Name of package")) + <*> optional (strOption (short 'm' <> long "moduleName" <> help "Name of Module")) + <*> optional (strOption (short 'a' <> long "author" <> help "Name of the project's author")) + <*> optional (strOption (short 'e' <> long "email" <> help "Email address of the maintainer")) + <*> strOption (short 'r' <> long "repository" <> help "Template repository" <> value defaultRepo) + <*> optional (strOption (long "configuration-file" <> help "Use specified configuration file")) + <*> optional (switch (long "initialize-git-repository" <> help "Initialize with git repository")) + +defaultRepo :: String +defaultRepo = "git://github.com/fujimura/hi-hspec.git" diff --git a/src/Hi/Config.hs b/src/Hi/Config.hs --- a/src/Hi/Config.hs +++ b/src/Hi/Config.hs @@ -4,15 +4,15 @@ parseConfig ) where -import Control.Applicative ((<$>), (<*)) -import Data.Maybe (catMaybes) -import Hi.Types +import Control.Applicative ((<$>), (<*)) +import Control.Monad +import Data.Maybe (catMaybes) import Text.Parsec import Text.Parsec.String --- | Parse config file and return 'Option's. +-- | Parse config file parseConfig :: String -> [(String, String)] -parseConfig x = case parse configFile "ERROR" x of -- TODO Error message +parseConfig x = case parse configFile "Invalid config file format" x of Left l -> error $ show l Right xs -> xs @@ -23,7 +23,7 @@ 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,7 +36,7 @@ line :: Parser (Maybe (String, String)) line = do spaces - try (comment >> return Nothing) <|> (line' >>= return . Just) + try (comment >> return Nothing) <|> liftM Just line' where line' = do spaces diff --git a/src/Hi/Directory.hs b/src/Hi/Directory.hs --- a/src/Hi/Directory.hs +++ b/src/Hi/Directory.hs @@ -10,14 +10,14 @@ -- |Run callback in a temporary directory. inTemporaryDirectory :: String -- ^ Base of temporary directory name - -> (IO a -> IO a) -- ^ Callback + -> IO a -> IO a -- ^ Callback inTemporaryDirectory name callback = withSystemTempDirectory name $ flip inDirectory callback -- |Run callback in given directory. inDirectory :: FilePath -- ^ Filepath to run callback - -> (IO a -> IO a) -- ^ Callback + -> IO a -> IO a -- ^ Callback inDirectory path callback = do pwd <- getCurrentDirectory bracket_ (setCurrentDirectory path) (setCurrentDirectory pwd) callback diff --git a/src/Hi/FilePath.hs b/src/Hi/FilePath.hs --- a/src/Hi/FilePath.hs +++ b/src/Hi/FilePath.hs @@ -4,28 +4,47 @@ ) where import Hi.Template (untemplate) -import Hi.Types -import Hi.Utils import Data.List import Data.List.Split (splitOn) -import Data.Maybe (fromJust) -import System.FilePath (joinPath) +import System.FilePath (joinPath, splitPath) -- | Convert given path to the destination path, with given options. -rewritePath :: [Option] -> FilePath -> FilePath -rewritePath options = - rename1 . rename2 . untemplate +rewritePath :: String -> String -> FilePath -> FilePath +rewritePath packageName moduleName = + replacePackageName . removeFirstPackageName . replaceModuleName . untemplate where - rename1 = replace "package-name" $ fromJust $ lookupArg "packageName" options - rename2 = replace "ModuleName" $ toDir . fromJust $ lookupArg "moduleName" options + replacePackageName = replace "package-name" packageName + replaceModuleName = replace "ModuleName" $ moduleNameToFilePath moduleName + +-- | Remove first occurence of given subdirectory +-- +-- >>> removeFirstPackageName "package-name/bar.hs" +-- "bar.hs" +-- +-- >>> removeFirstPackageName "package-name/package-name.hs" +-- "package-name.hs" +-- +-- >>> removeFirstPackageName "package-name.hs" +-- "package-name.hs" +-- +removeFirstPackageName :: FilePath -> FilePath +removeFirstPackageName path = go $ splitPath path + where + go :: [FilePath] -> FilePath + go [] = [] + go (x:xs) + | x == "package-name/" = joinPath xs + | otherwise = joinPath $ x:xs + -- | Convert module name to path --- @ --- toDir "Foo.bar" # => "Foo/Bar" --- @ -toDir :: String -> FilePath -toDir = joinPath . splitOn "." +-- +-- >>> moduleNameToFilePath "Foo.Bar" +-- "Foo/Bar" +-- +moduleNameToFilePath :: String -> FilePath +moduleNameToFilePath = joinPath . splitOn "." replace :: Eq a => [a] -> [a] -> [a] -> [a] replace a b = foldl1 (++) . intersperse b . splitOn a diff --git a/src/Hi/Git.hs b/src/Hi/Git.hs --- a/src/Hi/Git.hs +++ b/src/Hi/Git.hs @@ -1,27 +1,39 @@ +{-# LANGUAGE ScopedTypeVariables #-} + module Hi.Git ( clone + , config , lsFiles , expandUrl ) where import Control.Applicative -import Data.List (isPrefixOf) -import System.Exit (ExitCode) -import System.Process (readProcess, system) +import System.Exit +import System.Process (readProcess, readProcessWithExitCode, callCommand) +import Control.Exception expandUrl :: String -> String -expandUrl url = if "gh:" `isPrefixOf` url - then expand url - else url - where expand (_:_:_:xs) = "git@github.com:" ++ xs ++ ".git" +expandUrl ('g':'h':':':xs) = "git@github.com:" ++ xs ++ ".git" +expandUrl xs = xs -- | 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" +clone :: String -> IO () +clone repoUrl = handle (\(e :: IOException) -> print e >> exitFailure) $ do + callCommand $ "git clone --no-checkout --quiet " ++ repoUrl ++ " " ++ "./" + callCommand "git checkout HEAD --quiet" -- | Return file list by `git ls-files` lsFiles :: IO [String] lsFiles = lines <$> readProcess "git" ["ls-files"] [] + +-- | Return given config value +config :: String -> IO (Maybe String) +config name = do + (exitCode,s,_) <- readProcessWithExitCode "git" ["config", name] [] + return $ if exitCode == ExitSuccess + then Just $ removeNewline s + else Nothing + +removeNewline :: String -> String +removeNewline = reverse . dropWhile (=='\n') . reverse diff --git a/src/Hi/Option.hs b/src/Hi/Option.hs --- a/src/Hi/Option.hs +++ b/src/Hi/Option.hs @@ -1,179 +1,84 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Hi.Option ( - getOptions - , getMode - , options - , usage + buildOption ) where -import Hi.Config (parseConfig) +import Hi.CommandLineOption (CommandLineOption) +import qualified Hi.CommandLineOption as CommandLineOption +import Hi.Config (parseConfig) +import qualified Hi.Git as Git import Hi.Types -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 Option] -options = - [ 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" - ] - -toOption :: (String, String) -> Maybe Option -toOption (key, value) = maybe err ok $ key `lookupOption` options - where - 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 +import Control.Monad +import Data.Char (toUpper) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (toGregorian) +import Data.Time.Clock (getCurrentTime, utctDay) --- | Returns 'Options'. -getOptions :: IO [Option] -getOptions = handleError - <$> validateOptions - =<< addDefaultRepo - =<< addPackageNameIfMissing - =<< addOptionsFromConfigFile - =<< addYear - =<< parseOptions - <$> System.Environment.getArgs +buildOption :: CommandLineOption -> IO Option +buildOption copt = do + let moduleName = modularize $ CommandLineOption.packageName copt + year <- getCurrentYear + author <- guessAuthor + email <- guessEmail + return Option { initializeGitRepository = fromMaybe False $ CommandLineOption.initializeGitRepository copt + , moduleName = fromMaybe moduleName $ CommandLineOption.moduleName copt + , packageName = CommandLineOption.packageName copt + , author = author + , email = email + , templateSource = FromRepo $ CommandLineOption.repository copt + , year = year + } where - addYear :: [Option] -> IO [Option] - addYear vals = do - y <- getCurrentYear - return $ vals ++ [y] - - addOptionsFromConfigFile :: [Option] -> IO [Option] - addOptionsFromConfigFile vals = do - repo <- do - mfile <- readFileMaybe =<< getConfigFileName - 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 + lookupConfig :: String -> IO (Maybe String) + lookupConfig k = case CommandLineOption.configFilePath copt of + Just path -> lookup k . parseConfig <$> readFile path + Nothing -> return Nothing + choice :: [IO (Maybe String)] -> IO (Maybe String) + choice xs = foldr1 mplus <$> sequence xs + guessAuthor :: IO String + guessAuthor = do + mc <- choice [ return $ CommandLineOption.author copt + , lookupConfig "author" + , Git.config "user.name" + ] + case mc of + Just x -> return x + Nothing -> fail "No user specified" + guessEmail :: IO String + guessEmail = do + mc <- choice [ return $ CommandLineOption.email copt + , lookupConfig "email" + , Git.config "user.email" + ] + case mc of + Just x -> return x + Nothing -> fail "No email specified" + getCurrentYear :: IO String + getCurrentYear = do + (y,_,_) <- (toGregorian . utctDay) <$> getCurrentTime + return $ show y --- | Return file contents in Maybe String or Nothing. +-- | Capitalize words and connect them with periods -- -readFileMaybe :: FilePath -> IO (Maybe String) -readFileMaybe f = do - e <- doesFileExist f - if e then Just <$> readFile f else return Nothing - --- | Returns 'Mode'. -getMode :: IO Mode -getMode = do - args <- parseOptions <$> System.Environment.getArgs - return $ modeFor args - where - modeFor args | Help `elem` args = ShowHelp - | Version `elem` args = ShowVersion - | otherwise = Run - -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...]\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 - h <- getHomeDirectory - return $ joinPath [h, defaultConfigFileName] - -defaultConfigFileName :: FilePath -defaultConfigFileName = ".hirc" - -defaultRepo :: String -defaultRepo = "git://github.com/fujimura/hi-hspec.git" - -getConfigFileName :: IO FilePath -getConfigFileName = go =<< parseOptions <$> System.Environment.getArgs +-- >>> modularize "package" +-- "Package" +-- +-- >>> modularize "package-name" +-- "Package.Name" +-- +-- >>> modularize "another-package-name" +-- "Another.Package.Name" +-- +modularize :: String -> String +modularize [] = [] +modularize [x] = [toUpper x] +modularize (x:xs) = toUpper x : rest xs where - go [] = defaultConfigFilePath - go ((Arg "configFile" p):_) = return p - go (_:xs) = go xs - -getCurrentYear :: IO Option -getCurrentYear = do - (y,_,_) <- (toGregorian . utctDay) <$> getCurrentTime - 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 + rest [] = [] + rest ('-':ys) = '.' : modularize ys + rest (y:ys) = y:rest ys diff --git a/src/Hi/Template.hs b/src/Hi/Template.hs --- a/src/Hi/Template.hs +++ b/src/Hi/Template.hs @@ -16,11 +16,10 @@ import Data.List.Split (splitOn) -- | Read templates in given 'FilePath' -readTemplates :: FilePath -> IO Files -readTemplates repo = +readTemplates :: TemplateSource -> IO Files +readTemplates (FromRepo repo) = inTemporaryDirectory "hi" $ do - -- TODO Handle error - _ <- Git.clone $ Git.expandUrl repo + Git.clone $ Git.expandUrl repo paths <- Git.lsFiles mapM fetchFile paths diff --git a/src/Hi/Types.hs b/src/Hi/Types.hs --- a/src/Hi/Types.hs +++ b/src/Hi/Types.hs @@ -1,26 +1,27 @@ {-# LANGUAGE OverloadedStrings #-} module Hi.Types - ( Label - , Option(..) - , Mode(..) + ( Option(..) , File(..) , Files - , Error + , TemplateSource (..) ) where import Data.ByteString (ByteString) -data File = TemplateFile { getFilePath :: FilePath, getFileContents :: ByteString } | RegularFile { getFilePath :: FilePath, getFileContents :: ByteString } - -type Files = [File] - -type Error = String +data File = TemplateFile { getFilePath :: FilePath, getFileContents :: ByteString } | + RegularFile { getFilePath :: FilePath, getFileContents :: ByteString } deriving (Show) -type Label = String +data TemplateSource = FromRepo String deriving (Eq,Ord,Show) --- | Options -data Option = Version | Help | InitializeGitRepository | Arg Label String deriving(Eq, Show) +type Files = [File] --- | Run mode. -data Mode = ShowVersion | ShowHelp | Run deriving(Eq, Show) +data Option = Option + { initializeGitRepository :: Bool + , moduleName :: String + , packageName :: String + , author :: String + , email :: String + , year :: String + , templateSource :: TemplateSource + } deriving (Eq,Ord,Show) diff --git a/src/Hi/Utils.hs b/src/Hi/Utils.hs deleted file mode 100644 --- a/src/Hi/Utils.hs +++ /dev/null @@ -1,6 +0,0 @@ -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 deleted file mode 100644 --- a/src/Hi/Version.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Hi.Version - ( - version - ) where - -version :: String -version = "0.0.8.2" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,14 +1,9 @@ -module Main where +module Main + ( main + ) where -import Hi (run) -import Hi.Option (getOptions, getMode, usage) -import Hi.Types -import Hi.Version (version) +import Hi.Cli (run) +import System.Environment (getArgs) main :: IO () -main = do - mode <- getMode - case mode of - ShowHelp -> putStrLn usage - ShowVersion -> putStrLn version - _ -> run =<< getOptions +main = getArgs >>= run diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -2,4 +2,10 @@ import System.Process import Test.DocTest -main = doctest =<< lines <$> readProcess "git" ["ls-files", "src"] [] +main = do + files <- lines <$> readProcess "git" ["ls-files", "src"] [] + doctest $ ["-idist/build/" + ,"-idist/build/autogen" + ,"-optP-include" + ,"-optPdist/build/autogen/cabal_macros.h" + ] ++ files