{-# 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.Extensible
import Data.Char
import Data.Maybe
import Text.PrettyPrint.HughesPJ hiding (mode)
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 :: [String]
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)
         , field "build-type"    "Simple"] $$

    ( 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 :: [ReaderT P IO ()]
doEverything =
    [ createDir
    , createCabal
    , createSetup
    , createSrc
    , createLicense
    , createReadme
    , done
    ]

--
-- Things to do: cabal only
--
doCabalOnly :: [ReaderT P IO ()]
doCabalOnly =
    [ createCabal
    , createSetup
    , cabalDone ]

--
-- create a new directory for this project
--
createDir :: ReaderT P IO ()
createDir = do
    dir <- asks directory
    io $ do createDirectory     dir
            setCurrentDirectory dir

--
-- create a cabal file, populate it
--
createCabal :: ReaderT P IO ()
createCabal = do
    c    <- asks cabal_file
    info <- asks cabal_info
    io $ do writeFile c (ppr info)

-- create a stub src file
createSetup :: ReaderT P IO ()
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 :: ReaderT P IO ()
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 :: ReaderT P IO ()
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 :: ReaderT P IO ()
createReadme  = io $ writeFile "README" "\n"

--
-- print end message
--
done :: ReaderT P IO ()
done = do
    dir <- asks directory
    io $ putStrLn $ "Created new project directory: " ++ dir

--
-- print end message
--
cabalDone :: ReaderT P IO ()
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 :: IO a -> ReaderT P IO a
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 :: IO (String, String)
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 handleIO (\_ -> 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 . maybe defNameAndMail tail $
                        match (compile "(.*?)[[:space:]]*<(.*)>" []) s []
    pair [x,y]      = (x,y)
    pair _          = undefined

    handleIO        :: (Control.Exception.Extensible.IOException -> IO a)
                    -> IO a -> IO a
    handleIO        = handle