headergen-0.1.0.0: src/Main.hs

{- |
Module      :  $Header$
Description :  The main module of the application.
Copyright   :  (c) 2015 Nils 'bash0r' Jonsson
License     :  MIT

Maintainer  :  aka.bash0r@gmail.com
Stability   :  unstable
Portability :  non-portable (Portability is not tested.)

The main module is the entry point of the application.
-}

{-# LANGUAGE OverloadedStrings #-}

module Main
( main
) where

import Control.Applicative
import Control.Monad

import Data.Aeson
import Data.Aeson.Encode.Pretty
import qualified Data.ByteString.Lazy as BS
import Data.Time.Clock
import Data.Time.Calendar

import System.FilePath.Posix
import System.Console.Haskeline
import System.Directory
import System.Environment
import System.IO

date :: IO (Integer, Int, Int)
date = liftM (toGregorian . utctDay) getCurrentTime

-- | The configuration is used to read / write configuration to JSON.
data Configuration = Configuration
  { getModule      :: String
  , getDescription :: String
  , getAuthor      :: String
  , getCopyright   :: String
  , getLicense     :: String
  , getMaintainer  :: String
  , getStability   :: String
  , getPortability :: String
  }

defaultConfiguration = Configuration
  { getModule      = "$Header$"
  , getDescription = ""
  , getAuthor      = ""
  , getCopyright   = ""
  , getLicense     = ""
  , getMaintainer  = ""
  , getStability   = "unstable"
  , getPortability = "non-portable (Portability is untested.)"
  }

instance ToJSON Configuration where
  toJSON (Configuration mod desc auth copyr lic maint stab portab) =
    object [ "module"      .= mod
           , "author"      .= auth
           , "description" .= desc
           , "copyright"   .= copyr
           , "license"     .= lic
           , "maintainer"  .= maint
           , "stability"   .= stab
           , "portability" .= portab
           ]

instance FromJSON Configuration where
  parseJSON (Object o) =
    Configuration <$> o .: "module"
                  <*> o .: "description"
                  <*> o .: "author"
                  <*> o .: "copyright"
                  <*> o .: "license"
                  <*> o .: "maintainer"
                  <*> o .: "stability"
                  <*> o .: "portability"
  parseJSON _          =
    empty

-- | Try to get the parent directory of a given path.
parentDirectory :: FilePath -> Maybe FilePath
parentDirectory path =
  let splitted   = splitDirectories path
      reversed   = reverse splitted
      dropped    = drop 1 reversed
      rereversed = reverse dropped
      newPath    = joinPath rereversed
   in case newPath of
        []        -> Nothing
        otherwise -> Just otherwise

-- | Traverses the path up to root directory.
traversePath :: String -> FilePath -> IO ()
traversePath mod cwd = do
  putStrLn ("Checking " ++ cwd ++ " ...")
  let headerGenDef = cwd </> ".headergen.def"
  exists <- doesFileExist headerGenDef
  if exists
     then do
       h  <- openFile headerGenDef ReadMode
       cs <- BS.hGetContents h
       let hgd = decode cs :: Maybe Configuration 
       case hgd of
         Just a  -> createHeader mod a
         Nothing -> printCorruptedMessage
       hClose h 
     else case parentDirectory cwd of
       Just a  -> traversePath mod a
       Nothing -> printExitMessage

-- | Print message about a corrupted .headergen.def.
printCorruptedMessage :: IO ()
printCorruptedMessage = do
  putStrLn "The .headergen.def is corrupted."
  putStrLn "Exitting now."
  putStrLn ""

-- | Print the exit message.
printExitMessage :: IO ()
printExitMessage = do
  putStrLn "There is no .headergen.def in any parent directory."
  putStrLn "Exitting now."
  putStrLn ""

requestForAllowance :: IO Bool
requestForAllowance = runInputT defaultSettings allowanceRequest
  where
    allowanceRequest = do
      line <- getInputLine "File for module exists already. Override? [y/n] "
      case line of
        (Just "y") -> return True
        (Just "n") -> return False
        _          -> allowanceRequest

-- | Create the header.
createHeader :: String -> Configuration -> IO ()
createHeader mod conf = do
  exists <- doesFileExist mod
  if exists
     then do
       v <- requestForAllowance
       if v
          then printHeader mod conf
          else printExit
     else printHeader mod conf

printExit :: IO ()
printExit = do
  putStrLn "No resources have been created."
  putStrLn "Exiting now."
  putStrLn ""

printHeader :: String -> Configuration -> IO ()
printHeader modFile (Configuration mod des aut cop lic mai sta por) = do
  h <- openFile modFile WriteMode
  hPutStrLn h  "{- |"
  hPutStrLn h ("Module      :  " ++ mod)
  hPutStrLn h ("Description :  " ++ des)
  hPutStrLn h ("Author      :  " ++ aut)
  hPutStrLn h ("Copyright   :  " ++ cop)
  hPutStrLn h ("License     :  " ++ lic)
  hPutStrLn h  ""
  hPutStrLn h ("Maintainer  :  " ++ mai)
  hPutStrLn h ("Stability   :  " ++ sta)
  hPutStrLn h ("Portability :  " ++ por)
  hPutStrLn h  ""
  hPutStrLn h  "TODO: module description"
  hPutStrLn h  "-}"
  hFlush h
  hClose h

def :: Maybe String -> String -> String
def v d =
  case v of
    Just v ->
      if null v
         then d
         else v
    Nothing ->
      d

alignText :: String -> String
alignText xs =
  if length xs < 8
     then alignText (xs ++ " ")
     else xs

defaultText :: String -> String
defaultText crt =
  if length crt >= 8
     then take 8 crt
     else alignText crt

requestConfiguration :: IO Configuration
requestConfiguration = do
  (year, _, _) <- date
  runInputT defaultSettings $ do
    mod    <- getInputLine  "Module      [$Header$]: "
    desc   <- getInputLine  "Description [        ]: "
    auth   <- getInputLine  "Author      [        ]: "
    let copyRightText    = "(c) " ++ show year ++ " " ++ def auth ""
    copyr  <- getInputLine ("Copyright   [" ++ defaultText copyRightText ++ "]: ")
    lic    <- getInputLine  "License     [MIT     ]: "
    maint  <- getInputLine  "Maintainer  [        ]: "
    stab   <- getInputLine  "Stability   [unstable]: "
    portab <- getInputLine  "Portability [non-port]: "
    return $ Configuration (def mod "$Header$")
                           (def desc "")
                           (def auth "")
                           (def copyr copyRightText)
                           (def lic "MIT")
                           (def maint "")
                           (def stab "unstable")
                           (def portab "non-portable (Portability is untested.)")

initializeDefinition :: IO ()
initializeDefinition = do
  conf <- requestConfiguration
  file <- openFile ".headergen.def" WriteMode
  BS.hPutStr file (encodePretty conf)
  hFlush file
  hClose file

tryCreate :: String -> IO ()
tryCreate mod = do
  cwd <- getCurrentDirectory
  traversePath mod cwd

printHelpMessage :: IO ()
printHelpMessage = do
  putStrLn "Usage: [init|create MODULE]"
  putStrLn ""

-- | The entry point of the application.
main :: IO ()
main = do
  args <- getArgs
  handleParameters args
  where
    handleParameters ["init"]        = initializeDefinition
    handleParameters ["create", mod] = tryCreate (mod -<.> ".hs")
    handleParameters _               = printHelpMessage