Browse Source

Mostly-working, largely-undocumented commit of Charter

Getty Ritter 6 years ago
commit
e2775128c8
7 changed files with 456 additions and 0 deletions
  1. 20 0
      .gitignore
  2. 12 0
      LICENSE
  3. 38 0
      charter.cabal
  4. 100 0
      charter/Main.hs
  5. 142 0
      src/Charter.hs
  6. 104 0
      src/Templates.hs
  7. 40 0
      src/Types.hs

+ 20 - 0
.gitignore

@@ -0,0 +1,20 @@
+dist
+dist-*
+*~
+cabal-dev
+*.o
+*.hi
+*.chi
+*.chs.h
+*.dyn_o
+*.dyn_hi
+.hpc
+.hsenv
+.cabal-sandbox/
+cabal.sandbox.config
+*.prof
+*.aux
+*.hp
+*.eventlog
+cabal.project.local
+.ghc.environment.*

File diff suppressed because it is too large
+ 12 - 0
LICENSE


+ 38 - 0
charter.cabal

@@ -0,0 +1,38 @@
+name:             charter
+version:          0.1.0.0
+-- synopsis:
+-- description:
+license:          BSD3
+license-file:     LICENSE
+author:           Getty Ritter <gdritter@galois.com>
+maintainer:       Getty Ritter <gdritter@galois.com>
+copyright:        ©2018 Getty Ritter
+-- category:
+build-type:       Simple
+cabal-version:    >= 1.14
+
+library
+  exposed-modules:     Charter
+  other-modules:       Templates
+                     , Types
+  hs-source-dirs:      src
+  build-depends:       base >=4.7 && <5
+                     , directory
+                     , filepath
+                     , process
+                     , text
+                     , lens-family-core
+                     , lens-family-th
+  default-language:    Haskell2010
+  default-extensions:  ScopedTypeVariables
+
+executable charter
+  hs-source-dirs:      charter
+  main-is:             Main.hs
+  default-extensions:  ScopedTypeVariables
+  ghc-options:         -Wall
+  build-depends:       base >=4.7 && <5
+                     , charter
+                     , text
+                     , lens-family-core
+  default-language:    Haskell2010

+ 100 - 0
charter/Main.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Main where
+
+import qualified Data.Text as T
+import           Lens.Family
+import qualified System.Console.GetOpt as Opt
+import qualified System.Environment as Sys
+import qualified System.Exit as Sys
+
+import qualified Charter as C
+
+data Option
+  = AddBinary T.Text
+  | SetCategory T.Text
+  | SetSynopsis T.Text
+  | SetDescription T.Text
+  | SetLicense T.Text
+  | SetRoot T.Text
+  | AddDep T.Text
+  | AddUsualDeps
+    deriving (Eq, Show)
+
+options :: [Opt.OptDescr Option]
+options =
+  [ Opt.Option ['b'] ["bin"]
+    (Opt.ReqArg (AddBinary . T.pack) "PROGRAM NAME")
+    "Add another binary target to this Cabal file"
+  , Opt.Option ['r'] ["root"]
+    (Opt.ReqArg (SetRoot . T.pack) "DIRECTORY")
+    "Set the root directory for this project"
+
+  , Opt.Option ['c'] ["category"]
+    (Opt.ReqArg (SetCategory . T.pack) "CATEGORY")
+    "Set the category for this project"
+  , Opt.Option ['s'] ["synopsis"]
+    (Opt.ReqArg (SetSynopsis . T.pack) "SYNOPSIS")
+    "Set the synopsis for this project"
+  , Opt.Option ['d'] ["description"]
+    (Opt.ReqArg (SetDescription . T.pack) "DESCRIPTION")
+    "Set the description for this project"
+  , Opt.Option ['l'] ["license"]
+    (Opt.ReqArg (SetLicense . T.pack) "LICENSE")
+    "Set the license for this project"
+
+  , Opt.Option ['a'] ["add-dep"]
+    (Opt.ReqArg (AddDep . T.pack) "PACKAGE")
+    "Add a dependency to this application"
+  , Opt.Option ['A'] ["add-usual-deps"]
+    (Opt.NoArg AddUsualDeps)
+    "Add the typical set of dependencies to this application"
+  ]
+
+
+usageInfo :: String
+usageInfo = Opt.usageInfo header options
+  where header = "Usage: charter (quick|executable|library) [name]"
+
+
+process :: [Option] -> C.Project -> C.Project
+process opts p = foldr ($) p (map go opts)
+  where
+    go (AddBinary n) proj =
+      proj & C.binDetails %~ (C.mkBinary n :)
+    go (SetCategory s) proj =
+      proj & C.projectDetails . C.projectCategory .~ Just s
+    go (SetSynopsis s) proj =
+      proj & C.projectDetails . C.projectSynopsis .~ Just s
+    go (SetDescription s) proj =
+      proj & C.projectDetails . C.projectDescription .~ Just s
+    go (SetLicense s) proj =
+      proj & C.projectDetails . C.projectLicense .~ Just s
+    go (SetRoot _) proj = proj
+
+    go (AddDep dep) proj =
+      proj & C.binDetails %~ fmap (& C.execDeps %~ (dep :))
+           & C.libDetails %~ fmap (& C.libDeps %~ (dep :))
+    go (AddUsualDeps) proj =
+      proj & C.binDetails %~ fmap (& C.execDeps %~ (C.usualDeps ++))
+           & C.libDetails %~ fmap (& C.libDeps %~ (C.usualDeps ++))
+
+setupProject :: String -> String -> IO C.Project
+setupProject typ name = do
+  details <- C.projectDefaults (T.pack name)
+  case typ of
+    "quick"      -> return (C.quickBin details)
+    "executable" -> return (C.projectBin details)
+    "library"    -> return (C.library details)
+    _            -> Sys.die ("unknown project type: " ++ typ ++ "\n" ++ usageInfo)
+
+main :: IO ()
+main = do
+  args <- Sys.getArgs
+  case Opt.getOpt Opt.Permute options args of
+    (os, [typ, name], []) -> do
+      proj <- process os <$> setupProject typ name
+      C.createProject proj
+    (_, _, errs) -> do
+      mapM_ putStrLn errs
+      Sys.die usageInfo

+ 142 - 0
src/Charter.hs

@@ -0,0 +1,142 @@
+{-# 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 ()

+ 104 - 0
src/Templates.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Templates where
+
+import           Data.Monoid ((<>))
+import qualified Data.Text as T
+import           Lens.Family
+
+import Types
+
+cabalHeader :: ProjectDetails -> T.Text
+cabalHeader pr = T.unlines
+  [ "name: " <> pr^.projectName
+  , "version: 0.1.0.0"
+  , case pr^.projectSynopsis of
+      Just s -> "synopsis: " <> s
+      Nothing -> "-- synopsis:"
+  , case pr^.projectDescription of
+      Just s -> "description: " <> s
+      Nothing -> "-- description:"
+  , case pr^.projectLicense of
+      Nothing -> "license: BSD3"
+      Just l  -> "license: " <> l
+  , "author: " <> pr^.projectAuthor <> " <" <> pr^.projectEmail <> ">"
+  , "maintainer: " <> pr^.projectAuthor <> " <" <> pr^.projectEmail <> ">"
+  , "copyright: @" <> pr^.projectYear <> " " <> pr^.projectAuthor
+  , case pr^.projectCategory of
+      Just c  -> "category: " <> c
+      Nothing -> "-- category:"
+  , "build-type: Simple"
+  , "cabal-version: >=1.14"
+  ]
+
+cabalLibrary :: LibraryDetails -> T.Text
+cabalLibrary lib = T.unlines $
+  [ "library"
+  , "  hs-source-dirs: src"
+  , "  ghc-options: -Wall"
+  , "  build-depends: base >=4.7 && <5"
+  , "  default-language: Haskell2010"
+  , "  default-extensions: ScopedTypeVariables"
+  ] <> mods
+  where
+    mods = case lib^.libExposedModules of
+             []     -> []
+             (x:xs) ->
+               ("  exposed-modules: " <> x) :
+               ["                 , " <> m | m <- xs ]
+
+cabalExecutable :: ExecutableDetails -> T.Text
+cabalExecutable exe = T.unlines $
+  [ "executable " <> exe^.execName
+  , "  hs-source-dirs: " <> exe^.execDir
+  , "  main-is: Main.hs"
+  , "  default-language: Haskell2010"
+  , "  default-extensions: ScopedTypeVariables"
+  , "  ghc-options: -Wall"
+  ] <> deps
+  where
+    baseDep = "  build-depends: base >=4.7 && <5"
+    deps =
+      baseDep : [ "               , " <> m
+                | m <- exe^.execDeps
+                ]
+
+defaultBin :: T.Text
+defaultBin = T.unlines $
+  [ "module Main where"
+  , ""
+  , "main :: IO ()"
+  , "main = return ()"
+  ]
+
+defaultLib :: T.Text -> T.Text
+defaultLib mod = T.unlines $
+  [ "module " <> mod
+  , "("
+  , ") where"
+  ]
+
+defaultGitignore :: T.Text
+defaultGitignore = T.unlines
+  [ "dist"
+  , "dist-*"
+  , "*~"
+  , "cabal-dev"
+  , "*.o"
+  , "*.hi"
+  , "*.chi"
+  , "*.chs.h"
+  , "*.dyn_o"
+  , "*.dyn_hi"
+  , ".hpc"
+  , ".hsenv"
+  , ".cabal-sandbox/"
+  , "cabal.sandbox.config"
+  , "*.prof"
+  , "*.aux"
+  , "*.hp"
+  , "*.eventlog"
+  , "cabal.project.local"
+  , ".ghc.environment.*"
+  ]

+ 40 - 0
src/Types.hs

@@ -0,0 +1,40 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Types where
+
+import qualified Data.Text as T
+import qualified Lens.Family.TH as Lens
+
+data ProjectDetails = ProjectDetails
+  { _projectName        :: T.Text
+  , _projectAuthor      :: T.Text
+  , _projectEmail       :: T.Text
+  , _projectYear        :: T.Text
+  , _projectCategory    :: Maybe T.Text
+  , _projectSynopsis    :: Maybe T.Text
+  , _projectDescription :: Maybe T.Text
+  , _projectLicense     :: Maybe T.Text
+  }
+
+data LibraryDetails = LibraryDetails
+  { _libExposedModules :: [T.Text]
+  , _libDeps           :: [T.Text]
+  }
+
+data ExecutableDetails = ExecutableDetails
+  { _execName :: T.Text
+  , _execDir  :: T.Text
+  , _execDeps :: [T.Text]
+  }
+
+data Project = Project
+  { _projectDetails :: ProjectDetails
+  , _libDetails     :: Maybe LibraryDetails
+  , _binDetails     :: [ExecutableDetails]
+  , _projectRoot    :: Maybe T.Text
+  }
+
+Lens.makeLenses ''ProjectDetails
+Lens.makeLenses ''LibraryDetails
+Lens.makeLenses ''ExecutableDetails
+Lens.makeLenses ''Project