charter/src/Charter.hs

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

module Charter
( module Types
, projectBin
, quickBin
, library

, 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 :: T.Text -> LibraryDetails
mkLibrary n = LibraryDetails
  { _libExposedModules = [capitalize n]
  , _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 name
        name = deets^.projectName

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

library :: ProjectDetails -> Project
library deets =
  mkProject deets & libDetails .~ Just lib
  where
    lib = mkLibrary (deets^.projectName)

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^.libExposedModules) $ \ m -> do
        let modPath = "src" : T.splitOn "." (m <> ".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 ()