Yo

TODO.md

@@ -4,17 +4,13 @@
 
 * download progress
 
-* Downloads from URL
-* set                Set currently active GHC version
-* list               Show available GHCs and other tools
 * upgrade            Upgrade this script in-place
-* rm                 Remove an already installed GHC
+* maybe: changelog          Show the changelog of a GHC release (online)
-* debug-info         Print debug info (e.g. detected system/distro)
+* maybe: print-system-reqs  Print an approximation of system requirements
-* changelog          Show the changelog of a GHC release (online)
-* print-system-reqs  Print an approximation of system requirements
 
 * testing (especially distro detection -> unit tests)
 
+* TODO: cleanup temp files after use
 
 ## Old
 
@@ -26,7 +22,6 @@
 * check for new version on start
 * tarball tags as well as version tags?
 
-* --copy-compiler-tools
 * installing multiple versions in parallel?
 * how to version and extend the format of the downloads file? Compatibility?
 * how to propagate updates? Automatically? Might solve the versioning problem

app/Main.hs

@@ -1,177 +0,0 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE QuasiQuotes       #-}
-
-module Main where
-
-import           Control.Monad.Logger
-import           Control.Monad.Reader
-import           Control.Monad.IO.Class
-import           Data.Bifunctor
-import           Data.ByteString                ( ByteString )
-import           Data.Functor                   ( (<&>) )
-import           Data.Maybe
-import           Data.Semigroup                 ( (<>) )
-import           Data.String.QQ
-import           Data.Text                      ( Text )
-import qualified Data.Text                     as T
-import qualified Data.Text.Encoding            as E
-import           Data.Traversable
-import           Data.Versions
-import           GHCup
-import           GHCup.File
-import           GHCup.Prelude
-import           GHCup.Types
-import           Haskus.Utils.Variant.Excepts
-import           HPath
-import           Options.Applicative
-import           System.Console.Pretty
-import           System.Exit
-
-
-
-
-data Options = Options
-  { optVerbose :: Bool
-  , optCache   :: Bool
-  , optCommand :: Command
-  }
-
-data Command
-  = InstallGHC InstallGHCOptions
-  | InstallCabal InstallCabalOptions
-
-data InstallGHCOptions = InstallGHCOptions
-  { ghcVer :: Maybe Version
-  }
-
-data InstallCabalOptions = InstallCabalOptions
-  { cabalVer :: Maybe Version
-  }
-
-
-opts :: Parser Options
-opts =
-  Options
-    <$> switch
-          (short 'v' <> long "verbose" <> help "Whether to enable verbosity")
-    <*> switch (short 'c' <> long "cache" <> help "Whether to cache downloads")
-    <*> com
-
-
-com :: Parser Command
-com = subparser
-  (  command
-      "install-ghc"
-      (   InstallGHC
-      <$> (info (installGHCOpts <**> helper)
-                (progDesc "Install a GHC version")
-          )
-      )
-  <> command
-       "install-cabal"
-       (   InstallCabal
-       <$> (info (installCabalOpts <**> helper)
-                 (progDesc "Install a cabal-install version")
-           )
-       )
-  )
-
-installGHCOpts :: Parser InstallGHCOptions
-installGHCOpts = InstallGHCOptions <$> optional
-  (option
-    (eitherReader
-      (\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
-    )
-    (short 'v' <> long "version" <> metavar "VERSION" <> help
-      "The GHC version to install"
-    )
-  )
-
-
-installCabalOpts :: Parser InstallCabalOptions
-installCabalOpts = InstallCabalOptions <$> optional
-  (option
-    (eitherReader
-      (\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
-    )
-    (short 'v' <> long "version" <> metavar "VERSION" <> help
-      "The Cabal version to install"
-    )
-  )
-
-
-toSettings :: Options -> Settings
-toSettings Options {..} = let cache = optCache in Settings { .. }
-
-
--- TODO: something better than Show instance for errors
-
-main :: IO ()
-main = do
-  -- logger interpreter
-  let runLogger = runStderrLoggingT
-
-  customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
-    >>= \opt@Options {..} -> do
-          let settings = toSettings opt
-          -- wrapper to run effects with settings
-          let runInstTool =
-                runLogger
-                  . flip runReaderT settings
-                  . runE
-                    @'[ FileError
-                      , ArchiveError
-                      , ProcessError
-                      , URLException
-                      , PlatformResultError
-                      , NoDownload
-                      , NoCompatibleArch
-                      , DistroNotFound
-                      , TagNotFound
-                      , AlreadyInstalled
-                      , NotInstalled
-                      ]
-
-          case optCommand of
-            InstallGHC (InstallGHCOptions {..}) ->
-              void
-                $   (runInstTool $ do
-                      v <- maybe
-                        (  getRecommended availableDownloads GHC
-                        ?? TagNotFound Recommended GHC
-                        )
-                        pure
-                        ghcVer
-                      liftE $ installTool (ToolRequest GHC v)
-                                          Nothing
-                                          (OwnSpec availableDownloads)
-                    )
-                >>= \case
-                      VRight _ -> runLogger $ $(logInfo) ([s|GHC installation successful|])
-                      VLeft (V (AlreadyInstalled treq)) ->
-                        runLogger $ $(logWarn)
-                          (T.pack (show treq) <> [s| already installed|])
-                      VLeft e -> die (color Red $ show e)
-            InstallCabal (InstallCabalOptions {..}) ->
-              void
-                $   (runInstTool $ do
-                      v <- maybe
-                        (  getRecommended availableDownloads Cabal
-                        ?? TagNotFound Recommended Cabal
-                        )
-                        pure
-                        cabalVer
-                      liftE $ installTool (ToolRequest Cabal v)
-                                          Nothing
-                                          (OwnSpec availableDownloads)
-                    )
-                >>= \case
-                      VRight _ -> runLogger $ $(logInfo) ([s|Cabal installation successful|])
-                      VLeft (V (AlreadyInstalled treq)) ->
-                        runLogger $ $(logWarn)
-                          (T.pack (show treq) <> [s| already installed|])
-                      VLeft e -> die (color Red $ show e)
-  pure ()

app/ghcup-gen/AvailableDownloads.hs

@@ -0,0 +1,127 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+
+module AvailableDownloads where
+
+import qualified Data.Map                      as M
+import           GHCup.Prelude
+import           GHCup.Types
+import           HPath
+import           URI.ByteString.QQ
+
+
+
+-- TODO: version quasiquoter
+availableDownloads :: AvailableDownloads
+availableDownloads = M.fromList
+  [ ( GHC
+    , M.fromList
+      [ ( [vver|8.6.5|]
+        , VersionInfo [Latest] $ M.fromList
+          [ ( A_64
+            , M.fromList
+              [ ( Linux UnknownLinux
+                , M.fromList
+                  [ ( Nothing
+                    , DownloadInfo
+                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
+                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
+                    )
+                  ]
+                )
+              , ( Linux Ubuntu
+                , M.fromList
+                  [ ( Nothing
+                    , DownloadInfo
+                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
+                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
+                    )
+                  ]
+                )
+              , ( Linux Debian
+                , M.fromList
+                  [ ( Nothing
+                    , DownloadInfo
+                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
+                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
+                    )
+                  , ( Just $ [vers|8|]
+                    , DownloadInfo
+                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
+                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
+                    )
+                  ]
+                )
+              ]
+            )
+          ]
+        ),
+        ( [vver|8.4.4|]
+        , VersionInfo [Latest] $ M.fromList
+          [ ( A_64
+            , M.fromList
+              [ ( Linux UnknownLinux
+                , M.fromList
+                  [ ( Nothing
+                    , DownloadInfo
+                      [uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-fedora27-linux.tar.xz|]
+                      (Just ([rel|ghc-8.4.4|] :: Path Rel))
+                    )
+                  ]
+                )
+              , ( Linux Ubuntu
+                , M.fromList
+                  [ ( Nothing
+                    , DownloadInfo
+                      [uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb9-linux.tar.xz|]
+                      (Just ([rel|ghc-8.4.4|] :: Path Rel))
+                    )
+                  ]
+                )
+              , ( Linux Debian
+                , M.fromList
+                  [ ( Nothing
+                    , DownloadInfo
+                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
+                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
+                    )
+                  , ( Just $ [vers|8|]
+                    , DownloadInfo
+                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
+                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
+                    )
+                  ]
+                )
+              ]
+            )
+          ]
+        )
+      ]
+    )
+  , ( Cabal
+    , M.fromList
+      [ ( [vver|3.0.0.0|]
+        , VersionInfo [Recommended, Latest] $ M.fromList
+          [ ( A_64
+            , M.fromList
+              [ ( Linux UnknownLinux
+                , M.fromList
+                  [ ( Nothing
+                    , DownloadInfo
+                      [uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
+                      Nothing
+                    )
+                  ]
+                )
+              ]
+            )
+          ]
+        )
+      ]
+    )
+  ]

app/ghcup-gen/Main.hs

@@ -0,0 +1,143 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+
+module Main where
+
+import           AvailableDownloads
+import           Data.Aeson                     ( eitherDecode )
+import           Data.Aeson.Encode.Pretty
+import qualified Data.ByteString.Lazy          as L
+import           Data.Semigroup                 ( (<>) )
+import           GHCup.Types.JSON               ( )
+import           Options.Applicative     hiding ( style )
+import           GHCup.Logger
+import           System.Console.Pretty
+import           System.Exit
+import           System.IO                      ( stdout )
+import           Validate
+
+
+
+data Options = Options
+  { optCommand :: Command
+  }
+
+data Command = GenJSON GenJSONOpts
+             | ValidateJSON ValidateJSONOpts
+
+data Output
+  = FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
+  | StdOutput
+
+fileOutput :: Parser Output
+fileOutput =
+  FileOutput
+    <$> (strOption
+          (long "file" <> short 'f' <> metavar "FILENAME" <> help
+            "Output to a file"
+          )
+        )
+
+stdOutput :: Parser Output
+stdOutput = flag'
+  StdOutput
+  (short 'o' <> long "stdout" <> help "Print to stdout (default)")
+
+outputP :: Parser Output
+outputP = fileOutput <|> stdOutput
+
+
+data GenJSONOpts = GenJSONOpts
+  { output :: Maybe Output
+  }
+
+genJSONOpts :: Parser GenJSONOpts
+genJSONOpts = GenJSONOpts <$> optional outputP
+
+
+data Input
+  = FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
+  | StdInput
+
+fileInput :: Parser Input
+fileInput =
+  FileInput
+    <$> (strOption
+          (long "file" <> short 'f' <> metavar "FILENAME" <> help
+            "Input file to validate"
+          )
+        )
+
+stdInput :: Parser Input
+stdInput = flag'
+  StdInput
+  (short 'i' <> long "stdin" <> help "Validate from stdin (default)")
+
+inputP :: Parser Input
+inputP = fileInput <|> stdInput
+
+data ValidateJSONOpts = ValidateJSONOpts
+  { input :: Maybe Input
+  }
+
+validateJSONOpts :: Parser ValidateJSONOpts
+validateJSONOpts = ValidateJSONOpts <$> optional inputP
+
+opts :: Parser Options
+opts = Options <$> com
+
+com :: Parser Command
+com = subparser
+  (  (command
+       "gen"
+       (   GenJSON
+       <$> (info (genJSONOpts <**> helper)
+                 (progDesc "Generate the json downloads file")
+           )
+       )
+     )
+  <> (command
+       "check"
+       (   ValidateJSON
+       <$> (info (validateJSONOpts <**> helper)
+                 (progDesc "Generate the json downloads file")
+           )
+       )
+     )
+  )
+
+
+
+main :: IO ()
+main = do
+  customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
+    >>= \Options {..} -> case optCommand of
+          GenJSON gopts -> do
+            let
+              bs = encodePretty' (defConfig { confIndent = Spaces 2 })
+                                 availableDownloads
+            case gopts of
+              GenJSONOpts { output = Nothing }        -> L.hPutStr stdout bs
+              GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
+              GenJSONOpts { output = Just (FileOutput file) } ->
+                L.writeFile file bs
+          ValidateJSON vopts -> case vopts of
+            ValidateJSONOpts { input = Nothing } ->
+              L.getContents >>= valAndExit
+            ValidateJSONOpts { input = Just StdInput } ->
+              L.getContents >>= valAndExit
+            ValidateJSONOpts { input = Just (FileInput file) } ->
+              L.readFile file >>= valAndExit
+  pure ()
+
+ where
+  valAndExit contents = do
+    av <- case eitherDecode contents of
+      Right r -> pure r
+      Left  e -> die (color Red $ show e)
+    myLoggerTStdout (validate av) >>= exitWith

app/ghcup-gen/Validate.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE TemplateHaskell  #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes      #-}
+
+module Validate where
+
+import           GHCup
+import           GHCup.Types
+
+import           Control.Monad
+import           Control.Exception.Safe
+import           Control.Monad.Reader.Class
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Class      ( lift )
+import           Control.Monad.Trans.Reader     ( runReaderT )
+import           Data.List
+import           Data.String.Interpolate
+import           Data.Versions
+import           Data.IORef
+import           System.Exit
+import           Control.Monad.Logger
+
+import qualified Data.Map.Strict               as M
+
+
+-- TODO: improve logging
+
+
+data ValidationError = InternalError String
+  deriving Show
+
+instance Exception ValidationError
+
+
+-- TODO: test that GHC is in semver
+validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
+         => AvailableDownloads
+         -> m ExitCode
+validate av = do
+  ref <- liftIO $ newIORef 0
+  flip runReaderT ref $ do
+    -- unique tags
+    forM_ (M.toList av) $ \(t, _) -> checkUniqueTags t
+
+    -- required platforms
+    forM_ (M.toList av) $ \(t, versions) ->
+      forM_ (M.toList versions) $ \(v, vi) ->
+        forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
+          checkHasRequiredPlatforms t v arch (M.keys pspecs)
+
+    -- exit
+    e <- liftIO $ readIORef ref
+    if e > 0 then pure $ ExitFailure e else pure ExitSuccess
+ where
+  checkHasRequiredPlatforms t v arch pspecs = do
+    let v' = prettyVer v
+    when (not $ any (== Linux UnknownLinux) pspecs) $ do
+      lift $ $(logError)
+        [i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
+      addError
+    when (not $ any (== Darwin) pspecs) $ do
+      lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
+      addError
+    when (not $ any (== FreeBSD) pspecs) $ lift $ $(logWarn)
+      [i|FreeBSD missing for #{t} #{v'} #{arch}|]
+
+  checkUniqueTags tool = do
+    let allTags = join $ fmap snd $ availableToolVersions av tool
+    let nonUnique =
+          fmap fst
+            .   filter (\(_, b) -> not b)
+            <$> ( mapM
+                    (\case
+                      [] -> throwM $ InternalError "empty inner list"
+                      (t : ts) ->
+                        pure $ (t, ) $ if isUniqueTag t then ts == [] else True
+                    )
+                . group
+                . sort
+                $ allTags
+                )
+    case join nonUnique of
+      [] -> pure ()
+      xs -> do
+        lift $ $(logError) [i|Tags not unique: #{xs}|]
+        addError
+   where
+    isUniqueTag Latest      = True
+    isUniqueTag Recommended = True
+
+
+addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
+addError = do
+  ref <- ask
+  liftIO $ modifyIORef ref (+ 1)

app/ghcup/Main.hs

@@ -0,0 +1,404 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+
+module Main where
+
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Data.Bifunctor
+import qualified Data.ByteString.UTF8          as UTF8
+import           Data.Char
+import           Data.List                      ( intercalate )
+import           Data.Semigroup                 ( (<>) )
+import           Data.String.QQ
+import qualified Data.Text                     as T
+import           Data.Versions
+import           GHCup
+import           GHCup.Logger
+import           GHCup.File
+import           GHCup.Prelude
+import           GHCup.Types
+import           Haskus.Utils.Variant.Excepts
+import           Options.Applicative     hiding ( style )
+import           System.Console.Pretty
+import           System.Exit
+import           URI.ByteString
+import           Text.Layout.Table
+import           Data.String.Interpolate
+
+
+
+
+
+data Options = Options
+  { optVerbose   :: Bool
+  , optCache     :: Bool
+  , optUrlSource :: Maybe URI
+  , optCommand   :: Command
+  }
+
+data Command
+  = InstallGHC InstallGHCOptions
+  | InstallCabal InstallCabalOptions
+  | SetGHC SetGHCOptions
+  | List ListOptions
+  | Rm RmOptions
+  | DInfo
+
+data ToolVersion = ToolVersion Version
+                 | ToolTag Tag
+
+
+data InstallGHCOptions = InstallGHCOptions
+  { ghcVer :: Maybe ToolVersion
+  }
+
+data InstallCabalOptions = InstallCabalOptions
+  { cabalVer :: Maybe ToolVersion
+  }
+
+data SetGHCOptions = SetGHCOptions
+  { ghcVer :: Maybe ToolVersion
+  }
+
+data ListOptions = ListOptions
+  { lTool     :: Maybe Tool
+  , lCriteria :: Maybe ListCriteria
+  }
+
+data RmOptions = RmOptions
+  { ghcVer :: Version
+  }
+
+
+opts :: Parser Options
+opts =
+  Options
+    <$> switch
+          (short 'v' <> long "verbose" <> help
+            "Whether to enable verbosity (default: False)"
+          )
+    <*> switch
+          (short 'c' <> long "cache" <> help
+            "Whether to cache downloads (default: False)"
+          )
+    <*> (optional
+          (option
+            (eitherReader parseUri)
+            (short 's' <> long "url-source" <> metavar "URL" <> help
+              "Alternative ghcup download info url (default: internal)"
+            )
+          )
+        )
+    <*> com
+ where
+  parseUri s' =
+    bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
+
+com :: Parser Command
+com = subparser
+  (  command
+      "install-ghc"
+      (   InstallGHC
+      <$> (info (installGHCOpts <**> helper)
+                (progDesc "Install a GHC version")
+          )
+      )
+  <> command
+       "install-cabal"
+       (   InstallCabal
+       <$> (info (installCabalOpts <**> helper)
+                 (progDesc "Install a cabal-install version")
+           )
+       )
+  <> command
+       "set-ghc"
+       (   SetGHC
+       <$> (info (setGHCOpts <**> helper)
+                 (progDesc "Set the currently active GHC version")
+           )
+       )
+  <> command
+       "list"
+       (   List
+       <$> (info (listOpts <**> helper)
+                 (progDesc "Show available GHCs and other tools")
+           )
+       )
+  <> command
+       "rm"
+       (   Rm
+       <$> (info (rmOpts <**> helper)
+                 (progDesc "Remove a GHC version installed by ghcup")
+           )
+       )
+  <> command
+       "debug-info"
+       ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
+  )
+
+installGHCOpts :: Parser InstallGHCOptions
+installGHCOpts = InstallGHCOptions <$> optional toolVersionParser
+
+
+installCabalOpts :: Parser InstallCabalOptions
+installCabalOpts = InstallCabalOptions <$> optional toolVersionParser
+
+setGHCOpts :: Parser SetGHCOptions
+setGHCOpts = SetGHCOptions <$> optional toolVersionParser
+
+listOpts :: Parser ListOptions
+listOpts =
+  ListOptions
+    <$> optional
+          (option
+            (eitherReader toolParser)
+            (short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
+              "Tool to list versions for. Default is all"
+            )
+          )
+    <*> (optional
+          (option
+            (eitherReader criteriaParser)
+            (  short 'c'
+            <> long "show-criteria"
+            <> metavar "<installed|set>"
+            <> help "Show only installed or set tool versions"
+            )
+          )
+        )
+
+rmOpts :: Parser RmOptions
+rmOpts =
+  RmOptions
+    <$> (option
+          (eitherReader
+            (bimap (const "Not a valid version") id . version . T.pack)
+          )
+          (short 'v' <> long "version" <> metavar "VERSION" <> help
+            "The GHC version to remove"
+          )
+        )
+
+
+
+versionParser :: Parser Version
+versionParser = option
+  (eitherReader (bimap (const "Not a valid version") id . version . T.pack))
+  (short 'v' <> long "version" <> metavar "VERSION")
+
+
+toolVersionParser :: Parser ToolVersion
+toolVersionParser = verP <|> toolP
+ where
+  verP = ToolVersion <$> versionParser
+  toolP =
+    ToolTag
+      <$> (option
+            (eitherReader
+              (\s' -> case fmap toLower s' of
+                "recommended" -> Right Recommended
+                "latest"      -> Right Latest
+                other         -> Left ([i|Unknown tag #{other}|])
+              )
+            )
+            (short 't' <> long "tag" <> metavar "TAG")
+          )
+
+
+toolParser :: String -> Either String Tool
+toolParser s' | t == T.pack "ghc"   = Right GHC
+              | t == T.pack "cabal" = Right Cabal
+              | otherwise           = Left ("Unknown tool: " <> s')
+  where t = T.toLower (T.pack s')
+
+
+criteriaParser :: String -> Either String ListCriteria
+criteriaParser s' | t == T.pack "installed" = Right ListInstalled
+                  | t == T.pack "set"       = Right ListSet
+                  | otherwise               = Left ("Unknown criteria: " <> s')
+  where t = T.toLower (T.pack s')
+
+
+toSettings :: Options -> Settings
+toSettings Options {..} =
+  let cache     = optCache
+      urlSource = maybe GHCupURL OwnSource optUrlSource
+  in  Settings { .. }
+
+
+-- TODO: something better than Show instance for errors
+
+main :: IO ()
+main = do
+  -- logger interpreter
+  let runLogger = myLoggerTStderr
+
+  customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
+    >>= \opt@Options {..} -> do
+          let settings = toSettings opt
+          -- wrapper to run effects with settings
+          let runInstTool =
+                runLogger
+                  . flip runReaderT settings
+                  . runE
+                    @'[ AlreadyInstalled
+                      , ArchiveError
+                      , DistroNotFound
+                      , FileDoesNotExistError
+                      , FileError
+                      , JSONError
+                      , NoCompatibleArch
+                      , NoDownload
+                      , NotInstalled
+                      , PlatformResultError
+                      , ProcessError
+                      , TagNotFound
+                      , URLException
+                      ]
+
+          let runSetGHC =
+                runLogger
+                  . flip runReaderT settings
+                  . runE
+                    @'[ FileDoesNotExistError
+                      , NotInstalled
+                      , TagNotFound
+                      , URLException
+                      , JSONError
+                      , TagNotFound
+                      ]
+
+          let runListGHC =
+                runLogger
+                  . flip runReaderT settings
+                  . runE @'[FileDoesNotExistError , URLException , JSONError]
+
+          let runRmGHC =
+                runLogger . flip runReaderT settings . runE @'[NotInstalled]
+
+          let runDebugInfo =
+                runLogger
+                  . flip runReaderT settings
+                  . runE
+                    @'[PlatformResultError , NoCompatibleArch , DistroNotFound]
+
+          case optCommand of
+            InstallGHC (InstallGHCOptions {..}) ->
+              void
+                $   (runInstTool $ do
+                      av <- liftE getDownloads
+                      v  <- liftE $ fromVersion av ghcVer GHC
+                      liftE $ installTool (ToolRequest GHC v) Nothing
+                    )
+                >>= \case
+                      VRight _ -> runLogger
+                        $ $(logInfo) ([s|GHC installation successful|])
+                      VLeft (V (AlreadyInstalled treq)) ->
+                        runLogger $ $(logWarn)
+                          (T.pack (show treq) <> [s| already installed|])
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+            InstallCabal (InstallCabalOptions {..}) ->
+              void
+                $   (runInstTool $ do
+                      av <- liftE getDownloads
+                      v  <- liftE $ fromVersion av cabalVer Cabal
+                      liftE $ installTool (ToolRequest Cabal v) Nothing
+                    )
+                >>= \case
+                      VRight _ -> runLogger
+                        $ $(logInfo) ([s|Cabal installation successful|])
+                      VLeft (V (AlreadyInstalled treq)) ->
+                        runLogger $ $(logWarn)
+                          (T.pack (show treq) <> [s| already installed|])
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            SetGHC (SetGHCOptions {..}) ->
+              void
+                $   (runSetGHC $ do
+                      av <- liftE getDownloads
+                      v  <- liftE $ fromVersion av ghcVer GHC
+                      liftE $ setGHC v SetGHCOnly
+                    )
+                >>= \case
+                      VRight _ ->
+                        runLogger $ $(logInfo) ([s|GHC successfully set|])
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            List (ListOptions {..}) ->
+              void
+                $   (runListGHC $ do
+                      liftE $ listVersions lTool lCriteria
+                    )
+                >>= \case
+                      VRight r -> liftIO $ printListResult r
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            Rm (RmOptions {..}) ->
+              void
+                $   (runRmGHC $ do
+                      liftE $ rmGHCVer ghcVer
+                    )
+                >>= \case
+                      VRight _ -> pure ()
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            DInfo -> do
+              void
+                $   (runDebugInfo $ do
+                      liftE $ getDebugInfo
+                    )
+                >>= \case
+                      VRight dinfo -> putStrLn $ show dinfo
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+  pure ()
+
+
+fromVersion :: Monad m
+            => AvailableDownloads
+            -> Maybe ToolVersion
+            -> Tool
+            -> Excepts '[TagNotFound] m Version
+fromVersion av Nothing tool =
+  getRecommended av tool ?? TagNotFound Recommended tool
+fromVersion _ (Just (ToolVersion v)) _ = pure v
+fromVersion av (Just (ToolTag Latest)) tool =
+  getLatest av tool ?? TagNotFound Latest tool
+fromVersion av (Just (ToolTag Recommended)) tool =
+  getRecommended av tool ?? TagNotFound Recommended tool
+
+
+printListResult :: [ListResult] -> IO ()
+printListResult lr = do
+  let
+    formatted =
+      gridString
+          [ column expand left def def
+          , column expand left def def
+          , column expand left def def
+          , column expand left def def
+          ]
+        $ fmap
+            (\ListResult {..} ->
+              [ if
+                | lSet       -> (color Green "✔✔")
+                | lInstalled -> (color Green "✓")
+                | otherwise  -> (color Red "✗")
+              , fmap toLower . show $ lTool
+              , T.unpack . prettyVer $ lVer
+              , intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
+              ]
+            )
+            lr
+  putStrLn $ formatted

ghcup.cabal

@@ -22,6 +22,8 @@ source-repository head
 
 common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
 common aeson { build-depends: aeson >= 1.4 }
+common aeson-pretty { build-depends: aeson-pretty >= 0.8.8 }
+common attoparsec { build-depends: attoparsec >= 0.13 }
 common ascii-string { build-depends: ascii-string >= 1.0 }
 common async { build-depends: async >= 0.8 }
 common base { build-depends: base >= 4.12 && < 5 }
@@ -30,6 +32,7 @@ common bzlib { build-depends: bzlib >= 0.5.0.5 }
 common containers { build-depends: containers >= 0.6 }
 common generics-sop { build-depends: generics-sop >= 0.5 }
 common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
+common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
 common hpath { build-depends: hpath >= 0.11 }
 common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
 common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
@@ -46,11 +49,14 @@ common optics-vl { build-depends: optics-vl >= 0.2 }
 common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 }
 common parsec { build-depends: parsec >= 3.1 }
 common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 }
+common safe { build-depends: safe >= 0.3.18 }
 common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
 common streamly { build-depends: streamly >= 0.7 }
 common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
 common strict-base { build-depends: strict-base >= 0.4 }
 common string-qq { build-depends: string-qq >= 0.0.4 }
+common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
+common table-layout { build-depends: table-layout >= 0.8 }
 common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 }
 common template-haskell { build-depends: template-haskell >= 2.7 }
 common text { build-depends: text >= 1.2 }
@@ -87,11 +93,13 @@ library
                      , aeson
                      , ascii-string
                      , async
+                     , attoparsec
                      , bytestring
                      , bzlib
                      , containers
                      , generics-sop
                      , haskus-utils-variant
+                     , haskus-utils-types
                      , hpath
                      , hpath-directory
                      , hpath-filepath
@@ -106,11 +114,14 @@ library
                      , optics
                      , optics-vl
                      , parsec
+                     , pretty-terminal
+                     , safe
                      , safe-exceptions
                      , streamly
                      , streamly-bytestring
                      , strict-base
                      , string-qq
+                     , string-interpolate
                      , tar-bytestring
                      , template-haskell
                      , text
@@ -127,6 +138,7 @@ library
   exposed-modules:     GHCup
                        GHCup.Bash
                        GHCup.File
+                       GHCup.Logger
                        GHCup.Prelude
                        GHCup.Types
                        GHCup.Types.JSON
@@ -138,7 +150,9 @@ library
 executable ghcup
   import:                config
                        , base
+                       --
                        , bytestring
+                       , containers
                        , haskus-utils-variant
                        , monad-logger
                        , mtl
@@ -148,11 +162,47 @@ executable ghcup
                        , hpath
                        , pretty-terminal
                        , string-qq
+                       , string-interpolate
+                       , table-layout
+                       , uri-bytestring
+                       , utf8-string
   main-is:             Main.hs
   -- other-modules:
   -- other-extensions:
   build-depends:       ghcup
-  hs-source-dirs:      app
+  hs-source-dirs:      app/ghcup
+  default-language:    Haskell2010
+
+executable ghcup-gen
+  import:                config
+                       , base
+                       --
+                       , aeson
+                       , aeson-pretty
+                       , bytestring
+                       , containers
+                       , safe-exceptions
+                       , haskus-utils-variant
+                       , monad-logger
+                       , mtl
+                       , optics
+                       , optparse-applicative
+                       , text
+                       , versions
+                       , hpath
+                       , pretty-terminal
+                       , string-qq
+                       , string-interpolate
+                       , table-layout
+                       , transformers
+                       , uri-bytestring
+                       , utf8-string
+  main-is:             Main.hs
+  other-modules:       AvailableDownloads
+                       Validate
+  -- other-extensions:
+  build-depends:       ghcup
+  hs-source-dirs:      app/ghcup-gen
   default-language:    Haskell2010
 
 test-suite ghcup-test

lib/GHCup/File.hs

@@ -19,7 +19,6 @@ import           Data.Foldable
 import           Control.Monad
 import           Control.Exception.Safe
 import           Data.Functor
-import           System.Posix.Files.ByteString
 import           System.Posix.Foreign           ( oExcl )
 import           System.Posix.Env.ByteString
 import           System.IO
@@ -40,12 +39,6 @@ import qualified Streamly.FileSystem.Handle    as FH
 import qualified Streamly.Internal.Data.Unfold as SU
 import qualified Streamly.Prelude              as S
 import           System.Exit
-import qualified Streamly.Data.Fold            as FL
-import           Data.ByteString.Builder
-import           Foreign.C.Error
-import           GHCup.Prelude
-import           Control.Concurrent.Async
-import           Control.Concurrent
 import           System.Posix.FD               as FD
 import qualified Data.ByteString.UTF8          as UTF8
 import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
@@ -61,11 +54,12 @@ data ProcessError = NonZeroExit Int ByteString [ByteString]
                   deriving Show
 
 
-data CapturedProcess = CapturedProcess {
+data CapturedProcess = CapturedProcess
-    _exitCode :: ExitCode
+  { _exitCode :: ExitCode
   , _stdOut   :: ByteString
   , _stdErr   :: ByteString
-} deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 makeLenses ''CapturedProcess
 
@@ -101,7 +95,7 @@ findExecutable ex = do
   -- figure out if a file exists, then treat it as a negative result.
   asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
     -- asum for short-circuiting behavior
-    (\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
+    (\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
     sPaths
 
 
@@ -111,10 +105,9 @@ executeOut :: Path b          -- ^ command as filename, e.g. 'ls'
            -> [ByteString]      -- ^ arguments to the command
            -> Maybe (Path Abs)  -- ^ chdir to this path
            -> IO CapturedProcess
-executeOut path args chdir =
+executeOut path args chdir = captureOutStreams $ do
-  captureOutStreams $ do
+  maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
-   maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+  SPPB.executeFile (toFilePath path) True args Nothing
-   SPPB.executeFile (toFilePath path) True args Nothing
 
 
 -- | Capture the stdout and stderr of the given action, which
@@ -150,9 +143,9 @@ captureOutStreams action =
           stdout' <- L.toStrict <$> readFd parentStdoutRead
           stderr' <- L.toStrict <$> readFd parentStderrRead
           pure $ CapturedProcess { _exitCode = es
-                                        , _stdOut   = stdout'
+                                 , _stdOut   = stdout'
-                                        , _stdErr   = stderr'
+                                 , _stdErr   = stderr'
-                                        }
+                                 }
         _ -> throwIO $ userError $ ("No such PID " ++ show pid)
 
  where

lib/GHCup/Logger.hs

@@ -0,0 +1,30 @@
+module GHCup.Logger where
+
+
+import           System.Console.Pretty
+import           System.IO
+import           Control.Monad.Logger
+
+import qualified Data.ByteString as B
+
+
+myLoggerT :: (B.ByteString -> IO ()) -> LoggingT m a -> m a
+myLoggerT outter loggingt = runLoggingT loggingt mylogger
+ where
+  mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+  mylogger _ _ level str' = do
+    let l = case level of
+          LevelDebug   -> toLogStr (style Bold $ color Blue   "[ Debug ]")
+          LevelInfo    -> toLogStr (style Bold $ color Green  "[ Info  ]")
+          LevelWarn    -> toLogStr (style Bold $ color Yellow "[ Warn  ]")
+          LevelError   -> toLogStr (style Bold $ color Red    "[ Error ]")
+          LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
+    let out = fromLogStr (l <>  toLogStr " " <> str' <> toLogStr "\n")
+    outter out
+
+myLoggerTStdout :: LoggingT m a -> m a
+myLoggerTStdout = myLoggerT (B.hPut stdout)
+
+myLoggerTStderr :: LoggingT m a -> m a
+myLoggerTStderr = myLoggerT (B.hPut stderr)
+

lib/GHCup/Prelude.hs

@@ -15,18 +15,25 @@ module GHCup.Prelude where
 
 import           Control.Applicative
 import           Control.Monad
+import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      ( lift )
 import           Control.Exception.Safe
+import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
 import qualified Data.Strict.Maybe             as S
 import           Data.Monoid                    ( (<>) )
 import           Data.String
+
+import qualified Data.Text.Lazy.Builder        as B
+import qualified Data.Text.Lazy.Builder.Int    as B
 import qualified Data.Text.Lazy.Encoding       as TLE
 import qualified Data.Text.Lazy                as TL
 import           Data.Text                      ( Text )
+import qualified Data.Text.Encoding            as E
 import qualified Data.Text                     as T
 import           Data.Versions
 import qualified Data.ByteString.Lazy          as L
+import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           System.IO.Error
 import           Language.Haskell.TH
@@ -94,9 +101,14 @@ lBS2sT :: L.ByteString -> Text
 lBS2sT = TL.toStrict . TLE.decodeUtf8
 
 
-handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO ()
+
-handleIO' err handler =
+handleIO' :: (MonadIO m, MonadCatch m)
-  handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e)
+          => IOErrorType
+          -> (IOException -> m a)
+          -> m a
+          -> m a
+handleIO' err handler = handleIO
+  (\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)
 
 
 (??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
@@ -114,20 +126,60 @@ handleIO' err handler =
 lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
 lE = liftE . veitherToExcepts . fromEither
 
+lE' :: forall e' e es a m
+     . (Monad m, e :< es)
+    => (e' -> e)
+    -> Either e' a
+    -> Excepts es m a
+lE' f = liftE . veitherToExcepts . fromEither . bimap f id
+
 lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
 lEM em = lift em >>= lE
 
+lEM' :: forall e' e es a m
+      . (Monad m, e :< es)
+     => (e' -> e)
+     -> m (Either e' a)
+     -> Excepts es m a
+lEM' f em = lift em >>= lE . bimap f id
+
 fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
 
+
+liftException :: ( MonadCatch m
+                 , MonadIO m
+                 , Monad m
+                 , e :< es'
+                 , LiftVariant es es'
+                 )
+              => IOErrorType
+              -> e
+              -> Excepts es m a
+              -> Excepts es' m a
+liftException errType ex =
+  handleIO
+      (\e ->
+        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
+      )
+    . liftE
+
+
+-- TODO: does this work?
 hideExcept :: forall e es es' a m
             . (Monad m, e :< es, LiftVariant (Remove e es) es')
            => e
            -> a
            -> Excepts es m a
            -> Excepts es' m a
-hideExcept h a action =
+hideExcept _ a action =
-  catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m a)) action
+  catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
+
+
+throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
+throwEither a = case a of
+  Left  e -> throwM e
+  Right r -> pure r
 
 
 
@@ -152,8 +204,8 @@ qq quoteExp' = QuasiQuoter
     "illegal QuasiQuote (allowed as expression only, used as a declaration)"
   }
 
-ver :: QuasiQuoter
+vver :: QuasiQuoter
-ver = qq mkV
+vver = qq mkV
  where
   mkV :: Text -> Q Exp
   mkV = either (fail . show) TH.lift . version
@@ -181,3 +233,12 @@ pver = qq mkV
  where
   mkV :: Text -> Q Exp
   mkV = either (fail . show) TH.lift . pvp
+
+
+verToBS :: Version -> ByteString
+verToBS = E.encodeUtf8 . prettyVer
+
+
+
+intToText :: Integral a => a -> T.Text
+intToText = TL.toStrict . B.toLazyText . B.decimal

lib/GHCup/Types.hs

@@ -9,15 +9,27 @@ import           Data.Versions
 import           URI.ByteString
 
 
+data DebugInfo = DebugInfo
+  { diBaseDir   :: Path Abs
+  , diBinDir    :: Path Abs
+  , diGHCDir    :: Path Abs
+  , diCacheDir  :: Path Abs
+  , diURLSource :: URLSource
+  , diArch      :: Architecture
+  , diPlatform  :: PlatformResult
+  }
+  deriving Show
+
+
 data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
             | SetGHCMajor -- ^ ghc-x.y
-            | SetGHCMinor -- ^ ghc-x.y.z
+            | SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
             deriving Show
 
 
 data Tag = Latest
          | Recommended
-         deriving (Eq, Show)
+         deriving (Ord, Eq, Show)
 
 data VersionInfo = VersionInfo
   { _viTags :: [Tag]
@@ -33,11 +45,12 @@ data DownloadInfo = DownloadInfo
 
 data Tool = GHC
           | Cabal
+          | GHCUp
   deriving (Eq, GHC.Generic, Ord, Show)
 
 data ToolRequest = ToolRequest
-  { _tool        :: Tool
+  { _trTool        :: Tool
-  , _toolVersion :: Version
+  , _trVersion :: Version
   }
   deriving (Eq, Show)
 

lib/GHCup/Types/JSON.hs

@@ -6,7 +6,8 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE QuasiQuotes           #-}
 
 module GHCup.Types.JSON where
 
@@ -20,7 +21,11 @@ import           Data.Text.Encoding             ( decodeUtf8
                                                 )
 import           Data.Aeson.Types
 import           Data.Text.Encoding            as E
+import           HPath
 import           URI.ByteString
+import           Data.Word8
+import qualified Data.ByteString               as BS
+import           Data.String.QQ
 
 
 
@@ -33,6 +38,9 @@ deriveJSON defaultOptions ''SemVer
 deriveJSON defaultOptions ''Tool
 deriveJSON defaultOptions ''VSep
 deriveJSON defaultOptions ''VUnit
+deriveJSON defaultOptions ''VersionInfo
+deriveJSON defaultOptions ''Tag
+deriveJSON defaultOptions ''DownloadInfo
 
 
 instance ToJSON URI where
@@ -127,3 +135,17 @@ instance ToJSONKey Tool where
 
 instance FromJSONKey Tool where
   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
+
+instance ToJSON (Path Rel) where
+  toJSON p = case and . fmap isAscii . BS.unpack $ fp of
+    True  -> toJSON . E.decodeUtf8 $ fp
+    False -> String [s|/not/a/valid/path|]
+    where fp = toFilePath p
+
+instance FromJSON (Path Rel) where
+  parseJSON = withText "HPath Rel" $ \t -> do
+    let d = encodeUtf8 t
+    case parseRel d of
+      Right x -> pure x
+      Left  e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
+