charter/src/Charter.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}

module Charter
( module Types
, projectBin
, quickBin
, library

, validLicenses

, mkBinary
, projectDefaults
, createProject
, usualDeps
) where

import           Control.Monad (forM_)
import qualified Data.Char as Char
import           Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Lens.Family
import qualified System.Directory as Sys
import qualified System.Environment as Sys
import qualified System.FilePath as Sys
import qualified System.Process as Proc

import Types
import Templates


mkBinary :: T.Text -> ExecutableDetails
mkBinary n = ExecutableDetails
  { _execName = n
  , _execDir  = n
  , _execDeps = []
  }

mkLibrary :: LibraryDetails
mkLibrary = LibraryDetails
  { _libMods = []
  , _libDeps = []
  }

mkProject :: ProjectDetails -> Project
mkProject deets = Project
  { _projectDetails = deets
  , _libDetails = Nothing
  , _binDetails = []
  , _projectRoot = Nothing
  }

quickBin :: ProjectDetails -> Project
quickBin deets =
  mkProject deets & binDetails .~ [ bin ]
  where bin = mkBinary (deets^.projectName)
                & execDir .~ "src"

projectBin :: ProjectDetails -> Project
projectBin deets =
  mkProject deets & binDetails .~ [ bin ]
                  & libDetails .~ Just lib
  where bin = mkBinary name & execDeps .~ [name]
        lib = mkLibrary & libMods .~ [capitalize name]
        name = deets^.projectName

usualDeps :: [T.Text]
usualDeps =
  [ "text"
  , "containers"
  , "unordered-containers"
  , "bytestring"
  ]

library :: ProjectDetails -> Project
library deets =
  mkProject deets & libDetails .~ Just mkLibrary

mkdirBase :: T.Text -> [T.Text] -> IO ()
mkdirBase base fp = do
  let path = T.unpack (T.intercalate "/" (base:fp))
  Sys.createDirectoryIfMissing True path

writeBase :: T.Text -> [T.Text] -> T.Text -> IO ()
writeBase base fp contents = do
  mkdirBase base (init fp)
  let path = T.unpack (T.intercalate "/" (base:fp))
  putStrLn ("- creating file `" <> path <> "'")
  T.writeFile path contents

run :: String -> [String] -> IO T.Text
run x xs = (T.strip . T.pack) `fmap` Proc.readProcess x xs ""

projectDefaults :: T.Text -> IO ProjectDetails
projectDefaults _projectName = do
  _projectAuthor <- run "git" ["config", "user.name"]
  _projectEmail <- run "git" ["config", "user.email"]
  _projectYear <- run "date" ["+%Y"]
  let _projectCategory = Nothing
      _projectSynopsis = Nothing
      _projectDescription = Nothing
      _projectLicense = Nothing
  return ProjectDetails { .. }

-- | Capitalize just the first letter of a string
capitalize :: T.Text -> T.Text
capitalize t = case T.uncons t of
  Nothing -> mempty
  Just (x, xs) -> T.cons (Char.toUpper x) xs

-- | Actually build out the scaffolding for a project
createProject :: Project -> IO ()
createProject pr = do
  let deets = pr^.projectDetails
  let write = writeBase (deets^.projectName)

  let cabalFile =
        [ cabalHeader deets ] <>
        maybe [] (pure . cabalLibrary) (pr^.libDetails) <>
        map cabalExecutable (pr^.binDetails)

  T.putStrLn ("Creating project `" <> deets^.projectName <> "'")

  let cabalPath = [deets^.projectName <> ".cabal"]
  write cabalPath (T.unlines cabalFile)

  case (pr^.libDetails) of
    Nothing -> return ()
    Just lib -> do
      forM_ (lib^.libMods) $ \ m -> do
        let modPath = "src" : T.splitOn "." m
            modPath' = init modPath ++ [last modPath <> ".hs"]
        write modPath' (defaultLib m)

  forM_ (pr^.binDetails) $ \e -> do
    write [e^.execDir, "Main.hs"] defaultBin

  let pr = (Proc.proc "git" ["init"])
             { Proc.cwd = Just (T.unpack (deets^.projectName)) }
  _ <- Proc.withCreateProcess pr (\_ _ _ -> Proc.waitForProcess)
  write [".gitignore"] defaultGitignore
  return ()


validLicenses :: [T.Text]
validLicenses =
  [ "GPL", "AGPL", "LGPL",
    "BSD2", "BSD3", "BSD4",
    "MIT", "ISC", "MPL",
    "Apache", "PublicDomain",
    "AllRightsReserved",
    "UnspecifiedLicense",
    "OtherLicense"
  ]