hi 0.0.6 → 0.0.7
raw patch · 13 files changed
+258/−196 lines, 13 files
Files
- hi.cabal +5/−3
- src/Hi.hs +44/−19
- src/Hi/Config.hs +10/−9
- src/Hi/Context.hs +0/−21
- src/Hi/FilePath.hs +11/−8
- src/Hi/Flag.hs +0/−37
- src/Hi/Git.hs +30/−0
- src/Hi/Option.hs +132/−58
- src/Hi/Template.hs +8/−18
- src/Hi/Types.hs +7/−18
- src/Hi/Utils.hs +6/−0
- src/Hi/Version.hs +1/−1
- src/Main.hs +4/−4
hi.cabal view
@@ -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
src/Hi.hs view
@@ -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 ()
src/Hi/Config.hs view
@@ -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
− src/Hi/Context.hs
@@ -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
src/Hi/FilePath.hs view
@@ -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]
− src/Hi/Flag.hs
@@ -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"
+ src/Hi/Git.hs view
@@ -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"] []
src/Hi/Option.hs view
@@ -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
src/Hi/Template.hs view
@@ -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"] []
src/Hi/Types.hs view
@@ -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)
+ src/Hi/Utils.hs view
@@ -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]
src/Hi/Version.hs view
@@ -4,4 +4,4 @@ ) where version :: String-version = "0.0.6"+version = "0.0.7"
src/Main.hs view
@@ -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