diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for jbi + +## 0.1.0.0 -- 2017-09-05 + +* First version. Released on an semi-suspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2017 Ivan Lazar Miljenovic + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,219 @@ +Just Build It, and hack on! +=========================== + +[![Hackage](https://img.shields.io/hackage/v/jbi.svg)](https://hackage.haskell.org/package/jbi) [![Build Status](https://travis-ci.org/ivan-m/jbi.svg)](https://travis-ci.org/ivan-m/jbi) + +> A "do what I mean" abstraction for Haskell build tools. + +Motivation +---------- + +You've decided to work on an existing Haskell project. The repository +has been forked, you've cloned it to your computer, and you're about +to start work. What's the first thing you need to do? + +1) Replace all copyright notices with your own name. + +2) Swap all tabs and spaces. + +3) Convert all the code to Literate Haskell because it's such a pain + to write your long prosaic comments whilst remembering to preface + every line with `-- `. + +Actually, unless you're someone with a religious obsession of using +what you prefer no matter what project you're working on or who you're +collaborating with, the first task you generally need to do is: + +4) Work out which build tool is being used in the project. + +After all, especially as we tend to put in more and more +metadata/hints into our different build tool files rather than just +using `runhaskell Setup.hs `, it's more convenient and friendlier +to work with a project the same way everyone else (especially the +maintainer!) does. + +But this means you need to mentally switch gears and try and remember +the quirks of each individual tool's command line configuration (how +do I launch a REPL again?). Your editing environment may need to be +configured so as to use the correct tool, whatever keyboard shortcuts +you use to run tests needs to change, etc. + +Wouldn't it be nice if there was a simple way your development +environment (including your muscle memory!) could stay the same and +let some common interface handle the changing (without falling into +the trap of trying to [replace everything](https://xkcd.com/927/))? + +Enter _jbi_ +----------- + +_jbi_ - short for "Just Build It" - is aimed at providing a common +interface between the various Haskell build tools. You should be able +to enter any directory containing a Haskell project and just run `jbi` +and it will successfully determine the best build tool to use, +download dependencies and build the project. + +Currently, _jbi_ knows of the following Haskell build tools: + +* `stack` (with automatic [Nix] support) + +* `cabal-install` with [Nix] support (using `cabal2nix` and `nix-shell`) + +* `cabal-install` using sandboxes + +[Nix]: https://nixos.org/nix/ + +Note that nothing within _jbi_ is inherently Haskell-oriented; it can +be extended to any build tool for any language which has similar +concepts for build tooling. + +How _jbi_ works +--------------- + +To determine which build tool to works, _jbi_ takes into account three +things: + +1. The order in which the tools are available to be checked in + (currently the same as in the list above). + +2. Whether a build tool is able to be used (i.e. the tool is installed + and an appropriate project can be found). + +3. Whether it is already being used. + +Preference is given to tools already in evidence of being used. As an +example, consider the following scenario: + +``` +myProjectDir/ $ ls +cabal.sandbox.config LICENSE myProject.cabal src/ stack.yaml +``` + +If both `cabal-install` and `stack` are available, then - despite the +presence of a `stack.yaml` - the presence of a sandbox configuration +indicates that a preference has been made for using them. + +### Features + +* Automatically install dependencies for and enable test-suites and + benchmarks. + +* Attempt to re-configure (including installing dependencies) if + builds fail (which `stack` already provides) + +* The equivalent of `cabal run` for `stack`. + +* Print out a list of targets (equivalent of `stack ide targets`, for + which `cabal-install` does not have an analogue). + +* Detailed debugging information about tool availability. + +* Work within any sub-directory of a project (no need to make sure + you're running from the root directory!). + +### Caveats + +_jbi_ will not: + +* Generate a `stack.yaml` for you. This is an explicit opt-in of + wanting to use `stack`, and furthermore isn't possible to determine + whether you want it just for the current package or if it's part of + a larger multi-package project. + +* Install the result of the build for you. _jbi_ is purely for + developmental purposes. + +* Allow you to not build the test suite or benchmarks (unless you + specifically build a specific target). + +* Allow you to have flexible builds, pass through extra command-line + options, etc. It is opinionated in how it does things to cover the + common cases. + +Furthermore: + +* I have only recently started using [Nix] (both with Stack and + cabal-install) and as such may not have it quite right (it seems to + work with me though). + +Fortuitously Anticipated Queries +-------------------------------- + +### Why isn't my build tool of choice being used? + +Run `jbi info details` to find the information being used to choose +the build tool. The chosen build tool will have: + +* `"installation"` non-null. +* `"usable": true` +* A non-null `"project"` + +Preference is given to: + +* Build tools with `"artifactsPresent": true` +* Higher up in the list. + +### What are these artifacts? + +"Artifacts" is the term used by _jbi_ to denote the build-tool +specific files/directories found within the project that indicate it +is being worked upon. + +These are: + +_stack_ + ~ `.stack-work/` +_cabal+nix_ + ~ `shell.nix` or `default.nix` +_cabal+sandbox_ + ~ `cabal.sandbox.config` (note that the sandbox itself may be in a + different directory) + +`jbi prepare` will generate these; `jbi clean` will remove them (with +any other files/directories likely to have been produced as part of +the build process). Typically you will never need to explicitly run +`jbi prepare`. + +### Stack doesn't seem to be using Nix + +For [Nix] support to work, you need to [configure your + `stack.yaml`](https://docs.haskellstack.org/en/stable/nix_integration/). + +### Why can't I use Stack with shell.nix? + +For a project with no `.stack-work/`, _jbi_ takes the presence of a +`shell.nix` file to indicate that the project is using _cabal+nix_, +irregardless as to whether a `stack.yaml` file is present. + +There are two ways you can work around this: + +1. Explicitly create a `.stack-work/` directory; as _stack_ has a higher + priority, _jbi_ will then pick it over _cabal+nix_. Note, however, + you may also need to explicitly run `stack setup` if using a + non-system GHC. + +2. Use a different filename other than `shell.nix` (remember to + specify the filename properly in the `shell-file` section!). + +The latter is preferred as it will allow more of _jbi_'s automatic +features to work (e.g. calling `stack setup`). + +### How can I re-generate my shell.nix after updating my .cabal file? + +**For _cabal+nix_.** + +Run `jbi prepare`. This is likely the only scenario you will ever +need to explicitly run this command in. + +### How do I add a new build tool? + +Pull requests are welcome. + +To add a new tool, you need to create an instance of the `BuildTool` +class from `System.JBI.Commands.BuildTool`, and then insert your new +tool into an appropriate place in `defaultTools` in `System.JBI`. + +### What about languages other than Haskell? + +If, for some reason, you wish to use a language other than Haskell and +would like to use _jbi_ with it, you're more than welcome to send me a +pull request. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/jbi.cabal b/jbi.cabal new file mode 100644 --- /dev/null +++ b/jbi.cabal @@ -0,0 +1,63 @@ +name: jbi +version: 0.1.0.0 +synopsis: Just Build It - a "do what I mean" abstraction for Haskell build tools +description: + If you work with multiple Haskell projects, it can be annoying have to + change gears mentally as to which set of tooling you have to work with + for each one (configuring your editor, or even just the command-line). + . + @jbi@ aims to provide a common interface to the various Haskell build + tools available and automatically determine which one you should use, + so you can get back to hacking on your code, rather than on your + environment. +license: MIT +license-file: LICENSE +author: Ivan Lazar Miljenovic +maintainer: Ivan.Miljenovic@gmail.com +-- copyright: +category: Development +build-type: Simple +extra-source-files: ChangeLog.md, README.md +cabal-version: >=1.10 +tested-with: GHC == 7.10.2, GHC == 8.0.2, GHC == 8.1.* + +source-repository head + type: git + location: https://github.com/ivan-m/jbi.git + +library + exposed-modules: System.JBI + , System.JBI.Commands + , System.JBI.Commands.BuildTool + , System.JBI.Commands.Cabal + , System.JBI.Commands.Nix + , System.JBI.Commands.Stack + , System.JBI.Commands.Tool + , System.JBI.Environment + , System.JBI.Tagged + + build-depends: base >=4.8 && <4.11 + , aeson >= 0.11.1.0 && < 1.3 + , Cabal >= 1.22.0.0 && < 2.1 + , directory >= 1.2.5.0 + , filepath >= 1.4.0.0 && < 1.5 + , process >= 1.4.3.0 && < 1.7 + , tagged == 0.8.* + hs-source-dirs: lib + default-language: Haskell2010 + ghc-options: -Wall + +executable jbi + main-is: Main.hs + + other-modules: Paths_jbi + + build-depends: jbi + , base + , aeson-pretty >= 0.7.2 && < 0.9 + , optparse-applicative >= 0.13.0.0 && < 0.15 + , text == 1.* + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/lib/System/JBI.hs b/lib/System/JBI.hs new file mode 100644 --- /dev/null +++ b/lib/System/JBI.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} + +{- | + Module : System.JBI + Description : Just Build It + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module System.JBI + ( WrappedTool + , Valid + , defaultTools + , withTool + , chooseTool + , toolName + , infoProjectDir + -- * System state\/environment + , GlobalEnv(..) + , globalEnv + -- * Information\/Diagnostics + , Information (..) + , getInformation + -- * Commands + , prepare + , targets + , build + , repl + , clean + , test + , bench + , exec + , run + , update + ) where + +import System.JBI.Commands +import System.JBI.Commands.BuildTool (ToolInformation) +import System.JBI.Commands.Cabal +import System.JBI.Commands.Stack +import System.JBI.Environment + +import Control.Applicative ((<|>)) +import Data.Aeson (ToJSON) +import Data.List (find) +import Data.Maybe (listToMaybe) +import Data.Proxy (Proxy(..)) +import GHC.Generics (Generic) + +-------------------------------------------------------------------------------- + +defaultTools :: [WrappedTool Proxy] +defaultTools = [ Wrapped (Proxy :: Proxy Stack) + , Wrapped (Proxy :: Proxy (Cabal Nix)) + , Wrapped (Proxy :: Proxy (Cabal Sandbox)) + ] + +withTool :: IO res -> (GlobalEnv -> WrappedTool Valid -> IO res) + -> [WrappedTool proxy] -> IO res +withTool onFailure f tools = do + env <- globalEnv + mtool <- chooseTool env tools + maybe onFailure (f env) mtool + +chooseTool :: GlobalEnv -> [WrappedTool proxy] -> IO (Maybe (WrappedTool Valid)) +chooseTool env tools = do + valid <- mapMaybeM (checkValidity env) tools + return (find alreadyUsed valid <|> listToMaybe valid) + +data Information = Information + { environment :: !GlobalEnv + , toolDetails :: ![WrappedTool ToolInformation] + } deriving (Show, Generic, ToJSON) + +getInformation :: [WrappedTool proxy] -> IO Information +getInformation tools = do + env <- globalEnv + Information env <$> mapM (toolInformation env) tools + +-------------------------------------------------------------------------------- + +mapMaybeM :: (a -> IO (Maybe b)) -> [a] -> IO [b] +mapMaybeM f = go + where + go [] = return [] + go (a:as) = do + mb <- f a + maybe id (:) mb <$> go as diff --git a/lib/System/JBI/Commands.hs b/lib/System/JBI/Commands.hs new file mode 100644 --- /dev/null +++ b/lib/System/JBI/Commands.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE FlexibleInstances, GADTs, OverloadedStrings, RankNTypes, + StandaloneDeriving #-} + +{- | + Module : System.JBI.Commands + Description : Running a specific build tool + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module System.JBI.Commands + ( WrappedTool (..) + , Valid + , toolName + , toolInformation + , checkValidity + , alreadyUsed + , infoProjectDir + -- * Commands + , prepare + , targets + , build + , repl + , clean + , test + , bench + , exec + , run + , update + ) where + +import System.JBI.Commands.BuildTool +import System.JBI.Commands.Tool +import System.JBI.Environment +import System.JBI.Tagged + +import Control.Monad (forM) +import Data.Aeson (ToJSON(toJSON)) +import Data.Function (on) +import Data.Proxy (Proxy(..)) +import System.Directory (withCurrentDirectory) +import System.Exit (ExitCode(ExitSuccess), die) + +-------------------------------------------------------------------------------- + +data WrappedTool proxy where + Wrapped :: (NamedTool bt) => proxy bt -> WrappedTool proxy + +-- | Not made polymorphic as there might be extra data contained +-- within. +instance Eq (WrappedTool Proxy) where + (==) = (==) `on` toolName + +-- | Not really a valid instance as it doesn't produce Haskell code. +instance Show (WrappedTool Proxy) where + show = toolName + +deriving instance Show (WrappedTool ToolInformation) +deriving instance Show (WrappedTool Valid) + +instance ToJSON (WrappedTool ToolInformation) where + toJSON = withWrapped toJSON + +withWrapped :: (forall bt. (NamedTool bt) => proxy bt -> res) + -> WrappedTool proxy -> res +withWrapped f (Wrapped bt) = f bt + +toolName :: WrappedTool proxy -> String +toolName = withWrapped prettyName + +toolInformation :: GlobalEnv -> WrappedTool proxy -> IO (WrappedTool ToolInformation) +toolInformation env (Wrapped pr) = Wrapped <$> commandToolInformation env pr + +-------------------------------------------------------------------------------- + +data Valid bt = Valid + { command :: !(Installed bt) + , projectDir :: !(Tagged bt ProjectRoot) + , hasArtifacts :: !Bool + -- ^ Only to be used with 'ensurePrepared', 'prepare', 'unprepared'. + } deriving (Eq, Ord, Show, Read) + +alreadyUsed :: WrappedTool Valid -> Bool +alreadyUsed = withWrapped hasArtifacts + +infoProjectDir :: WrappedTool Valid -> ProjectRoot +infoProjectDir = withWrapped (stripTag . projectDir) + +-- This is pretty ugly; one way to clean it up would be to use MaybeT. +checkValidity :: GlobalEnv -> WrappedTool proxy -> IO (Maybe (WrappedTool Valid)) +checkValidity env (Wrapped p) = fmap Wrapped <$> check p + where + check :: (BuildTool bt) => proxy' bt -> IO (Maybe (Valid bt)) + check _ = do + mInst <- commandInformation + case mInst of + Nothing -> return Nothing + Just inst -> do + usbl <- canUseCommand env inst + if not usbl + then return Nothing + else do mroot <- commandProjectRoot (path inst) + forM mroot $ \root -> + Valid inst root <$> hasBuildArtifacts root + +runInProject :: (forall bt. (BuildTool bt) => Tagged bt CommandPath -> IO res) + -> WrappedTool Valid -> IO res +runInProject f (Wrapped val) = withCurrentDirectory (stripTag (projectDir val)) + (f (path (command val))) + +prepareWrapped :: GlobalEnv -> WrappedTool Valid -> IO (WrappedTool Valid) +prepareWrapped env wt@(Wrapped val) = do + ec <- runInProject (commandPrepare env) wt + case ec of + ExitSuccess -> do + hasArt <- canUseCommand env (command val) + if hasArt + then return (Wrapped (val { hasArtifacts = True })) + else die "Preparation failed" + _ -> die "Could not prepare" + +runPrepared :: (forall bt. (BuildTool bt) => GlobalEnv -> Tagged bt CommandPath -> IO res) + -> GlobalEnv -> WrappedTool Valid -> IO res +runPrepared f env wv = do + wv' <- if not (alreadyUsed wv) + then prepareWrapped env wv + else return wv + runInProject (f env) wv' + +-------------------------------------------------------------------------------- +-- This mimics the actual command-level portion of BuildTool + +prepare :: GlobalEnv -> WrappedTool Valid -> IO ExitCode +prepare env wv = prepareWrapped env wv >> return ExitSuccess +-- Explicitly prepare. + +targets :: GlobalEnv -> WrappedTool Valid -> IO [ProjectTarget] +targets = runPrepared (const (fmap stripTags . commandTargets)) + +build :: Maybe ProjectTarget -> GlobalEnv -> WrappedTool Valid -> IO ExitCode +build targ = runPrepared (\env cp -> commandBuild env cp (tagInner (tag targ))) + +repl :: Maybe ProjectTarget -> GlobalEnv -> WrappedTool Valid -> IO ExitCode +repl targ = runPrepared (\env cp -> commandRepl env cp (tagInner (tag targ))) + +clean :: GlobalEnv -> WrappedTool Valid -> IO ExitCode +clean = runPrepared commandClean + +test :: GlobalEnv -> WrappedTool Valid -> IO ExitCode +test = runPrepared commandTest + +bench :: GlobalEnv -> WrappedTool Valid -> IO ExitCode +bench = runPrepared commandBench + +exec :: String -> Args -> GlobalEnv -> WrappedTool Valid -> IO ExitCode +exec cmd args = runPrepared (\env cp -> commandExec env cp cmd args) + +run :: ProjectTarget -> Args -> GlobalEnv -> WrappedTool Valid -> IO ExitCode +run targ args = runPrepared (\env cp -> commandRun env cp (tag targ) args) + +update :: GlobalEnv -> WrappedTool Valid -> IO ExitCode +update = runPrepared commandUpdate diff --git a/lib/System/JBI/Commands/BuildTool.hs b/lib/System/JBI/Commands/BuildTool.hs new file mode 100644 --- /dev/null +++ b/lib/System/JBI/Commands/BuildTool.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleContexts, + MultiParamTypeClasses #-} + +{- | + Module : System.JBI.Commands.Common + Description : How to handle build tools + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module System.JBI.Commands.BuildTool where + +import System.JBI.Commands.Tool +import System.JBI.Environment +import System.JBI.Tagged + +import Control.Applicative (liftA2) +import Control.Exception (SomeException(SomeException), handle) +import Control.Monad (filterM, forM) +import Data.Aeson (ToJSON(toJSON)) +import Data.List (span) +import Data.Maybe (isJust) +import Data.String (IsString(..)) +import GHC.Generics (Generic) +import System.Directory (doesFileExist, getCurrentDirectory, listDirectory) +import System.Exit (ExitCode) +import System.FilePath (dropTrailingPathSeparator, isDrive, takeDirectory, + ()) + +-------------------------------------------------------------------------------- + +class (Tool bt) => BuildTool bt where + + -- | Make sure there's nothing in the environment preventing us from + -- using this tool. + -- + -- For example, a minimum version, need another tool installed, etc. + canUseCommand :: GlobalEnv -> Installed bt -> IO Bool + canUseCommand _ _ = return True + + -- | Try and determine the root directory for this project. + commandProjectRoot :: Tagged bt CommandPath -> IO (Maybe (Tagged bt ProjectRoot)) + + hasBuildArtifacts :: Tagged bt ProjectRoot -> IO Bool + + -- | Ensure's that 'hasBuildArtifacts' is 'True' afterwards; + -- i.e. forces this build tool. + -- + -- The intent for this is \"No build tool is currently being used + -- (i.e. 'hasBuildArtifacts' is 'False' for all) so start using + -- the one chosen.\" This will not do the equivalent of @stack + -- init@ and create project configuration. + -- + -- Some manual fiddling is allowed after this. + -- + -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. + commandPrepare :: GlobalEnv -> Tagged bt CommandPath -> IO ExitCode + + -- | Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. + commandTargets :: Tagged bt CommandPath -> IO [Tagged bt ProjectTarget] + + -- | Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. + commandBuild :: GlobalEnv -> Tagged bt CommandPath -> Maybe (Tagged bt ProjectTarget) + -> IO ExitCode + + -- | Launch a @ghci@ session within the current project. Should + -- pass through the @-ferror-spans@ argument to the underlying + -- ghci process. + -- + -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. + commandRepl :: GlobalEnv -> Tagged bt CommandPath -> Maybe (Tagged bt ProjectTarget) + -> IO ExitCode + + -- | Remove /all/ build artifacts of using this build tool (that is, + -- afterwards 'hasBuildArtifacts' should return 'False'). + -- + -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. + commandClean :: GlobalEnv -> Tagged bt CommandPath -> IO ExitCode + + -- | Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. + commandTest :: GlobalEnv -> Tagged bt CommandPath -> IO ExitCode + + -- | Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. + commandBench :: GlobalEnv -> Tagged bt CommandPath -> IO ExitCode + + -- | Run an external command within this environment. + -- + -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. + commandExec :: GlobalEnv -> Tagged bt CommandPath -> String -> Args -> IO ExitCode + + -- | Run an executable component within this environment (building + -- it first if required). + -- + -- Assumes 'canUseBuildTool'. Should be run within 'ProjectRoot'. + commandRun :: GlobalEnv -> Tagged bt CommandPath -> Tagged bt ProjectTarget + -> Args -> IO ExitCode + + -- | Update index of available packages. + commandUpdate :: GlobalEnv -> Tagged bt CommandPath -> IO ExitCode + +-- | This class exists because of: +-- +-- a) Distinguish the different Cabal variants +-- +-- b) Be able to use a wrapper GADT that takes a @proxy bt@ and can +-- be an instance of 'BuildTool' but not this. +class (BuildTool bt) => NamedTool bt where + prettyName :: proxy bt -> String + prettyName = nameOfCommand . proxy commandName + +data ToolInformation bt = ToolInformation + { tool :: !String + , information :: !(Maybe (BuildUsage bt)) + } deriving (Eq, Show, Read, Generic, ToJSON) + +commandToolInformation :: (NamedTool bt) + => GlobalEnv -> proxy bt + -> IO (ToolInformation bt) +commandToolInformation env pr = + ToolInformation (prettyName pr) <$> commandBuildUsage env + +data BuildUsage bt = BuildUsage + { installation :: !(Installed bt) + , usable :: !Bool + , project :: !(Maybe (BuildProject bt)) + } deriving (Eq, Show, Read, Generic, ToJSON) + +data BuildProject bt = BuildProject + { projectRoot :: !(Tagged bt ProjectRoot) + , artifactsPresent :: !Bool + } deriving (Eq, Show, Read, Generic, ToJSON) + +-- | A 'Nothing' indicates that this tool cannot be used for this +-- project (i.e. needs configuration). +commandBuildUsage :: (BuildTool bt) + => GlobalEnv + -> IO (Maybe (BuildUsage bt)) +commandBuildUsage env = do + mInst <- commandInformation + forM mInst $ \inst -> + BuildUsage inst <$> canUseCommand env inst + <*> commandBuildProject (path inst) + + +commandBuildProject :: (BuildTool bt) => Tagged bt CommandPath + -> IO (Maybe (BuildProject bt)) +commandBuildProject cmd = do + mroot <- commandProjectRoot cmd + forM mroot $ \root -> + BuildProject root <$> hasBuildArtifacts root + +canUseBuildTool :: Maybe (BuildUsage bt) -> Bool +canUseBuildTool = maybe False (liftA2 (&&) usable (isJust . project)) + +-------------------------------------------------------------------------------- + +newtype ProjectRoot = ProjectRoot { rootPath :: FilePath } + deriving (Eq, Ord, Show, Read) + +instance IsString ProjectRoot where + fromString = ProjectRoot + +instance ToJSON ProjectRoot where + toJSON = toJSON . rootPath + +-- | TODO: determine if this is a library, executable, test or benchmark component. +newtype ProjectTarget = ProjectTarget { projectTarget :: String } + deriving (Eq, Ord, Show, Read) + +instance IsString ProjectTarget where + fromString = ProjectTarget + +componentName :: Tagged bt ProjectTarget -> String +componentName = safeLast . splitOn ':' . stripTag + +safeLast :: [[a]] -> [a] +safeLast [] = [] +safeLast ass = last ass + +splitOn :: (Eq a) => a -> [a] -> [[a]] +splitOn sep = go + where + go [] = [] + go as = case span (/= sep) as of + (seg, []) -> seg : [] + (seg, _:as') -> seg : go as' + +-------------------------------------------------------------------------------- + +-- | If an exception occurs, return 'Nothing' +tryIO :: IO (Maybe a) -> IO (Maybe a) +tryIO = handle (\SomeException{} -> return Nothing) + +-- | Recurse up until you find a directory containing a file that +-- matches the predicate, returning that directory. +recurseUpFindFile :: (FilePath -> Bool) -> IO (Maybe FilePath) +recurseUpFindFile p = tryIO $ go . dropTrailingPathSeparator =<< getCurrentDirectory + where + go dir = do cntns <- listDirectory dir + files <- filterM (doesFileExist . (dir )) cntns + if any p files + then return (Just dir) + -- We do the base case check here so we can + -- actually check the top level directory. + else if isDrive dir + then return Nothing + else go (takeDirectory dir) diff --git a/lib/System/JBI/Commands/Cabal.hs b/lib/System/JBI/Commands/Cabal.hs new file mode 100644 --- /dev/null +++ b/lib/System/JBI/Commands/Cabal.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} + +{- | + Module : System.JBI.Commands.Cabal + Description : cabal-install support + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module System.JBI.Commands.Cabal + ( Cabal + , CabalMode + , Sandbox + , Nix + ) where + +import System.JBI.Commands.BuildTool +import System.JBI.Commands.Nix +import System.JBI.Commands.Tool +import System.JBI.Environment +import System.JBI.Tagged + +import Control.Applicative (liftA2, (<*>)) +import Control.Monad (filterM) +import Data.Maybe (isJust, maybeToList) +import Data.Proxy (Proxy(Proxy)) +import Data.Version (makeVersion) +import System.Directory (doesFileExist, getCurrentDirectory, listDirectory, + removeFile) +import System.Exit (ExitCode, die, exitSuccess) +import System.FilePath (takeExtension, ()) +import System.IO.Error (ioError, isDoesNotExistError, tryIOError) + +import qualified Distribution.Package as CPkg +import Distribution.PackageDescription (GenericPackageDescription, + condBenchmarks, + condExecutables, + condLibrary, + condTestSuites) +import qualified Distribution.PackageDescription.Parse as CParse +import Distribution.Verbosity (silent) + +#if MIN_VERSION_Cabal (2,0,0) +import Distribution.Types.UnqualComponentName (UnqualComponentName, + unUnqualComponentName) +#endif + +-------------------------------------------------------------------------------- + +data Cabal mode + +instance Tool (Cabal mode) where + commandName = "cabal" + +instance (CabalMode mode) => BuildTool (Cabal mode) where + canUseCommand = canUseMode + + commandProjectRoot = cabalProjectRoot + + hasBuildArtifacts = hasModeArtifacts + + commandPrepare = cabalPrepare + + commandTargets = cabalTargets + + commandBuild env cmd = cabalTry env cmd . cabalBuild env cmd + + commandRepl env cmd = cabalTry env cmd . cabalRepl env cmd + + commandClean = cabalClean + + commandTest = liftA2 (<*>) cabalTry cabalTest + + commandBench = liftA2 (<*>) cabalTry cabalBench + + commandExec = cabalExec + + commandRun env cmd = (cabalTry env cmd .) . cabalRun env cmd + + commandUpdate = cabalUpdate + +cabalTry :: (CabalMode mode) => GlobalEnv -> Tagged (Cabal mode) CommandPath + -> IO ExitCode -> IO ExitCode +cabalTry env cmd = tryCommand "Command failed, trying to re-configure" + (cabalConfigure env cmd) + +instance (CabalMode mode) => NamedTool (Cabal mode) where + prettyName p = "cabal+" ++ modeName (getMode p) + +getMode :: proxy (Cabal mode) -> Proxy mode +getMode _ = Proxy + +class CabalMode mode where + modeName :: proxy mode -> String + + canUseMode :: GlobalEnv -> Installed (Cabal mode) -> IO Bool + + cabalProjectRoot :: Tagged (Cabal mode) CommandPath + -> IO (Maybe (Tagged (Cabal mode) ProjectRoot)) + cabalProjectRoot = withTaggedF go + where + -- Type signature needed to make withTaggedF happy, though we + -- don't actually use the command itself for this. + go :: FilePath -> IO (Maybe FilePath) + go _ = recurseUpFindFile isCabalFile + + hasModeArtifacts :: Tagged (Cabal mode) ProjectRoot -> IO Bool + + cabalPrepare :: GlobalEnv -> Tagged (Cabal mode) CommandPath -> IO ExitCode + + cabalTargets :: Tagged (Cabal mode) CommandPath + -> IO [Tagged (Cabal mode) ProjectTarget] + cabalTargets = withTaggedF go + where + -- Make withTaggedF happy + go :: FilePath -> IO [String] + go _ = cabalFileComponents + + -- | This is an additional function than found in 'BuildTool'. May + -- include installing dependencies. + cabalConfigure :: GlobalEnv -> Tagged (Cabal mode) CommandPath -> IO ExitCode + + cabalBuild :: GlobalEnv -> Tagged (Cabal mode) CommandPath + -> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode + cabalBuild = commandArgTarget "build" + + cabalRepl :: GlobalEnv -> Tagged (Cabal mode) CommandPath + -> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode + cabalRepl = commandArgsTarget ["repl", "--ghc-options=-ferror-spans"] + + cabalClean :: GlobalEnv -> Tagged (Cabal mode) CommandPath -> IO ExitCode + + cabalTest :: GlobalEnv -> Tagged (Cabal mode) CommandPath -> IO ExitCode + cabalTest = commandArg "test" + + cabalBench :: GlobalEnv -> Tagged (Cabal mode) CommandPath -> IO ExitCode + cabalBench = commandArg "bench" + + cabalExec :: GlobalEnv -> Tagged (Cabal mode) CommandPath -> String -> Args -> IO ExitCode + cabalExec env cmd prog progArgs = commandArgs args env cmd + where + args = "exec" : prog : "--" : progArgs + + cabalRun :: GlobalEnv -> Tagged (Cabal mode) CommandPath -> Tagged (Cabal mode) ProjectTarget + -> Args -> IO ExitCode + cabalRun env cmd prog progArgs = commandArgs args env cmd + where + args = "run" : componentName (stripTag prog) : "--" : progArgs + + cabalUpdate :: GlobalEnv -> Tagged (Cabal mode) CommandPath -> IO ExitCode + cabalUpdate = commandArg "update" + +-------------------------------------------------------------------------------- + +data Sandbox + +instance CabalMode Sandbox where + modeName _ = "sandbox" + + canUseMode env inst = return (isJust (ghc env) + && maybe True ((>= makeVersion [1,18]) . stripTag) + (version inst)) + + hasModeArtifacts pr = doesFileExist (stripTag pr "cabal.sandbox.config") + + cabalPrepare = commandArgs ["sandbox", "init"] + + cabalConfigure env cmd = tryConfigure + where + install = commandArgs ["install", "--only-dependencies" + , "--enable-tests", "--enable-benchmarks"] + env cmd + + tryInstall = tryCommand "Installation failed; updating index." + (cabalUpdate env cmd) + install + + tryConfigure = tryCommand "Configuring failed; checking dependencies" + tryInstall + configure + + configure = commandArgs ["configure", "--enable-tests", "--enable-benchmarks"] + env cmd + + -- Note: we don't treat "dist" as part of the tool artifacts, but it + -- doesn't make sense without the sandbox so remove it as well. + cabalClean env cmd = commandArg "clean" env cmd + .&&. commandArgs ["sandbox", "delete"] env cmd + +-------------------------------------------------------------------------------- + +data Nix + +instance CabalMode Nix where + modeName _ = "nix" + + canUseMode env _ = return (liftA2 (&&) (isJust . nixShell) (isJust . cabal2Nix) (nix env)) + + hasModeArtifacts pr = or <$> mapM (doesFileExist . (stripTag pr )) + ["shell.nix", "default.nix"] + + -- Note that commandPrepare is meant to be run within ProjectRoot + cabalPrepare env _ = case path <$> cabal2Nix (nix env) of + Nothing -> die "cabal2Nix required" + Just c2n -> tryRunToFile "shell.nix" c2n ["--shell", "."] + + cabalConfigure env _ = case path <$> nixShell (nix env) of + Nothing -> die "nix-shell required" + Just ns -> tryRun ns ["--run", "cabal configure --enable-tests --enable-benchmarks"] + + cabalClean env cmd = commandArg "clean" env cmd + .&&. rmFile "shell.nix" + .&&. rmFile "default.nix" + where + rmFile file = do + rmStatus <- tryIOError (removeFile file) + case rmStatus of + -- We're guessing as to which file is the one being used + -- here, so an error because a file doesn't exist is OK; + -- anything else is serious and should be re-thrown. + Left err | not (isDoesNotExistError err) -> ioError err + _ -> exitSuccess + +-------------------------------------------------------------------------------- + +isCabalFile :: FilePath -> Bool +isCabalFile = (== ".cabal") . takeExtension + +-------------------------------------------------------------------------------- +-- The Cabal library likes to really keep changing things... + +cabalFileComponents :: IO [String] +cabalFileComponents = do + dir <- getCurrentDirectory + cntns <- map (dir ) <$> listDirectory dir + files <- filterM doesFileExist cntns + let cabalFiles = filter isCabalFile files + case cabalFiles of + [] -> return [] + (c:_) -> getComponents <$> parseCabalFile c + +parseCabalFile :: FilePath -> IO GenericPackageDescription +parseCabalFile = +#if MIN_VERSION_Cabal(2,0,0) + CParse.readGenericPackageDescription +#else + CParse.readPackageDescription +#endif + silent + +type ComponentName = +#if MIN_VERSION_Cabal (2,0,0) + UnqualComponentName +#else + String +#endif + +rawComponentName :: ComponentName -> String +rawComponentName = +#if MIN_VERSION_Cabal (2,0,0) + unUnqualComponentName +#else + id +#endif + +packageName :: GenericPackageDescription -> String +packageName = +#if MIN_VERSION_Cabal (2,0,0) + CPkg.unPackageName +#else + (\(CPkg.PackageName nm) -> nm) +#endif + . CPkg.packageName + +getComponents :: GenericPackageDescription -> [String] +getComponents gpd = concat + [ getLib + , getType condExecutables "exe" + , getType condTestSuites "test" + , getType condBenchmarks "bench" + ] + where + pkgName = packageName gpd + + getLib + | isJust (condLibrary gpd) = ["lib:" ++ pkgName] + | otherwise = [] + + getType f typ = map (\cmp -> typ ++ ':' : rawComponentName (fst cmp)) (f gpd) + +-------------------------------------------------------------------------------- + +commandArgsTarget :: Args -> GlobalEnv -> Tagged (Cabal mode) CommandPath + -> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode +commandArgsTarget args env cmd mt = commandArgs args' env cmd + where + args' = args ++ maybeToList (fmap stripTag mt) + +commandArgTarget :: String -> GlobalEnv -> Tagged (Cabal mode) CommandPath + -> Maybe (Tagged (Cabal mode) ProjectTarget) -> IO ExitCode +commandArgTarget = commandArgsTarget . (:[]) + +commandArg :: String -> GlobalEnv -> Tagged (Cabal mode) CommandPath + -> IO ExitCode +commandArg arg = commandArgs [arg] + +commandArgs :: Args -> GlobalEnv -> Tagged (Cabal mode) CommandPath + -> IO ExitCode +commandArgs args _env cmd = tryRun cmd args diff --git a/lib/System/JBI/Commands/Nix.hs b/lib/System/JBI/Commands/Nix.hs new file mode 100644 --- /dev/null +++ b/lib/System/JBI/Commands/Nix.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} + +{- | + Module : System.JBI.Commands.Nix + Description : Nix tooling support + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module System.JBI.Commands.Nix where + +import System.JBI.Commands.Tool +import System.JBI.Tagged + +import Control.Applicative (liftA2) +import Data.Aeson (ToJSON) +import Data.Char (isSpace) +import GHC.Generics (Generic) + +-------------------------------------------------------------------------------- + +data NixSupport = NixSupport + { nixShell :: !(Maybe (Installed NixShell)) + , cabal2Nix :: !(Maybe (Installed Cabal2Nix)) + } deriving (Eq, Ord, Show, Read, Generic, ToJSON) + +findNixSupport :: IO NixSupport +findNixSupport = liftA2 NixSupport commandInformation + commandInformation + +data NixShell + +instance Tool NixShell where + commandName = "nix-shell" + +data Cabal2Nix + +instance Tool Cabal2Nix where + commandName = "cabal2nix" + + commandVersion = withTaggedF (tryFindVersionBy getVer) + where + -- There's a digit in the command name, so the naive approach + -- doesn't work. + getVer = takeVersion . drop 1 . dropWhile (not . isSpace) diff --git a/lib/System/JBI/Commands/Stack.hs b/lib/System/JBI/Commands/Stack.hs new file mode 100644 --- /dev/null +++ b/lib/System/JBI/Commands/Stack.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +{- | + Module : System.JBI.Commands.Stack + Description : Stack commands + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module System.JBI.Commands.Stack (Stack) where + +import System.JBI.Commands.BuildTool +import System.JBI.Commands.Nix (nixShell) +import System.JBI.Commands.Tool +import System.JBI.Environment +import System.JBI.Tagged + +import Data.Maybe (isJust, maybeToList) +import System.Directory (doesDirectoryExist) +import System.Exit (ExitCode) +import System.FilePath (()) + +-------------------------------------------------------------------------------- + +data Stack + +instance Tool Stack where + commandName = "stack" + +instance BuildTool Stack where + + commandProjectRoot = withTaggedF go + where + go :: FilePath -> IO (Maybe FilePath) + go _ = recurseUpFindFile (== "stack.yaml") + + hasBuildArtifacts dir = doesDirectoryExist (stripTag dir ".stack-work") + + commandPrepare env cmd = commandArg "setup" env cmd + .&&. commandArgs ["build", "--dry-run"] env cmd + + commandTargets = withTaggedF go + where + go cmd = maybe [] lines <$> tryRunOutput cmd ["ide", "targets"] + + commandBuild = commandArgsTarget ["build", "--test", "--no-run-tests", "--bench", "--no-run-benchmarks"] + + commandRepl = commandArgsTarget ["ghci", "--ghci-options=-ferror-spans", "--test", "--bench", "--no-load"] + + commandClean = commandArgs ["clean", "--full"] + + commandTest = commandArg "test" + + commandBench = commandArg "bench" + + commandExec env cmd prog progArgs = commandArgs args env cmd + where + args = "exec" : prog : "--" : progArgs + + -- Stack doesn't have a "run" equivalent; see under \"component\" + -- here: + -- https://docs.haskellstack.org/en/stable/build_command/#target-syntax + commandRun env cmd prog progArgs = + commandBuild env cmd (Just prog) + .&&. commandExec env cmd (componentName prog) progArgs + + commandUpdate = commandArg "update" + +instance NamedTool Stack + +commandArgsTarget :: Args -> GlobalEnv -> Tagged Stack CommandPath + -> Maybe (Tagged Stack ProjectTarget) -> IO ExitCode +commandArgsTarget args env cmd mt = commandArgs args' env cmd + where + args' = args ++ maybeToList (fmap stripTag mt) + +commandArg :: String -> GlobalEnv -> Tagged Stack CommandPath + -> IO ExitCode +commandArg arg = commandArgs [arg] + +commandArgs :: Args -> GlobalEnv -> Tagged Stack CommandPath + -> IO ExitCode +commandArgs args env cmd = tryRun cmd args' + where + hasNix = isJust (nixShell (nix env)) + + args' + | hasNix = "--nix" : args + | otherwise = args diff --git a/lib/System/JBI/Commands/Tool.hs b/lib/System/JBI/Commands/Tool.hs new file mode 100644 --- /dev/null +++ b/lib/System/JBI/Commands/Tool.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} + +{- | + Module : System.JBI.Commands.Tool + Description : Common tooling commands + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module System.JBI.Commands.Tool where + +import System.JBI.Tagged + +import Control.Applicative (liftA2) +import Data.Aeson (ToJSON(toJSON)) +import Data.Char (isDigit) +import Data.Maybe (listToMaybe) +import Data.String (IsString(..)) +import Data.Version (Version, parseVersion) +import GHC.Generics (Generic) +import System.Directory (findExecutable) +import System.Exit (ExitCode(ExitSuccess)) +import System.IO (IOMode(WriteMode), withFile) +import System.Process (CreateProcess(..), + StdStream(Inherit, UseHandle), proc, + readProcessWithExitCode, waitForProcess, + withCreateProcess) +import Text.ParserCombinators.ReadP (eof, readP_to_S) + +-------------------------------------------------------------------------------- + +class Tool t where + commandName :: Tagged t CommandName + + commandVersion :: Tagged t CommandPath -> IO (Maybe (Tagged t Version)) + commandVersion = withTaggedF tryFindVersion + +commandPath :: (Tool t) => IO (Maybe (Tagged t CommandPath)) +commandPath = withTaggedF findExecutable commandName + +commandInformation :: (Tool t) => IO (Maybe (Installed t)) +commandInformation = commandPath >>= mapM getVersion + where + getVersion :: (Tool t') => Tagged t' CommandPath -> IO (Installed t') + getVersion tcp = Installed tcp <$> commandVersion tcp + +data GHC + +instance Tool GHC where + commandName = "ghc" + +-------------------------------------------------------------------------------- + +newtype CommandName = CommandName { nameOfCommand :: String } + deriving (Eq, Ord, Show, Read) + +instance IsString CommandName where + fromString = CommandName + +newtype CommandPath = CommandPath { pathToCommand :: FilePath } + deriving (Eq, Ord, Show, Read) + +instance ToJSON CommandPath where + toJSON = toJSON . pathToCommand + +instance IsString CommandPath where + fromString = CommandPath + +data Installed t = Installed + { path :: !(Tagged t CommandPath) + , version :: !(Maybe (Tagged t Version)) + -- ^ Try and determine the version. Only a factor in + -- case any features are version-specific. + } deriving (Eq, Ord, Show, Read, Generic, ToJSON) + +-------------------------------------------------------------------------------- + +-- | Attempt to find the version of the provided command, by assuming +-- it's contained in the first line of the output of @command +-- --version@. +tryFindVersion :: FilePath -> IO (Maybe Version) +tryFindVersion = tryFindVersionBy findVersion + where + findVersion str = takeVersion (dropWhile (not . isDigit) str) + +-- | If we're at the start of a Version, take all of it. +takeVersion :: String -> String +takeVersion = takeWhile (liftA2 (||) isDigit (=='.')) + +tryFindVersionBy :: (String -> String) -> FilePath -> IO (Maybe Version) +tryFindVersionBy findVersion cmd = + fmap (>>= parseVer) (tryRunOutput cmd ["--version"]) + where + parseVer ver = case readP_to_S (parseVersion <* eof) (findVersion ver) of + [(v,"")] -> Just v + _ -> Nothing + +type Args = [String] + +-- | Only return the stdout if the process was successful and had no stderr. +tryRunOutput :: FilePath -> Args -> IO (Maybe String) +tryRunOutput cmd args = do + res <- readProcessWithExitCode cmd args "" + return $ case res of + (ExitSuccess, out, "" ) -> Just out + -- Some tools (e.g. Stack) put output to stderr + (ExitSuccess, "", err) -> Just err + _ -> Nothing + +-- | As with 'tryRunOutput' but only return the first line (if any). +tryRunLine :: FilePath -> Args -> IO (Maybe String) +tryRunLine cmd = fmap (>>= listToMaybe . lines) . tryRunOutput cmd + +-- | Returns success of call. +tryRun :: Tagged t CommandPath -> Args -> IO ExitCode +tryRun cmd args = withCreateProcess cp $ \_ _ _ ph -> + waitForProcess ph + where + cmd' = stripTag cmd + + cp = (proc cmd' args) { std_in = Inherit + , std_out = Inherit + , std_err = Inherit + } + +tryRunToFile :: FilePath -> Tagged t CommandPath -> Args -> IO ExitCode +tryRunToFile file cmd args = withFile file WriteMode $ \h -> + withCreateProcess (cp h) $ \_ _ _ ph -> + waitForProcess ph + where + cmd' = stripTag cmd + + cp h = (proc cmd' args) { std_in = Inherit + , std_out = UseHandle h + , std_err = Inherit + } + +-- | Equivalent to chaining all the calls with @&&@ in bash, etc. +-- +-- Argument order to make it easier to feed it into a 'Tagged'-based +-- pipeline. +tryRunAll :: [Args] -> Tagged t CommandPath -> IO ExitCode +tryRunAll argss cmd = allSuccess $ map (tryRun cmd) argss + +(.&&.) :: (Monad m) => m ExitCode -> m ExitCode -> m ExitCode +m1 .&&. m2 = do ec1 <- m1 + case ec1 of + ExitSuccess -> m2 + _ -> return ec1 + +infixr 3 .&&. + +(.||.) :: (Monad m) => m ExitCode -> m ExitCode -> m ExitCode +m1 .||. m2 = do ec1 <- m1 + case ec1 of + ExitSuccess -> return ec1 + _ -> m2 + +infixr 2 .||. + +tryCommand :: String -> IO ExitCode -> IO ExitCode -> IO ExitCode +tryCommand msg tryWith run = run .||. tryAgain + where + tryAgain = do + putStrLn (makeBox msg) + tryWith .&&. run + +makeBox :: String -> String +makeBox msg = unlines [ border + , "* " ++ msg ++ " *" + , border + ] + where + msgLen = length msg + boxLen = msgLen + 4 -- asterisk + space on either side + + border = replicate boxLen '*' + +allSuccess :: (Monad m, Foldable t) => t (m ExitCode) -> m ExitCode +allSuccess = foldr (.&&.) (return ExitSuccess) + +-- | Monad version of 'all', aborts the computation at the first @False@ value +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM _ [] = return True +allM f (b:bs) = f b >>= (\bv -> if bv then allM f bs else return False) diff --git a/lib/System/JBI/Environment.hs b/lib/System/JBI/Environment.hs new file mode 100644 --- /dev/null +++ b/lib/System/JBI/Environment.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-} + +{- | + Module : System.JBI.Environment + Description : Build tool agnostic environment + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + This is used by build tools to help them determine how they should + run (as opposed to configuration environment which is their actual + working directories, etc.). + + -} +module System.JBI.Environment where + +import System.JBI.Commands.Nix +import System.JBI.Commands.Tool + +import Data.Aeson (ToJSON) +import GHC.Generics (Generic) + +-------------------------------------------------------------------------------- + +data GlobalEnv = GlobalEnv + { nix :: NixSupport + , ghc :: Maybe (Installed GHC) + } deriving (Eq, Show, Read, Generic, ToJSON) + +globalEnv :: IO GlobalEnv +globalEnv = GlobalEnv <$> findNixSupport <*> commandInformation diff --git a/lib/System/JBI/Tagged.hs b/lib/System/JBI/Tagged.hs new file mode 100644 --- /dev/null +++ b/lib/System/JBI/Tagged.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE DefaultSignatures, FlexibleContexts, KindSignatures, + MultiParamTypeClasses #-} + +{- | + Module : System.JBI.Commands.Tagged + Description : Support for the Tagged type + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module System.JBI.Tagged + ( WithTagged (..) + , stripTag + , stripTags + , tag + -- * Re-export + , Tagged (..) + , proxy + ) where + +import Data.Coerce (Coercible, coerce) +import Data.Tagged + +-------------------------------------------------------------------------------- + +class WithTagged (g :: * -> *) where + + -- | Strip off type safety, run the function, put type safety back on. + withTaggedF :: (Coercible a a', Coercible b b', Functor f) + => (a' -> f (g b')) -> Tagged t a -> f (g (Tagged t b)) + default withTaggedF :: ( Coercible a a', Coercible b b', Functor f + , Coercible (g b') (g (Tagged t b)) + , Coercible (g (Tagged t b)) (g b')) + => (a' -> f (g b')) -> Tagged t a -> f (g (Tagged t b)) + withTaggedF f = fmap coerce . f . coerce + + tagInner :: Tagged t (g a) -> g (Tagged t a) + default tagInner :: ( Coercible (Tagged t (g a)) (g (Tagged t a)) + , Coercible (g (Tagged t a)) (g a)) + => Tagged t (g a) -> g (Tagged t a) + tagInner = coerce + + tagOuter :: g (Tagged t a) -> Tagged t (g a) + default tagOuter :: (Coercible (g (Tagged t a)) (Tagged t (g a))) + => g (Tagged t a) -> Tagged t (g a) + tagOuter = coerce + +instance WithTagged Maybe +instance WithTagged [] + +-- | Remove the tag along with (potentially) any newtype wrappers +-- added on. +stripTag :: (Coercible a a') => Tagged t a -> a' +stripTag = coerce + +stripTags :: (Coercible a a') => [Tagged t a] -> [a'] +stripTags = coerce + +-- | Put the appropriate tag on. +tag :: (Coercible a a') => a -> Tagged t a' +tag = coerce diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,165 @@ +{- | + Module : Main + Description : Just Build It! + Copyright : (c) Ivan Lazar Miljenovic + License : MIT + Maintainer : Ivan.Miljenovic@gmail.com + + + + -} +module Main where + +import Paths_jbi (version) +import System.JBI +import System.JBI.Commands.BuildTool (ProjectTarget(..), rootPath) +import System.JBI.Commands.Tool (Args) + +import Control.Applicative (many, optional, (<*>), (<|>)) +import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder) +import Data.List (intercalate) +import Data.Monoid (mconcat, (<>)) +import Data.Text.Lazy (unpack) +import Data.Text.Lazy.Builder (toLazyText) +import Data.Version (showVersion) +import Options.Applicative (Parser, ParserInfo, argument, command, + execParser, footer, fullDesc, header, help, + helper, hsubparser, info, metavar, progDesc, + str, strArgument) +import System.Exit (ExitCode(ExitSuccess), die, exitWith) + +-------------------------------------------------------------------------------- + +main :: IO () +main = execParser parser >>= runCommand defaultTools + +-------------------------------------------------------------------------------- + +data Command = Prepare + | Targets + | Build (Maybe ProjectTarget) + | REPL (Maybe ProjectTarget) + | Clean + | Test + | Bench + | Exec String Args + | Run ProjectTarget Args + | Update + | Info InfoType + deriving (Eq, Show, Read) + +data InfoType = AvailableTools + | ChosenTool + | ProjectDir + | Detailed + deriving (Eq, Show, Read) + +parser :: ParserInfo Command +parser = info (helper <*> parseCommand) $ + header versionInfo + <> fullDesc + <> footer "No arguments is equivalent to running `build`" + +versionInfo :: String +versionInfo = "jbi " ++ showVersion version ++ " - Just Build It and Hack On!" + +parseCommand :: Parser Command +parseCommand = (hsubparser . mconcat $ + [ command "prepare" (info (pure Prepare) + (progDesc "Initialise the tool; usually not needed, \ + \but will (re-)generate the `shell.nix` for `cabal+nix`.")) + , command "targets" (info (pure Targets) + (progDesc "Print available targets")) + , command "build" (info (Build <$> optional parseTarget) + (progDesc "Build the project (optionally a specified target).")) + , command "repl" (info (REPL <$> optional parseTarget) + (progDesc "Start a REPL. Passing in a target is optional, but \ + \highly recommended when multiple targets are available.")) + , command "clean" (info (pure Clean) + (progDesc "Remove all build artifacts.")) + , command "test" (info (pure Test) + (progDesc "Run test suite(s).")) + , command "bench" (info (pure Bench) + (progDesc "Run benchmark(s).")) + , command "exec" (info (Exec <$> parseExecutable <*> parseArgs) + (progDesc "Run the specified executable within the build environment.")) + , command "run" (info (Run <$> parseTarget <*> parseArgs) + (progDesc "Run the specified executable target within the build environment.")) + , command "update" (info (pure Update) + (progDesc "Update the package index (usually not needed).")) + , command "info" (info (Info <$> parseInfo) + (progDesc "Build tool information; useful for debugging.")) + ]) + <|> pure (Build Nothing) + +parseTarget :: Parser ProjectTarget +parseTarget = argument (ProjectTarget <$> str) ( metavar "TARGET" + <> help "Project target (see the `targets` command)" + ) + +parseExecutable :: Parser String +parseExecutable = strArgument ( metavar "COMMAND" + <> help "A command/executable" + ) + +parseArgs :: Parser Args +parseArgs = many (strArgument ( metavar "ARG" + <> help "Optional arguments to pass through to the command" + )) + +parseInfo :: Parser InfoType +parseInfo = hsubparser . mconcat $ + [ command "tools" (info (pure AvailableTools) + (progDesc "Print all known build tools.")) + , command "chosen" (info (pure ChosenTool) + (progDesc "Print the build tool chosen.")) + , command "project" (info (pure ProjectDir) + (progDesc "Path to the project directory.")) + , command "details" (info (pure Detailed) + (progDesc "Print detailed information about build tools.")) + ] + +-------------------------------------------------------------------------------- + +runCommand :: [WrappedTool proxy] -> Command -> IO () +runCommand tools cmd = do + ec <- case cmd of + Prepare -> tooled prepare + Build mt -> tooled (build mt) + REPL mt -> tooled (repl mt) + Clean -> tooled clean + Test -> tooled test + Bench -> tooled bench + Exec exe args -> tooled (exec exe args) + Run exe args -> tooled (run exe args) + Update -> tooled update + Targets -> printSuccess printTargets + Info it -> printSuccess (printInfo it) + exitWith ec + where + tooled :: (GlobalEnv -> WrappedTool Valid -> IO a) -> IO a + tooled f = withTool toolFail f tools + + toolFail :: IO a + toolFail = die "No possible tool found." + + printSuccess act = do out <- act + putStrLn out + return ExitSuccess + + printTargets = tooled ((fmap (multiLine . map projectTarget) .) . targets) + + withChosen f = do env <- globalEnv + mTool <- chooseTool env tools + maybe toolFail (return . f) mTool + + jsonStr = unpack . toLazyText . encodePrettyToTextBuilder + + printInfo AvailableTools = return . multiLine . map toolName $ tools + printInfo ChosenTool = withChosen toolName + printInfo ProjectDir = withChosen (rootPath . infoProjectDir) + printInfo Detailed = jsonStr <$> getInformation tools + +-- Unlike unlines, this doesn't add a trailing newline. +multiLine :: [String] -> String +multiLine = intercalate "\n"