module HolyProject where
import HolyProject.GitConfig ( getNameAndMailFromGitConfig)
import HolyProject.StringUtils ( projectNameFromString
, capitalize
, checkProjectName)
import HolyProject.GithubAPI ( searchGHUser)
import HolyProject.MontyPython ( bk
, you
, ask
)
import Numeric (readOct)
import Data.Time.Clock
import Data.Time.Calendar
import Data.Data
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.IO as TIO
import Text.Hastache
import Text.Hastache.Context
import System.Directory
import System.FilePath.Posix (takeDirectory,(</>))
import System.Posix.Files (setFileMode)
import System.Process (system)
import System.Random
import Control.Concurrent
import Paths_holy_project
import Data.Maybe (fromMaybe)
import Control.Monad (void)
data Project = Project {
projectName :: String
, moduleName :: String
, author :: String
, mail :: String
, ghaccount :: String
, synopsis :: String
, year :: String } deriving (Data, Typeable)
holyError :: String -> IO ()
holyError str = do
r <- randomIO
if r
then
do
bk "What... is your favourite colour?"
you "Blue. No, yel..."
putStrLn "[You are thrown over the edge into the volcano]"
you "You: Auuuuuuuuuuuugh"
bk " Hee hee heh."
else
do
bk "What is the capital of Assyria?"
you "I don't know that!"
putStrLn "[You are thrown over the edge into the volcano]"
you "Auuuuuuuuuuuugh"
error ('\n':str)
ioassert :: Bool -> String -> IO ()
ioassert True _ = return ()
ioassert False str = holyError str
holyStarter :: IO ()
holyStarter = do
intro
(name,email) <- getNameAndMailFromGitConfig
earlyhint <- newEmptyMVar
maybe (putMVar earlyhint Nothing)
(\hintmail ->
void (forkIO (putMVar earlyhint =<< searchGHUser hintmail)))
email
project <- ask "project name" Nothing
ioassert (checkProjectName project)
"Use only letters, numbers, spaces ans dashes please"
let projectname = projectNameFromString project
modulename = capitalize project
in_author <- ask "name" name
in_email <- ask "email" email
ghUserHint <- if fromMaybe "" email /= in_email
then searchGHUser in_email
else takeMVar earlyhint
in_ghaccount <- ask "github account" ghUserHint
in_synopsis <- ask "project in less than a dozen word?" Nothing
current_year <- getCurrentYear
createProject $ Project projectname modulename in_author in_email
in_ghaccount in_synopsis current_year
end
getCurrentYear :: IO String
getCurrentYear = do
(current_year,_,_) <- fmap (toGregorian . utctDay) getCurrentTime
return (show current_year)
intro :: IO ()
intro = do
bk "Stop!"
bk "Who would cross the Bridge of Death"
bk "must answer me these questions three,"
bk "ere the other side he see."
you "Ask me the questions, bridgekeeper, I am not afraid.\n"
end :: IO ()
end = do
putStrLn "\n\n"
bk "What... is the air-speed velocity of an unladen swallow?"
you "What do you mean? An African or European swallow?"
bk "Huh? I... I don't know that."
putStrLn "[the bridgekeeper is thrown over]"
bk "Auuuuuuuuuuuugh"
putStrLn "Sir Bedevere: How do you know so much about swallows?"
you "Well, you have to know these things when you're a king, you know."
genFile :: MuContext IO
-> String
-> FilePath
-> IO ()
genFile context filename outputFileName = do
putStrLn $ '\t':outputFileName
template <- TIO.readFile =<< getDataFileName ("scaffold/" ++ filename)
transformedFile <- hastacheStr defaultConfig (T.toStrict template) context
createDirectoryIfMissing True (takeDirectory outputFileName)
TIO.writeFile outputFileName transformedFile
createProject :: Project -> IO ()
createProject p = do
let context = mkGenericContext p
dirExists <- doesDirectoryExist (projectName p)
ioassert (not dirExists) (projectName p ++ " directory already exists")
createDirectory (projectName p)
setCurrentDirectory (projectName p)
mapM_ (uncurry (genFile context))
[ ( "gitignore"
, ".gitignore"
)
, ( "auto-update"
, "auto-update"
)
, ( "LICENSE"
, "LICENSE"
)
, ( "Setup.hs"
, "Setup.hs"
)
, ( "interact"
, "interact"
)
, ( "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"
)
]
_ <- setFileMode "auto-update" ((fst . head . readOct) "777")
_ <- setFileMode "interact" ((fst . head . readOct) "777")
_ <- system "git init ."
_ <- system "cabal sandbox init"
_ <- system "cabal install"
_ <- system "cabal test"
_ <- system $ "./.cabal-sandbox/bin/test-" ++ projectName p
return ()