mkcabal-0.4.1: mkcabal.hs
{-# OPTIONS_GHC -fglasgow-exts #-}
-- Pattern guards
--
-- Copyright (c) 2006-7 Don Stewart <dons@galois.com>
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
--
--
-- Create stub files for a new Haskell project, following the rules of:
-- http://haskell.org/haskellwiki/How_to_write_a_Haskell_program
--
import System.Console.Readline
import System.Directory hiding (executable)
import System.Environment
import System.Time
import System.Locale
import Control.Monad.Reader
import Control.Exception
import Data.Char
import Data.Maybe
import Text.PrettyPrint.HughesPJ
import Text.Printf
import Text.Regex.PCRE.Light.Char8
import Licenses
--
-- user-supplied info
--
data P =
P { project_u :: String
, project_lc :: String
, main_is :: String
, cabal_file :: String
, directory :: String
, cabal_info :: Cabal }
--
-- licenses
--
licenses =
["GPL2"
,"GPL3"
,"LGPL2"
,"LGPL3"
,"BSD3"
,"BSD4"
,"PublicDomain"
,"AllRightsReserved"]
--
-- what mode
--
data Mode = CabalOnly -- create only .cabal and Setup.lhs files
| TheWorks -- create an entire project, including darcs repos
deriving Eq
data Type = Library -- we're creating a library cabal file
| Executable -- we're creating an executable
deriving (Eq, Read, Show)
data Category
= Codec
| Control
| Data
| Database
| Development
| Distribution
| Game
| Graphics
| Language
| Math
| Network
| Sound
| System
| Testing
| Text
| Web
| Other
deriving (Read, Show, Eq, Ord, Bounded, Enum)
--
-- A type for a simple cabal file
--
data Cabal =
Cabal { name :: String
, version :: (Int,Int)
, description :: String
, category :: String
, license :: String
, author :: String
, email :: String
, depends :: String
, ghc_options :: String
, cabal_type :: Type
, exec_stanza :: Maybe ExecStanza
}
--
-- if we're building an executable
--
data ExecStanza =
ExecStanza { executable :: String
, main_is_file :: String }
--
-- pretty print
--
ppr :: Cabal -> String
ppr c = render $
vcat [ field "name" (name c)
, field "version" ((show.fst.version$ c) +.+ (show.snd.version$ c))
, field "synopsis" (description c)
, field "description" (description c)
, field "category" (category c)
, field "license" (license c)
, field "license-file" "LICENSE"
, field "author" (author c)
, field "maintainer" (email c)
, field "build-Depends" (depends c)] $$
( if cabal_type c == Executable
then
let Just e = exec_stanza c
in vcat [ text ""
, field "executable" (executable e)
, field "main-is" (main_is_file e)] $$ empty
else empty )
$$ field "ghc-options" (ghc_options c)
where
field s t = text s <> colon
<> text (take (20 - length s) (repeat ' '))
<> text t
main :: IO ()
main = do
args <- getArgs
let mode = case args of
[] -> CabalOnly
["--init-project"] -> TheWorks
_ -> error "mkcabal: usage: mkcabal [--init-project]"
evaluate mode
-- todo, provide arguments or prompting
p <- promptStr "Project name" Nothing
l <- promptStr "What license" $ Just (licenses, 4)
e <- prompt "What kind of project" $ Just ([Executable,Library], 0)
c <- prompt "Under what category?" $ Just ([Codec ..], 0)
(person, mail) <- queryAuthorNameMail
per <- query "Is this your name?" $ Just person
ml <- query "Is this your email address?" $ Just mail
let lc = map toLower p
uc = toUpper (head lc) : tail lc
d = lc
cabal = Cabal { name = lc
, version = (0,0)
, description = "<Project description>"
, license = l
, category = if c == Other then "" else show c
, author = per
, email = ml
, depends = "base"
, ghc_options = ""
, cabal_type = e
, exec_stanza = if e /= Executable
then Nothing
else Just $ ExecStanza
{ executable = lc
, main_is_file= uc +.+ "hs" }
}
let st = P { project_u = uc
, project_lc = lc
, main_is = uc +.+ "hs"
, cabal_file = lc +.+ "cabal"
, directory = d
, cabal_info = cabal
}
flip runReaderT st $ sequence_ $ if mode == TheWorks
then doEverything
else doCabalOnly
--
-- Things to do: everything
--
doEverything =
[ createDir
, createCabal
, createSetup
, createSrc
, createLicense
, createReadme
, done
]
--
-- Things to do: cabal only
--
doCabalOnly =
[ createCabal
, createSetup
, cabalDone ]
--
-- create a new directory for this project
--
createDir = do
dir <- asks directory
io $ do createDirectory dir
setCurrentDirectory dir
--
-- create a cabal file, populate it
--
createCabal = do
c <- asks cabal_file
info <- asks cabal_info
io $ do writeFile c (ppr info)
-- create a stub src file
createSetup = io $ writeFile "Setup.lhs" setup_hs
where
setup_hs =
"#!/usr/bin/env runhaskell\n\
\> import Distribution.Simple\n\
\> main = defaultMain\n"
--
-- And create a stub src file
--
createSrc = do
f <- asks main_is
io $ writeFile f mainsrc
where
mainsrc =
"main :: IO ()\n\
\main = putStrLn \"Hello, world!\"\n"
--
-- a stub license file
--
createLicense = do
l <- asks (license . cabal_info)
w <- asks (author . cabal_info)
case l of
"BSD3" -> do
t <- io $ getClockTime
ct <- io $ toCalendarTime t
let s = formatCalendarTime defaultTimeLocale "%Y" ct
lic = bsd3 (trim w) s
io $ writeFile "LICENSE" (lic ++ "\n")
"GPL2" -> do
io $ writeFile "LICENSE" (gplv2 ++ "\n")
"GPL3" -> do
io $ writeFile "LICENSE" (gplv3 ++ "\n")
"LGPL2" ->
io $ writeFile "LICENSE" (lgpl2 ++ "\n")
"LGPL3" ->
io $ writeFile "LICENSE" (lgpl3 ++ "\n")
_ -> io $ writeFile "LICENSE" (l ++ "\n")
where
trim s = if last s == ' ' then
init s
else s
--
-- a stub readme file
--
createReadme = io $ writeFile "README" "\n"
--
-- print end message
--
done = do
dir <- asks directory
io $ putStrLn $ "Created new project directory: " ++ dir
--
-- print end message
--
cabalDone = do
file <- asks cabal_file
io $ putStrLn $ "Created Setup.lhs and" +++ file
--
-- | Convenient prompt handling
--
promptStr :: String -> Maybe ([String],Int) -> IO String
promptStr str options = do
x <- readline $ case options of
Nothing -> printf "%s: " str
Just (opts, n) -> printf "%s %s [%s]: " str (show opts) (show $ opts !! n)
case x of
Nothing -> error "End of input"
Just [] -> return $ case options of Nothing -> error "prompt returned nothing"
Just (o,i) -> o !! i
Just s -> return s
--
-- | Convenient prompt handling
--
prompt :: (Read a , Show a) => String -> Maybe ([a],Int) -> IO a
prompt str options = do
x <- readline $ case options of
Nothing -> printf "%s: " str
Just (opts, n) -> printf "%s %s [%s]: " str (show opts) (show $ opts !! n)
case x of
Nothing -> error "End of input"
Just [] -> return $ case options of Nothing -> error "prompt returned nothing"
Just (o,i) -> o !! i
Just s -> return (read s)
query :: String -> Maybe String -> IO String
query str option = do
x <- readline $ case option of
Nothing -> printf "%s: " str
Just opt -> printf "%s - %s [Y/n]: " str (show opt)
case (option,x) of
(Nothing, Nothing) -> return ""
(Nothing, Just st) -> return st
(Just op, Nothing) -> return op
(Just op, Just st) -> if (take 1 (map toLower st)) == "n"
then promptStr "Enter alternative" Nothing
else return op
--
-- helpers
--
io = liftIO
infixr 6 +/+, +.+, +++
(+/+), (+.+), (+++) :: FilePath -> FilePath -> FilePath
[] +/+ b = b
a +/+ b = a ++ "/" ++ b
[] +.+ b = b
a +.+ b = a ++ "." ++ b
[] +++ b = b
a +++ b = a ++ " " ++ b
--
-- darcs interaction
--
-- user's name and email
--
-- checks _darcs/prefs/author, ~/.darcs/author in that order
--
-- try to check EMAIL and DARCS_EMAIL vars, and user name.
--
queryAuthorNameMail = do
re <- doesFileExist authorRepo
if re
then readFile authorRepo >>= return . nameAndMail
else do
authorHome <- getAuthorHome
he <- doesFileExist authorHome
if he
then readFile authorHome >>= return . nameAndMail
else handle (\_ -> return $ pair defNameAndMail) $ do
env <- getEnvironment
let p | Just e <- lookup "DARCS_EMAIL" env = break (=='<') e
| Just e <- lookup "EMAIL" env = (defName, e)
| otherwise = pair defNameAndMail
return p
where
getAuthorHome = getHomeDirectory >>= return . flip (+/+) ".darcs/author"
authorRepo = "_darcs/prefs/author"
defName = "Author Name"
defMail = "user@email.address"
defNameAndMail = [defName,defMail]
nameAndMail s = pair . fromMaybe defNameAndMail $
match (compile "(.*)[[:space:]]*<(.*)>" []) s []
pair [x,y] = (x,y)