packages feed

jbi (empty) → 0.1.0.0

raw patch · 15 files changed

+1674/−0 lines, 15 filesdep +Cabaldep +aesondep +aeson-prettysetup-changed

Dependencies added: Cabal, aeson, aeson-pretty, base, directory, filepath, jbi, optparse-applicative, process, tagged, text

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for jbi++## 0.1.0.0  -- 2017-09-05++* First version. Released on an semi-suspecting world.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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 <foo>`, 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ jbi.cabal view
@@ -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
+ lib/System/JBI.hs view
@@ -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
+ lib/System/JBI/Commands.hs view
@@ -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
+ lib/System/JBI/Commands/BuildTool.hs view
@@ -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)
+ lib/System/JBI/Commands/Cabal.hs view
@@ -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
+ lib/System/JBI/Commands/Nix.hs view
@@ -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)
+ lib/System/JBI/Commands/Stack.hs view
@@ -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
+ lib/System/JBI/Commands/Tool.hs view
@@ -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)
+ lib/System/JBI/Environment.hs view
@@ -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
+ lib/System/JBI/Tagged.hs view
@@ -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
+ src/Main.hs view
@@ -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"