diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,8 @@ +# Changelog for hs + +## Unreleased changes + + +## v0.1.0.0 + + * First release: provides minimal working integration of stack and cabal-install for Unix. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Chris Dornan (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,56 @@ +# hs: a Haskell installation-manager broker + +Build managers like `cabal-install` and `stack` need access to installed toolchains managed by +installation managers like `stack` and `ghcup`. `hs` keeps track of the toolchains installed by +the managers and locates them on request for the build managers. + +```bash +$ hs whereis ghc-8.10.4 +/Users/chris/.stack/programs/x86_64-osx/ghc-8.10.4 +``` + +We have a prototype integration for `stack` (watch this space) and a collection of wrappers for +each tool that `cabal-install` can use, like the following for ghc-pkg-8.10.4: + +```bash +#!/usr/bin/env bash +hs run ghc-pkg-8.10.4 --ask-install -- "$@" +``` + +Used in this way, `hs` will try to locate `ghc-pkg-8.10.4`, asking the user if to proceed with an +installation with the preferred installation manager (`stack` or `ghcup`) if it cannot locate the +installation. + +To list the installation in your development environment try this: + +``` +$ stack list +8.6.5 stack /Users/chris/.stack/programs/x86_64-osx/ghc-8.6.5 +8.8.3 stack /Users/chris/.stack/programs/x86_64-osx/ghc-8.8.3 +8.8.4 stack /Users/chris/.stack/programs/x86_64-osx/ghc-8.8.4 +8.10.4 stack /Users/chris/.stack/programs/x86_64-osx/ghc-8.10.4 +8.10.5 ghcup /Users/chris/.ghcup/ghc/8.10.5 +9.0.1 ghcup /Users/chris/.ghcup/ghc/9.0.1 +``` + +To configure the defaults you can do these. + +```bash +# ghcup to carry out installations requested from the build tools +$ hs use ghcup stack +# ask before installing any missing toolchains +$ hs use-install-mode ask-install +# specify the deafult toolchain when no version specified +$ hs use-compiler 8.10.4 +``` + +To dump a new set of wrappers into `~/.hs/bin` with your preferred `ask-install` installation +option: + +```bash +$ hs dump-ghc-wrappers ask-install +``` + +With the path set up right your stack and cabal-install projects should play nicely together. + +Share and Enjoy! 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/app/hs.hs b/app/hs.hs new file mode 100644 --- /dev/null +++ b/app/hs.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import HS +import HS.CLI + + +main :: IO () +main = hs =<< parseCLI diff --git a/hs.cabal b/hs.cabal new file mode 100644 --- /dev/null +++ b/hs.cabal @@ -0,0 +1,95 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: hs +version: 0.1.0.0 +synopsis: GHC-toolchain installer broker +description: A tool for keeping track of where GHC installations have been placed and reporting + that to the build managers (like @stack@ and @cabal-install@). +category: Development +homepage: https://github.com/githubuser/hs#readme +bug-reports: https://github.com/githubuser/hs/issues +author: Chris Dornan +maintainer: Chris Dornan +copyright: 2021 Chris Dornan +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/githubuser/hs + +library + exposed-modules: + HS + HS.Cfg + HS.Cfg.CfgFile + HS.Cfg.Load + HS.Cfg.Types + HS.CLI + HS.CLI.CLI + HS.CLI.OptParse + HS.CLI.Parse + HS.CLI.ToolArgs + HS.Cmd + HS.Cmd.Dump + HS.Cmd.List + HS.Cmd.Run + HS.Cmd.Use + HS.Cmd.Whereis + HS.Install + HS.Managers + HS.Managers.Ghcup + HS.Managers.Stack + HS.Managers.Types + HS.Types + HS.Types.CompilerTool + HS.Types.InstallMode + HS.Types.Manager + other-modules: + Paths_hs + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , containers + , data-default + , directory + , enum-text + , filepath + , fmt + , optparse-applicative + , possibly + , text + , typed-process + default-language: Haskell2010 + +executable hs + main-is: hs.hs + other-modules: + Paths_hs + hs-source-dirs: + app + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , containers + , data-default + , directory + , enum-text + , filepath + , fmt + , hs + , optparse-applicative + , possibly + , text + , typed-process + default-language: Haskell2010 diff --git a/src/HS.hs b/src/HS.hs new file mode 100644 --- /dev/null +++ b/src/HS.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HS + ( hs + , module HS.CLI.CLI + ) where + +import Data.Version +import Fmt +import HS.Cfg +import HS.CLI +import HS.CLI.CLI +import HS.Cmd +import Paths_hs + + +-- | run an @hs@ command +hs :: CLI -> IO () +hs cli = + case cli of + CLI_version -> fmtLn $ ""+|showVersion version|+"" + CLI_whereis imd cp -> ld $ \cfg -> cmdWhereis cfg imd cp + CLI_run imd cp as -> ld $ \cfg -> cmdRun cfg imd cp as + CLI_list cp -> ld $ \cfg -> cmdList cfg cp + CLI_use is -> ld $ \cfg -> cmdUse cfg is + CLI_use_install_mode imd -> ld $ \cfg -> cmdUseIM cfg imd + CLI_use_compiler cpv -> ld $ \cfg -> cmdUseCp cfg cpv + CLI_dump_ghc_wrappers imd -> ld $ \cfg -> cmdDump cfg imd + where + ld :: (Cfg -> IO ()) -> IO () + ld cmd = cmd =<< loadCfg diff --git a/src/HS/CLI.hs b/src/HS/CLI.hs new file mode 100644 --- /dev/null +++ b/src/HS/CLI.hs @@ -0,0 +1,4 @@ +module HS.CLI (module X) where + +import HS.CLI.Parse as X +import HS.CLI.CLI as X diff --git a/src/HS/CLI/CLI.hs b/src/HS/CLI/CLI.hs new file mode 100644 --- /dev/null +++ b/src/HS/CLI/CLI.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} + +module HS.CLI.CLI + ( CLI(..) + , InstallMode(..) + , Compiler(..) + , CompilerVersion(..) + , Tool(..) + , ToolName(..) + , ToolArgs(..) + , Manager(..) + ) where + +import HS.CLI.ToolArgs +import HS.Types.CompilerTool +import HS.Types.InstallMode +import HS.Types.Manager + + +-- | command line abstrax syntax type +data CLI + = CLI_version + | CLI_whereis (Maybe InstallMode) Compiler + | CLI_run (Maybe InstallMode) Tool ToolArgs + | CLI_list (Maybe Compiler) + | CLI_use [Manager] + | CLI_use_install_mode (Maybe InstallMode) + | CLI_use_compiler (Maybe CompilerVersion) + | CLI_dump_ghc_wrappers (Maybe InstallMode) + deriving (Show) diff --git a/src/HS/CLI/OptParse.hs b/src/HS/CLI/OptParse.hs new file mode 100644 --- /dev/null +++ b/src/HS/CLI/OptParse.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module HS.CLI.OptParse where + +import Control.Applicative +import Data.Char +import Data.Default +import Data.Maybe +import Data.Possibly +import qualified Data.Text as T +import Fmt +import HS.CLI.ToolArgs +import qualified Options.Applicative as OP +import Options.Applicative.Builder +import System.Environment +import Text.Enum.Text + + +-- | the OA parser +type Psr a = OP.Parser a + +-- | the OA optional operator +opt :: Psr a -> Psr (Maybe a) +opt = OP.optional + +-- | the OA Kleene closure operator +mny :: Psr a -> Psr [a] +mny = OP.many + + +-------------------------------------------------------------------------------- +-- parseArgs +-------------------------------------------------------------------------------- + +-- | main OA driver function +parseArgs :: forall a . (ToolArgs->Psr a) -> IO a +parseArgs psr = prs =<< getArgs + where + prs :: [String] -> IO a + prs as0 = parseIO (psr tas) as + where + tas = ToolArgs $ map T.pack $ tail' dd_tas + (as,dd_tas) = break (=="--") as0 + + tail' :: [b] -> [b] + tail' [] = [] + tail' (_:t) = t + + +-------------------------------------------------------------------------------- +-- the low-level drivers +-------------------------------------------------------------------------------- + +parserPrefs :: OP.ParserPrefs +parserPrefs = OP.prefs showHelpOnEmpty + +-- | making an IO parser +parseIO :: Psr a -> [String] -> IO a +parseIO psr as = OP.handleParseResult $ + OP.execParserPure parserPrefs (hsParserInfo $ psr) as + +-- | making a functional parser +pureParse :: Psr a -> [String] -> Maybe a +pureParse p = + OP.getParseResult . OP.execParserPure parserPrefs (hsParserInfo p) + +-- | testing CLI parsers +testCLI :: Show a => Psr a -> [String] -> IO () +testCLI psr ss = do + x <- OP.handleParseResult $ + OP.execParserPure parserPrefs (hsParserInfo psr) ss + print x + + +-------------------------------------------------------------------------------- +-- hsParserInfo +-------------------------------------------------------------------------------- + +-- | given a 'Psr' makes up a corresponding @ParserInfo@ +hsParserInfo :: Psr a -> OP.ParserInfo a +hsParserInfo p = + OP.info (OP.helper <*> p) + $ fullDesc + <> progDesc "GHC installation manager manager" + <> header "towards a unified Haskell Development Environment" + <> footer "see --help for details of each sub-command" + + +-------------------------------------------------------------------------------- +-- cmd +-------------------------------------------------------------------------------- + +-- | construct a sub-command parser from command name, description and parser +cmd :: String -> String -> Psr a -> OP.Mod OP.CommandFields a +cmd nme dsc psr = command nme $ info (OP.helper <*> psr) $ progDesc dsc + + +-------------------------------------------------------------------------------- +-- parser builders +-------------------------------------------------------------------------------- + +cmd_et_p :: EnumText a => String -> (a->String) -> Psr a +cmd_et_p hlp c_hlp = subparser $ mconcat $ + commandGroup hlp : + [ cmd (fmt $ build c) (c_hlp c) $ pure c + | c <- [minBound..maxBound] + ] + +-- | parsing an argument EnumText argument +arg_et_optd :: forall a . EnumText a => String -> a -> Psr a +arg_et_optd var df = fromMaybe df <$> ss_p + where + ss_p :: Psr (Maybe a) + ss_p = opt $ arg_et_p var + +-- | parsing an argument EnumText argument +arg_et_p :: forall a . (Bounded a,Enum a,Buildable a,TextParsable a) => String -> Psr a +arg_et_p var = arg_p var hlp + where + hlp = T.unpack $ T.intercalate "|" $ + map (fmt . build) [minBound..maxBound :: a] + +-- | pasring an EnumText option +opt_et_p :: forall a . EnumText a => Char -> String -> Psr a +opt_et_p c var = opt_p c var hlp + where + hlp = T.unpack $ T.intercalate "|" $ + map (fmt . build) [minBound..maxBound :: a] + +-- | pasring a TextParsable argument +arg_p :: TextParsable a => String -> String -> Psr a +arg_p = arg_p' parseText + +-- | pasring an argument ParseText, when passed the parser explicitly +arg_p' :: (T.Text->Possibly a) -> String -> String -> Psr a +arg_p' prs var hlp = argument (eitherReader $ prs . T.pack) + $ metavar var + <> help hlp + +-- | parsing a TextParsable option +opt_p :: TextParsable a => Char -> String -> String -> Psr a +opt_p ch nme hlp = option (eitherReader parseString) + $ metavar var + <> short ch + <> long lng + <> help hlp + where + var = map toUpper nme + lng = map toLower nme + +enum_switches_with_def_p :: forall a . (Default a,EnumText a) => Psr a +enum_switches_with_def_p = fmap (fromMaybe def) $ opt $ short_enum_switches_p $ const Nothing + +enum_switches_p :: forall a . EnumText a => Psr a +enum_switches_p = short_enum_switches_p $ const Nothing + +short_enum_switches_p :: forall a . EnumText a => (a->Maybe Char) -> Psr a +short_enum_switches_p sh_f = foldr (<|>) empty $ map mk [minBound..maxBound] + where + mk :: a -> Psr a + mk x = OP.flag' x $ (long $ fmt $ build x) <> shrt + where + shrt = case sh_f x of + Nothing -> mempty + Just c -> short c + +parseString :: TextParsable a => String -> Possibly a +parseString = parseText . T.pack diff --git a/src/HS/CLI/Parse.hs b/src/HS/CLI/Parse.hs new file mode 100644 --- /dev/null +++ b/src/HS/CLI/Parse.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.CLI.Parse where + +import HS.CLI.OptParse +import HS.CLI.ToolArgs +import HS.CLI.CLI +import Options.Applicative + + +-- | parse the command line +parseCLI :: IO CLI +parseCLI = parseArgs cli_p + +cli_p :: ToolArgs -> Psr CLI +cli_p tas = subparser $ mconcat + [ cmd "version" vrn $ pure CLI_version + , cmd "whereis" whr $ CLI_whereis <$> opt inmd_p <*> cplr_p + , cmd "run" run $ CLI_run <$> opt inmd_p <*> tool_p <*> pure tas + , cmd "list" lst $ CLI_list <$> opt cplr_p + , cmd "use" use $ CLI_use <$> mny mngr_p + , cmd "use-install-mode" uim $ CLI_use_install_mode <$> opt imda_p + , cmd "use-compiler" ucp $ CLI_use_compiler <$> opt cpvn_p + , cmd "dump-ghc-wrappers" dgw $ CLI_dump_ghc_wrappers <$> opt imda_p + ] + where + vrn = "print out the version of this program" + whr = "identify the location of a (Compiler) compiler" + run = "run the designated (Compiler) compiler, installing needed and permitted, passing through the arguments" + use = "specify the priority of the sources of (Compiler) toolchain installations" + lst = "list the visible (Compiler) toolchains" + uim = "set the default install mode" + ucp = "set the default compiler" + dgw = "dump the named directory GHC tool wrappers the indirect through hs" + +-- flags/switches + +inmd_p :: Psr InstallMode +inmd_p = enum_switches_p + +-- arguments + +imda_p :: Psr InstallMode +imda_p = arg_et_p "" + +cplr_p :: Psr Compiler +cplr_p = arg_p "" "compiler to use" + +cpvn_p :: Psr CompilerVersion +cpvn_p = arg_p "x.y.z" "version of the compiler to use" + +tool_p :: Psr Tool +tool_p = arg_p "" "compiler to use" + +mngr_p :: Psr Manager +mngr_p = arg_p "" "manager of Compiler installation (stack|ghcup|...)" diff --git a/src/HS/CLI/ToolArgs.hs b/src/HS/CLI/ToolArgs.hs new file mode 100644 --- /dev/null +++ b/src/HS/CLI/ToolArgs.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HS.CLI.ToolArgs where + +import Data.Text(Text) +import Fmt + + +-- | list of command line arguments to be passed through to the compiler tool +newtype ToolArgs = ToolArgs { getToolArgs :: [Text] } + deriving (Show) + +instance Buildable ToolArgs where + build (ToolArgs as) = unwordsF as diff --git a/src/HS/Cfg.hs b/src/HS/Cfg.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cfg.hs @@ -0,0 +1,4 @@ +module HS.Cfg (module X) where + +import HS.Cfg.Load as X +import HS.Cfg.Types as X diff --git a/src/HS/Cfg/CfgFile.hs b/src/HS/Cfg/CfgFile.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cfg/CfgFile.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Cfg.CfgFile where + +import Data.Default +import Data.Text(Text) +import qualified Data.Text.IO as T +import Fmt +import System.Directory +import System.FilePath +import System.IO +import Text.Enum.Text + + +-- | enumeration for the @hs@ configuration files +data CfgFile + = CF_managers + | CF_mode + | CF_compiler + deriving stock (Bounded,Enum,Eq,Ord,Show) + deriving anyclass (EnumText) + deriving (Buildable,TextParsable) via UsingEnumText CfgFile + +-- | load a configuration file +load :: forall a . (Default a,TextParsable a) => CfgFile -> IO a +load cf = rd =<< cfgFile cf + where + rd :: FilePath -> IO a + rd fp = do + yup <- doesFileExist fp + if | yup -> prs fp =<< T.readFile fp + | otherwise -> return def + + prs :: FilePath -> Text -> IO a + prs fp = either (oops fp) return . parseText + + oops :: FilePath -> String -> IO a + oops fp msg = do + hPutStr stderr $ + "hs: warning: failed to parse "+||fp||+" with "+||msg||+"; using default" + return def + +-- | save a configuration file +save :: Buildable a => CfgFile -> a -> IO () +save cf x = flip T.writeFile (fmt $ build x) =<< cfgFile cf + +-- | generate the 'FilePath' for a 'CfgFile' +cfgFile :: CfgFile -> IO FilePath +cfgFile cf = ( (fmt $ build cf)) <$> dotHs + +-- | generate the @hs@ configuration directory 'FilePath' +dotHs :: IO FilePath +dotHs = do + dhs <- ( ".hs") <$> getHomeDirectory + const dhs <$> createDirectoryIfMissing True dhs diff --git a/src/HS/Cfg/Load.hs b/src/HS/Cfg/Load.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cfg/Load.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Cfg.Load where + +import Data.Map(Map) +import Fmt +import HS.Cfg.CfgFile +import HS.Managers +import HS.Types +import System.IO + + +loadCfg :: IO Cfg +loadCfg = ld =<< recover + where + ld :: Cfg -> IO Cfg + ld cfg0 = fmap (mk . mconcat) $ mapM (disco cfg0) $ getManagers _cfg_managers + where + mk :: Map Compiler Installation -> Cfg + mk mp = cfg0 + { _cfg_installations = mp + } + + Cfg{..} = cfg0 + + disco :: Cfg -> Manager -> IO (Map Compiler Installation) + disco cfg mgr + | mgr == stack = stackDiscover cfg + | mgr == ghcup = ghcupDiscover cfg + | otherwise = do + hPutStrLn stderr $ "hs: manager "+|mgr|+" not recognised: ignoring" + return mempty + +recover :: IO Cfg +recover = Cfg <$> load CF_managers <*> load CF_mode <*> load CF_compiler <*> pure mempty diff --git a/src/HS/Cfg/Types.hs b/src/HS/Cfg/Types.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cfg/Types.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} + +module HS.Cfg.Types where + +import Data.Default +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import Fmt +import HS.Managers.Types +import HS.Types.CompilerTool +import HS.Types.InstallMode +import HS.Types.Manager +import System.FilePath +import Text.Enum.Text + + +data Cfg = + Cfg + { _cfg_managers :: Managers + , _cfg_mode :: InstallMode + , _cfg_compiler :: CompilerVersion + , _cfg_installations :: Map Compiler Installation + } + deriving (Show) + +data Installation = + Installation + { _iln_compiler :: CompilerVersion + , _iln_manager :: Manager + , _iln_dir :: FilePath + } + deriving (Show) + +newtype Managers = Managers { getManagers :: [Manager] } + deriving stock (Eq,Ord,Show) + +instance Buildable Installation where + build Installation{..} = + "" +|padRightF 10 ' ' _iln_compiler|+ + " "+|padRightF 5 ' ' _iln_manager |+ + " "+| _iln_dir |+ + "" + +instance Buildable Managers where + build = unwordsF . getManagers + +instance TextParsable Managers where + parseText = fmap Managers . mapM parseText . T.words + +instance Default Managers where + def = Managers [stack,ghcup] + +_iln_executable :: Installation -> FilePath +_iln_executable iln = _iln_tool_executable iln TN_ghc + +_iln_tool_executable :: Installation -> ToolName -> FilePath +_iln_tool_executable iln tnm = _iln_bin iln (fmt $ build tnm) + +_iln_bin :: Installation -> FilePath +_iln_bin Installation{..} = _iln_dir "bin" + +resolveCompilerVersion :: Cfg -> Compiler -> CompilerVersion +resolveCompilerVersion cfg cp = fromMaybe _cfg_compiler $ compilerVersion cp + where + Cfg{..} = cfg + + +---------------------------------------------------------------------------------------------------- +-- testing tools +---------------------------------------------------------------------------------------------------- + +ghc, ghc_8'10'4, ghc_9'0'2 :: Compiler +ghc = Compiler Nothing +ghc_8'10'4 = Compiler $ Just v8'10'4 +ghc_9'0'2 = Compiler $ Just v9'0'2 + +v8'10'4, v9'0'2 :: CompilerVersion +v8'10'4 = CompilerVersion (8,10,4) +v9'0'2 = CompilerVersion (9,0,2) + +testCfg :: Cfg +testCfg = + Cfg + { _cfg_managers = Managers [stack,ghcup] + , _cfg_mode = def + , _cfg_compiler = v8'10'4 + , _cfg_installations = Map.fromList as + } + where + as :: [(Compiler,Installation)] + as = + [ (,) ghc $ Installation v8'10'4 stack "/Users/chris/.stack/programs/x86_64-osx/ghc-8.10.4" + , (,) ghc_8'10'4 $ Installation v8'10'4 stack "/Users/chris/.stack/programs/x86_64-osx/ghc-8.10.4" + , (,) ghc_9'0'2 $ Installation v9'0'2 ghcup "/Users/chris/.ghcup/ghc/9.0.1" + ] diff --git a/src/HS/Cmd.hs b/src/HS/Cmd.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cmd.hs @@ -0,0 +1,7 @@ +module HS.Cmd (module X) where + +import HS.Cmd.Dump as X +import HS.Cmd.List as X +import HS.Cmd.Run as X +import HS.Cmd.Use as X +import HS.Cmd.Whereis as X diff --git a/src/HS/Cmd/Dump.hs b/src/HS/Cmd/Dump.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cmd/Dump.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Cmd.Dump (cmdDump) where + +import Data.Maybe +import qualified Data.Text.IO as T +import Fmt +import HS.Cfg.CfgFile +import HS.Types +import System.Directory +import System.FilePath +import Text.Enum.Text + + +-- | command driver to write the `cabal` wrappers out to @~/.hs/bin@ +cmdDump :: Cfg -> Maybe InstallMode -> IO () +cmdDump cfg mb = do + bin <- bin_dir cfg + fmtLn $ "writing to "+|bin|+":" + sequence_ + [ write_wrapper cfg bin im tnm vrn + | vrn <- versions + , tnm <- [minBound..maxBound] + ] + where + im = fromMaybe (_cfg_mode cfg) mb + +write_wrapper :: Cfg -> FilePath -> InstallMode -> ToolName -> CompilerVersion -> IO () +write_wrapper _ dir imd tn cv = do + fmtLn $ " "+|tl|+"" + T.writeFile fp $ fmt $ unlinesF + [ "#!/usr/bin/env bash" + , "hs run "+|tl|+" --"+|imd|+" -- \"$@\"" :: Builder + ] + setPermissions fp . setOwnerExecutable True =<< getPermissions fp + where + fp = dir fmt tl + tl = ""+|tn|+"-"+|cv|+"" :: Builder + +bin_dir :: Cfg -> IO FilePath +bin_dir _ = mk =<< dotHs + where + mk dh = const bin <$> createDirectoryIfMissing True bin + where + bin = dh "bin" + +versions :: [CompilerVersion] +versions = either error id $ mapM parseText + [ "9.2.1" + + , "9.0.2" + , "9.0.1" + + , "8.10.6" + , "8.10.5" + , "8.10.4" + , "8.10.3" + , "8.10.2" + , "8.10.1" + + , "8.8.4" + , "8.8.3" + , "8.8.2" + , "8.8.1" + + , "8.6.5" + , "8.6.4" + , "8.6.3" + , "8.6.2" + , "8.6.1" + + , "8.4.4" + , "8.4.3" + , "8.4.2" + , "8.4.1" + + , "8.2.2" + , "8.2.1" + + , "8.0.2" + , "8.0.1" + + , "7.10.3" + , "7.10.2" + , "7.10.1" + + , "7.8.4" + , "7.8.3" + , "7.8.2" + , "7.8.1" + + , "7.6.3" + , "7.6.2" + , "7.6.1" + + , "7.4.2" + , "7.4.1" + + , "7.2.2" + , "7.2.1" + + , "7.0.4" + , "7.0.3" + , "7.0.2" + , "7.0.1" + + , "6.12.3" + , "6.12.2" + , "6.12.1" + ] diff --git a/src/HS/Cmd/List.hs b/src/HS/Cmd/List.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cmd/List.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module HS.Cmd.List where + +import qualified Data.Map as Map +import Data.Maybe +import HS.Types + + +-- | command driver to list all the installations +cmdList :: Cfg -> Maybe Compiler -> IO () +cmdList Cfg{..} mb = sequence_ + [ fmtLn $ build iln + | iln <- Map.elems _cfg_installations + , isNothing mb || mb == Just (Compiler $ Just $ _iln_compiler iln) + ] diff --git a/src/HS/Cmd/Run.hs b/src/HS/Cmd/Run.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cmd/Run.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Cmd.Run where + +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import HS.Install +import HS.Types +import System.Process.Typed + + +-- | command driver to run the given tool +cmdRun :: Cfg -> Maybe InstallMode -> Tool -> ToolArgs -> IO () +cmdRun cfg mb_im tl tas = case mb_iln of + Nothing -> install cfg im cp >>= go + Just iln -> go iln + where + go :: Installation -> IO () + go iln = runProcess_ $ proc (_iln_tool_executable iln tn) as + + (tn,cp) = toolToCompiler' tl + im = fromMaybe _cfg_mode mb_im + mb_iln = Map.lookup cp _cfg_installations + as = map T.unpack $ getToolArgs tas + + Cfg{..} = cfg diff --git a/src/HS/Cmd/Use.hs b/src/HS/Cmd/Use.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cmd/Use.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Cmd.Use where + +import HS.Cfg.CfgFile +import HS.Types + + +-- | command driver to configure installation manager priorities +cmdUse :: Cfg -> [Manager] -> IO () +cmdUse Cfg{..} ms = case ms of + [] -> fmtLn $ build _cfg_managers + _ -> save CF_managers $ Managers ms + +-- | command driver to configure default @InstallMode@ +cmdUseIM :: Cfg -> Maybe InstallMode -> IO () +cmdUseIM Cfg{..} mb = case mb of + Nothing -> fmtLn $ build _cfg_mode + Just im -> save CF_mode im + +-- | command driver to configure default toolchain +cmdUseCp :: Cfg -> Maybe CompilerVersion -> IO () +cmdUseCp Cfg{..} mb = case mb of + Nothing -> fmtLn $ build _cfg_compiler + Just cp -> save CF_compiler cp diff --git a/src/HS/Cmd/Whereis.hs b/src/HS/Cmd/Whereis.hs new file mode 100644 --- /dev/null +++ b/src/HS/Cmd/Whereis.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Cmd.Whereis where + +import qualified Data.Map as Map +import Data.Maybe +import HS.Install +import HS.Types + + +-- | command driver to print out bindist root of desiganted compiler +cmdWhereis :: Cfg -> Maybe InstallMode -> Compiler -> IO () +cmdWhereis cfg mb_im cp = case mb_iln of + Nothing -> install cfg im cp >>= go + Just iln -> go iln + where + go :: Installation -> IO () + go iln = putStrLn $ _iln_dir iln + + im = fromMaybe _cfg_mode mb_im + mb_iln = Map.lookup cp _cfg_installations + + Cfg{..} = cfg diff --git a/src/HS/Install.hs b/src/HS/Install.hs new file mode 100644 --- /dev/null +++ b/src/HS/Install.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Install(install) where + +import qualified Data.Text as T +import HS.Managers +import HS.Types +import System.IO + + +-- | call out to the configured installer to install a bindist +install :: Cfg -> InstallMode -> Compiler -> IO Installation +install cfg im cp = case getManagers $ _cfg_managers cfg of + [] -> not_found cp "no managers" + mgr:_ -> case im of + IM_no_install -> not_found cp "not in auto-installing mode" + IM_install -> install' cfg mgr cp + IM_ask_install -> do + yup <- ask cp + if | yup -> install' cfg mgr cp + | otherwise -> not_found cp "declined" + +ask :: Compiler -> IO Bool +ask cp = do + bm <- hGetBuffering stderr + hSetBuffering stderr NoBuffering + hPutStrLn stderr $ "toolchain "+|cp|+" is required but not installed" + hPutStr stderr $ "would you like to install it? (y/n) : " + tx <- T.strip . T.pack <$> getLine + hSetBuffering stderr bm + return $ tx `elem` ["y","yes"] + +install' :: Cfg -> Manager -> Compiler -> IO Installation +install' cfg mgr cp + | mgr==stack = installStack cfg cv + | mgr==ghcup = installGhcup cfg cv + | otherwise = not_found cp $ "manager "+|mgr|+" not recognised" + where + cv = resolveCompilerVersion cfg cp + +not_found :: Compiler -> String -> IO a +not_found cp ctx = fail $ "toolchain "+|cp|+" not installed ("+|ctx|+")" diff --git a/src/HS/Managers.hs b/src/HS/Managers.hs new file mode 100644 --- /dev/null +++ b/src/HS/Managers.hs @@ -0,0 +1,5 @@ +module HS.Managers (module X) where + +import HS.Managers.Ghcup as X +import HS.Managers.Stack as X +import HS.Types.Manager as X diff --git a/src/HS/Managers/Ghcup.hs b/src/HS/Managers/Ghcup.hs new file mode 100644 --- /dev/null +++ b/src/HS/Managers/Ghcup.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Managers.Ghcup + ( installGhcup + , ghcupDiscover + ) where + +import Control.Exception +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import Fmt +import HS.Cfg.Types +import HS.Managers.Types +import HS.Types.CompilerTool +import System.Directory +import System.Process.Typed +import Text.Enum.Text + + +-- | use @ghcup@ to install a toolchain +installGhcup :: Cfg -> CompilerVersion -> IO Installation +installGhcup cfg cv = do + runProcess_ $ proc "ghcup" ["install","ghc","ghc-"+|cv|+""] + dir <- ghcupInstallationDir cfg cv + return + Installation + { _iln_compiler = cv + , _iln_manager = ghcup + , _iln_dir = dir + } + +-- | locate all of the toolchains being managed by the local @ghcup@ installation +ghcupDiscover :: Cfg -> IO (Map Compiler Installation) +ghcupDiscover cfg = handle hdl $ mk =<< listDirectory =<< ghcupStashDir cfg + where + mk :: [FilePath] -> IO (Map Compiler Installation) + mk fps = mk' fps <$> ghcupStashDir cfg + + mk' :: [FilePath] -> FilePath -> Map Compiler Installation + mk' fps sr = Map.fromList $ catMaybes $ map (chk sr) fps + + chk :: FilePath -> FilePath -> Maybe (Compiler,Installation) + chk sr fp = do + cv <- either (const Nothing) Just $ parseText $ T.pack fp + return $ (,) (compiler cv) + Installation + { _iln_compiler = cv + , _iln_manager = ghcup + , _iln_dir = ghcupInstallationDir' cfg cv sr + } + + hdl :: SomeException -> IO (Map Compiler Installation) + hdl _ = return mempty + +ghcupInstallationDir :: Cfg -> CompilerVersion -> IO FilePath +ghcupInstallationDir cfg cv = ghcupInstallationDir' cfg cv <$> ghcupStashDir cfg + +ghcupInstallationDir' :: Cfg -> CompilerVersion -> FilePath -> FilePath +ghcupInstallationDir' _ cv sr = ""+|sr|+"/"+|cv|+"" + +ghcupStashDir :: Cfg -> IO FilePath +ghcupStashDir _ = mk <$> getHomeDirectory + where + mk :: FilePath -> FilePath + mk hme = ""+|hme|+"/.ghcup/ghc" diff --git a/src/HS/Managers/Stack.hs b/src/HS/Managers/Stack.hs new file mode 100644 --- /dev/null +++ b/src/HS/Managers/Stack.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Managers.Stack + ( installStack + , stackDiscover + ) where + +import Control.Exception +import Data.Map(Map) +import qualified Data.Map as Map +import Data.Maybe +import qualified Data.Text as T +import Fmt +import HS.Cfg.Types +import HS.Managers.Types +import HS.Types.CompilerTool +import System.Directory +import System.Info(os,arch) +import System.Process.Typed +import Text.Enum.Text + + +-- | use @stack@ to install a toolchain +installStack :: Cfg -> CompilerVersion -> IO Installation +installStack cfg cv = do + runProcess_ $ proc "stack" ["setup","ghc-"+|cv|+""] + dir <- stackInstallationDir cfg cv + return + Installation + { _iln_compiler = cv + , _iln_manager = stack + , _iln_dir = dir + } + +-- | locate all of the toolchains being managed by the local stack installation +stackDiscover :: Cfg -> IO (Map Compiler Installation) +stackDiscover cfg = handle hdl $ mk =<< listDirectory =<< stackStashDir cfg + where + mk :: [FilePath] -> IO (Map Compiler Installation) + mk fps = mk' fps <$> stackStashDir cfg + + mk' :: [FilePath] -> FilePath -> Map Compiler Installation + mk' fps sr = Map.fromList $ catMaybes $ map (chk sr) fps + + chk :: FilePath -> FilePath -> Maybe (Compiler,Installation) + chk sr fp = do + cp <- either (const Nothing) Just $ parseText $ T.pack fp + cv <- compilerVersion cp + return $ (,) cp + Installation + { _iln_compiler = cv + , _iln_manager = stack + , _iln_dir = stackInstallationDir' cfg cv sr + } + + hdl :: SomeException -> IO (Map Compiler Installation) + hdl _ = return mempty + +stackInstallationDir :: Cfg -> CompilerVersion -> IO FilePath +stackInstallationDir cfg cv = stackInstallationDir' cfg cv <$> stackStashDir cfg + +stackInstallationDir' :: Cfg -> CompilerVersion -> FilePath -> FilePath +stackInstallationDir' _ cv sr = ""+|sr|+"/ghc-"+|cv|+"" + +stackStashDir :: Cfg -> IO FilePath +stackStashDir _ = mk <$> getHomeDirectory + where + mk :: FilePath -> FilePath + mk hme = ""+|hme|+"/.stack/programs/"+|arch|+"-"+|os'|+"" + + os' :: String + os' = + if | os=="darwin" -> "osx" + | otherwise -> os diff --git a/src/HS/Managers/Types.hs b/src/HS/Managers/Types.hs new file mode 100644 --- /dev/null +++ b/src/HS/Managers/Types.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HS.Managers.Types where + +import HS.Types.Manager + + +ghcup :: Manager +ghcup = "ghcup" + +stack :: Manager +stack = "stack" diff --git a/src/HS/Types.hs b/src/HS/Types.hs new file mode 100644 --- /dev/null +++ b/src/HS/Types.hs @@ -0,0 +1,7 @@ +module HS.Types (module X) where + +import Fmt as X +import HS.CLI.CLI as X +import HS.Cfg.Types as X +import HS.Managers.Types as X +import HS.Types.CompilerTool as X diff --git a/src/HS/Types/CompilerTool.hs b/src/HS/Types/CompilerTool.hs new file mode 100644 --- /dev/null +++ b/src/HS/Types/CompilerTool.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} + +module HS.Types.CompilerTool + ( Compiler(..) + , Tool(..) + , CompilerVersion(..) + , ToolName(..) + , compiler + , compiler' + , compilerVersion + , toolVersion + , compilerToGhcTool + , compilerToTool + , toolToCompiler + , toolToCompiler' + ) where + +import Data.Char +import Data.Coerce +import Data.Default +import Data.Possibly +import Data.Text(Text) +import qualified Data.Text as T +import Fmt +import Text.Enum.Text + + +-- | @ghc@ or @ghc-8.10.4@, etc. +newtype Compiler = Compiler { getCompiler :: Maybe CompilerVersion } + deriving (Eq,Ord,Show) + +-- | @ghci@ or @ghc-pkg-9.0.1@, etc. +newtype Tool = Tool { getTool :: (ToolName,Maybe CompilerVersion) } + deriving (Eq,Ord,Show) + +-- | @8.6.5@, etc. +newtype CompilerVersion = CompilerVersion { getCompilerVersion :: (Int,Int,Int) } + deriving (Eq,Ord,Show) + +-- | @ghc@, @ghc-pkg@, @ghci@, etc. +data ToolName + = TN_ghc + | TN_ghc_pkg + | TN_ghci + | TN_haddock + | TN_h2ps + | TN_hpc + | TN_hsc2hs + | TN_runghc + | TN_runhaskell + deriving stock (Bounded,Enum,Eq,Ord,Show) + deriving anyclass (EnumText) + deriving (Buildable,TextParsable) via UsingEnumText ToolName + +instance Buildable Compiler where build = build_compiler +instance TextParsable Compiler where parseText = parse_compiler +instance Buildable Tool where build = build_tool +instance TextParsable Tool where parseText = parse_tool + +instance Buildable CompilerVersion where + build (CompilerVersion (a,b,c)) = ""+|a|+"."+|b|+"."+|c|+"" + +instance TextParsable CompilerVersion where + parseText vrn = + case T.splitOn "." vrn of + [a_t,b_t,c_t] -> fmap CompilerVersion $ + (,,) <$> parseText a_t <*> parseText b_t <*> parseText c_t + _ -> Left $ "expected version a.b.c : "+|vrn|+"" + +instance Default CompilerVersion where + def = CompilerVersion (8,10,4) + +compiler :: CompilerVersion -> Compiler +compiler = compiler' . Just + +compiler' :: Maybe CompilerVersion -> Compiler +compiler' = coerce + +compilerVersion :: Compiler -> Maybe CompilerVersion +compilerVersion = coerce + +toolVersion :: Tool -> Maybe CompilerVersion +toolVersion = compilerVersion . toolToCompiler + +compilerToGhcTool :: Compiler -> Tool +compilerToGhcTool = compilerToTool . (,) TN_ghc + +compilerToTool :: (ToolName,Compiler) -> Tool +compilerToTool = coerce + +toolToCompiler :: Tool -> Compiler +toolToCompiler = snd . toolToCompiler' + +toolToCompiler' :: Tool -> (ToolName,Compiler) +toolToCompiler' = coerce + + +---------------------------------------------------------------------------------------------------- +-- build_compiler, parse_compiler +---------------------------------------------------------------------------------------------------- + +build_compiler :: Compiler -> Builder +build_compiler = build . compilerToGhcTool + +parse_compiler :: Text -> Possibly Compiler +parse_compiler txt = chk =<< parseText txt + where + chk :: Tool -> Possibly Compiler + chk tl | tn == TN_ghc = return cp + | otherwise = Left $ "expected 'ghc' but saw "+|tn|+" in: "+|txt|+"" + where + (tn,cp) = toolToCompiler' tl + + +---------------------------------------------------------------------------------------------------- +-- build_tool, parse_tool +---------------------------------------------------------------------------------------------------- + +build_tool :: Tool -> Builder +build_tool tl = ""+|tn|++|maybe "" (("-"<>) . build) mb_vrn + where + mb_vrn = compilerVersion cp + (tn,cp) = toolToCompiler' tl + +parse_tool :: Text -> Possibly Tool +parse_tool txt0 = case T.breakOnEnd "-" txt0 of + (frt,vrn) | not (T.null frt) && plausible_vrn vrn + -> with_vrn (T.dropWhileEnd (=='-') frt) vrn + | otherwise -> Tool . (,Nothing) <$> parseText txt0 + where + with_vrn :: Text -> Text -> Possibly Tool + with_vrn tool vrn = fmap Tool $ + (,) <$> parseText tool <*> (Just <$> parseText vrn) + +plausible_vrn :: Text -> Bool +plausible_vrn = T.all is_vrn_c + where + is_vrn_c :: Char -> Bool + is_vrn_c c = isDigit c || c=='.' diff --git a/src/HS/Types/InstallMode.hs b/src/HS/Types/InstallMode.hs new file mode 100644 --- /dev/null +++ b/src/HS/Types/InstallMode.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +module HS.Types.InstallMode where + +import Data.Default +import Fmt +import Text.Enum.Text + + +-- | how to react to a missing toolchain? +data InstallMode + = IM_no_install -- ^ do not try to install, report error + | IM_install -- ^ download and install + | IM_ask_install -- ^ ask the user if they want to install the misssing toolchain + deriving stock (Bounded,Enum,Eq,Ord,Show) + deriving anyclass (EnumText) + deriving (Buildable,TextParsable) via UsingEnumText InstallMode + +instance Default InstallMode where + def = minBound diff --git a/src/HS/Types/Manager.hs b/src/HS/Types/Manager.hs new file mode 100644 --- /dev/null +++ b/src/HS/Types/Manager.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} + +module HS.Types.Manager where + +import Data.String +import Data.Text(Text) +import Fmt +import Text.Enum.Text + + +-- | installation manager @stack@ or @ghcup@ or ... +newtype Manager = Manager { getManager :: Text } + deriving stock (Eq,Ord,Show) + deriving newtype (Buildable,IsString,TextParsable)