WIP

.gitlab-ci.yml

@@ -182,12 +182,12 @@ variables:
     - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
 
     # make sure to not pollute the machine with temp files etc
-    - mkdir -p $CI_PROJECT_DIR/.brew_cache
+    - mkdir -p $CI_PROJECT_DIR/.bc
-    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
+    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.bc
-    - mkdir -p $CI_PROJECT_DIR/.brew_logs
+    - mkdir -p $CI_PROJECT_DIR/.bl
-    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
+    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.bl
-    - mkdir -p $CI_PROJECT_DIR/.brew_tmp
+    - mkdir -p $CI_PROJECT_DIR/.bt
-    - export HOMEBREW_TEMP=$CI_PROJECT_DIR/.brew_tmp
+    - export HOMEBREW_TEMP=$CI_PROJECT_DIR/.bt
 
     # update and install packages
     - brew update
@@ -541,12 +541,12 @@ release:darwin:aarch64:
     - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
 
     # make sure to not pollute the machine with temp files etc
-    - mkdir -p $CI_PROJECT_DIR/.brew_cache
+    - mkdir -p $CI_PROJECT_DIR/.bc
-    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.brew_cache
+    - export HOMEBREW_CACHE=$CI_PROJECT_DIR/.bc
-    - mkdir -p $CI_PROJECT_DIR/.brew_logs
+    - mkdir -p $CI_PROJECT_DIR/.bl
-    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.brew_logs
+    - export HOMEBREW_LOGS=$CI_PROJECT_DIR/.bl
-    - mkdir -p $CI_PROJECT_DIR/.brew_tmp
+    - mkdir -p $CI_PROJECT_DIR/.bt
-    - export HOMEBREW_TEMP=$CI_PROJECT_DIR/.brew_tmp
+    - export HOMEBREW_TEMP=$CI_PROJECT_DIR/.bt
 
     # update and install packages
     - brew update

app/ghcup/BrickMain.hs

@@ -13,9 +13,9 @@ import           GHCup.Errors
 import           GHCup.Types.Optics ( getDirs )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.Prelude ( decUTF8Safe )
+import           GHCup.Prelude ( decUTF8Safe )
-import           GHCup.Utils.File
+import           GHCup.System.Process
 
 import           Brick
 import           Brick.Widgets.Border
@@ -27,6 +27,9 @@ import           Brick.Widgets.List             ( listSelectedFocusedAttr
                                                 )
 import           Codec.Archive
 import           Control.Exception.Safe
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Except
 import           Control.Monad.Trans.Resource
@@ -556,17 +559,7 @@ settings' = unsafePerformIO $ do
                                   , fileOutter    = \_ -> pure ()
                                   , fancyColors   = True
                                   }
-  newIORef $ AppState (Settings { cache      = True
+  newIORef $ AppState defaultSettings
-                                , noVerify   = False
-                                , keepDirs   = Never
-                                , downloader = Curl
-                                , verbose    = False
-                                , urlSource  = GHCupURL
-                                , noNetwork  = False
-                                , gpgSetting = GPGNone
-                                , noColor    = False
-                                , ..
-                                })
                       dirs
                       defaultKeyBindings
                       (GHCupInfo mempty mempty mempty)

app/ghcup/GHCup/OptParse.hs

@@ -67,6 +67,7 @@ data Options = Options
   -- global options
     optVerbose     :: Maybe Bool
   , optCache       :: Maybe Bool
+  , optMetaCache   :: Maybe Integer
   , optUrlSource   :: Maybe URI
   , optNoVerify    :: Maybe Bool
   , optKeepDirs    :: Maybe KeepDirs
@@ -105,6 +106,7 @@ opts =
   Options
     <$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
     <*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
+    <*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal))
     <*> optional
           (option
             (eitherReader parseUri)

app/ghcup/GHCup/OptParse/ChangeLog.hs

@@ -12,9 +12,9 @@ module GHCup.OptParse.ChangeLog where
 
 
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Logger
 import           GHCup.OptParse.Common
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -34,8 +34,8 @@ import GHCup.Types.Optics
 import GHCup.Utils
 import Data.Versions
 import URI.ByteString (serializeURIRef')
-import GHCup.Utils.Prelude
+import GHCup.Prelude
-import GHCup.Utils.File (exec)
+import GHCup.System.Process (exec)
 import Data.Char (toLower)
 
 

app/ghcup/GHCup/OptParse/Common.hs

@@ -14,9 +14,9 @@ import           GHCup.Platform
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.MegaParsec
+import           GHCup.MegaParsec
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
 
 import           Control.Exception.Safe
 #if !MIN_VERSION_base(4,13,0)
@@ -299,7 +299,7 @@ tagCompleter tool add = listIOCompleter $ do
         , fancyColors    = False
         }
   let appState = LeanAppState
-        (Settings True False Never Curl False GHCupURL True GPGNone False)
+        (defaultSettings { noNetwork = True })
         dirs'
         defaultKeyBindings
         loggerConfig
@@ -322,7 +322,7 @@ versionCompleter criteria tool = listIOCompleter $ do
         , fileOutter     = mempty
         , fancyColors    = False
         }
-  let settings = Settings True False Never Curl False GHCupURL True GPGNone False
+  let settings = defaultSettings { noNetwork = True }
   let leanAppState = LeanAppState
                    settings
                    dirs'
@@ -399,7 +399,7 @@ fromVersion' (SetToolVersion v) tool = do
     Right pvpIn ->
       lift (getLatestToolFor tool pvpIn dls) >>= \case
         Just (pvp_, vi') -> do
-          v' <- lift $ pvpToVersion pvp_
+          v' <- lift $ pvpToVersion pvp_ ""
           when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
           pure (GHCTargetVersion (_tvTarget v) v', Just vi')
         Nothing -> pure (v, vi)

app/ghcup/GHCup/OptParse/Compile.hs

@@ -13,13 +13,13 @@ module GHCup.OptParse.Compile where
 
 import           GHCup
 import           GHCup.Errors
-import           GHCup.Utils.File
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Utils.Logger
+import           GHCup.Logger
 import           GHCup.OptParse.Common
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
+import           GHCup.System.Process
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Config.hs

@@ -14,9 +14,9 @@ module GHCup.OptParse.Config where
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -122,6 +122,7 @@ updateSettings config' settings = do
    mergeConf :: UserSettings -> Settings -> Settings
    mergeConf UserSettings{..} Settings{..} =
      let cache'      = fromMaybe cache uCache
+         metaCache'  = fromMaybe metaCache uMetaCache
          noVerify'   = fromMaybe noVerify uNoVerify
          keepDirs'   = fromMaybe keepDirs uKeepDirs
          downloader' = fromMaybe downloader uDownloader
@@ -129,7 +130,7 @@ updateSettings config' settings = do
          urlSource'  = fromMaybe urlSource uUrlSource
          noNetwork'  = fromMaybe noNetwork uNoNetwork
          gpgSetting' = fromMaybe gpgSetting uGPGSetting
-     in Settings cache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
+     in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
 
 
 

app/ghcup/GHCup/OptParse/DInfo.hs

@@ -17,9 +17,10 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.Version
 import           GHCup.Types
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
-import           GHCup.Utils.Dirs
+import           GHCup.Directories
-import           GHCup.Utils.Logger
+import           GHCup.Logger
+import           GHCup.System.Process
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -36,7 +37,6 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
-import GHCup.Utils.File
 import Language.Haskell.TH
 
 
@@ -51,7 +51,7 @@ describe_result = $( LitE . StringL <$>
                      runIO (do
                              CapturedProcess{..} <-  do
                               dirs <- liftIO getAllDirs
-                              let settings = AppState (Settings True False Never Curl False GHCupURL False GPGNone False)
+                              let settings = AppState (defaultSettings { noNetwork = True })
                                                dirs
                                                defaultKeyBindings
                               flip runReaderT settings $ executeOut "git" ["describe"] Nothing

app/ghcup/GHCup/OptParse/GC.hs

@@ -14,8 +14,8 @@ module GHCup.OptParse.GC where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Install.hs

@@ -17,9 +17,9 @@ import           GHCup.OptParse.Common
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.File
+import           GHCup.Logger
-import           GHCup.Utils.Logger
+import           GHCup.QQ.String
-import           GHCup.Utils.String.QQ
+import           GHCup.System.Process
 
 import           Codec.Archive
 #if !MIN_VERSION_base(4,13,0)

app/ghcup/GHCup/OptParse/List.hs

@@ -11,7 +11,7 @@ module GHCup.OptParse.List where
 
 
 import           GHCup
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
 import           GHCup.Types
 import           GHCup.OptParse.Common
 

app/ghcup/GHCup/OptParse/Nuke.hs

@@ -14,7 +14,7 @@ module GHCup.OptParse.Nuke where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -14,9 +14,9 @@ module GHCup.OptParse.Prefetch where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Logger
 import           GHCup.OptParse.Common
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -33,7 +33,7 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
-import GHCup.Utils.Prelude
+import GHCup.Prelude
 import GHCup.Download (getDownloadsF)
 
 

app/ghcup/GHCup/OptParse/Rm.hs

@@ -18,9 +18,9 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Utils
-import           GHCup.Utils.Logger
+import           GHCup.Logger
 import           GHCup.OptParse.Common
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Set.hs

@@ -17,8 +17,8 @@ import           GHCup.OptParse.Common
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/ToolRequirements.hs

@@ -10,7 +10,7 @@ module GHCup.OptParse.ToolRequirements where
 
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -28,7 +28,7 @@ import qualified Data.Text.IO                  as T
 import Control.Exception.Safe (MonadMask)
 import GHCup.Types.Optics
 import GHCup.Platform
-import GHCup.Utils.Prelude
+import GHCup.Prelude
 import GHCup.Requirements
 import System.IO
 

app/ghcup/GHCup/OptParse/UnSet.hs

@@ -16,8 +16,8 @@ module GHCup.OptParse.UnSet where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -14,7 +14,7 @@ module GHCup.OptParse.Upgrade where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Whereis.hs

@@ -17,8 +17,8 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.OptParse.Common
 import           GHCup.Types
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/Main.hs

@@ -21,9 +21,9 @@ import           GHCup.Errors
 import           GHCup.Platform
 import           GHCup.Types
 import           GHCup.Utils
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 import           GHCup.Version
 
 import           Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
@@ -55,6 +55,7 @@ import qualified Data.ByteString               as B
 import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
+import qualified GHCup.Types                   as Types
 
 
 
@@ -72,15 +73,16 @@ toSettings options = do
  where
    mergeConf :: Options -> UserSettings -> Bool -> (Settings, KeyBindings)
    mergeConf Options{..} UserSettings{..} noColor =
-     let cache       = fromMaybe (fromMaybe False uCache) optCache
+     let cache       = fromMaybe (fromMaybe (Types.cache defaultSettings) uCache) optCache
-         noVerify    = fromMaybe (fromMaybe False uNoVerify) optNoVerify
+         metaCache   = fromMaybe (fromMaybe (Types.metaCache defaultSettings) uMetaCache) optMetaCache
-         verbose     = fromMaybe (fromMaybe False uVerbose) optVerbose
+         noVerify    = fromMaybe (fromMaybe (Types.noVerify defaultSettings) uNoVerify) optNoVerify
-         keepDirs    = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs
+         verbose     = fromMaybe (fromMaybe (Types.verbose defaultSettings) uVerbose) optVerbose
+         keepDirs    = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
          downloader  = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
          keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
-         urlSource   = maybe (fromMaybe GHCupURL uUrlSource) OwnSource optUrlSource
+         urlSource   = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) OwnSource optUrlSource
-         noNetwork   = fromMaybe (fromMaybe False uNoNetwork) optNoNetwork
+         noNetwork   = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
-         gpgSetting  = fromMaybe (fromMaybe GPGNone uGPGSetting) optGpg
+         gpgSetting  = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
      in (Settings {..}, keyBindings)
 #if defined(INTERNAL_DOWNLOADER)
    defaultDownloader = Internal

cabal.project

@@ -12,6 +12,11 @@ constraints: http-io-streams -brotli,
              any.Cabal ==3.6.2.0,
              any.aeson >= 2.0.1.0
 
+source-repository-package
+  type: git
+  location: https://github.com/input-output-hk/optparse-applicative
+  tag: 7497a29cb998721a9068d5725d49461f2bba0e7a
+
 package libarchive
   flags: -system-libarchive
 

data/config.yaml

@@ -36,6 +36,10 @@ key-bindings:
   show-all-tools:
     KChar: 't'
 
+# The caching for the metadata files containing download info, depending on last access time
+# of the file. These usually are in '~/.ghcup/cache/ghcup-<ver>.yaml'.
+meta-cache: 300 # in seconds
+
 # Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
 # check the 'URLSource' type in the code.
 url-source:

docs/guide.md

@@ -53,6 +53,25 @@ as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
 and make sure your bashrc sources the startup script
 (`/usr/share/bash-completion/bash_completion` on some distros).
 
+## Caching
+
+GHCup has a few caching mechanisms to avoid redownloads. All cached files end up in `~/.ghcup/cache` by default.
+
+### Downloads cache
+
+Downloaded tarballs (such as GHC, cabal, etc.) are not cached by default unless you pass `ghcup --cache` or set caching
+in your [config](#configuration) via `ghcup config set cache true`.
+
+### Metadata cache
+
+The metadata files (also see [github.com/haskell/ghcup-metadata](https://github.com/haskell/ghcup-metadata))
+have a 5 minutes cache per default depending on the last access time of the file. That means if you run
+`ghcup list` 10 times in a row, only the first time will trigger a download attempt.
+
+### Clearing the cache
+
+If you experience problems, consider clearing the cache via `ghcup gc --cache`.
+
 ## Compiling GHC from source
 
 Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help`

ghcup.cabal

@@ -51,8 +51,16 @@ flag no-exe
 library
   exposed-modules:
     GHCup
+    GHCup.Data.Versions
+    GHCup.GHC
+    GHCup.GHC.Rm
+    GHCup.GHC.Unset
+    GHCup.GHC.Set
+    GHCup.GHC.Compile
+    GHCup.GHC.Common
+    GHCup.GHC.Install
     GHCup.Download
-    GHCup.Download.Utils
+    GHCup.Download.Common
     GHCup.Errors
     GHCup.Platform
     GHCup.Requirements
@@ -60,14 +68,16 @@ library
     GHCup.Types.JSON
     GHCup.Types.Optics
     GHCup.Utils
-    GHCup.Utils.Dirs
+    GHCup.Directories
-    GHCup.Utils.File
+    GHCup.System.Process
-    GHCup.Utils.File.Common
+    GHCup.System.Directory
-    GHCup.Utils.Logger
+    GHCup.System.Process.Common
-    GHCup.Utils.MegaParsec
+    GHCup.System.Console
-    GHCup.Utils.Prelude
+    GHCup.Logger
-    GHCup.Utils.String.QQ
+    GHCup.MegaParsec
-    GHCup.Utils.Version.QQ
+    GHCup.Prelude
+    GHCup.QQ.String
+    GHCup.QQ.Version
     GHCup.Version
 
   hs-source-dirs:     lib
@@ -96,7 +106,7 @@ library
   build-depends:
     , aeson                 >=1.4
     , async                 >=0.8        && <2.3
-    , base                  >=4.13       && <5
+    , base                  >=4.12       && <5
     , base16-bytestring     >=0.1.1.6    && <1.1
     , binary                ^>=0.8.6.0
     , bytestring            ^>=0.10
@@ -152,9 +162,9 @@ library
   if os(windows)
     cpp-options:   -DIS_WINDOWS
     other-modules:
-      GHCup.Utils.File.Windows
+      GHCup.System.Process.Windows
-      GHCup.Utils.Prelude.Windows
+      GHCup.Prelude.Windows
-      GHCup.Utils.Windows
+      GHCup.System.Console.Windows
 
     build-depends:
       , bzlib
@@ -163,9 +173,9 @@ library
 
   else
     other-modules:
-      GHCup.Utils.File.Posix
+      GHCup.System.Process.Posix
-      GHCup.Utils.Posix
+      GHCup.System.Console.Posix
-      GHCup.Utils.Prelude.Posix
+      GHCup.Prelude.Posix
       System.Console.Terminal.Common
       System.Console.Terminal.Posix
 
@@ -219,7 +229,7 @@ executable ghcup
     , aeson                 >=1.4
     , aeson-pretty          ^>=0.8.8
     , async                 ^>=2.2.3
-    , base                  >=4.13     && <5
+    , base                  >=4.12     && <5
     , bytestring            ^>=0.10
     , cabal-plan            ^>=0.7.2
     , containers            ^>=0.6
@@ -231,7 +241,7 @@ executable ghcup
     , libarchive            ^>=3.0.3.0
     , megaparsec            >=8.0.0    && <9.1
     , mtl                   ^>=2.2
-    , optparse-applicative  >=0.15.1.0 && <0.17
+    , optparse-applicative-fork  >=0.15.1.0 && <0.17
     , pretty                ^>=1.1.3.1
     , pretty-terminal       ^>=0.1.0.0
     , resourcet             ^>=1.2.2
@@ -287,7 +297,7 @@ test-suite ghcup-test
     -fwarn-incomplete-record-updates
 
   build-depends:
-    , base                      >=4.13    && <5
+    , base                      >=4.12    && <5
     , bytestring                ^>=0.10
     , containers                ^>=0.6
     , generic-arbitrary         ^>=0.1.0

hie.yaml

@@ -4,7 +4,5 @@ cradle:
     path: ./lib
   - component: "ghcup:exe:ghcup"
     path: ./app/ghcup
-  - component: "ghcup:exe:ghcup-gen"
-    path: "./app/ghcup-gen"
   - component: "ghcup:test:ghcup-test"
     path: ./test

lib/GHCup/Directories.hs

@@ -5,7 +5,7 @@
 {-# LANGUAGE ViewPatterns          #-}
 
 {-|
-Module      : GHCup.Utils.Dirs
+Module      : GHCup.Directories
 Description : Definition of GHCup directories
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -13,7 +13,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Utils.Dirs
+module GHCup.Directories
   ( getAllDirs
   , ghcupBaseDir
   , ghcupConfigFile
@@ -35,9 +35,9 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.JSON               ( )
 import           GHCup.Types.Optics
-import           GHCup.Utils.MegaParsec
+import           GHCup.MegaParsec
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
 
 import           Control.Exception.Safe
 import           Control.Monad

lib/GHCup/Download.hs

@@ -27,16 +27,16 @@ module GHCup.Download where
 
 #if defined(INTERNAL_DOWNLOADER)
 import           GHCup.Download.IOStreams
-import           GHCup.Download.Utils
+import           GHCup.Download.Common
 #endif
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.Dirs
+import           GHCup.Directories
-import           GHCup.Utils.File
+import           GHCup.System.Process
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
 import           GHCup.Version
 
 import           Control.Applicative
@@ -242,14 +242,18 @@ getBase uri = do
     e <- liftIO $ doesFileExist json_file
     currentTime <- liftIO getCurrentTime
     Dirs { cacheDir } <- lift getDirs
+    Settings { metaCache } <- lift getSettings
 
        -- for local files, let's short-circuit and ignore access time
     if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True
        | e -> do
-          accessTime <- liftIO $ getAccessTime json_file
+          accessTime <- fmap utcTimeToPOSIXSeconds $ liftIO $ getAccessTime json_file
-
+          let sinceLastAccess = utcTimeToPOSIXSeconds currentTime - accessTime
+          let cacheInterval = fromInteger metaCache
+          lift $ logDebug $ "last access was " <> T.pack (show sinceLastAccess) <> " ago, cache interval is " <> T.pack (show cacheInterval)
           -- access time won't work on most linuxes, but we can try regardless
-          if | ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) ->
+          if | metaCache <= 0 -> dlWithMod currentTime json_file
+             | (sinceLastAccess > cacheInterval) ->
                 -- no access in last 5 minutes, re-check upstream mod time
                 dlWithMod currentTime json_file
              | otherwise -> pure json_file

lib/GHCup/Download/Common.hs

@@ -4,13 +4,13 @@
 {-# LANGUAGE TypeFamilies          #-}
 
 
-module GHCup.Download.Utils where
+module GHCup.Download.Common where
 
 
 import           GHCup.Errors
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
 
 import           Control.Applicative
 import           Control.Monad

lib/GHCup/Download/IOStreams.hs

@@ -7,10 +7,10 @@
 module GHCup.Download.IOStreams where
 
 
-import           GHCup.Download.Utils
+import           GHCup.Download.Common
 import           GHCup.Errors
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
 
 import           Control.Applicative
 import           Control.Exception.Safe

lib/GHCup/Logger.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 
 {-|
-Module      : GHCup.Utils.Logger
+Module      : GHCup.Logger
 Description : logger definition
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -14,12 +14,12 @@ Portability : portable
 
 Here we define our main logger.
 -}
-module GHCup.Utils.Logger where
+module GHCup.Logger where
 
 import           GHCup.Types
 import           GHCup.Types.Optics
-import {-# SOURCE #-} GHCup.Utils.File.Common
+import {-# SOURCE #-} GHCup.System.Directory
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
 import           Control.Exception.Safe
 import           Control.Monad
@@ -34,7 +34,7 @@ import           System.IO.Error
 import           Text.Regex.Posix
 
 import qualified Data.ByteString               as B
-import GHCup.Utils.Prelude
+import GHCup.Prelude
 import qualified Data.Text                     as T
 
 logInfo :: ( MonadReader env m

lib/GHCup/Logger.hs-boot

@@ -3,7 +3,7 @@
 {-# LANGUAGE DataKinds        #-}
 {-# LANGUAGE OverloadedStrings   #-}
 
-module GHCup.Utils.Logger where
+module GHCup.Logger where
 
 import           GHCup.Types
 

lib/GHCup/MegaParsec.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE OverloadedStrings    #-}
 
 {-|
-Module      : GHCup.Utils.MegaParsec
+Module      : GHCup.MegaParsec
 Description : MegaParsec utilities
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -10,7 +10,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Utils.MegaParsec where
+module GHCup.MegaParsec where
 
 import           GHCup.Types
 

lib/GHCup/Platform.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
@@ -22,11 +23,14 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.File
+import           GHCup.System.Process
-import           GHCup.Utils.Logger
+import           GHCup.Logger
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
-import           GHCup.Utils.String.QQ
+import           GHCup.QQ.String
 
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad

lib/GHCup/Prelude.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE TypeOperators       #-}
 
 {-|
-Module      : GHCup.Utils.Prelude
+Module      : GHCup.Prelude
 Description : MegaParsec utilities
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -17,12 +17,12 @@ Portability : portable
 
 GHCup specific prelude. Lots of Excepts functionality.
 -}
-module GHCup.Utils.Prelude
+module GHCup.Prelude
-  (module GHCup.Utils.Prelude,
+  (module GHCup.Prelude,
 #if defined(IS_WINDOWS)
-   module GHCup.Utils.Prelude.Windows
+   module GHCup.Prelude.Windows
 #else
-   module GHCup.Utils.Prelude.Posix
+   module GHCup.Prelude.Posix
 #endif
   )
 where
@@ -30,11 +30,11 @@ where
 import           GHCup.Types
 import           GHCup.Errors
 import           GHCup.Types.Optics
-import {-# SOURCE #-} GHCup.Utils.Logger
+import {-# SOURCE #-} GHCup.Logger
 #if defined(IS_WINDOWS)
-import           GHCup.Utils.Prelude.Windows
+import           GHCup.Prelude.Windows
 #else
-import           GHCup.Utils.Prelude.Posix
+import           GHCup.Prelude.Posix
 #endif
 
 import           Control.Applicative
@@ -44,7 +44,7 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd )
+import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
 import           Data.Maybe
 import           Data.Foldable
 import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
@@ -313,18 +313,46 @@ removeLensFieldLabel str' =
   maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
 
 
-pvpToVersion :: MonadThrow m => PVP -> m Version
+pvpToVersion :: MonadThrow m => PVP -> Text -> m Version
-pvpToVersion =
+pvpToVersion pvp_ rest =
-  either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . prettyPVP
+  either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_
 
-versionToPVP :: MonadThrow m => Version -> m PVP
+-- | Convert a version to a PVP and unparsable rest.
-versionToPVP v = either (\_ -> alternative v) pure . pvp . prettyVer $ v
+--
+-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v
+versionToPVP :: MonadThrow m => Version -> m (PVP, Text)
+versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch"
+versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v
  where
   alternative :: MonadThrow m => Version -> m PVP
   alternative v' = case NE.takeWhile isDigit (_vChunks v') of
     [] -> throwM $ ParseError "Couldn't convert Version to PVP"
     xs -> pure $ pvpFromList (unsafeDigit <$> xs)
 
+  rest :: Version -> Text
+  rest (Version _ cs pr me) =
+    let chunks = NE.dropWhile isDigit cs
+        ver = intersperse (T.pack ".") . chunksAsT $ chunks
+        me' = maybe [] (\m -> [T.pack "+",m]) me
+        pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr)
+        prefix = case (ver, pr', me') of
+                   (_:_, _, _) -> T.pack "."
+                   _           -> T.pack ""
+    in prefix <> mconcat (ver <> pr' <> me')
+   where
+    chunksAsT :: Functor t => t VChunk -> t Text
+    chunksAsT = fmap (foldMap f)
+      where
+        f :: VUnit -> Text
+        f (Digits i) = T.pack $ show i
+        f (Str s)    = s
+
+    foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b
+    foldable d g f | null f    = d
+                   | otherwise = g f
+
+
+
   isDigit :: VChunk -> Bool
   isDigit (Digits _ :| []) = True
   isDigit _                = False

lib/GHCup/Prelude/Posix.hs

@@ -1,4 +1,4 @@
-module GHCup.Utils.Prelude.Posix where
+module GHCup.Prelude.Posix where
 
 import System.Directory
 import System.Posix.Files

lib/GHCup/Prelude/Windows.hs

@@ -1,4 +1,4 @@
-module GHCup.Utils.Prelude.Windows where
+module GHCup.Prelude.Windows where
 
 import qualified System.Win32.File             as Win32
 

lib/GHCup/QQ/String.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 {-|
-Module      : GHCup.Utils.String.QQ
+Module      : GHCup.QQ.String
 Description : String quasi quoters
 Copyright   : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020
 License     : LGPL-3.0
@@ -30,7 +30,7 @@ Any instance of the IsString type is permitted.
 (For GHC versions 6, write "[$s||]" instead of "[s||]".)
 
 -}
-module GHCup.Utils.String.QQ
+module GHCup.QQ.String
   ( s
   )
 where

lib/GHCup/QQ/Version.hs

@@ -8,7 +8,7 @@
 
 
 {-|
-Module      : GHCup.Utils.Version.QQ
+Module      : GHCup.QQ.Version
 Description : Version quasi-quoters
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -16,7 +16,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Utils.Version.QQ where
+module GHCup.QQ.Version where
 
 import           Data.Data
 import           Data.Text                      ( Text )
@@ -53,6 +53,9 @@ deriving instance Data VUnit
 
 #if !MIN_VERSION_base(4,13,0)
 deriving instance Lift (NonEmpty Word)
+deriving instance Lift (NonEmpty VChunk)
+deriving instance Lift (NonEmpty MChunk)
+deriving instance Lift (NonEmpty VUnit)
 #endif
 
 qq :: (Text -> Q Exp) -> QuasiQuoter

lib/GHCup/System/Console.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE CPP #-}
+
+module GHCup.System.Console (
+#if IS_WINDOWS
+  module GHCup.System.Console.Windows
+#else
+  module GHCup.System.Console.Posix
+#endif
+) where
+
+
+#if IS_WINDOWS
+import GHCup.System.Console.Windows
+#else
+import GHCup.System.Console.Posix
+#endif

lib/GHCup/System/Console/Posix.hs

@@ -1,4 +1,4 @@
-module GHCup.Utils.Posix where
+module GHCup.System.Console.Posix where
 
 
 -- | Enables ANSI support on windows, does nothing on unix.

lib/GHCup/System/Console/Windows.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
-module GHCup.Utils.Windows where
+module GHCup.System.Console.Windows where
 
 
 import           Control.Exception.Safe

lib/GHCup/System/Directory.hs

@@ -3,51 +3,24 @@
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE ViewPatterns      #-}
 
-module GHCup.Utils.File.Common where
+module GHCup.System.Directory where
 
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
 
 import           Control.Monad.Reader
 import           Data.Maybe
 import           Data.Text               ( Text )
 import           Data.Void
 import           GHC.IO.Exception
-import           Optics                  hiding ((<|), (|>))
 import           System.Directory
 import           System.FilePath
-import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           Text.Regex.Posix
 
 import qualified Data.Text                     as T
-import qualified Data.ByteString.Lazy          as BL
 import qualified Text.Megaparsec               as MP
 
 
 
-data ProcessError = NonZeroExit Int FilePath [String]
-                  | PTerminated FilePath [String]
-                  | PStopped FilePath [String]
-                  | NoSuchPid FilePath [String]
-                  deriving Show
-
-instance Pretty ProcessError where
-  pPrint (NonZeroExit e exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
-  pPrint (PTerminated exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
-  pPrint (PStopped exe args) =
-    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
-  pPrint (NoSuchPid exe args) =
-    text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
-
-data CapturedProcess = CapturedProcess
-  { _exitCode :: ExitCode
-  , _stdOut   :: BL.ByteString
-  , _stdErr   :: BL.ByteString
-  }
-  deriving (Eq, Show)
-
-makeLenses ''CapturedProcess
 
 
 

lib/GHCup/System/Directory.hs-boot

@@ -1,4 +1,4 @@
-module GHCup.Utils.File.Common where
+module GHCup.System.Directory where
 
 import           Text.Regex.Posix
 

lib/GHCup/System/Process.hs

@@ -0,0 +1,19 @@
+{-# LANGUAGE CPP #-}
+
+module GHCup.System.Process (
+  module GHCup.System.Process.Common,
+#if IS_WINDOWS
+  module GHCup.System.Process.Windows
+#else
+  module GHCup.System.Process.Posix
+#endif
+) where
+
+
+#if IS_WINDOWS
+import GHCup.System.Process.Windows
+#else
+import GHCup.System.Process.Posix
+#endif
+
+import GHCup.System.Process.Common

lib/GHCup/System/Process/Common.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE TemplateHaskell  #-}
+
+module GHCup.System.Process.Common where
+
+
+import           GHC.IO.Exception
+import           Optics                  hiding ((<|), (|>))
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
+
+import qualified Data.ByteString.Lazy          as BL
+
+
+
+data ProcessError = NonZeroExit Int FilePath [String]
+                  | PTerminated FilePath [String]
+                  | PStopped FilePath [String]
+                  | NoSuchPid FilePath [String]
+                  deriving Show
+
+instance Pretty ProcessError where
+  pPrint (NonZeroExit e exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "failed with exit code" <+> text (show e <> ".")
+  pPrint (PTerminated exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "terminated."
+  pPrint (PStopped exe args) =
+    text "Process" <+> pPrint exe <+> text "with arguments" <+> pPrint args <+> text "stopped."
+  pPrint (NoSuchPid exe args) =
+    text "Could not find PID for process running " <+> pPrint exe <+> text " with arguments " <+> text (show args) <+> text "."
+
+data CapturedProcess = CapturedProcess
+  { _exitCode :: ExitCode
+  , _stdOut   :: BL.ByteString
+  , _stdErr   :: BL.ByteString
+  }
+  deriving (Eq, Show)
+
+makeLenses ''CapturedProcess

lib/GHCup/System/Process/Posix.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE FlexibleContexts  #-}
 
 {-|
-Module      : GHCup.Utils.File.Posix
+Module      : GHCup.System.Process.Posix
 Description : File and unix APIs
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -13,13 +13,13 @@ Portability : POSIX
 This module handles file and executable handling.
 Some of these functions use sophisticated logging.
 -}
-module GHCup.Utils.File.Posix where
+module GHCup.System.Process.Posix where
 
-import           GHCup.Utils.File.Common
+import           GHCup.Prelude
-import           GHCup.Utils.Prelude
+import           GHCup.Logger
-import           GHCup.Utils.Logger
 import           GHCup.Types
 import           GHCup.Types.Optics
+import           GHCup.System.Process.Common
 
 import           Control.Concurrent
 import           Control.Concurrent.Async

lib/GHCup/System/Process/Windows.hs

@@ -2,7 +2,7 @@
 {-# LANGUAGE FlexibleContexts  #-}
 
 {-|
-Module      : GHCup.Utils.File.Windows
+Module      : GHCup.System.Process.Windows
 Description : File and windows APIs
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -13,13 +13,14 @@ Portability : Windows
 This module handles file and executable handling.
 Some of these functions use sophisticated logging.
 -}
-module GHCup.Utils.File.Windows where
+module GHCup.System.Process.Windows where
 
 import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
-import           GHCup.Utils.Dirs
+import           GHCup.Directories
-import           GHCup.Utils.File.Common
 import           GHCup.Types
 import           GHCup.Types.Optics
+import           GHCup.System.Directory
+import           GHCup.System.Process.Common
 
 import           Control.Concurrent
 import           Control.DeepSeq

lib/GHCup/Types.hs

@@ -294,6 +294,7 @@ instance NFData (URIRef Absolute) where
 
 data UserSettings = UserSettings
   { uCache       :: Maybe Bool
+  , uMetaCache   :: Maybe Integer
   , uNoVerify    :: Maybe Bool
   , uVerbose     :: Maybe Bool
   , uKeepDirs    :: Maybe KeepDirs
@@ -306,12 +307,13 @@ data UserSettings = UserSettings
   deriving (Show, GHC.Generic)
 
 defaultUserSettings :: UserSettings
-defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 
 fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
 fromSettings Settings{..} Nothing =
   UserSettings {
       uCache = Just cache
+    , uMetaCache = Just metaCache
     , uNoVerify = Just noVerify
     , uVerbose = Just verbose
     , uKeepDirs = Just keepDirs
@@ -335,6 +337,7 @@ fromSettings Settings{..} (Just KeyBindings{..}) =
             }
   in UserSettings {
       uCache = Just cache
+    , uMetaCache = Just metaCache
     , uNoVerify = Just noVerify
     , uVerbose = Just verbose
     , uKeepDirs = Just keepDirs
@@ -410,6 +413,7 @@ instance NFData LeanAppState
 
 data Settings = Settings
   { cache      :: Bool
+  , metaCache  :: Integer
   , noVerify   :: Bool
   , keepDirs   :: KeepDirs
   , downloader :: Downloader
@@ -421,6 +425,12 @@ data Settings = Settings
   }
   deriving (Show, GHC.Generic)
 
+defaultMetaCache :: Integer
+defaultMetaCache = 300 -- 5 minutes
+
+defaultSettings :: Settings
+defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupURL False GPGNone False
+
 instance NFData Settings
 
 data Dirs = Dirs

lib/GHCup/Types/JSON.hs

@@ -22,9 +22,9 @@ Portability : portable
 module GHCup.Types.JSON where
 
 import           GHCup.Types
-import           GHCup.Utils.MegaParsec
+import           GHCup.MegaParsec
-import           GHCup.Utils.Prelude
+import           GHCup.Prelude
-import           GHCup.Utils.Logger             () -- TH is broken shite and needs GHCup.Utils.Logger for linking, although we don't depend on the file.
+import           GHCup.Logger             () -- TH is broken shite and needs GHCup.Logger for linking, although we don't depend on the file.
                                                    -- This is due to the boot file.
 
 import           Control.Applicative            ( (<|>) )

lib/GHCup/Utils.hs

@@ -20,33 +20,37 @@ This module contains GHCup helpers specific to
 installation and introspection of files/versions etc.
 -}
 module GHCup.Utils
-  ( module GHCup.Utils.Dirs
+  ( module GHCup.Directories
   , module GHCup.Utils
 #if defined(IS_WINDOWS)
-  , module GHCup.Utils.Windows
+  , module GHCup.System.Console.Windows
 #else
-  , module GHCup.Utils.Posix
+  , module GHCup.System.Console.Posix
 #endif
   )
 where
 
 
 #if defined(IS_WINDOWS)
-import GHCup.Utils.Windows
+import GHCup.System.Console.Windows
 #else
-import GHCup.Utils.Posix
+import GHCup.System.Console.Posix
 #endif
+import {-# SOURCE #-} GHCup.GHC.Common
+import {-# SOURCE #-} GHCup.GHC.Set
+import           GHCup.Data.Versions
 import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.Dirs
+import           GHCup.Directories
-import           GHCup.Utils.File
+import           GHCup.Logger
-import           GHCup.Utils.Logger
+import           GHCup.MegaParsec
-import           GHCup.Utils.MegaParsec
+import           GHCup.Prelude
-import           GHCup.Utils.Prelude
+import           GHCup.QQ.String
-import           GHCup.Utils.String.QQ
+import           GHCup.System.Directory
+import           GHCup.System.Process
 
 import           Codec.Archive           hiding ( Directory )
 import           Control.Applicative
@@ -59,6 +63,7 @@ import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
 import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
+import           Data.Bifunctor                 ( first )
 import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.Foldable
@@ -76,6 +81,7 @@ import           System.FilePath
 import           System.IO.Error
 import           Text.Regex.Posix
 import           URI.ByteString
+import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Codec.Compression.BZip        as BZip
 import qualified Codec.Compression.GZip        as GZip
@@ -96,22 +102,22 @@ import qualified Data.List.NonEmpty            as NE
 -- >>> import System.Directory
 -- >>> import URI.ByteString
 -- >>> import qualified Data.Text as T
--- >>> import GHCup.Utils.Prelude
+-- >>> import GHCup.Prelude
 -- >>> import GHCup.Download
 -- >>> import GHCup.Version
 -- >>> import GHCup.Errors
 -- >>> import GHCup.Types
 -- >>> import GHCup.Types.Optics
 -- >>> import Optics
--- >>> import GHCup.Utils.Version.QQ
+-- >>> import GHCup.QQ.Version
 -- >>> import qualified Data.Text.Encoding as E
 -- >>> import Control.Monad.Reader
 -- >>> import Haskus.Utils.Variant.Excepts
 -- >>> import Text.PrettyPrint.HughesPJClass ( prettyShow )
 -- >>> let lc = LoggerConfig { lcPrintDebug = False, consoleOutter = mempty, fileOutter = mempty, fancyColors = False }
 -- >>> dirs' <- getAllDirs
--- >>> let installedVersions = [ ([pver|8.10.7|], Nothing), ([pver|8.10.4|], Nothing), ([pver|8.8.4|], Nothing), ([pver|8.8.3|], Nothing) ]
+-- >>> let installedVersions = [ ([pver|8.10.7|], "-debug+lol", Nothing), ([pver|8.10.4|], "", Nothing), ([pver|8.8.4|], "", Nothing), ([pver|8.8.3|], "", Nothing) ]
--- >>> let settings = Settings True False Never Curl False GHCupURL True GPGNone False
+-- >>> let settings = Settings True 0 False Never Curl False GHCupURL True GPGNone False
 -- >>> let leanAppState = LeanAppState settings dirs' defaultKeyBindings lc
 -- >>> cwd <- getCurrentDirectory
 -- >>> (Right ref) <- pure $ parseURI strictURIParserOptions $ "file://" <> E.encodeUtf8 (T.pack cwd) <> "/data/metadata/" <> (urlBaseName . view pathL' $ ghcupURL)
@@ -119,161 +125,6 @@ import qualified Data.List.NonEmpty            as NE
 
 
 
-    ------------------------
-    --[ Symlink handling ]--
-    ------------------------
-
-
--- | The symlink destination of a ghc tool.
-ghcLinkDestination :: ( MonadReader env m
-                      , HasDirs env
-                      , MonadThrow m, MonadIO m)
-                   => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
-                   -> GHCTargetVersion
-                   -> m FilePath
-ghcLinkDestination tool ver = do
-  Dirs {..}  <- getDirs
-  ghcd <- ghcupGHCDir ver
-  pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
-
-
--- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
-rmMinorSymlinks :: ( MonadReader env m
-                   , HasDirs env
-                   , MonadIO m
-                   , HasLog env
-                   , MonadThrow m
-                   , MonadFail m
-                   , MonadMask m
-                   )
-                => GHCTargetVersion
-                -> Excepts '[NotInstalled] m ()
-rmMinorSymlinks tv@GHCTargetVersion{..} = do
-  Dirs {..}  <- lift getDirs
-
-  files                         <- liftE $ ghcToolFiles tv
-  forM_ files $ \f -> do
-    let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
-    let fullF = binDir </> f_xyz
-    lift $ logDebug ("rm -f " <> T.pack fullF)
-    lift $ hideError doesNotExistErrorType $ rmLink fullF
-
-
--- | Removes the set ghc version for the given target, if any.
-rmPlain :: ( MonadReader env m
-           , HasDirs env
-           , HasLog env
-           , MonadThrow m
-           , MonadFail m
-           , MonadIO m
-           , MonadMask m
-           )
-        => Maybe Text -- ^ target
-        -> Excepts '[NotInstalled] m ()
-rmPlain target = do
-  Dirs {..}  <- lift getDirs
-  mtv                           <- lift $ ghcSet target
-  forM_ mtv $ \tv -> do
-    files <- liftE $ ghcToolFiles tv
-    forM_ files $ \f -> do
-      let fullF = binDir </> f <> exeExt
-      lift $ logDebug ("rm -f " <> T.pack fullF)
-      lift $ hideError doesNotExistErrorType $ rmLink fullF
-    -- old ghcup
-    let hdc_file = binDir </> "haddock-ghc" <> exeExt
-    lift $ logDebug ("rm -f " <> T.pack hdc_file)
-    lift $ hideError doesNotExistErrorType $ rmLink hdc_file
-
-
--- | Remove the major GHC symlink, e.g. ghc-8.6.
-rmMajorSymlinks :: ( MonadReader env m
-                   , HasDirs env
-                   , MonadIO m
-                   , HasLog env
-                   , MonadThrow m
-                   , MonadFail m
-                   , MonadMask m
-                   )
-                => GHCTargetVersion
-                -> Excepts '[NotInstalled] m ()
-rmMajorSymlinks tv@GHCTargetVersion{..} = do
-  Dirs {..}  <- lift getDirs
-  (mj, mi) <- getMajorMinorV _tvVersion
-  let v' = intToText mj <> "." <> intToText mi
-
-  files                         <- liftE $ ghcToolFiles tv
-  forM_ files $ \f -> do
-    let f_xy = f <> "-" <> T.unpack v' <> exeExt
-    let fullF = binDir </> f_xy
-    lift $ logDebug ("rm -f " <> T.pack fullF)
-    lift $ hideError doesNotExistErrorType $ rmLink fullF
-
-
-
-
-    -----------------------------------
-    --[ Set/Installed introspection ]--
-    -----------------------------------
-
-
--- | Whether the given GHC versin is installed.
-ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
-ghcInstalled ver = do
-  ghcdir <- ghcupGHCDir ver
-  liftIO $ doesDirectoryExist ghcdir
-
-
--- | Whether the given GHC version is installed from source.
-ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
-ghcSrcInstalled ver = do
-  ghcdir <- ghcupGHCDir ver
-  liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
-
-
--- | Whether the given GHC version is set as the current.
-ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
-       => Maybe Text   -- ^ the target of the GHC version, if any
-                       --  (e.g. armv7-unknown-linux-gnueabihf)
-       -> m (Maybe GHCTargetVersion)
-ghcSet mtarget = do
-  Dirs {..}  <- getDirs
-  let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
-  let ghcBin = binDir </> ghc <> exeExt
-
-  -- link destination is of the form ../ghc/<ver>/bin/ghc
-  -- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
-  liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
-    link <- liftIO $ getLinkTarget ghcBin
-    Just <$> ghcLinkVersion link
- where
-  ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
-  ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
-   where
-    parser =
-        (do
-           _    <- parseUntil1 ghcSubPath
-           _    <- ghcSubPath
-           r    <- parseUntil1 pathSep
-           rest <- MP.getInput
-           MP.setInput r
-           x <- ghcTargetVerP
-           MP.setInput rest
-           pure x
-         )
-        <* pathSep
-        <* MP.takeRest
-        <* MP.eof
-    ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
-
--- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
--- If a dir cannot be parsed, returns left.
-getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
-getInstalledGHCs = do
-  ghcdir <- ghcupGHCBaseDir
-  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
-  forM fs $ \f -> case parseGHCupGHCDir f of
-    Right r -> pure $ Right r
-    Left  _ -> pure $ Left f
 
 
 -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
@@ -587,79 +438,6 @@ hlsSymlinks = do
 
 
 
-    -----------------------------------------
-    --[ Major version introspection (X.Y) ]--
-    -----------------------------------------
-
-
--- | Extract (major, minor) from any version.
-getMajorMinorV :: MonadThrow m => Version -> m (Int, Int)
-getMajorMinorV Version {..} = case _vChunks of
-  ((Digits x :| []) :| ((Digits y :| []):_)) -> pure (fromIntegral x, fromIntegral y)
-  _ -> throwM $ ParseError "Could not parse X.Y from version"
-
-
-matchMajor :: Version -> Int -> Int -> Bool
-matchMajor v' major' minor' = case getMajorMinorV v' of
-  Just (x, y) -> x == major' && y == minor'
-  Nothing     -> False
-
--- | Match PVP prefix.
---
--- >>> matchPVPrefix [pver|8.8|] [pver|8.8.4|]
--- True
--- >>> matchPVPrefix [pver|8|] [pver|8.8.4|]
--- True
--- >>> matchPVPrefix [pver|8.10|] [pver|8.8.4|]
--- False
--- >>> matchPVPrefix [pver|8.10|] [pver|8.10.7|]
--- True
-matchPVPrefix :: PVP -> PVP -> Bool
-matchPVPrefix (toL -> prefix) (toL -> full) = and $ zipWith (==) prefix full
-
-toL :: PVP -> [Int]
-toL (PVP inner) = fmap fromIntegral $ NE.toList inner
-
-
--- | Get the latest installed full GHC version that satisfies the given (possibly partial)
--- PVP version.
-getGHCForPVP :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
-             => PVP
-             -> Maybe Text -- ^ the target triple
-             -> m (Maybe GHCTargetVersion)
-getGHCForPVP pvpIn mt = do
-  ghcs <- rights <$> getInstalledGHCs
-  -- we're permissive here... failed parse just means we have no match anyway
-  let ghcs' = catMaybes $ flip fmap ghcs $ \GHCTargetVersion{..} -> do
-        pvp_ <- versionToPVP _tvVersion
-        pure (pvp_, _tvTarget)
-
-  getGHCForPVP' pvpIn ghcs' mt
-
--- | Like 'getGHCForPVP', except with explicit input parameter.
---
--- >>> fmap prettyShow $ getGHCForPVP' [pver|8|] installedVersions Nothing
--- "Just 8.10.7"
--- >>> fmap prettyShow $ getGHCForPVP' [pver|8.8|] installedVersions Nothing
--- "Just 8.8.4"
--- >>> fmap prettyShow $ getGHCForPVP' [pver|8.10.4|] installedVersions Nothing
--- "Just 8.10.4"
-getGHCForPVP' :: MonadThrow m
-             => PVP
-             -> [(PVP, Maybe Text)] -- ^ installed GHCs
-             -> Maybe Text          -- ^ the target triple
-             -> m (Maybe GHCTargetVersion)
-getGHCForPVP' pvpIn ghcs' mt = do
-  let mResult = lastMay
-                  . sortBy (\(x, _) (y, _) -> compare x y)
-                  . filter
-                      (\(pvp_, target) ->
-                        target == mt && matchPVPrefix pvp_ pvpIn
-                      )
-                  $ ghcs'
-  forM mResult $ \(pvp_, target) -> do
-    ver' <- pvpToVersion pvp_
-    pure (GHCTargetVersion target ver')
 
 
 -- | Get the latest available ghc for the given PVP version, which
@@ -679,7 +457,7 @@ getLatestToolFor :: MonadThrow m
 getLatestToolFor tool pvpIn dls = do
   let ls = fromMaybe [] $ preview (ix tool % to Map.toDescList) dls
   let ps = catMaybes $ fmap (\(v, vi) -> (,vi) <$> versionToPVP v) ls
-  pure . headMay . filter (\(v, _) -> matchPVPrefix pvpIn v) $ ps
+  pure . fmap (first fst) . headMay . filter (\((v, _), _) -> matchPVPrefix pvpIn v) $ ps
 
 
 
@@ -809,39 +587,6 @@ getLatestBaseVersion av pvpVer =
     -------------
 
 
--- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
--- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
---
--- Returns unversioned relative files without extension, e.g.:
---
---   - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
-ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
-             => GHCTargetVersion
-             -> Excepts '[NotInstalled] m [FilePath]
-ghcToolFiles ver = do
-  ghcdir <- lift $ ghcupGHCDir ver
-  let bindir = ghcdir </> "bin"
-
-  -- fail if ghc is not installed
-  whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
-        (throwE (NotInstalled GHC ver))
-
-  files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
-  pure (getUniqueTools . groupToolFiles . fmap (dropSuffix exeExt) $ files)
-
- where
-
-  groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
-  groupToolFiles = groupBy (\(a, _) (b, _) -> a == b) . fmap (splitOnPVP "-")
-
-  getUniqueTools :: [[(FilePath, String)]] -> [String]
-  getUniqueTools = filter (isNotAnyInfix blackListedTools) . nub . fmap fst . filter ((== "") . snd) . concat
-
-  blackListedTools :: [String]
-  blackListedTools = ["haddock-ghc"]
-
-  isNotAnyInfix :: [String] -> String -> Bool
-  isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
 
 
 -- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
@@ -1140,3 +885,33 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
 ghcBinaryName :: GHCTargetVersion -> String
 ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
 ghcBinaryName (GHCTargetVersion Nothing  v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
+
+
+
+-- | Warn if the installed and set HLS is not compatible with the installed and
+-- set GHC version.
+warnAboutHlsCompatibility :: ( MonadReader env m
+                             , HasDirs env
+                             , HasLog env
+                             , MonadThrow m
+                             , MonadCatch m
+                             , MonadIO m
+                             )
+                          => m ()
+warnAboutHlsCompatibility = do
+  supportedGHC <- hlsGHCVersions
+  currentGHC   <- fmap _tvVersion <$> ghcSet Nothing
+  currentHLS   <- hlsSet
+
+  case (currentGHC, currentHLS) of
+    (Just gv, Just hv) | gv `notElem` supportedGHC -> do
+      logWarn $
+        "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <>
+        "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <>
+        "Haskell IDE support may not work until this is fixed." <> "\n" <>
+        "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <>
+        T.pack (prettyShow supportedGHC)
+        
+    _ -> return ()
+
+

lib/GHCup/Utils/File.hs

@@ -1,17 +0,0 @@
-{-# LANGUAGE CPP #-}
-
-module GHCup.Utils.File (
-  module GHCup.Utils.File.Common,
-#if IS_WINDOWS
-  module GHCup.Utils.File.Windows
-#else
-  module GHCup.Utils.File.Posix
-#endif
-) where
-
-import GHCup.Utils.File.Common
-#if IS_WINDOWS
-import GHCup.Utils.File.Windows
-#else
-import GHCup.Utils.File.Posix
-#endif

test/GHCup/Types/JSONSpec.hs

@@ -3,7 +3,7 @@
 module GHCup.Types.JSONSpec where
 
 import           GHCup.ArbitraryTypes ()
-import           GHCup.Types
+import           GHCup.Types hiding ( defaultSettings )
 import           GHCup.Types.JSON ()
 
 import           Test.Aeson.GenericSpecs