code cleaning
This commit is contained in:
parent
1076958f14
commit
956a3a4ec4
1 changed files with 77 additions and 20 deletions
97
src/Main.hs
97
src/Main.hs
|
@ -44,6 +44,7 @@ data Project = Project {
|
||||||
, synopsis :: String
|
, synopsis :: String
|
||||||
, year :: String } deriving (Data, Typeable)
|
, year :: String } deriving (Data, Typeable)
|
||||||
|
|
||||||
|
-- | Error message
|
||||||
holyError :: String -> IO ()
|
holyError :: String -> IO ()
|
||||||
holyError str = do
|
holyError str = do
|
||||||
r <- randomIO
|
r <- randomIO
|
||||||
|
@ -63,10 +64,15 @@ holyError str = do
|
||||||
you "Auuuuuuuuuuuugh"
|
you "Auuuuuuuuuuuugh"
|
||||||
error ('\n':str)
|
error ('\n':str)
|
||||||
|
|
||||||
|
-- | Assert something true. In any other case show the holy error
|
||||||
ioassert :: Bool -> String -> IO ()
|
ioassert :: Bool -> String -> IO ()
|
||||||
ioassert True _ = return ()
|
ioassert True _ = return ()
|
||||||
ioassert False str = holyError str
|
ioassert False str = holyError str
|
||||||
|
|
||||||
|
-- | return the content of ~/.gitconfig if it exists
|
||||||
|
-- if the HOME environment variable is not set
|
||||||
|
-- or the file doesn't exists
|
||||||
|
-- We return an empty string
|
||||||
safeReadGitConfig :: IO LZ.ByteString
|
safeReadGitConfig :: IO LZ.ByteString
|
||||||
safeReadGitConfig = do
|
safeReadGitConfig = do
|
||||||
e <- tryJust (guard . isDoesNotExistError)
|
e <- tryJust (guard . isDoesNotExistError)
|
||||||
|
@ -95,6 +101,7 @@ main = do
|
||||||
in_ghaccount in_synopsis current_year
|
in_ghaccount in_synopsis current_year
|
||||||
end
|
end
|
||||||
|
|
||||||
|
-- | Simply return the current year as String
|
||||||
getCurrentYear :: IO String
|
getCurrentYear :: IO String
|
||||||
getCurrentYear = do
|
getCurrentYear = do
|
||||||
(current_year,_,_) <- getCurrentTime >>= return . toGregorian . utctDay
|
(current_year,_,_) <- getCurrentTime >>= return . toGregorian . utctDay
|
||||||
|
@ -142,14 +149,19 @@ end = do
|
||||||
you "Well, you have to know these things when you're a king, you know."
|
you "Well, you have to know these things when you're a king, you know."
|
||||||
|
|
||||||
-- | Ask for some info and returns it
|
-- | Ask for some info and returns it
|
||||||
ask :: String -> Maybe String -> IO String
|
ask :: String -- ^ What? "name" for example
|
||||||
|
-> Maybe String -- ^ Default value
|
||||||
|
-> IO String
|
||||||
ask info hint = do
|
ask info hint = do
|
||||||
bk $ "What is your " ++ info ++ "?" ++ (maybe "" (\h -> " ("++h++")") hint)
|
bk $ "What is your " ++ info ++ "?" ++
|
||||||
|
(maybe "" (\h -> " ("++h++")") hint)
|
||||||
putStr "> "
|
putStr "> "
|
||||||
hFlush stdout
|
hFlush stdout
|
||||||
answer <- getLine
|
answer <- getLine
|
||||||
putStrLn ""
|
putStrLn ""
|
||||||
return $ if (answer == "") && (hint /= Nothing) then fromJust hint else answer
|
return $ if (answer == "") && (hint /= Nothing)
|
||||||
|
then fromJust hint
|
||||||
|
else answer
|
||||||
|
|
||||||
-- | verify if project is conform
|
-- | verify if project is conform
|
||||||
checkProjectName :: String -> Bool
|
checkProjectName :: String -> Bool
|
||||||
|
@ -168,35 +180,73 @@ capitalize str = concat (map capitalizeWord (splitOneOf " -" str))
|
||||||
capitalizeWord (x:xs) = (toUpper x):map toLower xs
|
capitalizeWord (x:xs) = (toUpper x):map toLower xs
|
||||||
capitalizeWord _ = []
|
capitalizeWord _ = []
|
||||||
|
|
||||||
|
-- | This function use a Data file mustache template
|
||||||
genFile :: MuContext IO -> FilePath -> FilePath -> IO ()
|
-- and a hastache context to write a destination file
|
||||||
|
genFile :: MuContext IO -- ^ hastache context
|
||||||
|
-> String -- ^ Data file name (without 'scaffold/' see in .cabal)
|
||||||
|
-> FilePath -- ^ The destination file path
|
||||||
|
-> IO ()
|
||||||
genFile context filename outputFileName = do
|
genFile context filename outputFileName = do
|
||||||
putStrLn $ '\t':outputFileName
|
putStrLn $ '\t':outputFileName -- show the file name
|
||||||
pkgfileName <- getDataFileName ("scaffold/" ++ filename)
|
template <- BS.readFile =<< getDataFileName ("scaffold/" ++ filename)
|
||||||
template <- BS.readFile pkgfileName
|
|
||||||
transformedFile <- hastacheStr defaultConfig template context
|
transformedFile <- hastacheStr defaultConfig template context
|
||||||
createDirectoryIfMissing True (takeDirectory outputFileName)
|
createDirectoryIfMissing True (takeDirectory outputFileName)
|
||||||
LZ.writeFile outputFileName transformedFile
|
LZ.writeFile outputFileName transformedFile
|
||||||
|
|
||||||
|
-- | This function is where we create the project once the
|
||||||
|
-- question are answered
|
||||||
createProject :: Project -> IO ()
|
createProject :: Project -> IO ()
|
||||||
createProject p = do
|
createProject p = do
|
||||||
|
-- create the hastache context object from the Project data type
|
||||||
let context = mkGenericContext p
|
let context = mkGenericContext p
|
||||||
|
-- Check if the directory doesn't already exists
|
||||||
dirExists <- doesDirectoryExist (projectName p)
|
dirExists <- doesDirectoryExist (projectName p)
|
||||||
ioassert (not dirExists) ((projectName p) ++ " directory already exists")
|
ioassert (not dirExists) ((projectName p) ++ " directory already exists")
|
||||||
|
-- Create the directory and go into it
|
||||||
createDirectory (projectName p)
|
createDirectory (projectName p)
|
||||||
setCurrentDirectory (projectName p)
|
setCurrentDirectory (projectName p)
|
||||||
genFile context "gitignore" $ ".gitignore"
|
-- Generate all files using data files
|
||||||
genFile context "auto-update" $ "auto-update"
|
mapM_ (uncurry (genFile context))
|
||||||
genFile context "LICENSE" $ "LICENSE"
|
[ ( "gitignore"
|
||||||
genFile context "Setup.hs" $ "Setup.hs"
|
, ".gitignore"
|
||||||
genFile context "project.cabal" $ (projectName p) ++ ".cabal"
|
)
|
||||||
genFile context "src/Main.hs" $ "src" </> "Main.hs"
|
, ( "auto-update"
|
||||||
genFile context "src/ModuleName.hs" $ "src" </> ((moduleName p)++".hs")
|
, "auto-update"
|
||||||
genFile context "src/ModuleName/Coconut.hs" $ "src" </> (moduleName p) </> "Coconut.hs"
|
)
|
||||||
genFile context "src/ModuleName/Swallow.hs" $ "src" </> (moduleName p) </> "Swallow.hs"
|
, ( "LICENSE"
|
||||||
genFile context "test/ModuleName/Coconut/Test.hs" $ "test" </> (moduleName p) </> "Coconut" </> "Test.hs"
|
, "LICENSE"
|
||||||
genFile context "test/ModuleName/Swallow/Test.hs" $ "test" </> (moduleName p) </> "Swallow" </> "Test.hs"
|
)
|
||||||
genFile context "test/Test.hs" $ "test" </> "Test.hs"
|
, ( "Setup.hs"
|
||||||
|
, "Setup.hs"
|
||||||
|
)
|
||||||
|
, ( "project.cabal"
|
||||||
|
, (projectName p) ++ ".cabal"
|
||||||
|
)
|
||||||
|
, ( "src/Main.hs"
|
||||||
|
, "src" </> "Main.hs"
|
||||||
|
)
|
||||||
|
, ( "src/ModuleName.hs"
|
||||||
|
, "src" </> ((moduleName p)++".hs")
|
||||||
|
)
|
||||||
|
, ( "src/ModuleName/Coconut.hs"
|
||||||
|
, "src" </> (moduleName p) </> "Coconut.hs"
|
||||||
|
)
|
||||||
|
, ( "src/ModuleName/Swallow.hs"
|
||||||
|
, "src" </> (moduleName p) </> "Swallow.hs"
|
||||||
|
)
|
||||||
|
, ( "test/ModuleName/Coconut/Test.hs"
|
||||||
|
, "test" </> (moduleName p) </> "Coconut" </> "Test.hs"
|
||||||
|
)
|
||||||
|
, ( "test/ModuleName/Swallow/Test.hs"
|
||||||
|
, "test" </> (moduleName p) </> "Swallow" </> "Test.hs"
|
||||||
|
)
|
||||||
|
, ( "test/Test.hs"
|
||||||
|
, "test" </> "Test.hs"
|
||||||
|
)
|
||||||
|
]
|
||||||
|
-- Execute some commands
|
||||||
|
-- We don't really need them to be succesful
|
||||||
|
-- So we try them anyway
|
||||||
_ <- system "git init ."
|
_ <- system "git init ."
|
||||||
_ <- system "cabal sandbox init"
|
_ <- system "cabal sandbox init"
|
||||||
_ <- system "cabal install"
|
_ <- system "cabal install"
|
||||||
|
@ -204,12 +254,17 @@ createProject p = do
|
||||||
_ <- system $ "./.cabal-sandbox/bin/test-" ++ (projectName p)
|
_ <- system $ "./.cabal-sandbox/bin/test-" ++ (projectName p)
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
|
|
||||||
|
-- | Returns the name and email from the content of a .gitconfig file
|
||||||
getNameAndMail :: LZ.ByteString -> (Maybe String,Maybe String)
|
getNameAndMail :: LZ.ByteString -> (Maybe String,Maybe String)
|
||||||
getNameAndMail gitConfigContent = (selectElem "name",selectElem "email")
|
getNameAndMail gitConfigContent = (selectElem "name",selectElem "email")
|
||||||
where
|
where
|
||||||
|
-- make lines of words
|
||||||
conflines :: [[LZ.ByteString]]
|
conflines :: [[LZ.ByteString]]
|
||||||
conflines = map LZ.words (LZ.lines gitConfigContent)
|
conflines = map LZ.words (LZ.lines gitConfigContent)
|
||||||
|
|
||||||
|
-- Get the first line which start with
|
||||||
|
-- 'elem =' and return the third field (value)
|
||||||
selectElem :: String -> Maybe String
|
selectElem :: String -> Maybe String
|
||||||
selectElem elm = msafeHead $
|
selectElem elm = msafeHead $
|
||||||
filter (/= Nothing)
|
filter (/= Nothing)
|
||||||
|
@ -219,6 +274,8 @@ getNameAndMail gitConfigContent = (selectElem "name",selectElem "email")
|
||||||
msafeHead [] = Nothing
|
msafeHead [] = Nothing
|
||||||
msafeHead (x:_) = x
|
msafeHead (x:_) = x
|
||||||
|
|
||||||
|
-- Return the first field of a line starting by
|
||||||
|
-- 'elem =' or Nothing otherwise
|
||||||
getElem :: String -> [LZ.ByteString] -> Maybe String
|
getElem :: String -> [LZ.ByteString] -> Maybe String
|
||||||
getElem el (n:e:xs) = if (n == (LZ.pack el)) && (e == (LZ.pack "="))
|
getElem el (n:e:xs) = if (n == (LZ.pack el)) && (e == (LZ.pack "="))
|
||||||
then Just (LZ.unpack (LZ.unwords xs))
|
then Just (LZ.unpack (LZ.unwords xs))
|
||||||
|
|
Loading…
Reference in a new issue