Speed up 'whereis' subcommand wrt #179

.gitlab/script/ghcup_version.sh

@@ -142,6 +142,11 @@ else
 	fi
 fi
 
+# check that lazy loading works for 'whereis'
+cp "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak"
+echo '**' > "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
+eghcup whereis ghc $(ghc --numeric-version)
+mv -f "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml.bak" "$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml"
 
 eghcup rm $(ghc --numeric-version)
 
@@ -153,6 +158,7 @@ if [ "${OS}" = "LINUX" ] ; then
 	fi
 fi
 
+
 eghcup upgrade
 eghcup upgrade -f
 

app/ghcup/Main.hs

@@ -33,6 +33,8 @@ import           GHCup.Version
 import           Codec.Archive
 #endif
 import           Control.Concurrent
+import           Control.DeepSeq                ( force )
+import           Control.Exception              ( evaluate )
 import           Control.Exception.Safe
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -64,6 +66,7 @@ import           System.Environment
 import           System.Exit
 import           System.FilePath
 import           System.IO               hiding ( appendFile )
+import           System.IO.Unsafe               ( unsafeInterleaveIO )
 import           Text.Read               hiding ( lift )
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           URI.ByteString
@@ -1237,7 +1240,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let runLogger = myLoggerT loggerConfig
           let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
 
-          pfreq <- (
+          ----------------------------------------
+          -- Getting download and platform info --
+          ----------------------------------------
+
+
+          pfreq <- unsafeInterleaveIO $ (
             runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
             ) >>= \case
                     VRight r -> pure r
@@ -1246,13 +1254,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                         ($(logError) $ T.pack $ prettyShow e)
                       exitWith (ExitFailure 2)
 
-
+          ghcupInfo <- unsafeInterleaveIO $
-
-          ----------------------------------------
-          -- Getting download and platform info --
-          ----------------------------------------
-
-          ghcupInfo <-
             ( runLogger
               . runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
               $ liftE
@@ -1265,12 +1267,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                         ($(logError) $ T.pack $ prettyShow e)
                       exitWith (ExitFailure 2)
 
+
+
+          -------------------------
+          -- Setting up appstate --
+          -------------------------
+
+
           let appstate@AppState{dirs = Dirs{..}
-                               , ghcupInfo = GHCupInfo { _ghcupDownloads = dls, .. }
+                               , ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls, .. }
                                } = AppState settings dirs keybindings ghcupInfo pfreq
 
+
+          ---------------------------
+          -- Running startup tasks --
+          ---------------------------
+
           case optCommand of
             Upgrade _ _ -> pure ()
+            Whereis _ _ -> pure ()
             _ -> do
               lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
                 Nothing -> runLogger $ flip runReaderT appstate $ checkForUpdates
@@ -1278,12 +1293,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 
 
           -- ensure global tools
-          (siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case
+          case optCommand of
-            VRight _ -> pure ()
+            Whereis _ _ -> pure ()
-            VLeft e -> do
+            _ -> do
-              runLogger
+              (siletRunLogger $ flip runReaderT appstate $ runE ensureGlobalTools) >>= \case
-                ($(logError) $ T.pack $ prettyShow e)
+                VRight _ -> pure ()
-              exitWith (ExitFailure 30)
+                VLeft e -> do
+                  runLogger
+                    ($(logError) $ T.pack $ prettyShow e)
+                  exitWith (ExitFailure 30)
 
 
           -------------------------
@@ -1771,13 +1789,13 @@ Make sure to clean up #{tmpdir} afterwards.|])
                         runLogger $ $(logError) $ T.pack $ prettyShow e
                         pure $ ExitFailure 30
 
-            Upgrade uOpts force -> do
+            Upgrade uOpts force' -> do
               target <- case uOpts of
                 UpgradeInplace  -> Just <$> liftIO getExecutablePath
                 (UpgradeAt p)   -> pure $ Just p
                 UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
 
-              runUpgrade (liftE $ upgradeGHCup target force) >>= \case
+              runUpgrade (liftE $ upgradeGHCup target force') >>= \case
                 VRight v' -> do
                   let pretty_v = prettyVer v'
                   let vi = fromJust $ snd <$> getLatest dls GHCup
@@ -1849,6 +1867,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
 
             Nuke ->
               runRm (do
+                   void $ liftIO $ evaluate $ force appstate
                    lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
                    lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
                    liftIO $ threadDelay 10000000  -- wait 10s
@@ -1899,7 +1918,7 @@ fromVersion' SetRecommended tool = do
   (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
     ?? TagNotFound Recommended tool
 fromVersion' (SetToolVersion v) tool = do
-  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- lift ask
+  ~AppState { ghcupInfo = ~GHCupInfo { _ghcupDownloads = dls }} <- lift ask
   let vi = getVersionInfo (_tvVersion v) tool dls
   case pvp $ prettyVer (_tvVersion v) of
     Left _ -> pure (v, vi)

ghcup.cabal

@@ -82,7 +82,6 @@ library
     QuasiQuotes
     RecordWildCards
     ScopedTypeVariables
-    Strict
     StrictData
     TupleSections
     TypeApplications
@@ -195,7 +194,6 @@ executable ghcup
     PackageImports
     RecordWildCards
     ScopedTypeVariables
-    Strict
     StrictData
     TupleSections
 
@@ -207,6 +205,7 @@ executable ghcup
     , base                  >=4.13     && <5
     , bytestring            ^>=0.10
     , containers            ^>=0.6
+    , deepseq               ^>=1.4
     , filepath              ^>=1.4.2.1
     , ghcup
     , haskus-utils-variant  >=3.0      && <3.2
@@ -261,7 +260,6 @@ executable ghcup-gen
     QuasiQuotes
     RecordWildCards
     ScopedTypeVariables
-    Strict
     StrictData
     TupleSections
     TypeApplications
@@ -305,6 +303,7 @@ executable ghcup-gen
 test-suite ghcup-test
   type:               exitcode-stdio-1.0
   main-is:            Main.hs
+  build-tool-depends: hspec-discover:hspec-discover -any
   hs-source-dirs:     test
   other-modules:
     GHCup.ArbitraryTypes
@@ -324,8 +323,6 @@ test-suite ghcup-test
     -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
     -fwarn-incomplete-record-updates
 
-  build-tool-depends: hspec-discover:hspec-discover
-
   build-depends:
     , base                      >=4.13    && <5
     , bytestring                ^>=0.10

lib/GHCup.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP                   #-}
+{-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE FlexibleInstances     #-}
@@ -42,6 +43,7 @@ import           GHCup.Version
 import           Codec.Archive                  ( ArchiveResult )
 #endif
 import           Control.Applicative
+import           Control.DeepSeq                ( force )
 import           Control.Exception              ( evaluate )
 import           Control.Exception.Safe
 import           Control.Monad
@@ -1393,20 +1395,22 @@ rmGhcupDirs = do
     rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
     rmEnvFile enFilePath = do
       $logInfo "Removing Ghcup Environment File"
-      hideError doesNotExistErrorType $ liftIO $ deleteFile enFilePath
+      liftIO $ deleteFile enFilePath
 
     rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
     rmConfFile confFilePath = do
       $logInfo "removing Ghcup Config File"
-      hideError doesNotExistErrorType $ liftIO $ deleteFile confFilePath
+      liftIO $ deleteFile confFilePath
 
     rmDir :: (MonadLogger m, MonadIO m, MonadCatch m) => FilePath -> m ()
-    rmDir dir = do
+    rmDir dir =
-      $logInfo [i|removing #{dir}|]
+      -- 'getDirectoryContentsRecursive' is lazy IO. In case
-      contents <- hideErrorDef [doesNotExistErrorType] []
+      -- an error leaks through, we catch it here as well,
-        $ liftIO
+      -- althought 'deleteFile' should already handle it.
-        (getDirectoryContentsRecursive dir >>= evaluate)
+      hideErrorDef [doesNotExistErrorType] () $ do
-      forM_ contents (liftIO . deleteFile . (dir </>))
+        $logInfo [i|removing #{dir}|]
+        contents <- liftIO $ getDirectoryContentsRecursive dir
+        forM_ contents (liftIO . deleteFile . (dir </>))
 
     rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m ()
     rmBinDir binDir = do
@@ -1421,7 +1425,9 @@ rmGhcupDirs = do
 
     reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]
     reportRemainingFiles dir = do
-      remainingFiles <- liftIO $ getDirectoryContentsRecursive dir
+      -- force the files so the errors don't leak
+      (force -> !remainingFiles) <- liftIO
+        (getDirectoryContentsRecursive dir >>= evaluate)
       let normalizedFilePaths = fmap normalise remainingFiles
       let sortedByDepthRemainingFiles = sortBy (flip compareFn) normalizedFilePaths
       let remainingFilesAbsolute = fmap (dir </>) sortedByDepthRemainingFiles
@@ -1448,7 +1454,8 @@ rmGhcupDirs = do
 
     deleteFile :: FilePath -> IO ()
     deleteFile filepath = do
-      hideError InappropriateType $ rmFile filepath
+      hideError doesNotExistErrorType
+        $ hideError InappropriateType $ rmFile filepath
 
     removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m ()
     removeDirIfEmptyOrIsSymlink filepath =

lib/GHCup/Types.hs

@@ -1,7 +1,9 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE CPP               #-}
+{-# LANGUAGE BangPatterns      #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 {-|
 Module      : GHCup.Types
@@ -21,6 +23,7 @@ module GHCup.Types
   where
 
 import           Control.Applicative
+import           Control.DeepSeq                ( NFData, rnf )
 import           Control.Monad.Logger
 import           Data.Map.Strict                ( Map )
 import           Data.List.NonEmpty             ( NonEmpty (..) )
@@ -60,6 +63,8 @@ data GHCupInfo = GHCupInfo
   }
   deriving (Show, GHC.Generic)
 
+instance NFData GHCupInfo
+
 
 
     -------------------------
@@ -79,6 +84,8 @@ data Requirements = Requirements
   }
   deriving (Show, GHC.Generic)
 
+instance NFData Requirements
+
 
 
 
@@ -105,9 +112,13 @@ data Tool = GHC
           | Stack
   deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
 
+instance NFData Tool
+
 data GlobalTool = ShimGen
   deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
 
+instance NFData GlobalTool
+
 
 -- | All necessary information of a tool version, including
 -- source download and per-architecture downloads.
@@ -123,6 +134,8 @@ data VersionInfo = VersionInfo
   }
   deriving (Eq, GHC.Generic, Show)
 
+instance NFData VersionInfo
+
 
 -- | A tag. These are currently attached to a version of a tool.
 data Tag = Latest
@@ -133,6 +146,8 @@ data Tag = Latest
          | UnknownTag String  -- ^ used for upwardscompat
          deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
 
+instance NFData Tag
+
 tagToString :: Tag -> String
 tagToString Recommended        = "recommended"
 tagToString Latest             = "latest"
@@ -159,6 +174,8 @@ data Architecture = A_64
                   | A_ARM64
   deriving (Eq, GHC.Generic, Ord, Show)
 
+instance NFData Architecture
+
 archToString :: Architecture -> String
 archToString A_64 = "x86_64"
 archToString A_32 = "i386"
@@ -181,6 +198,8 @@ data Platform = Linux LinuxDistro
               -- ^ must exit
   deriving (Eq, GHC.Generic, Ord, Show)
 
+instance NFData Platform
+
 platformToString :: Platform -> String
 platformToString (Linux distro) = "linux-" ++ distroToString distro
 platformToString Darwin = "darwin"
@@ -206,6 +225,8 @@ data LinuxDistro = Debian
                  -- ^ must exit
   deriving (Eq, GHC.Generic, Ord, Show)
 
+instance NFData LinuxDistro
+
 distroToString :: LinuxDistro -> String
 distroToString Debian = "debian"
 distroToString Ubuntu = "ubuntu"
@@ -232,6 +253,7 @@ data DownloadInfo = DownloadInfo
   }
   deriving (Eq, Ord, GHC.Generic, Show)
 
+instance NFData DownloadInfo
 
 
 
@@ -245,6 +267,8 @@ data TarDir = RealDir FilePath
             | RegexDir String     -- ^ will be compiled to regex, the first match will "win"
             deriving (Eq, Ord, GHC.Generic, Show)
 
+instance NFData TarDir
+
 instance Pretty TarDir where
   pPrint (RealDir path) = text path
   pPrint (RegexDir regex) = text regex
@@ -257,6 +281,10 @@ data URLSource = GHCupURL
                | AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
                deriving (GHC.Generic, Show)
 
+instance NFData URLSource
+instance NFData (URIRef Absolute) where
+  rnf (URI !_ !_ !_ !_ !_) = ()
+
 
 data UserSettings = UserSettings
   { uCache       :: Maybe Bool
@@ -298,6 +326,9 @@ data KeyBindings = KeyBindings
   }
   deriving (Show, GHC.Generic)
 
+instance NFData KeyBindings
+instance NFData Key
+
 defaultKeyBindings :: KeyBindings
 defaultKeyBindings = KeyBindings
   { bUp = KUp
@@ -315,9 +346,11 @@ data AppState = AppState
   { settings :: Settings
   , dirs :: Dirs
   , keyBindings :: KeyBindings
-  , ghcupInfo :: GHCupInfo
+  , ghcupInfo :: ~GHCupInfo
-  , pfreq :: PlatformRequest
+  , pfreq :: ~PlatformRequest
-  } deriving (Show)
+  } deriving (Show, GHC.Generic)
+
+instance NFData AppState
 
 data Settings = Settings
   { cache      :: Bool
@@ -329,6 +362,8 @@ data Settings = Settings
   }
   deriving (Show, GHC.Generic)
 
+instance NFData Settings
+
 data Dirs = Dirs
   { baseDir  :: FilePath
   , binDir   :: FilePath
@@ -336,19 +371,25 @@ data Dirs = Dirs
   , logsDir  :: FilePath
   , confDir  :: FilePath
   }
-  deriving Show
+  deriving (Show, GHC.Generic)
+
+instance NFData Dirs
 
 data KeepDirs = Always
               | Errors
               | Never
-  deriving (Eq, Show, Ord)
+  deriving (Eq, Show, Ord, GHC.Generic)
+
+instance NFData KeepDirs
 
 data Downloader = Curl
                 | Wget
 #if defined(INTERNAL_DOWNLOADER)
                 | Internal
 #endif
-  deriving (Eq, Show, Ord)
+  deriving (Eq, Show, Ord, GHC.Generic)
+
+instance NFData Downloader
 
 data DebugInfo = DebugInfo
   { diBaseDir  :: FilePath
@@ -371,7 +412,9 @@ data PlatformResult = PlatformResult
   { _platform      :: Platform
   , _distroVersion :: Maybe Versioning
   }
-  deriving (Eq, Show)
+  deriving (Eq, Show, GHC.Generic)
+
+instance NFData PlatformResult
 
 platResToString :: PlatformResult -> String
 platResToString PlatformResult { _platform = plat, _distroVersion = Just v' }
@@ -387,7 +430,9 @@ data PlatformRequest = PlatformRequest
   , _rPlatform :: Platform
   , _rVersion  :: Maybe Versioning
   }
-  deriving (Eq, Show)
+  deriving (Eq, Show, GHC.Generic)
+
+instance NFData PlatformRequest
 
 pfReqToString :: PlatformRequest -> String
 pfReqToString (PlatformRequest arch plat ver) =
@@ -434,6 +479,8 @@ data VersionCmp = VR_gt Versioning
                 | VR_eq Versioning
   deriving (Eq, GHC.Generic, Ord, Show)
 
+instance NFData VersionCmp
+
 
 -- | A version range. Supports && and ||, but not  arbitrary
 -- combinations. This is a little simplified.
@@ -441,6 +488,7 @@ data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
                   | OrRange (NonEmpty VersionCmp) VersionRange
   deriving (Eq, GHC.Generic, Ord, Show)
 
+instance NFData VersionRange
 
 instance Pretty Versioning where
   pPrint = text . T.unpack . prettyV